1 ;------------------------------------------------------------------;
2 ; opus_libre -- text.scm ;
4 ; (c) 2008-2011 Valentin Villenave <valentin@villenave.net> ;
6 ; opus_libre is a free framework for GNU LilyPond: you may ;
7 ; redistribute it and/or modify it under the terms of the GNU ;
8 ; General Public License as published by the Free Software ;
9 ; Foundation, either version 3 of the License, or (at your option) ;
10 ; any later version. ;
11 ; This program is distributed WITHOUT ANY WARRANTY; without ;
12 ; even the implied warranty of MERCHANTABILITY or FITNESS FOR A ;
13 ; PARTICULAR PURPOSE. You should have received a copy of the GNU ;
14 ; General Public License along with this program (typically in the ;
15 ; share/doc/ directory). If not, see http://www.gnu.org/licenses/ ;
17 ;------------------------------------------------------------------;
20 ;; Macros for entering text elements.
22 (scm-load "../lib/libtext.scm")
23 (scm-load "../lib/libgraphics.scm")
25 ;; Composite dynamics ---------------------------------------------;
27 (define-event-function (arg) (markup?)
28 (let ((d (make-music 'AbsoluteDynamicEvent)))
29 (ly:music-set-property! d 'tweaks
30 ; not very elegant, but these composite dynamic
31 ; indication might get quite lengthy.
32 (acons 'X-extent (cons 0 0)
33 (ly:music-property d 'tweaks)))
34 (ly:music-set-property! d 'tweaks
35 ; ugh. hardcoded offset.
37 (ly:music-property d 'tweaks)))
38 (ly:music-set-property! d 'text
41 (if (string-every char-set:dynamics arg)
43 (markup #:dynamic-string arg)))
48 (define-event-function (arg) (markup?)
49 (make-music 'CrescendoEvent 'span-direction START
53 (if (string-every char-set:dynamics arg)
55 (markup #:dynamic-string arg)))
59 (define-event-function (arg) (markup?)
60 (make-music 'DecrescendoEvent 'span-direction START
64 (if (string-every char-set:dynamics arg)
66 (markup #:dynamic-string arg)))
69 ;; Adapted from LSR snippet #233 (from Reinhold?)
70 (define (make-hairpin-text dir text)
72 'OverrideProperty 'once #t
73 'grob-property-path (list 'stencil)
74 'grob-value (lambda (grob)
75 (ly:stencil-aligned-to
76 (ly:stencil-combine-at-edge
77 (ly:stencil-aligned-to (ly:hairpin::print grob) X CENTER)
78 Y dir ;;FIXME:direction should be computer automatically
79 (ly:stencil-aligned-to (grob-interpret-markup grob
80 (make-indic-markup text)) X CENTER))
85 ;; (define *hairpin-text-direction* (make-parameter #f))
86 ;; (define hairpinText
87 ;; (define-music-function (text) (markup?)
88 ;; (make-sequential-music
92 ;; 'procedure (lambda (ctx)
93 ;; (let ((parent-staff (ly:context-id (ly:context-parent ctx)))
94 ;; (global-dir (assoc-get 'direction
95 ;; (ly:context-grob-definition ctx 'DynamicLineSpanner))))
96 ;; (*hairpin-text-direction*
97 ;; (if (or (string-suffix-ci? lang:upper-hand parent-staff)
98 ;; (eq? global-dir UP))
101 ;; (make-hairpin-text (*hairpin-text-direction*) text)))))
104 ;; beware - this is a _music_ function, not a postfix event!
105 (define-music-function (text) (markup?)
106 (make-hairpin-text DOWN text)))
108 (define hairpinTextUp
109 (define-music-function (text) (markup?)
110 (make-hairpin-text UP text)))
112 (define hairpinTextDown
113 (define-music-function (text) (markup?)
114 (make-hairpin-text DOWN text)))
117 (define-event-function (txt) (markup?)
118 (make-text-span txt)))
120 ;; for consistency only.
125 (define-music-function (music) (ly:music?)
127 (equal? (ly:music-property music 'name) 'EventChord)
128 (set! (ly:music-property music 'elements)
129 (append (ly:music-property music 'elements)
130 (list (make-music 'TextScriptEvent 'text
131 ;; ugh. Haphazard alignment.
132 (markup #:translate-scaled (cons 4 0)
133 #:indic "(ten.)"))))))
137 (define-music-function (text music) (string? ly:music?)
139 (equal? (ly:music-property music 'name) 'EventChord)
140 (set! (ly:music-property music 'elements)
141 (append (ly:music-property music 'elements)
142 (list (make-music 'TextScriptEvent 'direction 1
143 'text (markup #:indic text))))))
147 (define-music-function (text music) (markup? ly:music?)
148 (let ((current-staff-position 0))
149 ; this shouldn't be needed!!!
150 (set! current-staff-position -4)
151 (make-music 'ApplyOutputEvent
155 (lambda (grob grob-origin context)
156 (let ((staff-pos (ly:grob-property grob 'staff-position)))
157 (if (number? staff-pos)
158 (set! current-staff-position staff-pos)))))
159 #{ \once \set fingeringOrientations = #'(left)
160 \once \override Fingering #'X-extent = #'(-2.0 . 0.0)
161 $(add-bracket current-staff-position #t text music)
165 (define-music-function (text music) (markup? ly:music?)
166 (let ((current-staff-position 0))
167 ; this shouldn't be needed!!!
168 (set! current-staff-position -1)
169 (make-music 'ApplyOutputEvent
173 (lambda (grob grob-origin context)
174 (let ((staff-pos (ly:grob-property grob 'staff-position)))
175 (if (number? staff-pos)
176 (set! current-staff-position staff-pos)))))
177 #{ \once \set fingeringOrientations = #'(left)
178 \once \override Fingering #'X-extent = #'(-2.0 . 0.0)
179 $(add-bracket current-staff-position #f text music)
183 (define-music-function (expr) (ly:music?)
184 #{ $(untaint-this expr) #}))