1 ;------------------------------------------------------------------;
2 ; opus_libre -- markup-commands.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 ;------------------------------------------------------------------;
22 ;; This code was provided by Nicolas Sceaux.
23 (define-markup-command (smallCaps layout props text) (markup?)
24 "Turn @code{text}, which should be a string, to small caps.
26 \\markup \\small-caps \"Text between double quotes\"
28 (define string-upper-case #f)
29 (define accented-char-upper-case? #f)
30 (define accented-char-lower-case? #f)
32 (define (string-list->markup strings lower)
33 (let ((final-string (string-upper-case
34 (apply string-append (reverse strings)))))
36 (markup #:fontsize -2 final-string)
38 (define (make-small-caps rest-chars currents current-is-lower prev-result)
39 (if (null? rest-chars)
40 (make-concat-markup (reverse! (cons (string-list->markup
41 currents current-is-lower)
43 (let* ((ch1 (car rest-chars))
44 (ch2 (and (not-null? (cdr rest-chars)) (cadr rest-chars)))
45 (this-char-string (string ch1))
46 (is-lower (char-lower-case? ch1))
47 (next-rest-chars (cdr rest-chars)))
48 (cond ((and ch2 (accented-char-lower-case? ch1 ch2))
49 (set! this-char-string (string ch1 ch2))
51 (set! next-rest-chars (cddr rest-chars)))
52 ((and ch2 (accented-char-upper-case? ch1 ch2))
53 (set! this-char-string (string ch1 ch2))
55 (set! next-rest-chars (cddr rest-chars))))
56 (if (or (and current-is-lower is-lower)
57 (and (not current-is-lower) (not is-lower)))
58 (make-small-caps next-rest-chars
59 (cons this-char-string currents)
62 (make-small-caps next-rest-chars
63 (list this-char-string)
67 (cons (string-list->markup
68 currents current-is-lower)
71 (let ((lower-case-accented-string "éèêëáàâäíìîïóòôöúùûüçœæ")
72 (upper-case-accented-string "ÉÈÊËÁÀÂÄÍÌÎÏÓÒÔÖÚÙÛÜÇŒÆ"))
73 (define (group-by-2 chars result)
74 (if (or (null? chars) (null? (cdr chars)))
76 (group-by-2 (cddr chars)
77 (cons (string (car chars) (cadr chars))
79 (let ((lower-case-accented-chars
80 (group-by-2 (string->list lower-case-accented-string) (list)))
81 (upper-case-accented-chars
82 (group-by-2 (string->list upper-case-accented-string) (list))))
83 (set! string-upper-case
85 (define (replace-chars str froms tos)
88 (replace-chars (regexp-substitute/global #f (car froms) str
92 (string-upcase (replace-chars str
93 lower-case-accented-chars
94 upper-case-accented-chars))))
95 (set! accented-char-upper-case?
97 (member (string char1 char2) upper-case-accented-chars string=?)))
98 (set! accented-char-lower-case?
100 (member (string char1 char2) lower-case-accented-chars string=?)))))
102 (interpret-markup layout props
104 (make-small-caps (string->list text) (list) #f (list))
107 (define-markup-command (dynamic-string layout props str) (string?)
110 @cindex dynamics, composite
111 @cindex dynamics, mixed with text
113 Print a string using the dynamic font only when appropriate.
114 Words may be separated with @code{_}; dynamic-style characters
115 will only be used in words that contain no other letter than
116 @b{f}, @b{m}, @b{p}, @b{r}, @b{s} and @b{z}, and punctuation
117 marks. Regular spaces are allowed inside words.
119 @lilypond[verbatim,quote]
121 \\dynamic-string #\"mp,_quasi_mf_ma più dolce.\"
124 (let ((composite-chars (char-set-union
127 char-set:punctuation))
128 (split (lambda (s) (string-index s #\_ )))
130 (dyn-markup (lambda (s)
131 (make-whiteout-markup
132 (make-dynamic-markup s))))
133 (text-markup (lambda (s)
134 (make-whiteout-markup
135 (make-normal-text-markup
136 (make-italic-markup s))))))
137 (do ((current-str (string-append str "_")))
138 ((not (split current-str)))
141 (append str-list (list
142 (string-take current-str (split current-str)))))
144 (string-drop current-str (+ (split current-str) 1)))))
145 (interpret-markup layout props
148 (if (string-every composite-chars word)
149 (if (string-every char-set:dynamics word)
151 (let ((word-lst (string->list word)))
154 (let ((print-ch (string ch)))
155 (if (char-punctuation? ch)
156 (text-markup print-ch)
157 (dyn-markup print-ch))))
162 (define-markup-command (fill-page layout props args)
164 #:properties ((text-direction UP)
168 (define (get-fill-space line-count page-height line-space text-heights)
170 ((null? text-heights) '())
172 ;; special case first padding
173 ((= (length text-heights) line-count)
175 (- (- (/ page-height (1- line-count)) (car text-heights))
176 (/ (car (cdr text-heights)) 2))
177 (get-fill-space line-count page-height line-space (cdr text-heights))))
178 ;; special case last padding
179 ((= (length text-heights) 2)
180 (list (- (/ page-height (1- line-count))
181 (+ (/ (car text-heights) 2) (car (cdr text-heights)))) 0))
183 (let ((default-padding
184 (- (/ page-height (1- line-count))
185 (/ (+ (car text-heights) (car (cdr text-heights))) 2))))
187 (if (> line-space default-padding)
190 (get-fill-space line-count page-height line-space (cdr text-heights)))))))
192 (let* ((orig-stencils (interpret-markup-list layout props args))
195 (if (ly:stencil-empty? stc)
197 stc)) orig-stencils))
200 (if (ly:stencil-empty? stc)
202 (interval-length (ly:stencil-extent stc Y))))
204 (text-height (apply + text-heights))
205 (line-count (length stencils))
206 (page-height (- (ly:output-def-lookup layout 'paper-height)
207 (+ (ly:output-def-lookup layout 'top-margin)
208 (ly:output-def-lookup layout 'bottom-margin))))
213 (/ (- page-height text-height) 2)
214 (/ (- page-height text-height) 2)))
217 (- page-height text-height)))
219 (get-fill-space line-count page-height line-space text-heights))))
221 (page-contents (if (= line-count 1)
228 (if (null? (remove ly:stencil-empty? orig-stencils))
231 (if (= text-direction UP)
232 (set! page-contents (reverse page-contents)))
234 (stack-stencils-padding-list
235 Y UP fill-space page-contents))
238 (ly:stencil-translate-axis
240 (- (car (ly:stencil-extent (car stencils) Y)))
245 ;; This markup-command may be overriden later by a theme-specific file.
246 (define-markup-command (indic layout props arg) (markup?)
247 (interpret-markup layout props
248 (markup #:whiteout #:medium #:small #:italic arg)))
250 (define-markup-command (bracketText layout props num up? arg) (number? boolean? markup?)
251 (let* ((pos (max 3 (- 10 (- num))))
252 (text (markup #:with-dimensions '(0 . 0)'(0 . 0) arg))
254 (markup #:normal-text #:fontsize 3
262 #:postscript (format #f "
267 (if up? "" text))))))
268 (if (not up?) (set! pos (- pos)))
269 (interpret-markup layout props (stack pos))))
271 (define-markup-command (copyright layout props) ()
272 (let* ((maintainer (chain-assoc-get 'header:maintainer props))
273 (this-year (+ 1900 (tm:year (gmtime (current-time)))))
274 (year (string->number (or (chain-assoc-get 'header:copyrightYear props)
275 (number->string this-year)))))
276 (interpret-markup layout props
277 (markup "Copyright ©"
278 (if (= year this-year)
279 (format #f "~a" this-year)
280 (format #f "~a-~a" year this-year))
283 (define-markup-command (today layout props) ()
284 (let ((today (gmtime (current-time))))
285 (interpret-markup layout props
286 (format #f "~a-~a-~a"
287 (+ 1900 (tm:year today))
291 (define-markup-command (vconcat layout props arg) (markup?)
292 (interpret-markup layout
293 (cons (list (cons 'baseline-skip 0)) props) arg))