;;;; output-lib.scm -- implement Scheme output helper functions
;;;;
;;;; source file of the GNU LilyPond music typesetter
-;;;;
+;;;;
;;;; (c) 1998--2009 Jan Nieuwenhuizen <janneke@gnu.org>
;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
(define-public (grob::has-interface grob iface)
(memq iface (ly:grob-interfaces grob)))
+(define-public (grob::is-live? grob)
+ (pair? (ly:grob-basic-properties grob)))
+
(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)
(define-public (event-cause grob)
(let*
((cause (ly:grob-property grob 'cause)))
-
+
(cond
((ly:stream-event? cause) cause)
((ly:grob? cause) (event-cause cause))
(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.
+ ;; remove 1 because list index starts at 0 and guitar string at 1.
(- string 1))))))
))
;; 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
+(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
+ (make-vcenter-markup
(let ((fret (- (ly:pitch-semitones pitch) (list-ref tuning (- string 1)))))
(number->string (cond
((and (> fret 0) (= string 5))
(ly:event-property (event-cause grob) 'duration)))
(define-public (note-head::calc-duration-log grob)
- (min 2
+ (min 2
(ly:duration-log
(ly:event-property (event-cause grob) 'duration))))
-;; silly, use alist?
+;; silly, use alist?
(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
;; "default" style is directly handled in note-head.cc as a
;; special case (HW says, mainly for performance reasons).
((harmonic-black) "2harmonic")
((harmonic-mixed) (if (<= log 1) "0harmonic"
"2harmonic"))
- ((baroque)
+ ((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
;; Bar lines.
;;
-;; How should a bar line behave at a break?
+;; How should a bar line behave at a break?
(define bar-glyph-alist
'((":|:" . (":|" . "|:"))
(":|.|:" . (":|" . "|:"))
(":|.:" . (":|" . "|:"))
("||:" . ("||" . "|:"))
- ("dashed" . ("dashed" . '()))
+ ("dashed" . ("dashed" . '()))
("|" . ("|" . ()))
("||:" . ("||" . "|:"))
("|s" . (() . "|"))
("|:" . ("|" . "|:"))
("|." . ("|." . ()))
-
+
;; hmm... should we end with a bar line here?
(".|" . ("|" . ".|"))
(":|" . (":|" . ()))
("'" . ("'" . ()))
("empty" . (() . ()))
("brace" . (() . "brace"))
- ("bracket" . (() . "bracket"))
+ ("bracket" . (() . "bracket"))
))
(define-public (bar-line::calc-glyph-name grob)
(let*
((ev (event-cause grob)))
- (format "~a:~a"
+ (format "~a:~a"
(ly:event-property ev 'denominator)
(ly:event-property ev 'numerator))))
-; a formatter function, which is simply a wrapper around an existing
+; a formatter function, which is simply a wrapper around an existing
; tuplet formatter function. It takes the value returned by the given
-; function and appends a note of given length.
+; function and appends a note of given length.
(define-public ((tuplet-number::append-note-wrapper function note) grob)
(let* ((txt (if function (function grob) #f)))
- (if txt
+ (if txt
(markup txt #:fontsize -5 #:note note UP)
(markup #:fontsize -5 #:note note UP))))
-; Print a tuplet denominator with a different number than the one derived from
+; Print a tuplet denominator with a different number than the one derived from
; the actual tuplet fraction
(define-public ((tuplet-number::non-default-tuplet-denominator-text denominator) grob)
-(number->string (if denominator
- denominator
+(number->string (if denominator
+ denominator
(ly:event-property (event-cause grob) 'denominator))))
-; Print a tuplet fraction with different numbers than the ones derived from
+; Print a tuplet fraction with different numbers than the ones derived from
; the actual tuplet fraction
(define-public ((tuplet-number::non-default-tuplet-fraction-text denominator numerator) grob)
(let* ((ev (event-cause grob))
(num (if numerator numerator (ly:event-property ev 'numerator))))
(format "~a:~a" den num)))
-; Print a tuplet fraction with note durations appended to the numerator and the
+; Print a tuplet fraction with note durations appended to the numerator and the
; denominator
(define-public ((tuplet-number::fraction-with-notes denominatornote numeratornote) grob)
(let* ((ev (event-cause grob))
(numerator (ly:event-property ev 'numerator)))
((tuplet-number::non-default-fraction-with-notes denominator denominatornote numerator numeratornote) grob)))
-; Print a tuplet fraction with note durations appended to the numerator and the
+; Print a tuplet fraction with note durations appended to the numerator and the
; denominator
(define-public ((tuplet-number::non-default-fraction-with-notes denominator denominatornote numerator numeratornote) grob)
(let* ((ev (event-cause grob))
(den (if denominator denominator (ly:event-property ev 'denominator)))
(num (if numerator numerator (ly:event-property ev 'numerator))))
- (make-concat-markup (list
- (make-simple-markup (format "~a" den))
+ (make-concat-markup (list
+ (make-simple-markup (format "~a" den))
(markup #:fontsize -5 #:note denominatornote UP)
(make-simple-markup " : ")
- (make-simple-markup (format "~a" num))
+ (make-simple-markup (format "~a" num))
(markup #:fontsize -5 #:note numeratornote UP)))))
(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)
((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
+ ;; 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.
+ ;; --dl.
(cond
((and (= c0 2) (= p 3) (> alter 0))
(set! p (- p 7)))
(1 . "accidentals.doublesharp")
(-1 . "accidentals.flatflat")
-
+
(3/4 . "accidentals.sharp.slashslash.stemstemstem")
(1/4 . "accidentals.sharp.slashslash.stem")
(-1/4 . "accidentals.mirroredflat")
(-8/9 . "accidentals.flat.slashslash")
(-1 . "accidentals.flatflat")
))
-
+
(define-public alteration-hufnagel-glyph-name-alist
'((-1/2 . "accidentals.hufnagelM1")
(0 . "accidentals.vaticana0")
(lp (car stencils))
(rp (cadr stencils))
(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-public (chain-grob-member-functions grob value . funcs)
(for-each
(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)
(+ left-x minimum-length)))
(self-x (ly:grob-relative-coordinate spanner common X))
(dx (- right-x left-x))
- (exp (list 'path thickness
+ (exp (list 'path thickness
`(quote
(rmoveto
,(- left-x self-x) 0
- rcurveto
+ rcurveto
,(/ dx 3)
0
,dx ,(* 0.66 delta-y)
(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)
y))
(x x)
(y y)))))
-
+
(fold moment-min #f (map get-difference
(iota (1- (ly:grob-array-length cols)))))))
(let*
((event (event-cause grob))
(digit (ly:event-property event 'digit)))
-
+
(if (> digit 5)
(ly:input-message (ly:event-property event 'origin)
"Warning: Fingering notation for finger number ~a" digit))
(define-public (string-number::calc-text grob)
(let*
((digit (ly:event-property (event-cause grob) 'string-number)))
-
+
(number->string digit 10)
))
(define-public (lyric-text::print grob)
"Allow interpretation of tildes as lyric tieing marks."
-
+
(let*
((text (ly:grob-property grob 'text)))
- (grob-interpret-markup grob
+ (grob-interpret-markup grob
(if (string? text)
(make-tied-lyric-markup text)
text))))
;; fret boards
(define-public (fret-board::calc-stencil grob)
- (grob-interpret-markup
+ (grob-interpret-markup
grob
(make-fret-diagram-verbose-markup
(ly:grob-property grob 'dot-placement-list))))
note-head-location)))
0.0))
0.0))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; instrument names
+
+(define-public (system-start-text::print grob)
+ (let* ((left-bound (ly:spanner-bound grob LEFT))
+ (left-mom (ly:grob-property left-bound 'when))
+ (name (if (moment<=? left-mom ZERO-MOMENT)
+ (ly:grob-property grob 'long-text)
+ (ly:grob-property grob 'text))))
+
+ (if (and (markup? name)
+ (!= (ly:item-break-dir left-bound) CENTER))
+
+ (grob-interpret-markup grob name)
+ (ly:grob-suicide! grob))))
+
+(define-public (system-start-text::calc-x-offset grob)
+ (let* ((left-bound (ly:spanner-bound grob LEFT))
+ (left-mom (ly:grob-property left-bound 'when))
+ (layout (ly:grob-layout grob))
+ (indent (ly:output-def-lookup layout
+ (if (moment<=? left-mom ZERO-MOMENT)
+ 'indent
+ 'short-indent)
+ 0.0))
+ (system (ly:grob-system grob))
+ (my-extent (ly:grob-extent grob system X))
+ (elements (ly:grob-object system 'elements))
+ (common (ly:grob-common-refpoint-of-array system elements X))
+ (total-ext empty-interval)
+ (align-x (ly:grob-property grob 'self-alignment-X 0))
+ (padding (min 0 (- (interval-length my-extent) indent)))
+ (right-padding (- padding
+ (/ (* padding (1+ align-x)) 2))))
+
+ (let loop ((l (ly:grob-array-length elements)))
+ (if (> l 0)
+ (let ((elt (ly:grob-array-ref elements (1- l))))
+
+ (if (grob::has-interface elt 'system-start-delimiter-interface)
+ (let ((dims (ly:grob-extent elt common X)))
+ (if (interval-sane? dims)
+ (set! total-ext (interval-union total-ext dims)))))
+ (loop (1- l)))))
+
+ (+
+ (ly:side-position-interface::x-aligned-side grob)
+ right-padding
+ (- (interval-length total-ext)))))
+
+(define-public (system-start-text::calc-y-offset grob)
+
+ (define (live-elements-list me)
+ (let* ((elements (ly:grob-object me 'elements))
+ (elts-length (ly:grob-array-length elements))
+ (live-elements '()))
+ (let get-live ((len elts-length))
+ (if (> len 0)
+ (let ((elt (ly:grob-array-ref elements (1- len))))
+
+ (if (grob::is-live? elt)
+ (set! live-elements (cons elt live-elements)))
+ (get-live (1- len)))))
+ live-elements))
+
+ (let* ((left-bound (ly:spanner-bound grob LEFT))
+ (live-elts (live-elements-list grob))
+ (system (ly:grob-system grob))
+ (extent empty-interval))
+
+ (if (and (pair? live-elts)
+ (interval-sane? (ly:grob-extent grob system Y)))
+ (let get-extent ((lst live-elts))
+ (if (pair? lst)
+ (let ((axis-group (car lst)))
+
+ (if (and (ly:spanner? axis-group)
+ (equal? (ly:spanner-bound axis-group LEFT)
+ left-bound))
+ (set! extent (add-point
+ extent
+ (ly:grob-relative-coordinate axis-group system Y))))
+
+ (get-extent (cdr lst))))))
+
+ (+
+ (ly:self-alignment-interface::y-aligned-on-self grob)
+ (interval-center extent))))
projects / lilypond.git / blobdiff