X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=b9f5e421e9103609a7f6fc0cfcf1d3824b3324ea;hb=b715af1d7ae27aa1c3cdca6b18cf17873ecdb6ba;hp=c174a295c33e1540ce7a9a3812347aeb7fb045e8;hpb=4b7d95665a24a10d6b893df83152d4bc9a7fb055;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index c174a295c3..b9f5e421e9 100644 --- a/scm/output-lib.scm +++ b/scm/output-lib.scm @@ -6,10 +6,9 @@ ;;;; Han-Wen Nienhuys - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; general + (define-public (grob::has-interface grob iface) (memq iface (ly:grob-interfaces grob))) @@ -20,7 +19,6 @@ "Return function that adds a box around the grob passed as argument." (lambda (grob) - (box-stencil (callback grob) thickness padding))) (define-public (make-stencil-circler thickness padding callback) @@ -30,72 +28,27 @@ (define-public (print-circled-text-callback grob) (grob-interpret-markup grob (make-circle-markup - (ly:grob-property grob 'text)) - )) + (ly:grob-property grob 'text)))) (define-public (event-cause grob) - (let* - ((cause (ly:grob-property grob 'cause))) + (let ((cause (ly:grob-property grob 'cause))) (cond ((ly:stream-event? cause) cause) ((ly:grob? cause) (event-cause cause)) (else #f)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; tablature - -;; The TabNoteHead tablatureFormat callback. -;; Compute the text grob-property -(define-public (fret-number-tablature-format string - context event) - (let* - ((tuning (ly:context-property context 'stringTunings)) - (pitch (ly:event-property event 'pitch)) - (is-harmonic (apply - functional-or - (map - (lambda (ev) - (eq? 'harmonic-event (ly:event-property ev 'class))) - (ly:event-property event 'articulations))))) - - - (make-whiteout-markup - (make-vcenter-markup - (format - "~a" - (- (ly:pitch-semitones pitch) - (list-ref tuning - ;; remove 1 because list index starts at 0 and guitar string at 1. - (- string 1)))))) - )) - -;; The 5-string banjo has got a extra string, the fifth (duh), wich -;; starts at the fifth fret on the neck. Frets on the fifth string -;; are referred to relative to the other frets: -;; the "first fret" on the fifth string is really the sixth fret -;; on the banjo neck. -;; We solve this by defining a new fret-number-tablature function: -(define-public (fret-number-tablature-format-banjo string - context event) - (let* - ((tuning (ly:context-property context 'stringTunings)) - (pitch (ly:event-property event 'pitch)) - ) - (make-whiteout-markup - (make-vcenter-markup - (let ((fret (- (ly:pitch-semitones pitch) (list-ref tuning (- string 1))))) - (number->string (cond - ((and (> fret 0) (= string 5)) - (+ fret 5)) - (else fret)))))) - )) +(define-public (grob-interpret-markup grob text) + (let* ((layout (ly:grob-layout grob)) + (defs (ly:output-def-lookup layout 'text-font-defaults)) + (props (ly:grob-alist-chain grob defs))) + + (ly:text-interface::interpret-markup layout props text))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; note heads - (define-public (stem::calc-duration-log grob) (ly:duration-log (ly:event-property (event-cause grob) 'duration))) @@ -110,13 +63,12 @@ (ly:event-property (event-cause grob) 'duration))) (define-public (dots::calc-staff-position grob) - (let* - ((head (ly:grob-parent grob Y)) - (log (ly:grob-property head 'duration-log))) + (let* ((head (ly:grob-parent grob Y)) + (log (ly:grob-property head 'duration-log))) (cond ((or (not (grob::has-interface head 'rest-interface)) - (not (integer? log))) 0) + (not (integer? log))) 0) ((= log 7) 4) ((> log 4) 3) ((= log 0) -1) @@ -124,16 +76,10 @@ ((= log -1) 1) (else 0)))) -(define (note-head::calc-tablature-stem-attachment grob) - (cons 0.0 1.35)) - - - ;; silly, use alist? (define-public (note-head::calc-glyph-name grob) - (let* - ((style (ly:grob-property grob 'style)) - (log (min 2 (ly:grob-property grob 'duration-log)))) + (let ((style (ly:grob-property grob 'style)) + (log (min 2 (ly:grob-property grob 'duration-log)))) (case style ;; "default" style is directly handled in note-head.cc as a @@ -144,7 +90,7 @@ ((harmonic) "0harmonic") ((harmonic-black) "2harmonic") ((harmonic-mixed) (if (<= log 1) "0harmonic" - "2harmonic")) + "2harmonic")) ((baroque) ;; Oops, I actually would not call this "baroque", but, for ;; backwards compatibility to 1.4, this is supposed to take @@ -153,6 +99,11 @@ (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) @@ -167,36 +118,43 @@ (string-append (number->string (max 0 log)) (symbol->string style))))))) -;; TODO junk completely? -(define (note-head-style->attachment-coordinates grob axis) - "Return pair (X . Y), containing multipliers for the note head -bounding box, where to attach the stem. e.g.: X==0 means horizontally -centered, X==1 is at the right, X == -1 is at the left." - - '(1.0 . 0.0)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; bar numbers - -(define-public ((every-nth-bar-number-visible n) barnum) (= 0 (modulo barnum n))) - -(define-public ((modulo-bar-number-visible n m) barnum) (and (> barnum 1) (= m (modulo barnum n)))) - -(define-public ((set-bar-number-visibility n) tr) - (let* ((bn (ly:context-property tr 'currentBarNumber))) - (ly:context-set-property! tr 'barNumberVisibility (modulo-bar-number-visible n (modulo bn n))))) - -(define-public (first-bar-number-invisible barnum) (> barnum 1)) - -(define-public (all-bar-numbers-visible barnum) #t) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; percent repeat counters - -(define-public ((every-nth-repeat-count-visible n) count context) (= 0 (modulo count n))) +(define-public (note-head::brew-ez-stencil grob) + (let* ((log (ly:grob-property grob 'duration-log)) + (pitch (ly:event-property (event-cause grob) 'pitch)) + (pitch-index (ly:pitch-notename pitch)) + (note-names (ly:grob-property grob 'note-names)) + (pitch-string (if (vector? note-names) + (vector-ref note-names pitch-index) + (string + (integer->char + (+ (modulo (+ pitch-index 2) 7) + (char->integer #\A)))))) + (staff-space (ly:staff-symbol-staff-space grob)) + (line-thickness (ly:staff-symbol-line-thickness grob)) + (stem (ly:grob-object grob 'stem)) + (stem-thickness (* (if (ly:grob? stem) + (ly:grob-property stem 'thickness) + 1.3) + line-thickness)) + (radius (/ (+ staff-space line-thickness) 2)) + (letter (markup #:center-align #:vcenter pitch-string)) + (filled-circle (markup #:draw-circle radius 0 #t))) + + (ly:stencil-translate-axis + (grob-interpret-markup + grob + (if (>= log 2) + (make-combine-markup + filled-circle + (make-with-color-markup white letter)) + (make-combine-markup + (make-combine-markup + filled-circle + (make-with-color-markup white (make-draw-circle-markup + (- radius stem-thickness) 0 #t))) + letter))) + radius X))) -(define-public (all-repeat-counts-visible count context) #t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; break visibility @@ -210,10 +168,10 @@ centered, X==1 is at the right, X == -1 is at the left." (define-public end-of-line-visible #(#t #f #f)) (define-public all-invisible #(#f #f #f)) -(define-public spanbar-begin-of-line-invisible - #(#t #f #f)) +(define-public spanbar-begin-of-line-invisible #(#t #f #f)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Bar lines. ;; @@ -242,29 +200,27 @@ centered, X==1 is at the right, X == -1 is at the left." ("'" . ("'" . ())) ("empty" . (() . ())) ("brace" . (() . "brace")) - ("bracket" . (() . "bracket")) - )) + ("bracket" . (() . "bracket")))) (define-public (bar-line::calc-glyph-name grob) - (let* ( - (glyph (ly:grob-property grob 'glyph)) + (let* ((glyph (ly:grob-property grob 'glyph)) (dir (ly:item-break-dir grob)) - (result (assoc glyph bar-glyph-alist)) + (result (assoc-get glyph bar-glyph-alist)) (glyph-name (if (= dir CENTER) glyph - (if (and result (string? (index-cell (cdr result) dir))) - (index-cell (cdr result) dir) - #f))) - ) + (if (and result + (string? (index-cell result dir))) + (index-cell result dir) + #f)))) glyph-name)) (define-public (bar-line::calc-break-visibility grob) (let* ((glyph (ly:grob-property grob 'glyph)) - (result (assoc glyph bar-glyph-alist))) - (if result - (vector (string? (cadr result)) #t (string? (cddr result))) - #(#f #f #f)))) + (result (assoc-get glyph bar-glyph-alist))) + (if result + (vector (string? (car result)) #t (string? (cdr result))) + all-invisible))) (define-public (shift-right-at-line-begin g) "Shift an item to the right, but only at the start of the line." @@ -280,58 +236,65 @@ centered, X==1 is at the right, X == -1 is at the left." (number->string (ly:event-property (event-cause grob) 'denominator))) (define-public (tuplet-number::calc-fraction-text grob) - (let* - ((ev (event-cause grob))) + (let ((ev (event-cause grob))) (format "~a:~a" (ly:event-property ev 'denominator) (ly:event-property ev 'numerator)))) - -; a formatter function, which is simply a wrapper around an existing -; tuplet formatter function. It takes the value returned by the given -; function and appends a note of given length. +;; a formatter function, which is simply a wrapper around an existing +;; tuplet formatter function. It takes the value returned by the given +;; function and appends a note of given length. (define-public ((tuplet-number::append-note-wrapper function note) grob) - (let* ((txt (if function (function grob) #f))) + (let ((txt (if function (function grob) #f))) + (if txt - (markup txt #:fontsize -5 #:note note UP) - (markup #:fontsize -5 #:note note UP)))) - -; Print a tuplet denominator with a different number than the one derived from -; the actual tuplet fraction -(define-public ((tuplet-number::non-default-tuplet-denominator-text denominator) grob) -(number->string (if denominator - denominator - (ly:event-property (event-cause grob) 'denominator)))) - -; Print a tuplet fraction with different numbers than the ones derived from -; the actual tuplet fraction -(define-public ((tuplet-number::non-default-tuplet-fraction-text denominator numerator) grob) + (markup txt #:fontsize -5 #:note note UP) + (markup #:fontsize -5 #:note note UP)))) + +;; Print a tuplet denominator with a different number than the one derived from +;; the actual tuplet fraction +(define-public ((tuplet-number::non-default-tuplet-denominator-text denominator) + grob) + (number->string (if denominator + denominator + (ly:event-property (event-cause grob) 'denominator)))) + +;; Print a tuplet fraction with different numbers than the ones derived from +;; the actual tuplet fraction +(define-public ((tuplet-number::non-default-tuplet-fraction-text + denominator numerator) grob) (let* ((ev (event-cause grob)) (den (if denominator denominator (ly:event-property ev 'denominator))) (num (if numerator numerator (ly:event-property ev 'numerator)))) - (format "~a:~a" den num))) -; Print a tuplet fraction with note durations appended to the numerator and the -; denominator -(define-public ((tuplet-number::fraction-with-notes denominatornote numeratornote) grob) + (format "~a:~a" den num))) + +;; Print a tuplet fraction with note durations appended to the numerator and the +;; denominator +(define-public ((tuplet-number::fraction-with-notes + denominatornote numeratornote) grob) (let* ((ev (event-cause grob)) (denominator (ly:event-property ev 'denominator)) (numerator (ly:event-property ev 'numerator))) - ((tuplet-number::non-default-fraction-with-notes denominator denominatornote numerator numeratornote) grob))) -; Print a tuplet fraction with note durations appended to the numerator and the -; denominator -(define-public ((tuplet-number::non-default-fraction-with-notes denominator denominatornote numerator numeratornote) grob) + ((tuplet-number::non-default-fraction-with-notes + denominator denominatornote numerator numeratornote) grob))) + +;; Print a tuplet fraction with note durations appended to the numerator and the +;; denominator +(define-public ((tuplet-number::non-default-fraction-with-notes + denominator denominatornote numerator numeratornote) grob) (let* ((ev (event-cause grob)) (den (if denominator denominator (ly:event-property ev 'denominator))) (num (if numerator numerator (ly:event-property ev 'numerator)))) - (make-concat-markup (list - (make-simple-markup (format "~a" den)) - (markup #:fontsize -5 #:note denominatornote UP) - (make-simple-markup " : ") - (make-simple-markup (format "~a" num)) - (markup #:fontsize -5 #:note numeratornote UP))))) + + (make-concat-markup (list + (make-simple-markup (format "~a" den)) + (markup #:fontsize -5 #:note denominatornote UP) + (make-simple-markup " : ") + (make-simple-markup (format "~a" num)) + (markup #:fontsize -5 #:note numeratornote UP))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -358,11 +321,12 @@ centered, X==1 is at the right, X == -1 is at the left." (define-public darkmagenta '(0.5 0.0 0.5)) (define-public darkyellow '(0.5 0.5 0.0)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; key signature - -(define-public (key-signature-interface::alteration-position step alter c0-position) +(define-public (key-signature-interface::alteration-position step alter + c0-position) ;; TODO: memoize - this is mostly constant. ;; fes, ges, as and bes typeset in lower octave @@ -372,16 +336,16 @@ centered, X==1 is at the right, X == -1 is at the left." (define SHARP_TOP_PITCH 4) (if (pair? step) - (+ (cdr step) (* (car step) 7) c0-position) - (let* - ((from-bottom-pos (modulo (+ 4 49 c0-position) 7)) - (p step) - (c0 (- from-bottom-pos 4))) + (+ (cdr step) (* (car step) 7) c0-position) + (let* ((from-bottom-pos (modulo (+ 4 49 c0-position) 7)) + (p step) + (c0 (- from-bottom-pos 4))) (if - (or (and (< alter 0) (or (> p FLAT_TOP_PITCH) (> (+ p c0) 4)) (> (+ p c0) 1)) - (and (> alter 0) (or (> p SHARP_TOP_PITCH) (> (+ p c0) 5)) (> (+ p c0) 2)) - ) + (or (and (< alter 0) + (or (> p FLAT_TOP_PITCH) (> (+ p c0) 4)) (> (+ p c0) 1)) + (and (> alter 0) + (or (> p SHARP_TOP_PITCH) (> (+ p c0) 5)) (> (+ p c0) 2))) ;; Typeset below c_position (set! p (- p 7))) @@ -407,64 +371,62 @@ centered, X==1 is at the right, X == -1 is at the left." ;; accidentals (define-public (accidental-interface::calc-alteration grob) - (ly:pitch-alteration (ly:event-property (event-cause grob) 'pitch))) - + (ly:pitch-alteration (ly:event-property (event-cause grob) 'pitch))) (define-public cancellation-glyph-name-alist '((0 . "accidentals.natural"))) (define-public standard-alteration-glyph-name-alist - '( - ;; ordered for optimal performance. - (0 . "accidentals.natural") - (-1/2 . "accidentals.flat") - (1/2 . "accidentals.sharp") + '( + ;; ordered for optimal performance. + (0 . "accidentals.natural") + (-1/2 . "accidentals.flat") + (1/2 . "accidentals.sharp") - (1 . "accidentals.doublesharp") - (-1 . "accidentals.flatflat") + (1 . "accidentals.doublesharp") + (-1 . "accidentals.flatflat") - (3/4 . "accidentals.sharp.slashslash.stemstemstem") - (1/4 . "accidentals.sharp.slashslash.stem") - (-1/4 . "accidentals.mirroredflat") - (-3/4 . "accidentals.mirroredflat.flat") - )) + (3/4 . "accidentals.sharp.slashslash.stemstemstem") + (1/4 . "accidentals.sharp.slashslash.stem") + (-1/4 . "accidentals.mirroredflat") + (-3/4 . "accidentals.mirroredflat.flat"))) ;; FIXME: standard vs default, alteration-FOO vs FOO-alteration -(define-public alteration-default-glyph-name-alist standard-alteration-glyph-name-alist) +(define-public alteration-default-glyph-name-alist + standard-alteration-glyph-name-alist) (define-public makam-alteration-glyph-name-alist - '((1 . "accidentals.doublesharp") - (8/9 . "accidentals.sharp.slashslashslash.stemstem") - (5/9 . "accidentals.sharp.slashslashslash.stem") - (4/9 . "accidentals.sharp") - (1/9 . "accidentals.sharp.slashslash.stem") - (0 . "accidentals.natural") - (-1/9 . "accidentals.mirroredflat") - (-4/9 . "accidentals.flat.slash") - (-5/9 . "accidentals.flat") - (-8/9 . "accidentals.flat.slashslash") - (-1 . "accidentals.flatflat") - )) + '((1 . "accidentals.doublesharp") + (8/9 . "accidentals.sharp.slashslashslash.stemstem") + (5/9 . "accidentals.sharp.slashslashslash.stem") + (4/9 . "accidentals.sharp") + (1/9 . "accidentals.sharp.slashslash.stem") + (0 . "accidentals.natural") + (-1/9 . "accidentals.mirroredflat") + (-4/9 . "accidentals.flat.slash") + (-5/9 . "accidentals.flat") + (-8/9 . "accidentals.flat.slashslash") + (-1 . "accidentals.flatflat"))) (define-public alteration-hufnagel-glyph-name-alist - '((-1/2 . "accidentals.hufnagelM1") - (0 . "accidentals.vaticana0") - (1/2 . "accidentals.mensural1"))) + '((-1/2 . "accidentals.hufnagelM1") + (0 . "accidentals.vaticana0") + (1/2 . "accidentals.mensural1"))) (define-public alteration-medicaea-glyph-name-alist - '((-1/2 . "accidentals.medicaeaM1") - (0 . "accidentals.vaticana0") - (1/2 . "accidentals.mensural1"))) + '((-1/2 . "accidentals.medicaeaM1") + (0 . "accidentals.vaticana0") + (1/2 . "accidentals.mensural1"))) (define-public alteration-vaticana-glyph-name-alist - '((-1/2 . "accidentals.vaticanaM1") - (0 . "accidentals.vaticana0") - (1/2 . "accidentals.mensural1"))) + '((-1/2 . "accidentals.vaticanaM1") + (0 . "accidentals.vaticana0") + (1/2 . "accidentals.mensural1"))) (define-public alteration-mensural-glyph-name-alist - '((-1/2 . "accidentals.mensuralM1") - (0 . "accidentals.vaticana0") - (1/2 . "accidentals.mensural1"))) + '((-1/2 . "accidentals.mensuralM1") + (0 . "accidentals.vaticana0") + (1/2 . "accidentals.mensural1"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -478,64 +440,53 @@ centered, X==1 is at the right, X == -1 is at the left." (list lp rp))) - -(define-public (grob-interpret-markup grob text) - (let* - ((layout (ly:grob-layout grob)) - (defs (ly:output-def-lookup layout 'text-font-defaults)) - (props (ly:grob-alist-chain grob defs))) - - (ly:text-interface::interpret-markup - layout props text))) - (define-public (parentheses-item::calc-angled-bracket-stencils grob) - (let* ( - (font (ly:grob-default-font grob)) - (lp (ly:stencil-aligned-to (ly:stencil-aligned-to (grob-interpret-markup grob (ly:wide-char->utf-8 #x2329)) - Y CENTER) X RIGHT)) - (rp (ly:stencil-aligned-to (ly:stencil-aligned-to (grob-interpret-markup grob (ly:wide-char->utf-8 #x232A)) - Y CENTER) X LEFT)) - ) + (let* ((font (ly:grob-default-font grob)) + (lp (ly:stencil-aligned-to (ly:stencil-aligned-to + (grob-interpret-markup + grob + (ly:wide-char->utf-8 #x2329)) + Y CENTER) + X RIGHT)) + (rp (ly:stencil-aligned-to (ly:stencil-aligned-to + (grob-interpret-markup + grob + (ly:wide-char->utf-8 #x232A)) + Y CENTER) + X LEFT))) (list (stencil-whiteout lp) (stencil-whiteout rp)))) (define (parenthesize-elements grob . rest) - (let* - ((refp (if (null? rest) - grob - (car rest))) - (elts (ly:grob-object grob 'elements)) - (x-ext (ly:relative-group-extent elts refp X)) - (stencils (ly:grob-property grob 'stencils)) - (lp (car stencils)) - (rp (cadr stencils)) - (padding (ly:grob-property grob 'padding 0.1))) + (let* ((refp (if (null? rest) + grob + (car rest))) + (elts (ly:grob-object grob 'elements)) + (x-ext (ly:relative-group-extent elts refp X)) + (stencils (ly:grob-property grob 'stencils)) + (lp (car stencils)) + (rp (cadr stencils)) + (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)) - )) + (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))) + (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)))) - )) + (- (ly:grob-relative-coordinate me x-ref X)) + (- y-center (ly:grob-relative-coordinate me y-ref Y)))))) @@ -550,6 +501,7 @@ centered, X==1 is at the right, X == -1 is at the left." value) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; falls/doits @@ -557,51 +509,53 @@ centered, X==1 is at the right, X == -1 is at the left." (define (close a b) (< (abs (- a b)) 0.01)) - (let* - ((delta-y (* 0.5 (ly:grob-property spanner 'delta-position))) - (left-span (ly:spanner-bound spanner LEFT)) - (dots (if (and (grob::has-interface left-span 'note-head-interface) - (ly:grob? (ly:grob-object left-span 'dot))) - (ly:grob-object left-span 'dot) #f)) - - (right-span (ly:spanner-bound spanner RIGHT)) - (thickness (* (ly:grob-property spanner 'thickness) - (ly:output-def-lookup (ly:grob-layout spanner) - 'line-thickness))) - (padding (ly:grob-property spanner 'padding 0.5)) - (common (ly:grob-common-refpoint right-span - (ly:grob-common-refpoint spanner - left-span X) - X)) - (common-y (ly:grob-common-refpoint spanner left-span Y)) - (minimum-length (ly:grob-property spanner 'minimum-length 0.5)) - - (left-x (+ padding - (max (interval-end (ly:grob-robust-relative-extent - left-span common X)) - (if (and - dots - (close (ly:grob-relative-coordinate dots common-y Y) - (ly:grob-relative-coordinate spanner common-y Y))) - (interval-end (ly:grob-robust-relative-extent dots common X)) - -10000) ;; TODO: use real infinity constant. - ))) - (right-x (max (- (interval-start (ly:grob-robust-relative-extent right-span common X)) - padding) - (+ left-x minimum-length))) - (self-x (ly:grob-relative-coordinate spanner common X)) - (dx (- right-x left-x)) - (exp (list 'path thickness - `(quote - (rmoveto - ,(- left-x self-x) 0 - - rcurveto - ,(/ dx 3) - 0 - ,dx ,(* 0.66 delta-y) - ,dx ,delta-y - ))))) + (let* ((delta-y (* 0.5 (ly:grob-property spanner 'delta-position))) + (left-span (ly:spanner-bound spanner LEFT)) + (dots (if (and (grob::has-interface left-span 'note-head-interface) + (ly:grob? (ly:grob-object left-span 'dot))) + (ly:grob-object left-span 'dot) #f)) + + (right-span (ly:spanner-bound spanner RIGHT)) + (thickness (* (ly:grob-property spanner 'thickness) + (ly:output-def-lookup (ly:grob-layout spanner) + 'line-thickness))) + (padding (ly:grob-property spanner 'padding 0.5)) + (common (ly:grob-common-refpoint right-span + (ly:grob-common-refpoint spanner + left-span X) + X)) + (common-y (ly:grob-common-refpoint spanner left-span Y)) + (minimum-length (ly:grob-property spanner 'minimum-length 0.5)) + + (left-x (+ padding + (max + (interval-end (ly:grob-robust-relative-extent + left-span common X)) + (if + (and dots + (close + (ly:grob-relative-coordinate dots common-y Y) + (ly:grob-relative-coordinate spanner common-y Y))) + (interval-end + (ly:grob-robust-relative-extent dots common X)) + ;; TODO: use real infinity constant. + -10000)))) + (right-x (max (- (interval-start + (ly:grob-robust-relative-extent right-span common X)) + padding) + (+ left-x minimum-length))) + (self-x (ly:grob-relative-coordinate spanner common X)) + (dx (- right-x left-x)) + (exp (list 'path thickness + `(quote + (rmoveto + ,(- left-x self-x) 0 + + rcurveto + ,(/ dx 3) + 0 + ,dx ,(* 0.66 delta-y) + ,dx ,delta-y))))) (ly:make-stencil exp @@ -609,73 +563,69 @@ centered, X==1 is at the right, X == -1 is at the left." (cons (min 0 delta-y) (max 0 delta-y))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; grace spacing - (define-public (grace-spacing::calc-shortest-duration grob) - (let* - ((cols (ly:grob-object grob 'columns)) - (get-difference - (lambda (idx) - (ly:moment-sub (ly:grob-property - (ly:grob-array-ref cols (1+ idx)) 'when) - (ly:grob-property - (ly:grob-array-ref cols idx) 'when)))) - - (moment-min (lambda (x y) - (cond - ((and x y) - (if (ly:moment digit 5) (ly:input-message (ly:event-property event 'origin) - "Warning: Fingering notation for finger number ~a" digit)) + "Warning: Fingering notation for finger number ~a" + digit)) - (number->string digit 10) - )) + (number->string digit 10))) (define-public (string-number::calc-text grob) - (let* - ((digit (ly:event-property (event-cause grob) 'string-number))) - - (number->string digit 10) - )) + (let ((digit (ly:event-property (event-cause grob) 'string-number))) + (number->string digit 10))) (define-public (stroke-finger::calc-text grob) - (let* - ((digit (ly:event-property (event-cause grob) 'digit)) - (text (ly:event-property (event-cause grob) 'text))) + (let* ((digit (ly:event-property (event-cause grob) 'digit)) + (text (ly:event-property (event-cause grob) 'text))) (if (string? text) text - (vector-ref (ly:grob-property grob 'digit-names) (1- (max (min 5 digit) 1)))))) + (vector-ref (ly:grob-property grob 'digit-names) + (1- (max (min 5 digit) 1)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; dynamics + (define-public (hairpin::calc-grow-direction grob) (if (eq? (ly:event-property (event-cause grob) 'class) 'decrescendo-event) START - STOP - )) + STOP)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; lyrics @@ -683,25 +633,25 @@ centered, X==1 is at the right, X == -1 is at the left." (define-public (lyric-text::print grob) "Allow interpretation of tildes as lyric tieing marks." - (let* - ((text (ly:grob-property grob 'text))) + (let ((text (ly:grob-property grob 'text))) - (grob-interpret-markup grob - (if (string? text) - (make-tied-lyric-markup text) - text)))) + (grob-interpret-markup grob (if (string? text) + (make-tied-lyric-markup text) + text)))) (define-public ((grob::calc-property-by-copy prop) grob) (ly:event-property (event-cause grob) prop)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; fret boards (define-public (fret-board::calc-stencil grob) - (grob-interpret-markup - grob - (make-fret-diagram-verbose-markup - (ly:grob-property grob 'dot-placement-list)))) + (grob-interpret-markup + grob + (make-fret-diagram-verbose-markup + (ly:grob-property grob 'dot-placement-list)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; scripts @@ -709,24 +659,28 @@ centered, X==1 is at the right, X == -1 is at the left." (define-public (script-interface::calc-x-offset grob) (ly:grob-property grob 'positioning-done) (let* ((shift (ly:grob-property grob 'toward-stem-shift 0.0)) - (note-head-location (ly:self-alignment-interface::centered-on-x-parent grob)) + (note-head-location + (ly:self-alignment-interface::centered-on-x-parent grob)) (note-head-grob (ly:grob-parent grob X)) (stem-grob (ly:grob-object note-head-grob 'stem))) + (+ note-head-location - ;; If the property 'toward-stem-shift is defined and the script has the - ;; same direction as the stem, move the script accordingly. Since scripts can - ;; also be over skips, we need to check whether the grob has a stem at all. + ;; If the property 'toward-stem-shift is defined and the script + ;; has the same direction as the stem, move the script accordingly. + ;; Since scripts can also be over skips, we need to check whether + ;; the grob has a stem at all. (if (ly:grob? stem-grob) (let ((dir1 (ly:grob-property grob 'direction)) (dir2 (ly:grob-property stem-grob 'direction))) (if (equal? dir1 dir2) (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X)) - (stem-location (ly:grob-relative-coordinate stem-grob common-refp X))) - (* shift (- stem-location - note-head-location))) + (stem-location + (ly:grob-relative-coordinate stem-grob common-refp X))) + (* shift (- stem-location note-head-location))) 0.0)) 0.0)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; instrument names @@ -762,7 +716,10 @@ centered, X==1 is at the right, X == -1 is at the left." (right-padding (- padding (/ (* padding (1+ align-x)) 2)))) - (let loop ((l (ly:grob-array-length elements))) + ;; compensate for the variation in delimiter extents by + ;; calculating an X-offset correction based on united extents + ;; of all delimiters in this system + (let unite-delims ((l (ly:grob-array-length elements))) (if (> l 0) (let ((elt (ly:grob-array-ref elements (1- l)))) @@ -770,7 +727,7 @@ centered, X==1 is at the right, X == -1 is at the left." (let ((dims (ly:grob-extent elt common X))) (if (interval-sane? dims) (set! total-ext (interval-union total-ext dims))))) - (loop (1- l))))) + (unite-delims (1- l))))) (+ (ly:side-position-interface::x-aligned-side grob) @@ -783,6 +740,7 @@ centered, X==1 is at the right, X == -1 is at the left." (let* ((elements (ly:grob-object me 'elements)) (elts-length (ly:grob-array-length elements)) (live-elements '())) + (let get-live ((len elts-length)) (if (> len 0) (let ((elt (ly:grob-array-ref elements (1- len)))) @@ -806,12 +764,48 @@ centered, X==1 is at the right, X == -1 is at the left." (if (and (ly:spanner? axis-group) (equal? (ly:spanner-bound axis-group LEFT) left-bound)) - (set! extent (add-point - extent - (ly:grob-relative-coordinate axis-group system Y)))) - - (get-extent (cdr lst)))))) + (set! extent (add-point extent + (ly:grob-relative-coordinate + axis-group system Y)))) + (get-extent (cdr lst))))) + ;; no live axis group(s) for this instrument name -> remove from system + (ly:grob-suicide! grob)) (+ (ly:self-alignment-interface::y-aligned-on-self grob) (interval-center extent)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ambitus + +(define-public (ambitus::print grob) + (let ((heads (ly:grob-object grob 'note-heads))) + + (if (and (ly:grob-array? heads) + (= (ly:grob-array-length heads) 2)) + (let* ((common (ly:grob-common-refpoint-of-array grob heads Y)) + (head-down (ly:grob-array-ref heads 0)) + (head-up (ly:grob-array-ref heads 1)) + (gap (ly:grob-property grob 'gap 0.35)) + (point-min (+ (interval-end (ly:grob-extent head-down common Y)) + gap)) + (point-max (- (interval-start (ly:grob-extent head-up common Y)) + gap))) + + (if (< point-min point-max) + (let* ((layout (ly:grob-layout grob)) + (line-thick (ly:output-def-lookup layout 'line-thickness)) + (blot (ly:output-def-lookup layout 'blot-diameter)) + (grob-thick (ly:grob-property grob 'thickness 2)) + (width (* line-thick grob-thick)) + (x-ext (symmetric-interval (/ width 2))) + (y-ext (cons point-min point-max)) + (line (ly:round-filled-box x-ext y-ext blot)) + (y-coord (ly:grob-relative-coordinate grob common Y))) + + (ly:stencil-translate-axis line (- y-coord) Y)) + empty-stencil)) + (begin + (ly:grob-suicide! grob) + (list)))))