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