X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=2496763397fd36deaf92990a186c2e07ecb456bf;hb=198f4d748307a3d6d8be3bb29e4197606f24b6b8;hp=f47c98bedd3a1068b54f7c7c8d99650247f2c6ab;hpb=85e92541326f7caccb6a2b6e85ea5d6e29a8b1ab;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index f47c98bedd..2496763397 100644 --- a/scm/output-lib.scm +++ b/scm/output-lib.scm @@ -2,121 +2,95 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2003 Jan Nieuwenhuizen +;;;; (c) 1998--2006 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys -; Tablature functions, by Jiba (jiba@tuxfamily.org) - -; The TabNoteHead stem attachment function. -(define (tablature-stem-attachment-function style duration) - (cons 0.0 0.5) ;; UGH! -) - -; The TabNoteHead molecule callback. -; Create a text molecule -(define-public (tablature-molecule-callback grob) - (let ((molecule (fontify-text - (ly:get-default-font grob) - (ly:get-grob-property grob 'text) - ))) - molecule ; return the molecule. - )) - -; The TabNoteHead tablatureFormat callback. -; Compute the text grob-property -(define-public (fret-number-tablature-format string tuning pitch) - (number->string - (- (ly:pitch-semitones pitch) - (list-ref tuning - (- string 1) ; remove 1 because list index starts at 0 and guitar string at 1. - ) - ) - ) - ) - -(define-public (hammer-molecule-callback grob) - (let* ((note-collums (ly:get-grob-property grob 'note-columns)) - (note-column1 (cadr note-collums)) - (note-column2 (car note-collums)) - (note1 (car (ly:get-grob-property note-column1 'note-heads))) - (note2 (car (ly:get-grob-property note-column2 'note-heads))) - (fret1 (string->number (ly:get-grob-property note1 'text))) - (fret2 (string->number (ly:get-grob-property note2 'text))) - (letter (if (< fret1 fret2) "H" - (if (> fret1 fret2) "P" - ""))) - ) - (let ((slur (Slur::brew_molecule grob)) - (text (fontify-text (ly:get-default-font grob) letter))) - - (let ((x (/ (- (cdr (ly:molecule-get-extent slur 0)) - (/ (cdr (ly:molecule-get-extent text 0)) 2.0) - ) - -2.0))) - - (ly:molecule-set-extent! text 0 (cons x x)) - (ly:molecule-align-to! text 0 1) - ) - - (ly:molecule-combine-at-edge slur 1 1 text -0.6) - ) - ) - ) +;;; 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)) -(define-public guitar-tunings '(4 -1 -5 -10 -15 -20)) - -; end of tablature functions - - -(define-public (make-molecule-boxer line-thick x-padding y-padding callback) - "Makes a routine that adds a box around the grob parsed as argument" - (define (molecule-boxer grob) - (let* - ( - (mol (callback grob)) - (x-ext (interval-widen (ly:molecule-get-extent mol 0) x-padding)) - (y-ext (interval-widen (ly:molecule-get-extent mol 1) y-padding)) - (x-rule (make-filled-box-molecule (interval-widen x-ext line-thick) - (cons 0 line-thick))) - (y-rule (make-filled-box-molecule (cons 0 line-thick) y-ext)) - ) - - (set! mol (ly:molecule-combine-at-edge mol 0 1 y-rule x-padding)) - (set! mol (ly:molecule-combine-at-edge mol 0 -1 y-rule x-padding)) - (set! mol (ly:molecule-combine-at-edge mol 1 1 x-rule 0)) - (set! mol (ly:molecule-combine-at-edge mol 1 -1 x-rule 0)) +;; 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))))))) + +;; 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 tuning 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))))))) + + +; default tunings for common string instruments +(define-public guitar-tuning '(4 -1 -5 -10 -15 -20)) +(define-public guitar-open-g-tuning '(2 -1 -5 -10 -17 -22)) +(define-public bass-tuning '(-17 -22 -27 -32)) +(define-public mandolin-tuning '(16 9 2 -5)) + +;; tunings for 5-string banjo +(define-public banjo-open-g-tuning '(2 -1 -5 -10 7)) +(define-public banjo-c-tuning '(2 -1 -5 -12 7)) +(define-public banjo-modal-tuning '(2 0 -5 -10 7)) +(define-public banjo-open-d-tuning '(2 -3 -6 -10 9)) +(define-public banjo-open-dm-tuning '(2 -3 -6 -10 9)) +;; convert 5-string banjo tuning to 4-string by removing the 5th string +(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) - mol - )) - molecule-boxer - ) + (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) (inexact->string arg 10)) + (cond ((number? arg) (ly:inexact->string arg 10)) ((string? arg) (string-append "\"" arg "\"")) ((symbol? arg) (string-append "\"" (symbol->string arg) "\"")))) -(define-public (func name . args) - (string-append - "(" name - (if (null? args) - "" - (apply string-append - (map (lambda (x) (string-append " " (arg->string x))) args))) - ")\n")) +(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 -(define-public (comment s) "") - -(define-public (numbers->string l) - (apply string-append (map ly:number->string l))) -; (define (chop-decimal x) (if (< (abs x) 0.001) 0.0 x)) +(define-public (ly:numbers->string lst) + (string-join (map ly:number->string lst) " ")) (define (number->octal-string x) (let* ((n (inexact->exact x)) @@ -127,92 +101,63 @@ (number->string n8) (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8))))) -(define-public (inexact->string x radix) +(define-public (ly:inexact->string x radix) (let ((n (inexact->exact x))) (number->string n radix))) - -(define-public (number-pair->string c) +(define-public (ly:number-pair->string c) (string-append (ly:number->string (car c)) " " - (ly:number->string (cdr c)) " ")) - -(define (font i) - (string-append - "font" - (make-string 1 (integer->char (+ (char->integer #\A) i))))) - -(define (scm-scm action-name) - 1) + (ly:number->string (cdr c)))) ;; silly, use alist? -(define-public (find-notehead-symbol duration style) - (case style - ((xcircle) "2xcircle") - ((harmonic) "0neo_mensural") - ((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 (< duration 0) - (string-append (number->string duration) "neo_mensural") - (number->string duration))) - ((mensural) - (string-append (number->string duration) (symbol->string style))) - ((neo_mensural) - (string-append (number->string duration) (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 (< duration -1) - (string-append (number->string duration) "neo_mensural") - (number->string duration))) - (else - (if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style)) - (symbol->string style) - (string-append (number->string (max 0 duration)) - (symbol->string style)))))) - - -(define (note-head-style->attachment-coordinates style duration) +(define-public (note-head::calc-glyph-name grob) + (let* + ((style (ly:grob-property grob 'style)) + (log (min 2 (ly:grob-property grob 'duration-log)))) + + (case style + ((xcircle) "2xcircle") + ((harmonic) "0harmonic") + ((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))) + ((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)))) + ((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) + (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." - - (case style - ((default) - (if (< duration -1) - '(0.0 . 0.6) ;; neo-mensural - '(1.0 . 0.5) ;; default - )) - ((cross) '(1.0 . 0.75)) - ((mensural) '(0.0 . 0.6)) - ((neo_mensural) '(0.0 . 0.6)) - ((diamond) '(1.0 . 0.8)) - ((transparent) '(1.0 . 1.0)) - ((slash) '(1.0 . 1.0)) - ((harmonic) '(1.0 0.0)) - - ;; - ;;UGH this needs to be changed: triangle is not point-symmetric, has different attachments - ;; for up/down stem - ((triangle) '(0.75 . 0.15)) - ((baroque) - (if (< duration 0) - '(0.0 . 0.6) ;; neo-mensural - '(1.0 . 0.5) ;; default - )) - (else - - ;; this also works for easy notation. - '(1.0 . 0.0) - ))) + '(1.0 . 0.0)) (define-public (string-encode-integer i) (cond @@ -222,60 +167,238 @@ centered, X==1 is at the right, X == -1 is at the left." (make-string 1 (integer->char (+ 65 (modulo i 26)))) (string-encode-integer (quotient i 26)))))) - (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:get-context-property tr 'currentBarNumber))) - (ly:set-context-property! tr 'barNumberVisibility (modulo-bar-number-visible n (modulo bn n))))) + (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)) + +;; See documentation of ly:item::visibility-lambda- +(define-public begin-of-line-visible + #(#f #f #t)) +(define-public end-of-line-visible + #(#t #f #f)) +(define-public end-of-line-invisible + #(#f #t #t)) +(define-public spanbar-begin-of-line-invisible + #(#t #f #f)) +(define-public all-visible #(#t #t #t)) +(define-public all-invisible #(#f #f #f)) +(define-public begin-of-line-invisible + #(#t #t #f)) +(define-public center-invisible #(#t #f #t)) -(define-public (default-bar-number-visibility barnum) (> barnum 1)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Bar lines. -;; See documentation of Item::visibility_lambda_ -(define-public (begin-of-line-visible d) (if (= d 1) '(#f . #f) '(#t . #t))) -(define-public (end-of-line-visible d) (if (= d -1) '(#f . #f) '(#t . #t))) -(define-public (spanbar-begin-of-line-invisible d) (if (= d -1) '(#t . #t) '(#f . #f))) +;; +;; How should a bar line behave at a break? +;; +;; Why prepend `default-' to every scm identifier? +(define-public (bar-line::calc-glyph-name grob) + (let* ( + (glyph (ly:grob-property grob 'glyph)) + (dir (ly:item-break-dir grob)) + (result (assoc glyph + '((":|:" . (":|" . "|:")) + ("||:" . ("||" . "|:")) + ("|" . ("|" . ())) + ("||:" . ("||" . "|:")) + ("|s" . (() . "|")) + ("|:" . ("|" . "|:")) + ("|." . ("|." . ())) + + ;; hmm... should we end with a bar line here? + (".|" . ("|" . ".|")) + (":|" . (":|" . ())) + ("||" . ("||" . ())) + (".|." . (".|." . ())) + ("" . ("" . "")) + (":" . (":" . "")) + ("." . ("." . ())) + ("empty" . (() . ())) + ("brace" . (() . "brace")) + ("bracket" . (() . "bracket")) ))) + (glyph-name (if (= dir CENTER) + glyph + (if (and result (string? (index-cell (cdr result) dir))) + (index-cell (cdr result) dir) + #f))) + ) + + (if (not glyph-name) + (ly:grob-suicide! grob)) + + glyph-name)) + + +(define-public (shift-right-at-line-begin g) + "Shift an item to the right, but only at the start of the line." + (if (and (ly:item? g) + (equal? (ly:item-break-dir g) RIGHT)) + (ly:grob-translate-axis! g 3.5 X))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Tuplets + +(define-public (tuplet-number::calc-denominator-text grob) + (let* + ((ev (ly:grob-property grob 'cause))) + + (number->string (ly:event-property ev 'denominator)))) -(define-public (all-visible d) '(#f . #f)) -(define-public (all-invisible d) '(#t . #t)) -(define-public (begin-of-line-invisible d) (if (= d 1) '(#t . #t) '(#f . #f))) -(define-public (end-of-line-invisible d) (if (= d -1) '(#t . #t) '(#f . #f))) +(define-public (tuplet-number::calc-fraction-text grob) + (let* + ((ev (ly:grob-property grob 'cause))) + (format "~a:~a" + (ly:event-property ev 'denominator) + (ly:event-property ev 'numerator)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Bar lines. +;; Color + +(define-public color? list?) + +; predefined colors +(define-public black '(0.0 0.0 0.0)) +(define-public white '(1.0 1.0 1.0)) +(define-public red '(1.0 0.0 0.0)) +(define-public green '(0.0 1.0 0.0)) +(define-public blue '(0.0 0.0 1.0)) +(define-public cyan '(0.0 1.0 1.0)) +(define-public magenta '(1.0 0.0 1.0)) +(define-public yellow '(1.0 1.0 0.0)) + +(define-public grey '(0.5 0.5 0.5)) +(define-public darkred '(0.5 0.0 0.0)) +(define-public darkgreen '(0.0 0.5 0.0)) +(define-public darkblue '(0.0 0.0 0.5)) +(define-public darkcyan '(0.0 0.5 0.5)) +(define-public darkmagenta '(0.5 0.0 0.5)) +(define-public darkyellow '(0.5 0.5 0.0)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; * Pitch Trill Heads +;; * Parentheses + +(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)) + + (font (ly:grob-default-font grob)) + (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)) + )) + + +(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))) + + (ly:stencil-translate + stencil + (cons + (- + (ly:grob-relative-coordinate me x-ref X)) + (- + y-center + (ly:grob-relative-coordinate me y-ref Y)))) + )) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; + +(define-public (chain-grob-member-functions grob value . funcs) + (for-each + (lambda (func) + (set! value (func grob value))) + funcs) + + value) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; falls + +(define-public (fall::print spanner) + (let* + ((delta (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))) + (padding (ly:grob-property spanner 'padding 0.5)) + (common (ly:grob-common-refpoint right-span + (ly:grob-common-refpoint spanner + 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)) + (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) + ,dx ,delta + )))) + ) + + (ly:make-stencil + exp + (cons 0 dx) + (cons (min 0 delta) + (max 0 delta))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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