X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=0d8c59785e8c7219db0e27ec11d188502c9c74a4;hb=caa28cbdc8801edf6f1bd04e2598a05bef28ae06;hp=f8ad46a1763a78787d736bbc87d03d9411d4c9b8;hpb=1fe440c70207e07c0e7c5d7714246d4ed190f427;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index f8ad46a176..0d8c59785e 100644 --- a/scm/output-lib.scm +++ b/scm/output-lib.scm @@ -9,7 +9,7 @@ ;;; Tablature functions, by Jiba (jiba@tuxfamily.org) ;; The TabNoteHead stem attachment function. -(define (tablature-stem-attachment-function style duration) +(define (note-head::calc-tablature-stem-attachment grob) (cons 0.0 1.35)) ;; The TabNoteHead tablatureFormat callback. @@ -59,8 +59,11 @@ ;;; end of tablature functions (define-public (make-stencil-boxer thickness padding callback) + "Return function that adds a box around the grob passed as argument." - (lambda (grob) (box-stencil (callback grob) thickness padding))) + (lambda (grob) + + (box-stencil (callback grob) thickness padding))) (define-public (make-stencil-circler thickness padding callback) "Return function that adds a circle around the grob passed as argument." @@ -73,14 +76,13 @@ (define-public (print-circled-text-callback grob) (let* ((text (ly:grob-property grob 'text)) + (layout (ly:grob-layout grob)) (defs (ly:output-def-lookup layout 'text-font-defaults)) (props (ly:grob-alist-chain grob defs)) (circle (Text_interface::interpret_markup - layout props (make-draw-circle-markup 0.8 0.1 #f))) - (text-stencil (Text_interface::interpret_markup layout props text))) - - (ly:stencil-add (centered-stencil text-stencil) circle))) + layout props (make-circle-markup text)))) + circle)) ;;(define (mm-to-pt x) @@ -110,41 +112,45 @@ ;; silly, use alist? -(define-public (find-notehead-symbol duration style) - (case style - ((xcircle) "2xcircle") - ((harmonic) "0harmonic") - ((baroque) - ;; Oops, I actually would not call this "baroque", but, for - ;; backwards compatibility to 1.4, this is supposed to take - ;; brevis, longa and maxima from the neo-mensural font and all - ;; other note heads from the default font. -- jr - (if (< duration 0) - (string-append (number->string duration) "neomensural") - (number->string duration))) - ((mensural) - (string-append (number->string duration) (symbol->string style))) - ((petrucci) - (if (< duration 0) - (string-append (number->string duration) "mensural") - (string-append (number->string duration) (symbol->string style)))) - ((neomensural) - (string-append (number->string duration) (symbol->string style))) - ((default) - ;; The default font in mf/feta-bolletjes.mf defines a brevis, but - ;; neither a longa nor a maxima. Hence let us, for the moment, - ;; take these from the neo-mensural font. TODO: mf/feta-bolletjes - ;; should define at least a longa for the default font. The longa - ;; should look exactly like the brevis of the default font, but - ;; with a stem exactly like that of the quarter note. -- jr - (if (< duration -1) - (string-append (number->string duration) "neomensural") - (number->string duration))) - (else - (if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style)) - (symbol->string style) - (string-append (number->string (max 0 duration)) - (symbol->string style)))))) +(define-public (note-head::calc-glyph-name grob) + (let* + ((style (ly:grob-property grob 'style)) + (log (min 2 (ly:grob-property grob 'duration-log)))) + + (case style + ((xcircle) "2xcircle") + ((harmonic) "0harmonic") + ((baroque) + ;; Oops, I actually would not call this "baroque", but, for + ;; backwards compatibility to 1.4, this is supposed to take + ;; brevis, longa and maxima from the neo-mensural font and all + ;; other note heads from the default font. -- jr + (if (< log 0) + (string-append (number->string log) "neomensural") + (number->string log))) + ((mensural) + (string-append (number->string log) (symbol->string style))) + ((petrucci) + (if (< log 0) + (string-append (number->string log) "mensural") + (string-append (number->string log) (symbol->string style)))) + ((neomensural) + (string-append (number->string log) (symbol->string style))) + ((default) + ;; The default font in mf/feta-bolletjes.mf defines a brevis, but + ;; neither a longa nor a maxima. Hence let us, for the moment, + ;; take these from the neo-mensural font. TODO: mf/feta-bolletjes + ;; should define at least a longa for the default font. The longa + ;; should look exactly like the brevis of the default font, but + ;; with a stem exactly like that of the quarter note. -- jr + (if (< log -1) + (string-append (number->string log) "neomensural") + (number->string log))) + (else + (if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style)) + (symbol->string style) + (string-append (number->string (max 0 log)) + (symbol->string style))))))) ;; TODO junk completely? (define (note-head-style->attachment-coordinates grob axis) @@ -194,8 +200,11 @@ centered, X==1 is at the right, X == -1 is at the left." ;; How should a bar line behave at a break? ;; ;; Why prepend `default-' to every scm identifier? -(define-public (default-break-barline glyph dir) - (let ((result (assoc glyph +(define-public (bar-line::calc-glyph-name grob) + (let* ( + (glyph (ly:grob-property grob 'glyph)) + (dir (ly:item-break-dir grob)) + (result (assoc glyph '((":|:" . (":|" . "|:")) ("||:" . ("||" . "|:")) ("|" . ("|" . ())) @@ -211,17 +220,27 @@ centered, X==1 is at the right, X == -1 is at the left." (".|." . (".|." . ())) ("" . ("" . "")) (":" . (":" . "")) + ("." . ("." . ())) ("empty" . (() . ())) ("brace" . (() . "brace")) - ("bracket" . (() . "bracket")) )))) + ("bracket" . (() . "bracket")) ))) + (glyph-name (if (= dir CENTER) + glyph + (if (and result (string? (index-cell (cdr result) dir))) + (index-cell (cdr result) dir) + #f))) + ) + + (if (not glyph-name) + (ly:grob-suicide! grob)) + + glyph-name)) - (if (equal? result #f) - (ly:warning (_ "unknown bar glyph: `~S'" glyph)) - (index-cell (cdr result) dir)))) (define-public (shift-right-at-line-begin g) "Shift an item to the right, but only at the start of the line." - (if (and (ly:item? g) (equal? (ly:item-break-dir g) RIGHT)) + (if (and (ly:item? g) + (equal? (ly:item-break-dir g) RIGHT)) (ly:grob-translate-axis! g 3.5 X))) @@ -264,3 +283,14 @@ centered, X==1 is at the right, X == -1 is at the left." (ly:stencil-translate-axis lp (- (car x-ext) padding) X) (ly:stencil-translate-axis rp (+ (cdr x-ext) padding) X)) )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; + +(define-public (chain-grob-member-functions grob value . funcs) + (for-each + (lambda (func) + (set! value (func grob value))) + funcs) + + value)