scm/font.scm

   1 ;; As an excercise, do it with records.
   2 ;; Should use GOOPS, really.
   3
   4 ;; TODO:
   5 ;;
   6 ;; lookup-font should be written in  C.
   7 ;;
   8 ;; should dump tree to .texi as internal documentation
   9 ;;
  10 ;; * should extract design sizes from fonts.
  11
  12 (define font-tree-record
  13   (make-record-type
  14    "font-tree-node"
  15    '(qualifier default children)))
  16
  17 (define-public font-tree-node?
  18   (record-predicate font-tree-record))
  19 (define-public font-tree-default
  20   (record-accessor font-tree-record 'default))
  21 (define-public font-tree-qualifier
  22   (record-accessor font-tree-record 'qualifier))
  23 (define-public font-tree-children
  24   (record-accessor font-tree-record 'children))
  25
  26
  27 (define (make-font-tree-node
  28          qualifier default)
  29   ((record-constructor font-tree-record)
  30     qualifier
  31     default
  32     (make-hash-table 11)))              ;ugh. hardcoded.
  33
  34 (define default-qualifier-order
  35   '(font-encoding font-family font-shape font-series))
  36
  37
  38 (define-public (add-font node fprops size-family)
  39   (define (assoc-delete key alist)
  40     (assoc-remove! (list-copy alist) key))
  41   (define (make-node fprops size-family)
  42     (if (null? fprops)
  43         size-family
  44         (let*
  45             ((qual (next-qualifier default-qualifier-order fprops)))
  46           (make-font-tree-node qual
  47                                (assoc-get qual fprops)))
  48         ))
  49   (define (next-qualifier order props)
  50     (cond
  51      ((and (null? props) (null? order))
  52       #f)
  53      ((null? props) (car order))
  54      ((null? order) (caar props))
  55      (else
  56       (if (assoc-get (car order) props)
  57           (car order)
  58           (next-qualifier (cdr order) props))
  59       )))
  60
  61   (if (font-tree-node? node)
  62       (let*
  63           ((q (font-tree-qualifier node))
  64            (d (font-tree-default node))
  65            (v (assoc-get q fprops d))
  66            (new-fprops (assoc-delete q fprops))
  67            (child (hashq-ref (font-tree-children node)
  68                              v #f)))
  69
  70
  71         (if (not child)
  72             (begin
  73               (set! child (make-node new-fprops size-family))
  74               (hashq-set! (font-tree-children node) v child)))
  75
  76         (add-font child new-fprops size-family))
  77       (if (not (equal? size-family node))
  78           (throw 'invalid-font props size-family)))
  79   )
  80
  81 (define-public (display-font-node node . rest)
  82   (let*
  83       ((port (if (pair? rest) (car rest) (current-output-port)))
  84        )
  85     (cond
  86      ((font-tree-node? node)
  87       (map
  88        (lambda (x)
  89          (display x port))
  90
  91        (list
  92         "Font_node { \nqual: "
  93         (font-tree-qualifier node)
  94         "(def: "
  95         (font-tree-default node)
  96         ") {\n"))
  97       (for-each
  98        (lambda (x)
  99          (display "\n")
 100          (display (car x) port)
 101          (display "=" port)
 102          (display-font-node (cdr x) port))
 103        (hash-table->alist (font-tree-children node)))
 104       (display "} } \n"))
 105
 106      (else
 107       (display node port))))
 108   )
 109
 110 (define-public (lookup-font node alist-chain)
 111   (cond
 112    ((font-tree-node? node)
 113     (let*
 114         ((qual (font-tree-qualifier node))
 115          (def (font-tree-default node))
 116          (val (chain-assoc-get qual alist-chain def))
 117          (desired-font (lookup-font
 118                         (hashq-ref (font-tree-children node)
 119                                    val) alist-chain))
 120          (font (if desired-font
 121                    desired-font
 122                    (lookup-font (hashq-ref (font-tree-children node)
 123                                            def) alist-chain)))
 124          )
 125       font))
 126    (else node)))
 127
 128 (define-public (make-font-tree factor)
 129   (let*
 130       ((n (make-font-tree-node 'font-encoding 'music))
 131        )
 132
 133     (for-each
 134      (lambda (x)
 135        (add-font n
 136                  (list (cons 'font-encoding (car x)))
 137                  (cons (* factor (cadr x))
 138                        (caddr x))))
 139      '((number 10
 140                #((3.82  . "feta-nummer4")
 141                  (5.5  . "feta-nummer6")
 142                  (8.0  . "feta-nummer8")
 143                  (10.0  . "feta-nummer10")
 144                  (12.0  . "feta-nummer12")
 145                  (16.0  . "feta-nummer16")))
 146        (dynamic 14.0  #((6.0 . "feta-din6")
 147                         (8.0 . "feta-din8")
 148                         (10.0 . "feta-din10")
 149                         (12.0 . "feta-din12")
 150                         (14.0 . "feta-din14")
 151                         (17.0 . "feta-din17")
 152                         ))
 153        (math 10 #((10.0 . "msam10")))
 154        (music 20.0
 155               #((11.22 . ("feta11" "parmesan11"))
 156                 (12.60 . ("feta13" "parmesan13"))
 157                 (14.14 . ("feta14" "parmesan14"))
 158                 (15.87 . ("feta16" "parmesan16"))
 159                 (17.82 . ("feta18" "parmesan18"))
 160                 (20.0 . ("feta20" "parmesan20"))
 161                 (22.45 . ("feta23" "parmesan23"))
 162                 (25.20 . ("feta26" "parmesan26"))
 163                 ))
 164        (braces 10 #((10.0 . ("feta-braces00"
 165                              "feta-braces10"
 166                              "feta-braces20"
 167                              "feta-braces30"
 168                              "feta-braces40"
 169                              "feta-braces50"
 170                              "feta-braces60"
 171                              "feta-braces70"
 172                              "feta-braces80"))
 173                     ))))
 174
 175     (for-each
 176      (lambda (x)
 177        (add-font
 178         n
 179         `((font-encoding . text)
 180           (font-series . ,(vector-ref (car x) 2))
 181           (font-shape . ,(vector-ref (car x) 1))
 182           (font-family . ,(vector-ref (car x) 0)))
 183         (cons (* factor (cadr x))
 184               (cddr x))
 185         ))
 186      '((#(roman upright medium) .
 187         (10.0 . #((6.0 . "cmr6")
 188                   (8.0 . "cmr8")
 189                   (10.0 . "cmr10")
 190                   (17.0 . "cmr17")
 191                   )))
 192
 193        (#(roman upright bold) .
 194         (10.0 . #((6.0 . "cmbx6")
 195                   (8.0 . "cmbx8")
 196                   (10.0 . "cmbx10")
 197                   (12.0 . "cmbx12")
 198                   )))
 199
 200        (#(roman italic medium) .
 201         (10.0 . #((7.0 . "cmti7")
 202                   (10.0 . "cmti10")
 203                   (12.0 . "cmti12")
 204                   )))
 205        (#(roman italic bold) .
 206         (10.0 . #((8.0 . "cmbxti8")
 207                   (10.0 . "cmbxti10")
 208                   (14.0 . "cmbxti14")
 209                   )))
 210
 211        (#(roman caps medium) .
 212         (10.0 . #((10.0 . "cmcsc10"))))
 213
 214        (#(roman upright bold-narrow ) .
 215         (10.0 . #((10.0 . "cmb10")
 216                   )))
 217
 218        (#(sans upright medium) .
 219         (10.0  . #((8.0 . "cmss8")
 220                    (10.0 . "cmss10")
 221                    (12.0 . "cmss12")
 222                    (17.0 . "cmss17")
 223                    )))
 224        (#(typewriter upright medium) .
 225         (10.0 . #((8.0 .  "cmtt8")
 226                   (10.0 . "cmtt10")
 227                   (12.0 . "cmtt12")
 228                   )))
 229        ))
 230     n))
 231
 232 (define-public (magstep x)
 233   (exp (* (/ x 6) (log 2))))