scm/new-font.scm

   1
   2
   3 ;; As an excercise, do it with records.
   4 ;; Should use GOOPS, really.
   5
   6 (define font-tree-record
   7   (make-record-type
   8    "font-tree-node"
   9    '(qualifier default children)))
  10
  11 (define-public font-tree-node?
  12   (record-predicate font-tree-record))
  13 (define-public font-tree-default
  14   (record-accessor font-tree-record 'default))
  15 (define-public font-tree-qualifier
  16   (record-accessor font-tree-record 'qualifier))
  17 (define-public font-tree-children
  18   (record-accessor font-tree-record 'children))
  19
  20
  21 (define (make-font-tree-node
  22          qualifier default)
  23   ((record-constructor font-tree-record)
  24     qualifier
  25     default
  26     (make-hash-table 11)))              ;ugh. hardcoded.
  27
  28 (define default-qualifier-order
  29   '(font-encoding font-family font-shape font-series))
  30
  31
  32 (define-public (add-font node fprops size-family)
  33   (define (assoc-delete key alist)
  34     (assoc-remove! (list-copy alist) key))
  35   (define (make-node fprops size-family)
  36     (if (null? fprops)
  37         size-family
  38         (let*
  39             ((qual (next-qualifier default-qualifier-order fprops)))
  40           (make-font-tree-node qual
  41                                (assoc-get qual fprops)))
  42         ))
  43   (define (next-qualifier order props)
  44     (cond
  45      ((and (null? props) (null? order))
  46       #f)
  47      ((null? props) (car order))
  48      ((null? order) (caar props))
  49      (else
  50       (if (assoc-get (car order) props)
  51           (car order)
  52           (next-qualifier (cdr order) props))
  53       )))
  54
  55   (if (font-tree-node? node)
  56       (let*
  57           ((q (font-tree-qualifier node))
  58            (d (font-tree-default node))
  59            (v (assoc-get q fprops d))
  60            (new-fprops (assoc-delete q fprops))
  61            (child (hashq-ref (font-tree-children node)
  62                              v #f)))
  63
  64
  65         (if (not child)
  66             (begin
  67               (set! child (make-node new-fprops size-family))
  68               (hashq-set! (font-tree-children node) v child)))
  69
  70         (add-font child new-fprops size-family))
  71       (if (not (equal? size-family node))
  72           (throw 'invalid-font props size-family)))
  73   )
  74
  75 (define-public (display-font-node node . rest)
  76   (let*
  77       ((port (if (pair? rest) (car rest) (current-output-port)))
  78        )
  79     (cond
  80      ((font-tree-node? node)
  81       (map
  82        (lambda (x)
  83          (display x port))
  84
  85        (list
  86         "Font_node { \nqual: "
  87         (font-tree-qualifier node)
  88         "(def: "
  89         (font-tree-default node)
  90         ") {\n"))
  91       (for-each
  92        (lambda (x)
  93          (display "\n")
  94          (display (car x) port)
  95          (display "=" port)
  96          (display-font-node (cdr x) port))
  97        (hash-table->alist (font-tree-children node)))
  98       (display "} } \n"))
  99
 100      (else
 101       (display node port))))
 102   )
 103
 104 (define-public (scale-font-node node factor)
 105   (cond
 106    ((font-tree-node? node)
 107     (hash-for-each (lambda (k v)
 108                      (scale-font-tree v factor)
 109                      (font-tree-children node))))
 110    (else
 111     (cons (* factor (car node))
 112           (cdr node)))))
 113
 114 (define-public (lookup-font node alist-chain)
 115   (cond
 116    ((font-tree-node? node)
 117     (let*
 118         ((qual (font-tree-qualifier node))
 119          (def (font-tree-default node))
 120          (val (chain-assoc-get qual alist-chain def))
 121          (desired-font (lookup-font
 122                         (hashq-ref (font-tree-children node)
 123                                    val) alist-chain))
 124          (font (if desired-font
 125                    desired-font
 126                    (lookup-font (hashq-ref (font-tree-children node)
 127                                            def) alist-chain)))
 128
 129          )
 130
 131       font))
 132    (else node))
 133    )
 134
 135
 136 (define-public paper20-font-tree (make-font-tree-node 'font-encoding 'music))
 137
 138
 139
 140 (add-font
 141  paper20-font-tree
 142  '((font-encoding . number))
 143  '(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
 150 (add-font
 151  paper20-font-tree
 152  '((font-encoding . dynamic))
 153  '(14.0 .  #((6.0 . "feta-din6")
 154             (8.0 . "feta-din8")
 155             (10.0 . "feta-din10")
 156             (12.0 . "feta-din12")
 157             (14.0 . "feta-din14")
 158             (17.0 . "feta-din17")
 159             )))
 160
 161     (use-modules (ice-9 readline))
 162
 163
 164
 165 (for-each
 166  (lambda (x)
 167    (add-font
 168     paper20-font-tree
 169     `((font-encoding . text)
 170       (font-series . ,(vector-ref (car x) 0))
 171       (font-shape . ,(vector-ref (car x) 1))
 172       (font-family . ,(vector-ref (car x) 2)))
 173     (cdr x))
 174    )
 175  '(
 176    (#(roman upright medium) .
 177     (10.0 . #((6.0 . "cmr6")
 178               (8.0 . "cmr8")
 179               (10.0 . "cmr10")
 180               (17.0 . "cmr17")
 181               )))
 182
 183
 184
 185    (#(roman upright bold) .
 186     (10.0 . #((6.0 . "cmbx6")
 187               (8.0 . "cmbx8")
 188               (10.0 . "cmbx10")
 189               (12.0 . "cmbx12")
 190               )))
 191
 192    (#(roman italic medium) .
 193     (10.0 . #((7.0 . "cmti7")
 194               (10.0 . "cmti10")
 195               (12.0 . "cmti12")
 196               )))
 197    (#(roman italic bold) .
 198     (10.0 . #((8.0 . "cmbxti8")
 199               (10.0 . "cmbxti10")
 200               (14.0 . "cmbxti14")
 201               )))
 202
 203    (#(roman caps medium) .
 204     (10.0 . #((10.0 . "cmcsc10"))))
 205
 206    (#(roman upright bold-narrow ) .
 207     (10.0 . #((10.0 . "cmb10")
 208               )))
 209
 210    (#(sans upright medium) .
 211     (10.0  . #((8.0 . "cmss8")
 212                (10.0 . "cmss10")
 213                (12.0 . "cmss12")
 214                (17.0 . "cmss17")
 215                )))
 216    (#(typewriter upright medium) .
 217     (10.0 . #((8.0 .  "cmtt8")
 218               (10.0 . "cmtt10")
 219               (12.0 . "cmtt12")
 220               )))
 221    ))
 222
 223
 224
 225 (add-font
 226  paper20-font-tree
 227  '((font-encoding . math))
 228  '(10.0 . #((10.0 . "msam10"))))
 229
 230 (add-font
 231  paper20-font-tree
 232  '((font-encoding . music))
 233  '(20.0 . #((11.22 . ("feta11" "parmesan11"))
 234             (12.60 . ("feta13" "parmesan13"))
 235             (14.14 . ("feta14" "parmesan14"))
 236             (15.87 . ("feta16" "parmesan16"))
 237             (17.82 . ("feta18" "parmesan18"))
 238             (20.0 . ("feta20" "parmesan20"))
 239             (22.45 . ("feta23" "parmesan23"))
 240             (25.20 . ("feta26" "parmesan26"))
 241             )))
 242
 243 (add-font
 244  paper20-font-tree
 245  '((font-encoding . braces))
 246  '(10 . #((10.0 . ("feta-braces00"
 247                   "feta-braces10"
 248                   "feta-braces20"
 249                   "feta-braces30"
 250                   "feta-braces40"
 251                   "feta-braces50"
 252                   "feta-braces60"
 253                   "feta-braces70"
 254                   "feta-braces80"))
 255          )))
 256
 257
 258 (display-font-node paper20-font-tree )
 259
 260 (if #f
 261     (begin
 262       (newline)
 263       (display
 264        (lookup-font
 265         paper20-font-tree
 266         '(((font-encoding . text)
 267            (font-shape . italic)
 268            ))))
 269       (newline)
 270       ))
 271
 272
 273
 274
 275
 276 (define (scale-font-tree root factor)
 277   "Scale ROOT with FACTOR."
 278   (cond
 279    ((and (font-tree-node? node)
 280          (equal? (font-tree-qualifier node) 'font-encoding))
 281     (hash-for-each (lambda (k v)
 282                      (if (not (equal? k 'braces))
 283                          (scale-font-node v factor))
 284                      (font-tree-children node))))
 285    (else
 286     (scale-font-node node))))
 287
 288
 289