X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=1a7747e9e6936fa9f6dca81693b7742a3a6d4aab;hb=6ec65b15b95eb3bd700579a9f85ce209ecd0812d;hp=03556dc7c50617d01109c357fd18ee501d835ba1;hpb=d3c94f2b7d7b3edb0455fcc37442595e124b22ac;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index 03556dc7c5..1a7747e9e6 100644 --- a/scm/output-lib.scm +++ b/scm/output-lib.scm @@ -2,14 +2,14 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2005 Jan Nieuwenhuizen +;;;; (c) 1998--2006 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;; 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))) + (circle (ly:text-interface::interpret-markup + 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) @@ -170,9 +176,9 @@ centered, X==1 is at the right, X == -1 is at the left." (let* ((bn (ly:context-property tr 'currentBarNumber))) (ly:context-set-property! tr 'barNumberVisibility (modulo-bar-number-visible n (modulo bn n))))) -(define-public (default-bar-number-visibility barnum) (> barnum 1)) +(define-public (first-bar-number-invisible barnum) (> barnum 1)) -;; See documentation of Item::visibility_lambda_ +;; See documentation of ly:item::visibility-lambda- (define-public begin-of-line-visible #(#f #f #t)) (define-public end-of-line-visible @@ -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))) @@ -249,18 +268,59 @@ centered, X==1 is at the right, X == -1 is at the left." (define-public darkyellow '(0.0 0.5 0.5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Pitch Trill Heads +;; * Pitch Trill Heads +;; * Parentheses -(define (parenthesize-elements grob) +(define (parenthesize-elements grob . rest) (let* - ((elts (ly:grob-object grob 'elements)) - (x-ext (ly:relative-group-extent elts grob X)) + ( + (refp (if (null? rest) + grob + (car rest))) + (elts (ly:grob-object grob 'elements)) + (x-ext (ly:relative-group-extent elts refp X)) + (font (ly:grob-default-font grob)) (lp (ly:font-get-glyph font "accidentals.leftparen")) (rp (ly:font-get-glyph font "accidentals.rightparen")) - (padding 0.1)) + (padding (ly:grob-property grob 'padding 0.1))) (ly:stencil-add (ly:stencil-translate-axis lp (- (car x-ext) padding) X) (ly:stencil-translate-axis rp (+ (cdr x-ext) padding) X)) )) + + +(define (parentheses-item::print me) + (let* + ((elts (ly:grob-object me 'elements)) + (y-ref (ly:grob-common-refpoint-of-array me elts Y)) + (x-ref (ly:grob-common-refpoint-of-array me elts X)) + (stencil (parenthesize-elements me x-ref)) + (elt-y-ext (ly:relative-group-extent elts y-ref Y)) + (y-center (interval-center elt-y-ext))) + + (ly:stencil-translate + stencil + (cons + (- + (ly:grob-relative-coordinate me x-ref X)) + (- + y-center + (ly:grob-relative-coordinate me y-ref Y)))) + )) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; + +(define-public (chain-grob-member-functions grob value . funcs) + (for-each + (lambda (func) + (set! value (func grob value))) + funcs) + + value) +