?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
A few more notes in the last scene
[opera_libre.git] / definitions / text-functions.ly
blob2479094ecf50b86daa6edcb705fbeafc0bf3603a
1
2 %% vertical space skip
3 #(define-markup-command (vspace layout props amount) (number?)
4 "This produces a invisible object taking vertical space."
5 (let ((amount (* amount 3.0)))
6 (if (> amount 0)
7 (ly:make-stencil "" (cons -1 1) (cons 0 amount))
8 (ly:make-stencil "" (cons -1 1) (cons amount amount)))))
9
10 #(define-markup-command (when-property layout props symbol markp) (symbol? markup?)
11 (if (chain-assoc-get symbol props)
12 (interpret-markup layout props markp)
13 (ly:make-stencil '() '(1 . -1) '(1 . -1))))
14
15 #(define-markup-command (custom-copyright layout props) ()
16 (let* ((maintainer (chain-assoc-get 'header:maintainer props))
17 (this-year (+ 1900 (tm:year (gmtime (current-time)))))
18 (year (string->number (or (chain-assoc-get 'header:copyrightYear props)
19 (number->string this-year)))))
20 (interpret-markup layout props
21 (markup "Copyright ©"
22 (if (= year this-year)
23 (format #f "~a" this-year)
24 (format #f "~a-~a" year this-year))
25 maintainer))))
26
27 #(define-markup-list-command (paragraphe paper props text) (markup-list?)
28 (let ((indentation (markup #:pad-to-box (cons 0 3) (cons 0 0) #:null)))
29 (interpret-markup-list paper props
30 (make-override-lines-markup-list '(baseline-skip . 0)
31 (make-justified-lines-markup-list (cons indentation text))))))
32
33 #(define-markup-list-command (columns paper props text) (markup-list?)
34 (interpret-markup-list paper props
35 (make-override-lines-markup-list '(baseline-skip . 1)
36 (make-column-lines-markup-list text))))
37
38 #(define-markup-command (boxed-justify layout props text) (markup-list?)
39 (interpret-markup layout props
40 (make-override-markup '(box-padding . 1)
41 (make-box-markup
42 (make-column-markup
43 (make-justified-lines-markup-list text))))))
44
45 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
46 %%% Utility markups
47
48 %% vertical space skip
49 #(define-markup-command (vspace layout props amount) (number?)
50 "This produces a invisible object taking vertical space."
51 (let ((amount (* amount 3.0)))
52 (if (> amount 0)
53 (ly:make-stencil "" (cons -1 1) (cons 0 amount))
54 (ly:make-stencil "" (cons -1 1) (cons amount amount)))))
55
56 #(define-markup-command (when-property layout props symbol markp) (symbol? markup?)
57 (if (chain-assoc-get symbol props)
58 (interpret-markup layout props markp)
59 (ly:make-stencil '() '(1 . -1) '(1 . -1))))
60
61 #(define-markup-command (line-width-ratio layout props width-ratio arg) (number? markup?)
62 (interpret-markup layout props
63 (markup #:override (cons 'line-width (* width-ratio (chain-assoc-get 'line-width props)))
64 arg)))
65
66 %%% Guile does not deal with accented letters
67 #(use-modules (ice-9 regex))
68 %%;; actually defined below, in a closure
69 #(define-public string-upper-case #f)
70 #(define accented-char-upper-case? #f)
71 #(define accented-char-lower-case? #f)
72
73 %%;; an accented character is seen as two characters by guile
74 #(let ((lower-case-accented-string "éèêëáà âäíìîïóòôöúùûüçœæ")
75 (upper-case-accented-string "ÉÈÊË�ÀÂÄ�ÌÎ�ÓÒÔÖÚÙÛÜÇŒÆ"))
76 (define (group-by-2 chars result)
77 (if (or (null? chars) (null? (cdr chars)))
78 (reverse! result)
79 (group-by-2 (cddr chars)
80 (cons (string (car chars) (cadr chars))
81 result))))
82 (let ((lower-case-accented-chars
83 (group-by-2 (string->list lower-case-accented-string) (list)))
84 (upper-case-accented-chars
85 (group-by-2 (string->list upper-case-accented-string) (list))))
86 (set! string-upper-case
87 (lambda (str)
88 (define (replace-chars str froms tos)
89 (if (null? froms)
90 str
91 (replace-chars (regexp-substitute/global #f (car froms) str
92 'pre (car tos) 'post)
93 (cdr froms)
94 (cdr tos))))
95 (string-upcase (replace-chars str
96 lower-case-accented-chars
97 upper-case-accented-chars))))
98 (set! accented-char-upper-case?
99 (lambda (char1 char2)
100 (member (string char1 char2) upper-case-accented-chars string=?)))
101 (set! accented-char-lower-case?
102 (lambda (char1 char2)
103 (member (string char1 char2) lower-case-accented-chars string=?)))))
104
105 #(define-markup-command (smallCaps layout props text) (markup?)
106 "Turn @code{text}, which should be a string, to small caps.
107 @example
108 \\markup \\small-caps \"Text between double quotes\"
109 @end example"
110 (define (string-list->markup strings lower)
111 (let ((final-string (string-upper-case
112 (apply string-append (reverse strings)))))
113 (if lower
114 (markup #:fontsize -2 final-string)
115 final-string)))
116 (define (make-small-caps rest-chars currents current-is-lower prev-result)
117 (if (null? rest-chars)
118 (make-concat-markup (reverse! (cons (string-list->markup
119 currents current-is-lower)
120 prev-result)))
121 (let* ((ch1 (car rest-chars))
122 (ch2 (and (not (null? (cdr rest-chars))) (cadr rest-chars)))
123 (this-char-string (string ch1))
124 (is-lower (char-lower-case? ch1))
125 (next-rest-chars (cdr rest-chars)))
126 (cond ((and ch2 (accented-char-lower-case? ch1 ch2))
127 (set! this-char-string (string ch1 ch2))
128 (set! is-lower #t)
129 (set! next-rest-chars (cddr rest-chars)))
130 ((and ch2 (accented-char-upper-case? ch1 ch2))
131 (set! this-char-string (string ch1 ch2))
132 (set! is-lower #f)
133 (set! next-rest-chars (cddr rest-chars))))
134 (if (or (and current-is-lower is-lower)
135 (and (not current-is-lower) (not is-lower)))
136 (make-small-caps next-rest-chars
137 (cons this-char-string currents)
138 is-lower
139 prev-result)
140 (make-small-caps next-rest-chars
141 (list this-char-string)
142 is-lower
143 (if (null? currents)
144 prev-result
145 (cons (string-list->markup
146 currents current-is-lower)
147 prev-result)))))))
148 (interpret-markup layout props
149 (if (string? text)
150 (make-small-caps (string->list text) (list) #f (list))
151 text)))
152
153 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
154 %%% Title page
155 %%%
156 \paper {
157 bookTitleMarkup = \markup \when-property #'header:title \column {
158 \vspace #6
159 \fill-line { \fontsize #8 \italic \fromproperty #'header:composer }
160 \vspace #1
161 \fill-line { \fontsize #8 \italic \fromproperty #'header:poet }
162 \vspace #6
163 \fill-line { \fontsize #10 \fromproperty #'header:title }
164 \vspace #6
165 \fill-line { \postscript #"-20 0 moveto 40 0 rlineto stroke" }
166 \vspace #6
167 \fill-line { \fontsize #5 \fromproperty #'header:date }
168 \vspace #1
169 \fill-line {
170 \when-property #'header:arrangement \column {
171 \vspace #5
172 \fill-line { \fontsize #3 \fromproperty #'header:arrangement }
173 }
174 }
175 }
176 scoreTitleMarkup = \markup \null
177 }
178
179 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
180 %%% Table of contents
181 %%%
182 #(define-markup-command (paper-prop layout props name default)
183 (symbol? markup?)
184 "Get the value of a \\paper property, or defaults to some value"
185 (let ((val (ly:output-def-lookup layout name)))
186 (interpret-markup layout props (if (markup? val)
187 val
188 default))))
189 \paper {
190 tocTitleMarkup = \markup \column {
191 \vspace #2
192 \fontsize #6 \fill-line { \paper-prop #'tocTitle "TABLE OF CONTENTS" }
193 \vspace #2
194 }
195 tocPieceMarkup = \markup \fill-line {
196 \line-width-ratio #0.7 \fill-line {
197 \line { \fromproperty #'toc:text }
198 \fromproperty #'toc:page
199 }
200 }
201 tocSectionMarkup = \markup \italic \column {
202 \fill-line { \fromproperty #'toc:text }
203 }
204 tocChapterMarkup = \markup \large \italic \column {
205 \vspace #1
206 \fontsize #2 \fill-line { \fromproperty #'toc:text }
207 \vspace #1
208 }
209 }
210
211 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
212 %%% Markup commands for page headers
213 %%%
214 #(define-public add-odd-page-header-text #f)
215 #(define-public add-even-page-header-text #f)
216 #(define header-markup-aux #f)
217 #(let ((odd-label-header-table (list))
218 (odd-page-header-table (list))
219 (even-label-header-table (list))
220 (even-page-header-table (list)))
221 (set! header-markup-aux
222 (lambda (layout props odd)
223 (define (page-text page-number table)
224 (if (null? table)
225 ""
226 (let* ((elment (car table))
227 (p (car elment))
228 (text (cadr elment))
229 (display-1st (caddr elment)))
230 (cond ((and (= page-number p) (not display-1st)) #f)
231 ((>= page-number p) text)
232 (else (page-text page-number (cdr table)))))))
233 (ly:make-stencil
234 `(delay-stencil-evaluation
235 ,(delay (ly:stencil-expr
236 (begin
237 (if (or (and odd (null? odd-page-header-table))
238 (and (not odd) (null? even-page-header-table)))
239 (let ((page-header-table (list)))
240 (for-each (lambda (label-header)
241 (let* ((label (car label-header))
242 (text-disp (cdr label-header))
243 (table (ly:output-def-lookup layout 'label-page-table))
244 (label-page (and (list? table) (assoc label table)))
245 (page-number (and label-page (cdr label-page)))
246 (prev-value (and page-number (assoc page-number page-header-table))))
247 (if (not prev-value)
248 (set! page-header-table (cons (cons page-number text-disp)
249 page-header-table))
250 (set! page-header-table
251 (assoc-set! page-header-table
252 page-number
253 (list (car text-disp) (caddr prev-value)))))))
254 (reverse (if odd odd-label-header-table even-label-header-table)))
255 (if odd
256 (set! odd-page-header-table page-header-table)
257 (set! even-page-header-table page-header-table))))
258 (interpret-markup layout props
259 (let* ((page-number (chain-assoc-get 'page:page-number props -1))
260 (text (page-text page-number (if odd odd-page-header-table even-page-header-table)))
261 (text-markup (markup #:italic (or text "")))
262 (page-number-markup (number->string page-number)))
263 (cond ((or (= 1 page-number) (not text)) (markup #:null))
264 (odd (markup #:fill-line (#:null text-markup page-number-markup)))
265 (else (markup #:fill-line (page-number-markup text-markup #:null))))))))))
266 (cons 0 0)
267 (ly:stencil-extent (interpret-markup layout props "XXX") Y))))
268 (set! add-odd-page-header-text
269 (lambda (parser text display-1st)
270 (let ((label (gensym "header")))
271 (set! odd-label-header-table
272 (cons (list label text display-1st)
273 odd-label-header-table))
274 (collect-music-for-book parser
275 (make-music 'Music
276 'page-marker #t
277 'page-label label)))))
278 (set! add-even-page-header-text
279 (lambda (parser text display-1st)
280 (let ((label (gensym "header")))
281 (set! even-label-header-table
282 (cons (list label text display-1st)
283 even-label-header-table))
284 (collect-music-for-book parser
285 (make-music 'Music
286 'page-marker #t
287 'page-label label))))))
288
289 #(define-markup-command (odd-header layout props) ()
290 (header-markup-aux layout props #t))
291
292 #(define-markup-command (even-header layout props) ()
293 (header-markup-aux layout props #f))
294
295 \paper {
296 evenHeaderMarkup = \markup \even-header
297 oddHeaderMarkup = \markup \odd-header
298 }
299
300 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
301 %%% Utilities for adding (no-)page breaks, toplevel markups
302 %%%
303 #(define (add-page-break parser)
304 (collect-music-for-book parser
305 (make-music 'Music
306 'page-marker #t
307 'line-break-permission 'force
308 'page-break-permission 'force)))
309
310 #(define (add-no-page-break parser)
311 (collect-music-for-book parser
312 (make-music 'Music
313 'page-marker #t
314 'page-break-permission 'forbid)))
315
316 #(define (add-toplevel-markup parser text)
317 (collect-scores-for-book parser (list text)))
318
319 #(define (add-toc-item parser markup-symbol text)
320 (collect-music-for-book parser
321 (add-toc-item! markup-symbol text)))
322
323 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
324 %%% Rehearsal numbers
325 %%%
326 #(define-public rehearsal-number #f)
327 #(define-public increase-rehearsal-major-number #f)
328 #(let ((major-number 0)
329 (minor-number 0))
330 (set! increase-rehearsal-major-number
331 (lambda ()
332 (set! major-number (1+ major-number))
333 (set! minor-number 0)))
334 (set! rehearsal-number
335 (lambda ()
336 (set! minor-number (1+ minor-number))
337 (format #f "~a-~a" major-number minor-number))))
338
339 #(define-public (add-rehearsal-number parser)
340 (collect-scores-for-book parser
341 (list (markup #:huge #:bold (rehearsal-number)))))
342
343 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
344 %%% Commands
345 %%%
346
347 #(use-modules (srfi srfi-39))
348 #(define *book-title* (make-parameter ""))
349 #(define *use-rehearsal-numbers* (make-parameter #f))
350
351 useRehearsalNumbers =
352 #(define-music-function (parser location use-numbers) (boolean?)
353 (*use-rehearsal-numbers* use-numbers)
354 (make-music 'Music 'void #t))
355
356 bookTitle =
357 #(define-music-function (parser location title) (string?)
358 (*book-title* title)
359 (make-music 'Music 'void #t))
360
361 chapter =
362 #(define-music-function (parser location title) (string?)
363 (increase-rehearsal-major-number)
364 (add-page-break parser)
365 (add-toc-item parser 'tocChapterMarkup title)
366 (add-even-page-header-text parser (string-upper-case (*book-title*)) #f)
367 (add-odd-page-header-text parser (string-upper-case title) #f)
368 (add-toplevel-markup parser (markup #:chapter-title (string-upper-case title)))
369 (add-no-page-break parser)
370 (make-music 'Music 'void #t))
371
372 section =
373 #(define-music-function (parser location title) (string?)
374 (add-toc-item parser 'tocSectionMarkup title)
375 (add-toplevel-markup parser (markup #:section-title (string-upper-case title)))
376 (add-no-page-break parser)
377 (make-music 'Music 'void #t))
378
379 piece =
380 #(define-music-function (parser location title) (markup?)
381 (add-toc-item parser 'tocPieceMarkup title)
382 (add-no-page-break parser)
383 (if (*use-rehearsal-numbers*)
384 (add-toplevel-markup parser (markup #:rehearsal-number (rehearsal-number))))
385 (add-no-page-break parser)
386 (make-music 'Music 'void #t))
387
388 titledPiece =
389 #(define-music-function (parser location title) (markup?)
390 (add-toc-item parser 'tocPieceMarkup title)
391 (if (*use-rehearsal-numbers*)
392 (add-toplevel-markup parser
393 (markup #:piece-title-with-number (rehearsal-number) (string-upper-case title)))
394 (add-toplevel-markup parser (markup #:piece-title (string-upper-case title))))
395 (add-no-page-break parser)
396 (make-music 'Music 'void #t))
397
398 #(define-markup-command (chapter-title layout props title) (markup?)
399 (interpret-markup layout props
400 (markup #:column (#:vspace 3
401 #:pad-markup 3 #:fill-line (#:fontsize 5 title)))))
402
403 #(define-markup-command (section-title layout props title) (markup?)
404 (interpret-markup layout props
405 (markup #:column (#:vspace 1
406 #:fill-line (#:fontsize 3 title)
407 #:vspace 1))))
408
409 #(define-markup-command (piece-title layout props title) (markup?)
410 (interpret-markup layout props
411 (markup #:fill-line (#:override '(line-width . 80) title))))
412
413 #(define-markup-command (rehearsal-number layout props number) (markup?)
414 (interpret-markup layout props
415 (markup #:huge #:bold number)))
416
417 #(define-markup-command (piece-title-with-number layout props number title)
418 (markup? markup?)
419 (interpret-markup layout props
420 (markup #:rehearsal-number number
421 #:hspace 1
422 #:huge title)))
Opera Libre is a free-licensed contemporary music score, created using the GNU LilyPond music software.