1 %------------------------------------------------------------------%
2 % Opéra Libre -- text-functions.ly %
4 % (c) Valentin Villenave, 2008, 2009 %
5 %------------------------------------------------------------------%
7 #(use-modules
(ice-
9 regex
))
8 #(use-modules
(ice-
9 optargs
))
10 %%%%%%%%%%%%%%%%%%%%%%%%%%% Definitions %%%%%%%%%%%%%%%%%%%%%%%%%%%%
12 %% Advanced definitions -------------------------------------------%
14 %%% This code was provided by Nicolas Sceaux.
16 #(define-public string-upper-case
#f)
17 #(define accented-char-upper-case?
#f)
18 #(define accented-char-lower-case?
#f)
20 %%;; an accented character is seen as two characters by guile
21 #(let
((lower-case-accented-string
"éèêëáàâäíìîïóòôöúùûüçœæ")
22 (upper-case-accented-string
"ÉÈÊËÁÀÂÄÍÌÎÏÓÒÔÖÚÙÛÜÇŒÆ"))
23 (define
(group-by-
2 chars result
)
24 (if
(or
(null? chars
) (null?
(cdr chars
)))
26 (group-by-
2 (cddr chars
)
27 (cons
(string
(car chars
) (cadr chars
))
29 (let
((lower-case-accented-chars
30 (group-by-
2 (string-
>list lower-case-accented-string
) (list
)))
31 (upper-case-accented-chars
32 (group-by-
2 (string-
>list upper-case-accented-string
) (list
))))
33 (set
! string-upper-case
35 (define
(replace-chars str froms tos
)
38 (replace-chars
(regexp-substitute
/global
#f (car froms
) str
42 (string-upcase
(replace-chars str
43 lower-case-accented-chars
44 upper-case-accented-chars
))))
45 (set
! accented-char-upper-case?
47 (member
(string char
1 char
2) upper-case-accented-chars string
=?
)))
48 (set
! accented-char-lower-case?
50 (member
(string char
1 char
2) lower-case-accented-chars string
=?
)))))
52 #(define-markup-command
(smallCaps layout props text
) (markup?
)
53 "Turn @code{text}, which should be a string, to small caps.
55 \\markup \\small-caps \"Text between double quotes\"
57 (define
(string-list-
>markup strings lower
)
58 (let
((final-string
(string-upper-case
59 (apply string-append
(reverse strings
)))))
61 (markup
#:fontsize -
2 final-string
)
63 (define
(make-small-caps rest-chars currents current-is-lower prev-result
)
64 (if
(null? rest-chars
)
65 (make-concat-markup
(reverse
! (cons
(string-list-
>markup
66 currents current-is-lower
)
68 (let
* ((ch
1 (car rest-chars
))
69 (ch
2 (and
(not
(null?
(cdr rest-chars
))) (cadr rest-chars
)))
70 (this-char-string
(string ch
1))
71 (is-lower
(char-lower-case? ch
1))
72 (next-rest-chars
(cdr rest-chars
)))
73 (cond
((and ch
2 (accented-char-lower-case? ch
1 ch
2))
74 (set
! this-char-string
(string ch
1 ch
2))
76 (set
! next-rest-chars
(cddr rest-chars
)))
77 ((and ch
2 (accented-char-upper-case? ch
1 ch
2))
78 (set
! this-char-string
(string ch
1 ch
2))
80 (set
! next-rest-chars
(cddr rest-chars
))))
81 (if
(or
(and current-is-lower is-lower
)
82 (and
(not current-is-lower
) (not is-lower
)))
83 (make-small-caps next-rest-chars
84 (cons this-char-string currents
)
87 (make-small-caps next-rest-chars
88 (list this-char-string
)
92 (cons
(string-list-
>markup
93 currents current-is-lower
)
95 (interpret-markup layout props
97 (make-small-caps
(string-
>list text
) (list
) #f (list
))
100 %% Graphic fine-tuning --------------------------------------------%
102 #(define-markup-command
(vspace layout props amount
) (number?
)
103 (let
((amount
(* amount
3.0)))
105 (ly
:make-stencil
"" (cons -
1 1) (cons
0 amount
))
106 (ly
:make-stencil
"" (cons -
1 1) (cons amount amount
)))))
108 #(define-public
(rounded-whiteout-stencil stencil blot
)
110 ((x-ext
(ly
:stencil-extent stencil X
))
111 (y-ext
(ly
:stencil-extent stencil Y
)))
113 (stencil-with-color
(ly
:round-filled-box x-ext y-ext blot
)
117 %TODO: make radius arg optional.
118 #(define-markup-command
(rounded-whiteout layout props radius arg
)
120 (rounded-whiteout-stencil
(interpret-markup layout props arg
) radius
))
122 #(define-markup-command
(line-width-ratio layout props width-ratio arg
) (number? markup?
)
123 (interpret-markup layout props
124 (markup
#:override
(cons
'line-width
(* width-ratio
(chain-assoc-get
'line-width props
)))
127 %% Expressive indications -----------------------------------------%
129 #(define-markup-command
(indic layout props arg
) (markup?
)
130 (interpret-markup layout props
131 (markup
#:rounded-whiteout
1 #:small
#:italic arg
)))
133 %% Dynamics -------------------------------------------------------%
135 %%% This function was provided by Graham Percival.
136 #(define
(make-dynamic-extra dynamic string
)
138 'AbsoluteDynamicEvent
140 ;; calculate centering for text
141 (list
(cons
(quote X-offset
)
142 (+ -
0.5 (* -
0.5 (string-length dynamic
)))))
144 (markup
#:rounded-whiteout
1
148 #:normal-text
#:italic string
))
151 #(define
(make-extra-dynamic string dynamic
)
153 'AbsoluteDynamicEvent
155 ;; calculate centering for text
156 (list
(cons
(quote X-offset
)
157 (+ -
0.5 (* -
0.5 (string-length dynamic
)))))
159 (markup
#:rounded-whiteout
1
161 #:normal-text
#:italic string
166 %%%%%%%%%%%%%%%%%%%%%%%%%% In-score Text %%%%%%%%%%%%%%%%%%%%%%%%%%%
169 %% Non-standard synamics ------------------------------------------%
171 fpp
= #(make-dynamic-script
"fpp")
172 sffz
= #(make-dynamic-script
"sffz")
175 %% Composite Dynamics ---------------------------------------------%
177 % because of the use of a music-function,
178 % non-predefined composite dynamics have to be entered *before*
179 % the affected beat (unlike standard or predefined dynamics).
181 #(define-music-function
(parser location dyn str
) (string? string?
)
182 (make-music
'SequentialMusic
'elements
184 (make-music
'OverrideProperty
186 'grob-property-path
(list
'self-alignment-X
)
187 'grob-value -
0.6 'once
#t
)
188 (make-music
'AbsoluteDynamicEvent
190 (markup
#:rounded-whiteout
1
191 #:line
(#:dynamic dyn
193 #:text
#:medium
#:italic str
))))))
196 #(define-music-function
(parser location str dyn
) (string? string?
)
197 (make-music
'SequentialMusic
'elements
199 (make-music
'OverrideProperty
201 'grob-property-path
(list
'self-alignment-X
)
202 'grob-value -
0.6 'once
#t
)
203 (make-music
'AbsoluteDynamicEvent
205 (markup
#:rounded-whiteout
1
206 #:line
(#:text
#:medium
#:italic str
210 %% Predefined commands
212 ffsubito
= #(make-dynamic-extra
"ff" "subito")
213 fsubito
= #(make-dynamic-extra
"f" "subito")
214 fsempre
= #(make-dynamic-extra
"f" "sempre")
215 mfsubito
= #(make-dynamic-extra
"mf" "subito")
216 fmolto
= #(make-dynamic-extra
"f" "molto")
217 psempre
= #(make-dynamic-extra
"p" "sempre")
218 ppsempre
= #(make-dynamic-extra
"pp" "sempre")
219 mpsempre
= #(make-dynamic-extra
"mp" "sempre")
220 mfsempre
= #(make-dynamic-extra
"mf" "sempre")
221 mfintenso
= #(make-dynamic-extra
"mf" "intenso")
222 mpsostenuto
= #(make-dynamic-extra
"mp" "sostenuto")
223 psubito
= #(make-dynamic-extra
"p" "subito")
224 pdolce
= #(make-dynamic-extra
"p" "dolce")
225 ppdolce
= #(make-dynamic-extra
"pp" "dolce")
226 pleggiero
= #(make-dynamic-extra
"p" "leggiero")
227 ppleggiero
= #(make-dynamic-extra
"pp" "leggiero")
228 ppsubito
= #(make-dynamic-extra
"pp" "subito")
229 mfleggiero
= #(make-dynamic-extra
"mf" "leggiero")
230 piuf
= #(make-extra-dynamic
"più" "f")
231 pocof
= #(make-extra-dynamic
"poco" "f")
234 %% Text indications -----------------------------------------------%
237 #(define-music-function
(parser location text music
) (string? ly
:music?
)
239 (equal?
(ly
:music-property music
'name
) 'EventChord
)
240 (set
! (ly
:music-property music
'elements
)
241 (append
(ly
:music-property music
'elements
)
242 (list
(make-music
'TextScriptEvent
'direction
1
243 'text
(markup
#:indic text
))))))
247 #(define-music-function
(parser location texte
)
250 (markup
#:text
#:indic texte
)))
252 %% Predefined commands
255 #(define-music-function
(parser location music
) (ly
:music?
)
257 (equal?
(ly
:music-property music
'name
) 'EventChord
)
258 (set
! (ly
:music-property music
'elements
)
259 (append
(ly
:music-property music
'elements
)
260 (list
(make-music
'TextScriptEvent
'text
261 (markup
#:translate
(cons
4 0)
262 #:indic
"(ten.)"))))))
267 #(define-music-function
(parser location music
) (ly
:music?
)
268 #{ \ind #"pizz." $music
#})
271 #(define-music-function
(parser location music
) (ly
:music?
)
272 #{ \ind #"arco" $music
#})
275 #(define-music-function
(parser location music
) (ly
:music?
)
276 #{ \ind #"flautando" $music
#})
279 #(define-music-function
(parser location music
) (ly
:music?
)
280 #{ \ind #"simile" $music
#})
283 #(define-music-function
(parser location music
) (ly
:music?
)
284 #{ \ind #"loco" $music
#})
287 #(define-music-function
(parser location music
) (ly
:music?
)
288 #{ \ind #"(ordin.)" $music
#})
291 #(define-music-function
(parser location music
) (ly
:music?
)
292 #{ \ind #"meno" $music
#})
295 #(define-music-function
(parser location music
) (ly
:music?
)
296 #{ \ind #"jeté" $music
#})
299 %% Text Spanners --------------------------------------------------%
301 #(define
(make-txt-span music t
)
302 (set
! (ly
:music-property music
'elements
)
303 (append
(ly
:music-property music
'elements
)
304 (list
(make-music
'TextSpanEvent
305 'span-direction t
))))
308 %% The two following functions are deprecated. Better code follows below.
310 #(define-music-function
(parser location texte music
) (string? ly
:music?
)
311 #{ \override TextSpanner
#'bound-details
#'left
#'text
=
312 \markup { \bold $texte
}
313 $
(make-txt-span music -
1)#})
316 #(define-music-function
(parser location music
) (ly
:music?
)
317 (make-txt-span music
1))
319 #(define
(make-text-span txt
)
320 "Make a TextSpanner that begins with the given STR."
321 (let
* ((m
(make-music
'TextSpanEvent
323 (details
(assoc-get
'bound-details
324 (assoc-get
'TextSpanner
325 all-grob-descriptions
)))
326 (left-details
(assoc-get
'left
328 (ly
:music-set-property
! m
'tweaks
329 (acons
'bound-details
334 (ly
:music-property m
'tweaks
)))
338 #(define-music-function
(location parser txt
) (string?
)
339 (make-text-span txt
))
341 stopText
= #(make-music
'TextSpanEvent
'span-direction
1)
343 %% Predefined commands
345 rit
= #(make-text-span
"rit.")
349 %%%%%%%%%%%%%%%%%%%%%%%%%%%% Other Text %%%%%%%%%%%%%%%%%%%%%%%%%%%%
352 %% Lyrics formatting ----------------------------------------------%
355 \override Lyrics
. LyricExtender
#'stencil
= ##f }
358 \revert Lyrics
. LyricExtender
#'stencil
}
361 \once \override LyricText
#'self-alignment-X
= #0.9 }
364 \once \override LyricHyphen
#'minimum-distance
= #4
365 \once \override LyricHyphen
#'length
= #2
366 \once \override LyricHyphen
#'thickness
= #1.2
370 \once \override LyricText
#'font-shape
= #'italic
}
373 \override LyricText
#'font-shape
= #'caps
}
376 \revert LyricText
#'font-shape
}
379 %% Scenography formatting ---------------------------------------%
381 \once \override TextScript
#'extra-spacing-width
= #'(0 . 0)
382 \once \override TextScript
#'infinite-spacing-height
= ##t
385 #(define-markup-command
(did layout props text
) (markup?
)
386 (interpret-markup layout props
387 (markup
#:override
'(line-width
. 40)
388 #:override
'(box-padding
. 1)
389 #:override
'(corner-radius
. 2)
390 #:rounded-box
#:sans
#:italic
#:small
#:justify-string text
)))
392 #(define-markup-command
(init-did layout props text
) (markup?
)
393 (interpret-markup layout props
395 ;
#:override
(cons
'line-width
(* 1 (chain-assoc-get
'line-width props
)))
397 #:override
'(line-width
. 60)
398 #:override
'(box-padding
. 1.5)
399 #:override
'(corner-radius
. 2)
400 #:rounded-box
#:sans
#:italic
#:small
#:justify-string text
))))
403 %% Table of contents --------------------------------------------%
405 #(define-music-function
(parser location text
) (markup?
)
406 (add-toc-item
! 'tocActMarkup text
))
409 #(define-music-function
(parser location text
) (markup?
)
410 (add-toc-item
! 'tocQuoteMarkup text
))
412 %% Characters and instrument names ------------------------------%
414 #(define characters `
((dummy
. "")))
415 #(define instruments `
((dummy
. "")))
417 #(define
(char-name n
) (car
(car
(assoc-get n characters
))))
418 #(define
(char-shortname n
) (cdr
(car
(assoc-get n characters
))))
419 #(define
(instr-name n
) (car
(car
(assoc-get n instruments
))))
420 #(define
(instr-shortname n
) (cdr
(car
(assoc-get n instruments
))))
422 #(define
(make-char-name n
. pad
)
423 (let
* ((txt
(char-name n
))
424 (srt
(char-shortname n
))
426 (markup
#:hcenter-in
(car pad
) txt
)
428 (n
(markup srt
))) fixme
: shortname has no padding
429 (ly
:export
(make-sequential-music
(list
430 (context-spec-music
(make-property-set
'instrumentName m
)
432 (context-spec-music
(make-property-set
'shortInstrumentName n
)
434 (context-spec-music
(make-property-set
'midiInstrument
"voice oohs")
437 #(define
(make-instrument-name n midi
. pad
)
438 (let
* ((txt
(instr-name n
))
439 (srt
(instr-shortname n
))
441 (markup
#:hcenter-in
(car pad
) txt
)
443 (n
(markup srt
))) ;; fixme
: shortname has no padding
444 (ly
:export
(make-sequential-music
(list
445 (context-spec-music
(make-property-set
'instrumentName m
)
447 (context-spec-music
(make-property-set
'shortInstrumentName n
)
449 (context-spec-music
(make-property-set
'midiInstrument midi
)