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