scm/bass-figure.scm

   1 ;;;; figured bass support ...
   2
   3 ;;;; todo: make interfaces as 1st level objects in LilyPond.
   4
   5 (define (brew-one-figure grob fig-music)
   6   "Brew a single column for a music figure"
   7   (let* (
   8          (mf (ly-get-font grob '( (font-family .  music)  )))
   9          (nf (ly-get-font grob '( (font-family .  number)  )))
  10          (mol (ly-make-molecule  '() '(0 . 0) '(0 . 1.0)))
  11          (fig  (ly-get-mus-property fig-music 'figure))
  12          (acc  (ly-get-mus-property fig-music 'alteration))
  13          )
  14
  15     (if (number? fig)
  16         (begin
  17           (set! mol   (fontify-text nf (number->string fig)))
  18           (ly-align-to! mol Y CENTER)
  19         ))
  20
  21     (if (number? acc)
  22         (set! mol
  23               (ly-combine-molecule-at-edge
  24                mol 0 1 (ly-find-glyph-by-name mf (string-append "accidentals-" (number->string acc)))
  25                0.2))
  26         )
  27     (if (molecule? mol)
  28         (ly-align-to! mol X CENTER)
  29         )
  30     mol))
  31
  32 (define (brew-bass-figure grob)
  33   "Make a molecule for a Figured Bass grob"
  34   (let* (
  35          (figs (ly-get-grob-property grob 'causes ))
  36          (mol (ly-make-molecule '() '(0 . 0) '(0 . 0)))
  37          (padding (ly-get-grob-property grob 'padding))
  38          (kerning (ly-get-grob-property grob 'kern))
  39          (thickness (*
  40                      (ly-get-paper-variable grob 'linethickness)
  41                      (ly-get-grob-property grob 'thickness))
  42                     )
  43          )
  44
  45     (define (brew-complete-figure grob figs mol)
  46       "recursive function: take some stuff from FIGS, and add it to MOL."
  47       (define (end-bracket? fig)
  48         (eq? (ly-get-mus-property fig 'bracket-stop) #t)
  49         )
  50
  51       (if (null? figs)
  52           mol
  53           (if (eq? (ly-get-mus-property (car figs) 'bracket-start) #t)
  54               (let* (
  55                      (gather-todo (take-from-list-until figs '() end-bracket?))
  56                      (unbr-mols
  57                       (map
  58                        (lambda (x) (brew-one-figure grob x))
  59                        (reverse! (car gather-todo) '())))
  60                      (br-mol (bracketify-molecule
  61                               (stack-molecules Y UP kerning unbr-mols)
  62                               Y thickness (* 2 padding) padding))
  63                      )
  64                 (brew-complete-figure
  65                  grob (cdr gather-todo)
  66                  (ly-combine-molecule-at-edge mol Y UP br-mol kerning)
  67                  )
  68                 )
  69               (brew-complete-figure
  70                grob (cdr figs)
  71                (ly-combine-molecule-at-edge mol Y UP (brew-one-figure grob (car figs))
  72                                             kerning))
  73               )
  74           ))
  75
  76
  77     (set! mol (brew-complete-figure grob (reverse figs) mol))
  78     (ly-align-to! mol Y DOWN)
  79     mol
  80     ))
  81
  82
  83 (ly-add-interface
  84 'bass-figure-interface
  85  "A bass figure, including bracket"
  86  '(padding thickness ))