X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=96cc55cdd62260915b25a41b9f18713364eab4c6;hb=95007e0bdb368a9eb77e241e9952cb3a8651633d;hp=8db3a6f1f6ac689a7e20f0ef15f63fa002982ce9;hpb=fd8ed70c80d71a3bc6e0e62cc86a3659e23eb0a2;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index 8db3a6f1f6..96cc55cdd6 100644 --- a/scm/output-lib.scm +++ b/scm/output-lib.scm @@ -2,125 +2,94 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2001 Jan Nieuwenhuizen +;;;; (c) 1998--2005 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 - (- (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-get-molecule-extent slur 0)) - (/ (cdr (ly-get-molecule-extent text 0)) 2.0) - ) - -2.0))) - - (ly-set-molecule-extent! text 0 (cons x x)) - (ly-align-to! text 0 1) - ) - - (ly-combine-molecule-at-edge slur 1 1 text -0.6) - ) - ) - ) - +;;; Tablature functions, by Jiba (jiba@tuxfamily.org) -(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 (widen-interval (ly-get-molecule-extent mol 0) x-padding)) - (y-ext (widen-interval (ly-get-molecule-extent mol 1) y-padding)) - (x-rule (box-molecule (widen-interval x-ext line-thick) - (cons 0 line-thick))) - (y-rule (box-molecule (cons 0 line-thick) y-ext)) - ) - - (set! mol (ly-combine-molecule-at-edge mol 0 1 y-rule x-padding)) - (set! mol (ly-combine-molecule-at-edge mol 0 -1 y-rule x-padding)) - (set! mol (ly-combine-molecule-at-edge mol 1 1 x-rule 0)) - (set! mol (ly-combine-molecule-at-edge mol 1 -1 x-rule 0)) - - mol - )) - molecule-boxer - ) - +;; The TabNoteHead stem attachment function. +(define (tablature-stem-attachment-function style duration) + (cons 0.0 1.35)) -(define (arg->string arg) - (cond ((number? arg) (inexact->string arg 10)) +;; 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))))))) + + +(define-public guitar-tuning '(4 -1 -5 -10 -15 -20)) +(define-public bass-tuning '(-17 -22 -27 -32)) + +;; 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 tunings to 4-string tunings by +;; removing the 5th string +;; +;; example: +;; \set TabStaff.stringTunings = #(four-string-banjo banjo-open-g-tuning) +(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) "\"")))) -;; ugh: naming. -(define (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 (Text_interface::interpret_markup + layout props (make-draw-circle-markup 0.8 0.1 #f))) + (text-stencil (Text_interface::interpret_markup layout props text))) + + (ly:stencil-add (centered-stencil text-stencil) circle))) ;;(define (mm-to-pt x) ;; (* (/ 72.27 25.40) x)) ;; do nothing in .scm output -(define (comment s) "") -(define (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)) @@ -131,89 +100,61 @@ (number->string n8) (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8))))) -(define (inexact->string x radix) +(define-public (ly:inexact->string x radix) (let ((n (inexact->exact x))) (number->string n radix))) - -(define (control->string c) - (string-append (number->string (car c)) " " - (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) +(define-public (ly:number-pair->string c) + (string-append (ly:number->string (car c)) " " + (ly:number->string (cdr c)))) ;; silly, use alist? -(define (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) - "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." - +(define-public (find-notehead-symbol duration style) (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 (< duration 0) + (string-append (number->string duration) "neomensural") + (number->string duration))) + ((mensural) + (string-append (number->string duration) (symbol->string style))) + ((petrucci) + (if (< duration 0) + (string-append (number->string duration) "mensural") + (string-append (number->string duration) (symbol->string style)))) + ((neomensural) + (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) - '(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)) - ((triangle) '(0.75 . 0.15)) - ((baroque) - (if (< duration 0) - '(0.0 . 0.6) ;; neo-mensural - '(1.0 . 0.5) ;; default - )) + (string-append (number->string duration) "neomensural") + (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)))))) + +;; 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." - ;; this also works for easy notation. - '(1.0 . 0.0) - ))) + '(1.0 . 0.0)) -(define (string-encode-integer i) +(define-public (string-encode-integer i) (cond ((= i 0) "o") ((< i 0) (string-append "n" (string-encode-integer (- i)))) @@ -221,7 +162,106 @@ 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 ((every-nth-bar-number-visible n) barnum) (= 0 (modulo barnum n))) - -(define-public (default-bar-number-visibility barnum) (> barnum 1)) +(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)) + +;; See documentation of 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Bar lines. + +;; +;; How should a bar line behave at a break? +;; +;; Why prepend `default-' to every scm identifier? +(define-public (default-break-barline glyph dir) + (let ((result (assoc glyph + '((":|:" . (":|" . "|:")) + ("||:" . ("||" . "|:")) + ("|" . ("|" . ())) + ("||:" . ("||" . "|:")) + ("|s" . (() . "|")) + ("|:" . ("|" . "|:")) + ("|." . ("|." . ())) + + ;; hmm... should we end with a bar line here? + (".|" . ("|" . ".|")) + (":|" . (":|" . ())) + ("||" . ("||" . ())) + (".|." . (".|." . ())) + ("" . ("" . "")) + (":" . (":" . "")) + ("empty" . (() . ())) + ("brace" . (() . "brace")) + ("bracket" . (() . "bracket")) )))) + + (if (equal? result #f) + (ly:warning (_ "unknown bar glyph: `~S'" glyph)) + (index-cell (cdr result) dir)))) + +(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))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 '(1.0 1.0 0.0)) +(define-public magenta '(1.0 0.0 1.0)) +(define-public yellow '(0.0 1.0 1.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.5 0.5 0.0)) +(define-public darkmagenta '(0.5 0.0 0.5)) +(define-public darkyellow '(0.0 0.5 0.5)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Pitch Trill Heads + +(define (parenthesize-elements grob) + (let* + ((elts (ly:grob-object grob 'elements)) + (x-ext (ly:relative-group-extent elts grob X)) + (font (ly:grob-default-font grob)) + (lp (ly:font-get-glyph font "accidentals.leftparen")) + (rp (ly:font-get-glyph font "accidentals.rightparen")) + (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)) + ))