X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=0087169af5f6eefe0ce879e856d013ee50a10744;hb=c3153e5513e6b0ccdc226fbedd6e886d7df23a25;hp=dd456be80c026322f5bf1b6cfd47904ee97f8072;hpb=1bcba0490ef7ad8671d221844b16b95da22ce9a0;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index dd456be80c..0087169af5 100644 --- a/scm/output-lib.scm +++ b/scm/output-lib.scm @@ -3,14 +3,55 @@ ;;;; source file of the GNU LilyPond music typesetter ;;;; ;;;; (c) 1998--2006 Jan Nieuwenhuizen -;;;; Han-Wen Nienhuys +;;;; Han-Wen Nienhuys -;;; Tablature functions, by Jiba (jiba@tuxfamily.org) -;; The TabNoteHead stem attachment function. -(define (note-head::calc-tablature-stem-attachment grob) - (cons 0.0 1.35)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; general + +(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))) + +(define-public (make-stencil-circler thickness padding callback) + "Return function that adds a circle around the grob passed as argument." + + (lambda (grob) (circle-stencil (callback grob) thickness padding))) + +(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 (ly:text-interface::interpret-markup + layout props (make-circle-markup text)))) + circle)) + +(define-public (music-cause grob) + (let* + ((event (event-cause grob))) + + (if (ly:stream-event? event) + (ly:event-property event 'music-cause) + #f))) + +(define-public (event-cause grob) + (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 @@ -55,59 +96,20 @@ (define-public (four-string-banjo tuning) (reverse (cdr (reverse tuning)))) -;;; 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))) - -(define-public (make-stencil-circler thickness padding callback) - "Return function that adds a circle around the grob passed as argument." - (lambda (grob) (circle-stencil (callback grob) thickness padding))) - -(define-public (arg->string arg) - (cond ((number? arg) (ly:inexact->string arg 10)) - ((string? arg) (string-append "\"" arg "\"")) - ((symbol? arg) (string-append "\"" (symbol->string arg) "\"")))) - -(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 (ly:text-interface::interpret-markup - layout props (make-circle-markup text)))) - circle)) - - -;;(define (mm-to-pt x) -;; (* (/ 72.27 25.40) x)) - -;; do nothing in .scm output +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; note heads -(define-public (ly:numbers->string lst) - (string-join (map ly:number->string lst) " ")) +(define-public (note-head::calc-duration-log grob) + (ly:duration-log + (ly:event-property (event-cause grob) 'duration))) -(define (number->octal-string x) - (let* ((n (inexact->exact x)) - (n64 (quotient n 64)) - (n8 (quotient (- n (* n64 64)) 8))) - (string-append - (number->string n64) - (number->string n8) - (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8))))) +(define-public (dots::calc-dot-count grob) + (ly:duration-dot-count + (ly:event-property (event-cause grob) 'duration))) -(define-public (ly:inexact->string x radix) - (let ((n (inexact->exact x))) - (number->string n radix))) +(define (note-head::calc-tablature-stem-attachment grob) + (cons 0.0 1.35)) -(define-public (ly:number-pair->string c) - (string-append (ly:number->string (car c)) " " - (ly:number->string (cdr c)))) ;; silly, use alist? @@ -117,6 +119,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) @@ -135,16 +141,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) @@ -159,13 +155,9 @@ centered, X==1 is at the right, X == -1 is at the left." '(1.0 . 0.0)) -(define-public (string-encode-integer i) - (cond - ((= i 0) "o") - ((< i 0) (string-append "n" (string-encode-integer (- i)))) - (else (string-append - (make-string 1 (integer->char (+ 65 (modulo i 26)))) - (string-encode-integer (quotient i 26)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bar numbers (define-public ((every-nth-bar-number-visible n) barnum) (= 0 (modulo barnum n))) @@ -177,7 +169,9 @@ centered, X==1 is at the right, X == -1 is at the left." (define-public (first-bar-number-invisible barnum) (> barnum 1)) -;; See documentation of ly:item::visibility-lambda- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; break visibility + (define-public begin-of-line-visible #(#f #f #t)) (define-public end-of-line-visible @@ -206,6 +200,7 @@ centered, X==1 is at the right, X == -1 is at the left." (result (assoc glyph '((":|:" . (":|" . "|:")) ("||:" . ("||" . "|:")) + ("dashed" . ("dashed" . '())) ("|" . ("|" . ())) ("||:" . ("||" . "|:")) ("|s" . (() . "|")) @@ -247,18 +242,15 @@ centered, X==1 is at the right, X == -1 is at the left." ;; Tuplets (define-public (tuplet-number::calc-denominator-text grob) - (let* - ((ev (ly:grob-property grob 'cause))) - - (number->string (ly:event-property ev 'denominator)))) - + (number->string (ly:event-property (event-cause grob) 'denominator))) (define-public (tuplet-number::calc-fraction-text grob) (let* - ((ev (ly:grob-property grob 'cause))) + ((ev (event-cause grob))) + (format "~a:~a" - (ly:event-property ev 'denominator) - (ly:event-property ev 'numerator)))) + (ly:event-property ev 'denominator) + (ly:event-property ev 'numerator)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Color @@ -289,8 +281,7 @@ centered, X==1 is at the right, X == -1 is at the left." (define (parenthesize-elements grob . rest) (let* - ( - (refp (if (null? rest) + ((refp (if (null? rest) grob (car rest))) (elts (ly:grob-object grob 'elements)) @@ -300,7 +291,7 @@ centered, X==1 is at the right, X == -1 is at the left." (lp (ly:font-get-glyph font "accidentals.leftparen")) (rp (ly:font-get-glyph font "accidentals.rightparen")) (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)) @@ -326,8 +317,6 @@ centered, X==1 is at the right, X == -1 is at the left." (ly:grob-relative-coordinate me y-ref Y)))) )) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -345,18 +334,23 @@ centered, X==1 is at the right, X == -1 is at the left." (define-public (fall::print spanner) (let* - ((delta (ly:grob-property spanner 'delta-position)) + ((delta-y (* 0.5 (ly:grob-property spanner 'delta-position))) (left-span (ly:spanner-bound spanner LEFT)) (right-span (ly:spanner-bound spanner RIGHT)) (thickness (* (ly:grob-property spanner 'thickness) - (ly:output-def-lookup (ly:grob-layout spanner) 'line-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) + 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)) + (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)) (self-x (ly:grob-relative-coordinate spanner common X)) (dx (- right-x left-x)) (exp (list 'path thickness @@ -367,16 +361,16 @@ centered, X==1 is at the right, X == -1 is at the left." rcurveto ,(/ dx 3) 0 - ,dx ,(* 0.66 delta) - ,dx ,delta + ,dx ,(* 0.66 delta-y) + ,dx ,delta-y )))) ) (ly:make-stencil exp (cons 0 dx) - (cons (min 0 delta) - (max 0 delta))))) + (cons (min 0 delta-y) + (max 0 delta-y))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; grace spacing @@ -387,8 +381,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 @@ -399,6 +395,108 @@ centered, X==1 is at the right, X == -1 is at the left." (x x) (y y))))) - - (fold moment-min #f (map get-difference (iota (1- (ly:grob-array-length cols))))))) + (fold moment-min #f (map get-difference + (iota (1- (ly:grob-array-length cols))))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fingering + +(define-public (fingering::calc-text grob) + (let* + ((event (event-cause grob)) + (digit (ly:event-property event 'digit))) + + (if (> digit 5) + (ly:input-message (ly:event-property event 'origin) + "Music for the martians")) + + (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) + )) + + +(define-public (stroke-finger::calc-text grob) + (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)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamics +(define-public (hairpin::calc-grow-direction grob) + (if (eq? (ly:event-property (event-cause grob) 'class) 'decrescendo-event) + 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 (lyric-text::calc-text grob) + (ly:event-property (event-cause grob) 'text)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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))))