X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;ds=sidebyside;f=scm%2Foutput-lib.scm;h=2978f3b198e567adde40f529536590cde4684235;hb=e28484ea68c8cbcdaa5edfe7211b11f0d1779ff9;hp=2071541029972caf8643e8cb9fd9fe9a080f667b;hpb=7885b07ffa52242ee7e7863535d0c83b4581b235;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index 2071541029..2978f3b198 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,26 @@ (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)) - +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; note heads -;;(define (mm-to-pt x) -;; (* (/ 72.27 25.40) x)) -;; do nothing in .scm output +(define-public (stem::calc-duration-log grob) + (ly:duration-log + (ly:event-property (event-cause grob) 'duration))) -(define-public (ly:numbers->string lst) - (string-join (map ly:number->string lst) " ")) +(define-public (note-head::calc-duration-log grob) + (min 2 + (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 +125,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 +147,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 +161,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 +175,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 @@ -248,18 +248,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 @@ -326,8 +323,6 @@ centered, X==1 is at the right, X == -1 is at the left." (ly:grob-relative-coordinate me y-ref Y)))) )) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -349,14 +344,19 @@ centered, X==1 is at the right, X == -1 is at the left." (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 @@ -387,8 +387,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 @@ -402,3 +404,105 @@ centered, X==1 is at the right, X == -1 is at the left." (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 ((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))))