Imported sources

[lilypond.git] / scm / bass-figure.scm

diff --git a/scm/bass-figure.scm b/scm/bass-figure.scm
index 409d58224579f29d532841876dd9e9ed403caaf6..9c72b95ed07977e162df4e8bf7d372433aa6be81 100644 (file)
--- a/scm/bass-figure.scm
+++ b/scm/bass-figure.scm
@@ -1,64 +1,65 @@
 ;;;; figured bass support ...
 
-;;;; todo: make interfaces as 1st level objects in LilyPond.
+(ly:add-interface
+'bass-figure-interface
+ "A bass figure, including bracket"
+ '())
 
+(define  (recursive-split-at pred? l)
+  (if (null? l)
+      '()
+      (let*
+         ((x (split-at-predicate pred? l)))
+       (set-cdr! x (recursive-split-at pred? (cdr x)))
+       x
+       )))
 
-(define (fontify-text font-metric text)
-  "Set TEXT with font FONT-METRIC, returning a molecule."
-  (let* ((b  (ly-text-dimension font-metric text)))
-    (ly-make-molecule
-     (ly-fontify-atom font-metric `(text ,text)) (car b) (cdr b))
-    ))
-
-(define (brew-one-figure grob fig-music)
-  "Brew a single column for a music figure"
-  (let* (
-        (mf (ly-get-font grob '( (font-family .  music)  )))
-        (nf (ly-get-font grob '( (font-family .  number)  )))
-        (mol (ly-make-molecule  '() '(0 . 0) '(0 . 1.0)))
-        (fig  (ly-get-mus-property fig-music 'figure))
-        (acc  (ly-get-mus-property fig-music 'alteration))
-        )
-    
-    (if (number? fig)
-       (begin
-         (set! mol   (fontify-text nf (number->string fig)))
-         (ly-align-to! mol Y CENTER)
-       ))
-    
-    (if (number? acc)
-       (set! mol
-             (ly-combine-molecule-at-edge
-              mol 0 1 (ly-find-glyph-by-name mf (string-append "accidentals-" (number->string acc)))
-              0.2))
-       )
-    (if (molecule? mol)
-       (ly-align-to! mol X CENTER)
-       )
-    mol))
-
+(define-public (make-bass-figure-markup figures context)
+  
+  (define (no-end-bracket? f1 f2)
+    (eq? (ly:get-mus-property f1 'bracket-stop) '())
+    )
+  (define (no-start-bracket? f1 f2)
+    (eq? (ly:get-mus-property f2 'bracket-start) '())
+    )
 
-(define (stack-molecules axis dir padding mols)
-  "Stack molecules MOLS in direction AXIS,DIR, using PADDING."
-  (if (null? mols)
-      '()
-      (if (pair? mols)
-         (ly-combine-molecule-at-edge (car mols) axis dir 
-                                      (stack-molecules axis dir padding (cdr mols))
-                                      padding
-                                      )
-         )
-  ))
+  ;; TODO: support slashed numerals here.
+  (define (fig-to-markup fig-music)
+    (let*
+       ((align-accs (eq? #t (ly:get-context-property context 'alignBassFigureAccidentals)))
+        (fig  (ly:get-mus-property fig-music 'figure))
+        (acc  (ly:get-mus-property fig-music 'alteration))
+        (acc-markup #f)
+        (fig-markup
+         (if (string? fig)
+             (make-simple-markup fig)
+             (if align-accs (make-simple-markup " ")
+                 (if (not (eq? acc '()))
+                     (make-simple-markup "")
+                     (make-strut-markup)))
+             )))
 
-(define (brew-bass-figure grob)
-  "Make a molecule for a Figured Bass grob"
-  (let* (
-        (figs (ly-get-grob-property grob 'causes ))
-        (fig-mols (map (lambda (x) (brew-one-figure grob x)) figs))
-        (fig-mol (stack-molecules 1 -1 0.2 fig-mols))
+      (if (number? acc)
+         (make-line-markup (list fig-markup
+                                 (alteration->text-accidental-markup acc)))
+         fig-markup)
+      ))
+  
+  (define (fig-seq-to-markup figs)
+    (let*
+       (
+        (c (make-dir-column-markup (map fig-to-markup figs)))
         )
-
-    (ly-align-to! fig-mol Y DOWN)
-    fig-mol
-  ))
+      (if (eq? (ly:get-mus-property (car figs) 'bracket-start) #t)
+         (make-bracket-markup c)
+         c
+         )))
+  
+  (let*
+      (
+       (ends (recursive-split-at no-end-bracket? (reverse figures)))
+       (starts (map (lambda (x) (recursive-split-at no-start-bracket? x)) ends))
+       )
+    (make-dir-column-markup (map fig-seq-to-markup (apply append starts)))
+    ))