X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=733531c3c77259a80baaa48efd8d46074fe05c80;hb=3d54e4a6f45ccfb3847290cd0bdbefe4d21d7924;hp=8a5cae2b23f0fbcc79ab61c6334dd0222b115380;hpb=c5c06029fc0b17266d36b40255c631ac1d31a370;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index 8a5cae2b23..733531c3c7 100644 --- a/scm/output-lib.scm +++ b/scm/output-lib.scm @@ -395,56 +395,64 @@ (define-public (select-head-glyph style log) "Select a note head glyph string based on note head style @var{style} and duration-log @var{log}." - (case style - ;; "default" style is directly handled in note-head.cc as a - ;; special case (HW says, mainly for performance reasons). - ;; Therefore, style "default" does not appear in this case - ;; statement. -- jr - ((xcircle) "2xcircle") - ((harmonic) "0harmonic") - ((harmonic-black) "2harmonic") - ((harmonic-mixed) (if (<= log 1) "0harmonic" - "2harmonic")) - ((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))) - ((altdefault) - ;; Like default, but brevis is drawn with double vertical lines - (if (= log -1) - (string-append (number->string log) "double") - (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)))) - ((blackpetrucci) - (if (< log 0) - (string-append (number->string log) "blackmensural") - (string-append (number->string log) (symbol->string style)))) - ((semipetrucci) - (if (< log 0) - (string-append (number->string log) "semimensural") - (string-append (number->string log) "petrucci"))) - ((neomensural) - (string-append (number->string log) (symbol->string style))) - ((kievan) - (string-append (number->string log) "kievan")) - (else - (if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style)) - (symbol->string style) - (string-append (number->string (max 0 log)) - (symbol->string style)))))) + (if (symbol? style) + (case style + ;; "default" style is directly handled in note-head.cc as a + ;; special case (HW says, mainly for performance reasons). + ;; Therefore, style "default" does not appear in this case + ;; statement. -- jr + ;; Though we not to care if style is '(), see below. -- harm + ((xcircle) "2xcircle") + ((harmonic) "0harmonic") + ((harmonic-black) "2harmonic") + ((harmonic-mixed) (if (<= log 1) "0harmonic" + "2harmonic")) + ((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))) + ((altdefault) + ;; Like default, but brevis is drawn with double vertical lines + (if (= log -1) + (string-append (number->string log) "double") + (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)))) + ((blackpetrucci) + (if (< log 0) + (string-append (number->string log) "blackmensural") + (string-append (number->string log) (symbol->string style)))) + ((semipetrucci) + (if (< log 0) + (string-append (number->string log) "semimensural") + (string-append (number->string log) "petrucci"))) + ((neomensural) + (string-append (number->string log) (symbol->string style))) + ((kievan) + (string-append (number->string log) "kievan")) + (else + (if (string-match "vaticana*|hufnagel*|medicaea*" + (symbol->string style)) + (symbol->string style) + (string-append (number->string (max 0 log)) + (symbol->string style))))) + ;; 'vaticana-ligature-interface has a 'glyph-name-property for NoteHead. + ;; Probably best to return an empty list here, if called in a context + ;; without setting 'style, i.e. 'style is '(), to avoid a scheme-error. + '())) (define-public (note-head::calc-glyph-name grob) (let* ((style (ly:grob-property grob 'style)) - (log (if (string-match "kievan*" (symbol->string style)) + (log (if (and (symbol? style) + (string-match "kievan*" (symbol->string style))) (min 3 (ly:grob-property grob 'duration-log)) (min 2 (ly:grob-property grob 'duration-log))))) (select-head-glyph style log))) @@ -880,8 +888,9 @@ and duration-log @var{log}." (ly:stencil-aligned-to (make-parenthesis-stencil y-extent half-thickness - (- width) - angularity) + width + angularity + -1) Y CENTER) X RIGHT)) (lp-x-extent @@ -891,7 +900,8 @@ and duration-log @var{log}." (make-parenthesis-stencil y-extent half-thickness width - angularity) + angularity + 1) Y CENTER) X LEFT)) (rp-x-extent @@ -967,14 +977,53 @@ and duration-log @var{log}." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -(define-public (chain-grob-member-functions grob value . funcs) - (for-each - (lambda (func) - (set! value (func grob value))) - funcs) - - value) - +(define-public (grob::compose-function func data) + "This creates a callback entity to be stored in a grob property, +based on the grob property data @var{data} (which can be plain data, a +callback itself, or an unpure-pure-container). + +Function or unpure-pure-container @var{func} accepts a grob and a +value and returns another value. Depending on the type of @var{data}, +@var{func} is used for building a grob callback or an +unpure-pure-container." + (if (or (ly:unpure-pure-container? func) + (ly:unpure-pure-container? data)) + (ly:make-unpure-pure-container + (lambda (grob) (ly:unpure-call func grob (ly:unpure-call data grob))) + (lambda (grob start end) + (ly:pure-call func grob start end + (ly:pure-call data grob start end)))) + (lambda (grob) (ly:unpure-call func grob (ly:unpure-call data grob))))) + +(define*-public (grob::offset-function func data + #:optional (plus +)) + "This creates a callback entity to be stored in a grob property, +based on the grob property data @var{data} (which can be plain data, a +callback itself, or an unpure-pure-container). + +Function @var{func} accepts a grob and returns a value that is added +to the value resulting from @var{data}. Optional argument @var{plus} +defaults to @code{+} but may be changed to allow for using a different +underlying accumulation. + +If @var{data} is @code{#f} or @code{'()}, it is not included in the sum." + (cond ((or (not data) (null? data)) + func) + ((or (ly:unpure-pure-container? func) + (ly:unpure-pure-container? data)) + (ly:make-unpure-pure-container + (lambda rest + (plus (apply ly:unpure-call func rest) + (apply ly:unpure-call data rest))) + (lambda rest + (plus (apply ly:pure-call func rest) + (apply ly:pure-call data rest))))) + ((or (procedure? func) + (procedure? data)) + (lambda rest + (plus (apply ly:unpure-call func rest) + (apply ly:unpure-call data rest)))) + (else (plus func data)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; falls/doits @@ -1080,9 +1129,11 @@ and duration-log @var{log}." (define-public (stroke-finger::calc-text grob) (let ((event (event-cause grob))) (or (ly:event-property event 'text #f) - (vector-ref (ly:grob-property grob 'digit-names) - (1- (max 1 - (min 5 (ly:event-property event 'digit)))))))) + (let ((digit-names (ly:grob-property grob 'digit-names))) + (vector-ref digit-names + (1- (max 1 + (min (vector-length digit-names) + (ly:event-property event 'digit))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;