scm/new-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
  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       (if (equal? (chain-assoc-get  'font-family alist-chain) 'sans)
 126           (display (list "...........\n" node alist-chain)))
 127
 128       font))
 129    (else node))
 130    )
 131
 132 (define-public (make-font-tree factor)
 133   (let*
 134       ((n (make-font-tree-node 'font-encoding 'music))
 135        )
 136
 137     (for-each
 138      (lambda (x)
 139        (add-font n
 140                  (list (cons 'font-encoding (car x)))
 141                  (cons (* factor (cadr x))
 142                        (caddr x))))
 143      '((number 10 #((4.0  . "feta-nummer4")
 144                     (6.0  . "feta-nummer6")
 145                     (8.0  . "feta-nummer8")
 146                     (10.0  . "feta-nummer10")
 147                     (12.0  . "feta-nummer12")
 148                     (16.0  . "feta-nummer16")))
 149        (dynamic 14.0  #((6.0 . "feta-din6")
 150                         (8.0 . "feta-din8")
 151                         (10.0 . "feta-din10")
 152                         (12.0 . "feta-din12")
 153                         (14.0 . "feta-din14")
 154                         (17.0 . "feta-din17")
 155                         ))
 156        (math 10 #((10.0 . "msam10")))
 157        (music 20.0
 158               #((11.22 . ("feta11" "parmesan11"))
 159                 (12.60 . ("feta13" "parmesan13"))
 160                 (14.14 . ("feta14" "parmesan14"))
 161                 (15.87 . ("feta16" "parmesan16"))
 162                 (17.82 . ("feta18" "parmesan18"))
 163                 (20.0 . ("feta20" "parmesan20"))
 164                 (22.45 . ("feta23" "parmesan23"))
 165                 (25.20 . ("feta26" "parmesan26"))
 166                 ))
 167        (braces 10 #((10.0 . ("feta-braces00"
 168                               "feta-braces10"
 169                               "feta-braces20"
 170                               "feta-braces30"
 171                               "feta-braces40"
 172                               "feta-braces50"
 173                               "feta-braces60"
 174                               "feta-braces70"
 175                               "feta-braces80"))
 176                      ))))
 177
 178     (for-each
 179      (lambda (x)
 180        (add-font
 181         n
 182         `((font-encoding . text)
 183           (font-series . ,(vector-ref (car x) 2))
 184           (font-shape . ,(vector-ref (car x) 1))
 185           (font-family . ,(vector-ref (car x) 0)))
 186         (cons (* factor (cadr x))
 187               (cddr x))
 188        ))
 189      '((#(roman upright medium) .
 190         (10.0 . #((6.0 . "cmr6")
 191                   (8.0 . "cmr8")
 192                   (10.0 . "cmr10")
 193                   (17.0 . "cmr17")
 194                   )))
 195
 196        (#(roman upright bold) .
 197         (10.0 . #((6.0 . "cmbx6")
 198                   (8.0 . "cmbx8")
 199                   (10.0 . "cmbx10")
 200                   (12.0 . "cmbx12")
 201                   )))
 202
 203        (#(roman italic medium) .
 204         (10.0 . #((7.0 . "cmti7")
 205                   (10.0 . "cmti10")
 206                   (12.0 . "cmti12")
 207                   )))
 208        (#(roman italic bold) .
 209         (10.0 . #((8.0 . "cmbxti8")
 210                   (10.0 . "cmbxti10")
 211                   (14.0 . "cmbxti14")
 212                   )))
 213
 214        (#(roman caps medium) .
 215         (10.0 . #((10.0 . "cmcsc10"))))
 216
 217        (#(roman upright bold-narrow ) .
 218         (10.0 . #((10.0 . "cmb10")
 219                   )))
 220
 221        (#(sans upright medium) .
 222         (10.0  . #((8.0 . "cmss8")
 223                    (10.0 . "cmss10")
 224                    (12.0 . "cmss12")
 225                    (17.0 . "cmss17")
 226                    )))
 227        (#(typewriter upright medium) .
 228         (10.0 . #((8.0 .  "cmtt8")
 229                   (10.0 . "cmtt10")
 230                   (12.0 . "cmtt12")
 231                   )))
 232        ))
 233     n))
 234
 235 (display-font-node (make-font-tree 1.0))
 236
 237 (define-public (magstep x)
 238   (exp (* (/ x 6) (log 2))))