X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=f66a78bcbc7bf42082f35d66831dbd64c5e58c70;hb=3d169c6753c29a277a3cf10dd78bb58da16951a7;hp=7c7f64811c580468ba95c4311500c85df5aeed44;hpb=5d576b1299d374ae478cb38075cc05d5cb691046;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index 7c7f64811c..f66a78bcbc 100644 --- a/scm/output-lib.scm +++ b/scm/output-lib.scm @@ -10,6 +10,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; general +(define-public (grob::has-interface grob iface) + (memq iface (ly:grob-interfaces grob))) (define-public (make-stencil-boxer thickness padding callback) @@ -55,14 +57,28 @@ ;; The TabNoteHead tablatureFormat callback. ;; Compute the text grob-property -(define-public (fret-number-tablature-format string tuning pitch) - (make-whiteout-markup - (make-vcenter-markup - (number->string - (- (ly:pitch-semitones pitch) - (list-ref tuning - ;; remove 1 because list index starts at 0 and guitar string at 1. - (- string 1))))))) +(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 @@ -70,14 +86,20 @@ ;; 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 tuning pitch) +(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))))))) + (else fret)))))) + )) ; default tunings for common string instruments @@ -99,14 +121,35 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; note heads -(define-public (note-head::calc-duration-log grob) + +(define-public (stem::calc-duration-log grob) (ly:duration-log (ly:event-property (event-cause grob) 'duration))) +(define-public (note-head::calc-duration-log grob) + (min 2 + (ly:duration-log + (ly:event-property (event-cause grob) 'duration)))) + (define-public (dots::calc-dot-count grob) (ly:duration-dot-count (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))) + + (cond + ((or (not (grob::has-interface head 'rest-interface)) + (not (integer? log))) 0) + ((= log 7) 4) + ((> log 4) 3) + ((= log 0) -1) + ((= log 1) 1) + ((= log -1) 1) + (else 0)))) + (define (note-head::calc-tablature-stem-attachment grob) (cons 0.0 1.35)) @@ -119,6 +162,10 @@ (log (min 2 (ly:grob-property grob 'duration-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") ((baroque) @@ -137,16 +184,6 @@ (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) @@ -281,10 +318,145 @@ 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) + ;; TODO: memoize - this is mostly constant. + + ;; fes, ges, as and bes typeset in lower octave + (define FLAT_TOP_PITCH 2) + + ;; ais and bis typeset in lower octave + (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))) + + (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)) + ) + + ;; Typeset below c_position + (set! p (- p 7))) + + ;; Provide for the four cases in which there's a glitch + ;; it's a hack, but probably not worth + ;; the effort of finding a nicer solution. + ;; --dl. + (cond + ((and (= c0 2) (= p 3) (> alter 0)) + (set! p (- p 7))) + ((and (= c0 -3) (= p -1) (> alter 0)) + (set! p (+ p 7))) + ((and (= c0 -4) (= p -1) (< alter 0)) + (set! p (+ p 7))) + ((and (= c0 -2) (= p -3) (< alter 0)) + (set! p (+ p 7)))) + + (+ c0 p)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; accidentals + +(define-public (accidental-interface::calc-alteration grob) + (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") + + (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") + )) + +(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") + )) + +(define-public alteration-hufnagel-glyph-name-alist + '((1/2 . "accidentals.hufnagel-1") + (0 . "accidentals.vaticana0") + (-1/2 . "accidentals.mensural1"))) + +(define-public alteration-medicaea-glyph-name-alist + '((1/2 . "accidentals.medicaea-1") + (0 . "accidentals.vaticana0") + (-1/2 . "accidentals.mensural1"))) + +(define-public alteration-vaticana-glyph-name-alist + '((1/2 . "accidentals.vaticana-1") + (0 . "accidentals.vaticana0") + (-1/2 . "accidentals.mensural1"))) + +(define-public alteration-mensural-glyph-name-alist + '((1/2 . "accidentals.mensural-1") + (0 . "accidentals.vaticana0") + (-1/2 . "accidentals.mensural1"))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; * Pitch Trill Heads ;; * Parentheses +(define-public (parentheses-item::calc-parenthesis-stencils grob) + (let* ((font (ly:grob-default-font grob)) + (lp (ly:font-get-glyph font "accidentals.leftparen")) + (rp (ly:font-get-glyph font "accidentals.rightparen"))) + + (list lp rp))) + + +(define (grob-text 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-text grob (ly:wide-char->utf-8 #x2329)) + Y CENTER) X RIGHT)) + (rp (ly:stencil-aligned-to (ly:stencil-aligned-to (grob-text 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) @@ -292,10 +464,9 @@ centered, X==1 is at the right, X == -1 is at the left." (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")) + (stencils (ly:grob-property grob 'stencils)) + (lp (car stencils)) + (rp (cadr stencils)) (padding (ly:grob-property grob 'padding 0.1))) (ly:stencil-add @@ -323,8 +494,7 @@ centered, X==1 is at the right, X == -1 is at the left." (ly:grob-relative-coordinate me y-ref Y)))) )) - - + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -338,12 +508,19 @@ centered, X==1 is at the right, X == -1 is at the left." value) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; falls +;; falls/doits -(define-public (fall::print spanner) +(define-public (bend::print spanner) + (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) @@ -351,10 +528,22 @@ centered, X==1 is at the right, X == -1 is at the left." (padding (ly:grob-property spanner 'padding 0.5)) (common (ly:grob-common-refpoint right-span (ly:grob-common-refpoint spanner - left-span X) + left-span X) X)) - (left-x (+ padding (interval-end (ly:grob-robust-relative-extent left-span common X)))) - (right-x (- (interval-start (ly:grob-robust-relative-extent right-span common X)) padding)) + (common-y (ly:grob-common-refpoint spanner left-span Y)) + (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 (- (interval-start + (ly:grob-robust-relative-extent right-span common X)) + padding)) (self-x (ly:grob-relative-coordinate spanner common X)) (dx (- right-x left-x)) (exp (list 'path thickness @@ -367,12 +556,11 @@ centered, X==1 is at the right, X == -1 is at the left." 0 ,dx ,(* 0.66 delta-y) ,dx ,delta-y - )))) - ) + ))))) (ly:make-stencil exp - (cons 0 dx) + (cons (- left-x self-x) (- right-x self-x)) (cons (min 0 delta-y) (max 0 delta-y))))) @@ -385,8 +573,10 @@ centered, X==1 is at the right, X == -1 is at the left." ((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)))) + (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 @@ -412,7 +602,7 @@ centered, X==1 is at the right, X == -1 is at the left." (if (> digit 5) (ly:input-message (ly:event-property event 'origin) - "Music for the martians")) + "Warning: Fingering notation for finger number ~a" digit)) (number->string digit 10) )) @@ -424,11 +614,15 @@ centered, X==1 is at the right, X == -1 is at the left." (number->string digit 10) )) -(define-public (string-finger::calc-text grob) + +(define-public (stroke-finger::calc-text grob) (let* - ((text (ly:event-property (event-cause grob) 'text))) + ((digit (ly:event-property (event-cause grob) 'digit)) + (text (ly:event-property (event-cause grob) 'text))) - text)) + (if (string? text) + text + (vector-ref (ly:grob-property grob 'digit-names) (1- (max (min 5 digit) 1)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; dynamics @@ -437,3 +631,64 @@ centered, X==1 is at the right, X == -1 is at the left." START STOP )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; lyrics + +(define-public (lyric-text::print grob) + "Allow interpretation of tildes as lyric tieing marks." + + (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))) + + (ly:text-interface::interpret-markup layout + props + (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 (string-frets->description string-frets string-count) + (let* + ((desc (list->vector + (map (lambda (x) (list 'mute (1+ x))) + (iota string-count))))) + + (for-each (lambda (sf) + (let* + ((string (car sf)) + (fret (cadr sf)) + (finger (caddr sf))) + + + (vector-set! desc (1- string) + (if (= 0 fret) + (list 'open string) + (if finger + (list 'place-fret string fret finger) + (list 'place-fret string fret)) + + + )) + )) + string-frets) + + (vector->list desc))) + +(define-public (fret-board::calc-stencil grob) + (let* ((string-frets (ly:grob-property grob 'string-fret-finger-combinations)) + (string-count (ly:grob-property grob 'string-count)) + (layout (ly:grob-layout grob)) + (defs (ly:output-def-lookup layout 'text-font-defaults)) + (props (ly:grob-alist-chain grob defs))) + + (make-fret-diagram layout props + (string-frets->description string-frets 6))))