1 %------------------------------------------------------------------%
2 % Opéra Libre -- markup.ly %
4 % (c) Valentin Villenave, 2008 %
6 %------------------------------------------------------------------%
8 %%% The following functions were provided by
9 %%% Nicolas Sceaux <nicolas.sceaux@free.fr>
14 %%% like \hspace, but for vertical space
16 %%% \smallCaps <string>
17 %%% like built-in \smallCaps, but dealing with accented letters
19 %%% \when-property <symbol> <markup>
20 %%% if symbol is find in properties, interpret the markup
21 %%% otherwise, return an empty stencil
23 %%% \line-width-ratio <ratio> <markup>
24 %%% interpret markup with a line-width set to current line-width * ratio
27 %%% build a copyight line, using the maintainer and copyrightYear
30 %%% \wordwrap-center <markup-list>
31 %%% like wordwrap, but center align the lines
33 %%% Markup lines commands
34 %%% =====================
35 %%% \wordwrap-center-lines <markup-list>
36 %%% make a markup list composed centered lines of text.
41 #(define-markup-command
(vspace layout props amount
) (number?
)
42 "This produces a invisible object taking vertical space."
43 (let
((amount
(* amount
3.0)))
45 (ly
:make-stencil
"" (cons -
1 1) (cons
0 amount
))
46 (ly
:make-stencil
"" (cons -
1 1) (cons amount amount
)))))
48 #(define-markup-command
(copyright layout props
) ()
49 (let
* ((maintainer
(chain-assoc-get
'header
:maintainer props
))
50 (this-year
(+
1900 (tm
:year
(gmtime
(current-time
)))))
51 (year
(string-
>number
(or
(chain-assoc-get
'header
:copyrightYear props
)
52 (number-
>string this-year
)))))
53 (interpret-markup layout props
55 (if
(= year this-year
)
56 (format
#f "~a" this-year
)
57 (format
#f "~a-~a" year this-year
))
60 #(define-markup-command
(when-property layout props symbol markp
) (symbol? markup?
)
61 (if
(chain-assoc-get symbol props
)
62 (interpret-markup layout props markp
)
63 (ly
:make-stencil
'() '(1 . -
1) '(1 . -
1))))
65 #(define-markup-command
(line-width-ratio layout props width-ratio arg
) (number? markup?
)
66 (interpret-markup layout props
67 (markup
#:override
(cons
'line-width
(* width-ratio
(chain-assoc-get
'line-width props
)))
70 #(define-markup-list-command
(wordwrap-center-lines layout props args
)
72 (map
(lambda
(stencil
)
73 (interpret-markup layout props
(markup
#:fill-line
(#:stencil stencil
))))
74 (interpret-markup-list layout props
(make-wordwrap-lines-markup-list args
))))
76 #(define-markup-command
(wordwrap-center layout props args
) (markup-list?
)
77 (interpret-markup layout props
79 (make-wordwrap-center-lines-markup-list args
))))
82 #(define
(page-ref-aux layout props label gauge next
)
83 (let
* ((gauge-stencil
(interpret-markup layout props gauge
))
84 (x-ext
(ly
:stencil-extent gauge-stencil X
))
85 (y-ext
(ly
:stencil-extent gauge-stencil Y
)))
87 `
(delay-stencil-evaluation
88 ,(delay
(ly
:stencil-expr
89 (let
* ((table
(ly
:output-def-lookup layout
'label-page-table
))
90 (label-page
(and
(list? table
) (assoc label table
)))
91 (page-number
(and label-page
(cdr label-page
)))
92 (page-markup
(if page-number
93 (markup
#:concat
((format
"~a" page-number
) next
))
95 (page-stencil
(interpret-markup layout props page-markup
))
96 (gap
(-
(interval-length x-ext
)
97 (interval-length
(ly
:stencil-extent page-stencil X
)))))
98 (interpret-markup layout props
99 (markup
#:concat
(page-markup
#:hspace gap
)))))))
103 #(define-markup-command
(page-refI layout props label next
)
105 (page-ref-aux layout props label
"0" next
))
107 #(define-markup-command
(page-refII layout props label next
)
109 (page-ref-aux layout props label
"00" next
))
111 #(define-markup-command
(page-refIII layout props label next
)
113 (page-ref-aux layout props label
"000" next
))
115 #(define-markup-command
(super layout props arg
) (markup?
)
116 (ly
:stencil-translate-axis
119 (cons `
((font-size
. ,(-
(chain-assoc-get
'font-size props
0) 3))) props
)
121 (* 0.25 (chain-assoc-get
'baseline-skip props
))
124 #(define-markup-list-command
(paragraph paper props text
) (markup-list?
)
125 (let
((indentation
(markup
#:pad-to-box
(cons
0 3) (cons
0 0) #:null
)))
126 (interpret-markup-list paper props
127 (make-override-lines-markup-list
'(baseline-skip
. 0)
128 (make-justified-lines-markup-list
(cons indentation text
))))))
130 #(define-markup-list-command
(columns paper props text
) (markup-list?
)
131 (interpret-markup-list paper props
132 (make-override-lines-markup-list
'(baseline-skip
. 1)
133 (make-column-lines-markup-list text
))))
135 #(define-markup-command
(boxed-justify layout props text
) (markup-list?
)
136 (interpret-markup layout props
137 (make-override-markup
'(box-padding
. 1)
140 (make-justified-lines-markup-list text
))))))
142 %%% Guile does not deal with accented letters
143 #(use-modules
(ice-
9 regex
))
144 %%;; actually defined below, in a closure
145 #(define-public string-upper-case
#f)
146 #(define accented-char-upper-case?
#f)
147 #(define accented-char-lower-case?
#f)
149 %%;; an accented character is seen as two characters by guile
150 #(let
((lower-case-accented-string
"éèêëáàâäíìîïóòôöúùûüçœæ")
151 (upper-case-accented-string
"ÉÈÊËÁÀÂÄÍÌÎÏÓÒÔÖÚÙÛÜÇŒÆ"))
152 (define
(group-by-
2 chars result
)
153 (if
(or
(null? chars
) (null?
(cdr chars
)))
155 (group-by-
2 (cddr chars
)
156 (cons
(string
(car chars
) (cadr chars
))
158 (let
((lower-case-accented-chars
159 (group-by-
2 (string-
>list lower-case-accented-string
) (list
)))
160 (upper-case-accented-chars
161 (group-by-
2 (string-
>list upper-case-accented-string
) (list
))))
162 (set
! string-upper-case
164 (define
(replace-chars str froms tos
)
167 (replace-chars
(regexp-substitute
/global
#f (car froms
) str
168 'pre
(car tos
) 'post
)
171 (string-upcase
(replace-chars str
172 lower-case-accented-chars
173 upper-case-accented-chars
))))
174 (set
! accented-char-upper-case?
175 (lambda
(char
1 char
2)
176 (member
(string char
1 char
2) upper-case-accented-chars string
=?
)))
177 (set
! accented-char-lower-case?
178 (lambda
(char
1 char
2)
179 (member
(string char
1 char
2) lower-case-accented-chars string
=?
)))))
181 #(define-markup-command
(smallCaps layout props text
) (markup?
)
182 "Turn @code{text}, which should be a string, to small caps.
184 \\markup \\small-caps \"Text between double quotes\"
186 (define
(string-list-
>markup strings lower
)
187 (let
((final-string
(string-upper-case
188 (apply string-append
(reverse strings
)))))
190 (markup
#:fontsize -
2 final-string
)
192 (define
(make-small-caps rest-chars currents current-is-lower prev-result
)
193 (if
(null? rest-chars
)
194 (make-concat-markup
(reverse
! (cons
(string-list-
>markup
195 currents current-is-lower
)
197 (let
* ((ch
1 (car rest-chars
))
198 (ch
2 (and
(not
(null?
(cdr rest-chars
))) (cadr rest-chars
)))
199 (this-char-string
(string ch
1))
200 (is-lower
(char-lower-case? ch
1))
201 (next-rest-chars
(cdr rest-chars
)))
202 (cond
((and ch
2 (accented-char-lower-case? ch
1 ch
2))
203 (set
! this-char-string
(string ch
1 ch
2))
205 (set
! next-rest-chars
(cddr rest-chars
)))
206 ((and ch
2 (accented-char-upper-case? ch
1 ch
2))
207 (set
! this-char-string
(string ch
1 ch
2))
209 (set
! next-rest-chars
(cddr rest-chars
))))
210 (if
(or
(and current-is-lower is-lower
)
211 (and
(not current-is-lower
) (not is-lower
)))
212 (make-small-caps next-rest-chars
213 (cons this-char-string currents
)
216 (make-small-caps next-rest-chars
217 (list this-char-string
)
221 (cons
(string-list-
>markup
222 currents current-is-lower
)
224 (interpret-markup layout props
226 (make-small-caps
(string-
>list text
) (list
) #f (list
))
232 #(define-markup-command
(rehearsal-number layout props text
) (string?
)
233 (interpret-markup layout props
234 (markup
#:huge
#:bold text
)))
236 #(define-markup-command
(rehearsal-number-toc layout props text
) (string?
)
237 (let
* ((gauge-stencil
(interpret-markup layout props
"8-88"))
238 (x-ext
(ly
:stencil-extent gauge-stencil X
))
239 (y-ext
(ly
:stencil-extent gauge-stencil Y
))
240 (stencil
(interpret-markup layout props text
))
241 (gap
(-
(interval-length x-ext
)
242 (interval-length
(ly
:stencil-extent stencil X
)))))
243 (interpret-markup layout props
244 (markup
#:concat
(#:hspace gap text
#:hspace
1)))))
246 #(define-markup-command
(act layout props arg
) (markup?
)
247 (interpret-markup layout props
249 (markup
#:pad-markup
2 #:fill-line
(#:fontsize
6 arg
))
250 (markup
#:column
(#:vspace
3
251 #:pad-markup
3 #:fill-line
(#:fontsize
6 arg
))))))
253 #(define-markup-command
(scene layout props arg
) (markup?
)
254 (interpret-markup layout props
256 (markup
#:pad-markup
0.5 #:fill-line
(#:fontsize
4 arg
))
257 (markup
#:column
(#:vspace
1
258 #:fill-line
(#:fontsize
4 arg
)
261 #(define-markup-command
(scene-description layout props arg
) (markup?
)
262 (interpret-markup layout props
265 (markup
#:column
(#:fill-line
(#:override
'(line-width
. 80)
269 #(define-markup-command
(title layout props arg
) (markup?
)
270 (interpret-markup layout props
271 (markup
#:fill-line
(#:override
'(line-width
. 80)
274 #(define-markup-command
(small-title layout props arg
) (markup?
)
275 (interpret-markup layout props
276 (markup
#:fill-line
(#:override
'(line-width
. 80)
277 #:fontsize
0 #:italic arg
))))
280 #(define-markup-command
(characteri paper props name
) (markup?
)
281 (interpret-markup paper props
282 (markup
#:huge
#:smallCaps name
)))
284 #(define-markup-command
(character paper props name
) (markup?
)
285 (interpret-markup paper props
286 (markup
#:null
#:translate
(cons -
4 2) #:characteri name
)))
288 #(define-markup-command
(character-text paper props name text
) (markup? markup?
)
289 (interpret-markup paper props
290 (markup
#:null
#:translate
(cons -
4 2)
291 #:line
(#:characteri name
#:huge
" " #:huge
#:italic text
))))
293 #(define-public
(make-character-mark clefs name
)
294 #{ << { \set Staff
.forceClef
= ##t
\clef #$clefs
295 \once \override Staff
. Clef
#'full-size-change
= ##t
}
296 s1*0 ^\markup \character $name
>> #})