scm/bass-figure.scm

   1 ;;;; figured bass support ...
   2
   3 (ly:add-interface
   4 'bass-figure-interface
   5  "A bass figure, including bracket"
   6  '())
   7
   8 (define  (recursive-split-at pred? l)
   9   (if (null? l)
  10       '()
  11       (let*
  12           ((x (split-at-predicate pred? l)))
  13         (set-cdr! x (recursive-split-at pred? (cdr x)))
  14         x
  15         )))
  16
  17 (define-public (make-bass-figure-markup figures context)
  18
  19   (define (no-end-bracket? f1 f2)
  20     (eq? (ly:music-property f1 'bracket-stop) '())
  21     )
  22   (define (no-start-bracket? f1 f2)
  23     (eq? (ly:music-property f2 'bracket-start) '())
  24     )
  25
  26   ;; TODO: support slashed numerals here.
  27   (define (fig-to-markup fig-music)
  28     (let*
  29         ((align-accs (eq? #t (ly:context-property context 'alignBassFigureAccidentals)))
  30          (fig  (ly:music-property fig-music 'figure))
  31          (acc  (ly:music-property fig-music 'alteration))
  32          (acc-markup #f)
  33          (fig-markup
  34           (if (string? fig)
  35               (make-simple-markup fig)
  36               (if align-accs (make-simple-markup " ")
  37                   (if (not (eq? acc '()))
  38                       (make-simple-markup "")
  39                       (make-strut-markup)))
  40               )))
  41
  42       (if (number? acc)
  43           (make-line-markup (list fig-markup
  44                                   (alteration->text-accidental-markup acc)))
  45           fig-markup)
  46       ))
  47
  48   (define (fig-seq-to-markup figs)
  49     (let*
  50         (
  51          (c (make-dir-column-markup (map fig-to-markup figs)))
  52          )
  53       (if (eq? (ly:music-property (car figs) 'bracket-start) #t)
  54           (make-bracket-markup c)
  55           c
  56           )))
  57
  58   (let*
  59       (
  60        (ends (recursive-split-at no-end-bracket? (reverse figures)))
  61        (starts (map (lambda (x) (recursive-split-at no-start-bracket? x)) ends))
  62        )
  63     (make-dir-column-markup (map fig-seq-to-markup (apply append starts)))
  64     ))
  65