input/manual/font-table.ly

   1 #(set-global-staff-size 16)
   2
   3 #(begin
   4
   5   ;; some helper functions
   6
   7   (define (filter-out pred lst)
   8     (filter (lambda (x) (not (pred x))) lst))
   9
  10   (define (filter-out-group glyph-list substring)
  11     (filter-out (lambda (x) (string-contains x substring)) glyph-list))
  12
  13   (define (filter-out-groups glyph-list . substrings)
  14     (let loop ((new glyph-list) (rem substrings))
  15       (if (null? rem)
  16           new
  17           (loop (filter-out-group new (car rem))
  18                 (cdr rem)))))
  19
  20   (define (get-group glyph-list substring)
  21     (filter (lambda (x) (string-contains x substring)) glyph-list))
  22
  23   (define glyph-list
  24     (delete ".notdef"
  25             (ly:otf-glyph-list (ly:system-font-load "emmentaler-20"))))
  26
  27   ;;;;;;;;;
  28
  29   ;; define these 3 groups first since they're
  30   ;; harder to get with (get-groups ...)
  31   (define numbers
  32     '("plus" "comma" "hyphen" "period"
  33       "zero" "one"   "two"    "three"  "four"
  34       "five" "six"   "seven"  "eight"  "nine"))
  35
  36   (define default-noteheads
  37     '("noteheads.uM2" "noteheads.dM2" "noteheads.sM1"
  38       "noteheads.s0"  "noteheads.s1"  "noteheads.s2"))
  39
  40   (define dynamics
  41     '("space" "f" "m" "p" "r" "s" "z"))
  42
  43   ;; remove them from the glyph-list
  44   (for-each
  45     (lambda (x) (set! glyph-list (delete x glyph-list)))
  46     (append numbers
  47             default-noteheads
  48             dynamics))
  49
  50   ;;;;;;;;;
  51
  52   ;; extract ancient-music groups before extracting default
  53   ;; accidentals, rests, etc. to prevent duplication.
  54   (define vaticana    (get-group glyph-list "vaticana"))
  55   (define medicaea    (get-group glyph-list "medicaea"))
  56   (define hufnagel    (get-group glyph-list "hufnagel"))
  57   (define neomensural (get-group glyph-list "neomensural"))
  58
  59   ;; remove neomensural before defining mensural; otherwise, searching
  60   ;; for "mensural" would return "neomensural" matches too.
  61   (set! glyph-list
  62     (filter-out-groups
  63       glyph-list
  64       "vaticana"
  65       "medicaea"
  66       "hufnagel"
  67       "neomensural"))
  68
  69   ;; get the rest of the ancient-music groups
  70   (define mensural (get-group glyph-list "mensural"))
  71   (define petrucci (get-group glyph-list "petrucci"))
  72   (define solesmes (get-group glyph-list "solesmes"))
  73
  74   ;; remove them from the glyph-list
  75   (set! glyph-list
  76     (filter-out-groups
  77       glyph-list
  78       "mensural"
  79       "petrucci"
  80       "solesmes"))
  81
  82   ;; This would only get "rests.2classical".
  83   ;; We're leaving it with the other rests for now.
  84   ;; (define classical (get-group glyph-list "classical"))
  85   ;; (set! glyph-list (filter-out-groups glyph-list "classical"))
  86
  87   ;;;;;;;;;
  88
  89   ;; get everything else except noteheads.
  90   ;; * Some accidentals contain "slash" substring, so extract
  91   ;;   "accidentals" before extracting "slash" (noteheads).
  92   ;; * Also use "pedal." not "pedal", for example, to prevent things
  93   ;;   like "scripts.upedalheel" ending up in the "pedal." list.
  94   ;; * This doesn't apply to the ancient stuff because searching for
  95   ;;   "vaticana." (as an example) would miss things like
  96   ;;   "dots.dotvaticana"
  97   (define clefs       (get-group glyph-list "clefs."))
  98   (define timesig     (get-group glyph-list "timesig."))
  99   (define accidentals (get-group glyph-list "accidentals."))
 100   (define rests       (get-group glyph-list "rests."))
 101   (define flags       (get-group glyph-list "flags."))
 102   (define dots        (get-group glyph-list "dots."))
 103   (define scripts     (get-group glyph-list "scripts."))
 104   (define arrowheads  (get-group glyph-list "arrowheads."))
 105   (define brackettips (get-group glyph-list "brackettips."))
 106   (define pedal       (get-group glyph-list "pedal."))
 107   (define accordion   (get-group glyph-list "accordion."))
 108
 109   ;; remove them from the glyph-list
 110   (set! glyph-list
 111     (filter-out-groups
 112       glyph-list
 113       "clefs."
 114       "timesig."
 115       "accidentals."
 116       "rests."
 117       "flags."
 118       "dots."
 119       "scripts."
 120       "arrowheads."
 121       "brackettips."
 122       "pedal."
 123       "accordion."))
 124
 125   ;;;;;;;;;
 126
 127   ;; get special noteheads
 128   (define cross    (get-group glyph-list "cross"))
 129   (define diamond  (get-group glyph-list "diamond"))
 130   (define harmonic (get-group glyph-list "harmonic"))
 131   (define slash    (get-group glyph-list "slash"))
 132   (define triangle (get-group glyph-list "triangle"))
 133   (define xcircle  (get-group glyph-list "xcircle"))
 134
 135   (define special-noteheads
 136     (append cross
 137             diamond
 138             harmonic
 139             slash
 140             triangle
 141             xcircle))
 142
 143   ;; remove special noteheads from the glyph-list
 144   (set! glyph-list
 145     (filter-out-groups
 146       glyph-list
 147       "cross"
 148       "diamond"
 149       "harmonic"
 150       "slash"
 151       "triangle"
 152       "xcircle"))
 153
 154   ;; (lazy solution)
 155   ;; any remaining glyphs containing "noteheads." should be shape-notes.
 156   (define shape-note-noteheads (get-group glyph-list "noteheads."))
 157
 158   ;; remove shape-note-noteheads from the glyph-list
 159   (set! glyph-list (filter-out-group glyph-list "noteheads."))
 160
 161   ;;;;;;;;;
 162
 163   ;; simple debug test for any glyphs that didn't make it.
 164   (if #f
 165     (if (null? glyph-list)
 166         (format #t "No glyphs are missing from the table.\n")
 167         (format #t "You missed these glyphs: ~a\n" glyph-list)))
 168
 169 ) % end of (begin ...)
 170
 171 \paper {
 172   %% ugh. text on toplevel is a bit broken...
 173
 174   oddHeaderMarkup = \markup {}
 175   evenHeaderMarkup = \markup {}
 176   oddFooterMarkup = \markup {}
 177   evenFooterMarkup = \markup {}
 178   }
 179
 180 \version "2.12.0"
 181
 182 #(define-markup-command (doc-char layout props name) (string?)
 183   (interpret-markup layout props
 184    (let* ((n (string-length name)))
 185      (if (> n 24)
 186          ;; split long glyph names near the middle at dots
 187          (let* ((middle-pos (round (/ n 2)))
 188                 (left-dot-pos (string-rindex name #\. 0 middle-pos))
 189                 (right-dot-pos (string-index name #\. middle-pos))
 190                 (left-distance (if (number? left-dot-pos)
 191                                    (- middle-pos left-dot-pos)
 192                                    middle-pos))
 193                 (right-distance (if (number? right-dot-pos)
 194                                     (- right-dot-pos middle-pos)
 195                                     middle-pos))
 196                 (split-pos (if (> left-distance right-distance)
 197                                right-dot-pos
 198                                left-dot-pos))
 199                 (left (substring name 0 split-pos))
 200                 (right (substring name split-pos)))
 201            (markup
 202              #:pad-to-box '(0 . 36) '(-2 . 2) #:column (#:typewriter left
 203                                                         #:typewriter #:concat ("  " right))
 204              #:pad-to-box '(-2 . 4) '(-3.5 . 3.5) #:huge #:musicglyph name))
 205          (markup
 206            #:pad-to-box '(0 . 36) '(-2 . 2) #:typewriter name
 207            #:pad-to-box '(-2 . 4) '(-3.5 . 3.5) #:huge #:musicglyph name)))))
 208
 209 #(define-markup-list-command (doc-chars layout props names) (list?)
 210    (define (min-length lst n)
 211      "(min       (length lst) n)"
 212      (if (or (null? lst) (<= n 0))
 213          0
 214          (1+ (min-length (cdr lst) (1- n)))))
 215    (define (doc-chars-aux names acc)
 216      (let* ((n (min-length names 2))
 217             (head (take names n))
 218             (tail (drop names n)))
 219        (if (null? head)
 220            (reverse! acc)
 221            (doc-chars-aux tail
 222                          (cons (make-line-markup (map make-doc-char-markup head))
 223                                acc)))))
 224    (interpret-markup-list layout props (doc-chars-aux names (list))))