scm/bass-figure.scm

   1 ;;;; figured bass support ...
   2
   3 ;;;; todo: make interfaces as 1st level objects in LilyPond.
   4
   5
   6 (define (fontify-text font-metric text)
   7   "Set TEXT with font FONT-METRIC, returning a molecule."
   8   (let* ((b  (ly-text-dimension font-metric text)))
   9     (ly-make-molecule
  10      (ly-fontify-atom font-metric `(text ,text)) (car b) (cdr b))
  11     ))
  12
  13 (define (brew-one-figure grob fig-music)
  14   "Brew a single column for a music figure"
  15   (let* (
  16          (mf (ly-get-font grob '( (font-family .  music)  )))
  17          (nf (ly-get-font grob '( (font-family .  number)  )))
  18          (mol (ly-make-molecule  '() '(0 . 0) '(0 . 1.0)))
  19          (fig  (ly-get-mus-property fig-music 'figure))
  20          (acc  (ly-get-mus-property fig-music 'alteration))
  21          )
  22
  23     (if (number? fig)
  24         (begin
  25           (set! mol   (fontify-text nf (number->string fig)))
  26           (ly-align-to! mol Y CENTER)
  27         ))
  28
  29     (if (number? acc)
  30         (set! mol
  31               (ly-combine-molecule-at-edge
  32                mol 0 1 (ly-find-glyph-by-name mf (string-append "accidentals-" (number->string acc)))
  33                0.2))
  34         )
  35     (if (molecule? mol)
  36         (ly-align-to! mol X CENTER)
  37         )
  38     mol))
  39
  40
  41 (define (stack-molecules axis dir padding mols)
  42   "Stack molecules MOLS in direction AXIS,DIR, using PADDING."
  43   (if (null? mols)
  44       '()
  45       (if (pair? mols)
  46           (ly-combine-molecule-at-edge (car mols) axis dir
  47                                        (stack-molecules axis dir padding (cdr mols))
  48                                        padding
  49                                        )
  50           )
  51   ))
  52
  53 (define (brew-bass-figure grob)
  54   "Make a molecule for a Figured Bass grob"
  55   (let* (
  56          (figs (ly-get-grob-property grob 'causes ))
  57          (fig-mols (map (lambda (x) (brew-one-figure grob x)) figs))
  58          (fig-mol (stack-molecules 1 -1 0.2 fig-mols))
  59          )
  60
  61     (ly-align-to! fig-mol Y DOWN)
  62     fig-mol
  63   ))
  64