| blob | 62c34e9bed4666802d41a4e78aec49a292440676 |
1 %%% toc-columns.ily -- Table of content on several columns
2 %%%
3 %%% Author: Nicolas Sceaux <nicolas.sceaux@free.fr>
4 %%%
6 %% Add optional arguments to `add-toc-item!'
7 #(let ((toc-item-list (list)))
8 (set! add-toc-item!
9 (lambda (markup-symbol text . rest)
10 (let ((label (gensym "toc")))
11 (set! toc-item-list
12 (cons (append! (list label markup-symbol text) rest)
13 toc-item-list))
14 (make-music 'EventChord
15 'page-marker #t
16 'page-label label
17 'elements (list (make-music 'LabelEvent
18 'page-label label))))))
19 (set! toc-items (lambda ()
20 (reverse toc-item-list))))
22 %% Add dot-filling option to \line and \wordwrap
23 #(define-markup-command (fromproperty layout props sym) (symbol?)
24 (let ((m (chain-assoc-get sym props)))
25 (cond ((string? m)
26 (interpret-markup layout props (make-simple-markup m)))
27 ((markup? m)
28 (if (memq (car m) (list wordwrap-markup))
29 (interpret-markup layout props m)
30 (interpret-markup layout props (make-line-markup (list m)))))
31 (else
32 empty-stencil))))
34 #(define-markup-command (line layout props args) (markup-list?)
35 #:properties ((word-space)
36 (line-width #f)
37 (text-direction RIGHT)
38 (fill-with-dots #f))
39 "Like built-in @code{line}, but fill the line
40 with dots in property @code{fill-with-dots} is true."
41 (let* ((props (cons `((fill-with-dots . #f)) props))
42 (line (let ((stencils (interpret-markup-list layout props args)))
43 (if (= text-direction LEFT)
44 (set! stencils (reverse stencils)))
45 (stack-stencil-line
46 word-space
47 (remove ly:stencil-empty? stencils)))))
48 (if (not fill-with-dots)
49 line
50 (interpret-markup layout props
51 (markup #:fill-with-pattern 0.5 RIGHT "."
52 #:stencil line
53 #:null)))))
55 #(define-markup-command (simple layout props str) (string?)
56 #:properties ((fill-with-dots #f))
57 "Like built-in @code{simple}, but fill the line
58 with dots in property @code{fill-with-dots} is true."
59 (if fill-with-dots
60 (interpret-markup layout props (make-line-markup (list str)))
61 (interpret-markup layout props str)))
63 #(define-markup-command (wordwrap layout props args) (markup-list?)
64 #:properties ((baseline-skip 0.3)
65 (fill-with-dots #f)
66 wordwrap-internal-markup-list)
67 "Like built-in @code{wordwrap}, but fill the last line
68 with dots in property @code{fill-with-dots} is true."
69 (let* ((no-dots-props (cons `((fill-with-dots . #f)) props))
70 (lines (space-lines
71 baseline-skip
72 (wordwrap-internal-markup-list layout no-dots-props #f args))))
73 (stack-lines DOWN 0 0
74 (space-lines
75 baseline-skip
76 (if (or (null? lines) (not fill-with-dots))
77 lines
78 (let* ((reversed-lines (reverse! lines)))
79 (reverse! (cons (interpret-markup
80 layout props
81 (make-line-markup
82 (list (make-stencil-markup (car reversed-lines)))))
83 (cdr reversed-lines)))))))))
85 %% stencil utilities
86 #(define (combine-left stencil . rest)
87 (cond ((null? rest)
88 stencil)
89 ((ly:stencil-empty? (car rest))
90 (apply combine-left stencil (cdr rest)))
91 (else
92 (apply combine-left
93 ; ly:stencil-combine-at-edge first axis direction second padding
94 (ly:stencil-combine-at-edge stencil X RIGHT (car rest) 0)
95 (cdr rest)))))
97 #(define (space-stencil width)
98 (ly:make-stencil "" (cons 0 width) (cons 0 0)))
100 #(define-markup-command (toc-filled-line layout props rehearsal-number text page)
101 (markup? markup? markup?)
102 #:properties ((line-width #f)
103 (word-space 0)
104 (baseline-skip 0.3)
105 (fill-line-with-dots #t)
106 (use-rehearsal-numbers #f)
107 (rehearsal-number-gauge "8-88")
108 (rehearsal-number-align RIGHT)
109 (rehearsal-number-margin 1)
110 (page-number-gauge "000")
111 (page-number-margin 1))
112 (let* ((line-width (or line-width (ly:output-def-lookup layout 'line-width)))
113 ;; page number
114 (page-number-stencil
115 (let* ((bare-page-number-stencil (interpret-markup layout props page))
116 (left-padding (max 0
117 (- (interval-length
118 (ly:stencil-extent
119 (interpret-markup layout props page-number-gauge)
120 X))
121 (interval-length
122 (ly:stencil-extent bare-page-number-stencil X))))))
123 (combine-left (space-stencil page-number-margin)
124 (space-stencil left-padding)
125 bare-page-number-stencil)))
126 (page-number-width (interval-length
127 (ly:stencil-extent page-number-stencil X)))
128 ;; rehearsal numbers: set later if actually used
129 (num-width 0)
130 (num-stencil empty-stencil))
131 ;; If rehearsal number is printed, compute its width and stencil
132 (if use-rehearsal-numbers
133 (let* ((bare-num-stencil (interpret-markup layout props rehearsal-number))
134 (bare-width (interval-length (ly:stencil-extent bare-num-stencil X)))
135 (num-gauge-stencil (interpret-markup layout props rehearsal-number-gauge))
136 (gauge-width (interval-length (ly:stencil-extent num-gauge-stencil X)))
137 (padding (max 0 (- gauge-width bare-width)))
138 (right-padding (* (/ (1+ (* -1 rehearsal-number-align)) 2.0) padding))
139 (left-padding (- padding right-padding)))
140 (set! num-stencil
141 (combine-left
142 ; left padding
143 (space-stencil left-padding)
144 ; rehearsal-number
145 bare-num-stencil
146 ; right padding
147 (space-stencil right-padding)
148 ; margin
149 (space-stencil rehearsal-number-margin)))
150 (set! num-width (+ gauge-width rehearsal-number-margin))))
151 ;; compute text width and stencil
152 (let* ((text-max-width (- line-width page-number-width num-width))
153 (text-stencil (interpret-markup
154 layout props
155 (markup #:override `(fill-with-dots . ,fill-line-with-dots)
156 #:override `(line-width . ,text-max-width)
157 text)))
158 (y-offset (min 0 (+ (cdr (ly:stencil-extent page-number-stencil Y))
159 (- (interval-length (ly:stencil-extent page-number-stencil Y))
160 (interval-length (ly:stencil-extent text-stencil Y)))))))
161 (combine-left num-stencil
162 text-stencil
163 (ly:stencil-translate-axis page-number-stencil y-offset Y)))))
165 #(define-markup-command (paper-prop layout props name default)
166 (symbol? markup?)
167 "Get the value of a \\paper property, or defaults to some value"
168 (let ((val (ly:output-def-lookup layout name)))
169 (interpret-markup layout props (if (markup? val)
170 val
171 default))))
173 \paper {
174 tocTitleMarkup = \markup \column {
175 \vspace #2
176 \fontsize #6 \fill-line { \paper-prop #'tocTitle "TABLE OF CONTENTS" }
177 \vspace #2
178 }
179 tocActMarkup = \markup \large \italic \column {
180 \vspace #1
181 \fontsize #2 \fill-line { \fromproperty #'toc:text }
182 \vspace #1
183 }
184 tocSceneMarkup = \markup {
185 \override #'(fill-line-with-dots . #f) \toc-filled-line
186 "" \larger\fromproperty #'toc:text ""
187 }
188 tocPieceMarkup = \markup {
189 \toc-filled-line
190 \fromproperty #'toc:rehearsal-number
191 \fromproperty #'toc:text
192 \fromproperty #'toc:page
193 }
194 tocBoldPieceMarkup = \markup {
195 \toc-filled-line
196 \fromproperty #'toc:rehearsal-number
197 \bold\fromproperty #'toc:text
198 \fromproperty #'toc:page
199 }
200 }
202 #(define-markup-command (toc-item layout props toc-item) (list?)
203 #:properties ((section-markup 'tocActMarkup)
204 (column-number 2)
205 (inter-column-padding 5)
206 (line-width #f)
207 (baseline-skip 0.3))
208 (let ((label (car toc-item))
209 (toc-markup (cadr toc-item))
210 (text (caddr toc-item))
211 (num (if (null? (cdddr toc-item))
212 '()
213 (cadddr toc-item)))
214 (line-width (or line-width (ly:output-def-lookup layout 'line-width)))
215 (column-width (/ (- line-width
216 (* (- column-number 1) inter-column-padding))
217 column-number)))
218 (car (space-lines
219 baseline-skip
220 (list (interpret-markup
221 layout
222 (cons `((line-width . ,(if (eqv? toc-markup section-markup)
223 line-width
224 column-width))
225 (toc:page . ,(markup #:with-link label
226 #:page-ref label "XXX" "?"))
227 (toc:rehearsal-number . ,num)
228 (toc:text . ,text))
229 props)
230 (ly:output-def-lookup layout toc-markup)))))))
232 #(define-markup-command (toc-section layout props title-item items) (list? list?)
233 #:properties ((column-number 2)
234 (sub-section-markup 'tocSceneMarkup)
235 (sub-section-padding 1)
236 (inter-column-padding 6))
237 (let* ((item-stencils
238 (map (lambda (item)
239 (interpret-markup
240 layout props
241 (markup
242 #:override `(inter-column-padding . ,inter-column-padding)
243 #:toc-item item)))
244 items))
245 (sub-sections (map (lambda (item)
246 (eqv? (cadr item) sub-section-markup))
247 items))
248 (title-stencil (if (null? title-item)
249 empty-stencil
250 (interpret-markup layout props
251 (markup #:toc-item title-item))))
252 (total-height
253 (+ (reduce + 0 (map (lambda (stencil)
254 (interval-length (ly:stencil-extent stencil Y)))
255 item-stencils))
256 (if (not (pair? sub-sections))
257 0
258 (reduce + 0 (map (lambda (val)
259 (if val sub-section-padding 0))
260 (cdr sub-sections))))))
261 (average-height (/ total-height column-number)))
262 (let fill-columns ((lines item-stencils)
263 (sub-sections sub-sections)
264 (current-column-index 1)
265 (current-column-height 0)
266 (current-column-lines '())
267 (previous-columns '()))
268 (if (null? lines)
269 ;; the end result: the section title and the items on several columns
270 (stack-lines
271 DOWN 0 0
272 (list title-stencil
273 (stack-stencil-line
274 0
275 (reverse! (if current-column-lines
276 (cons (stack-lines
277 DOWN 0 0
278 (reverse! current-column-lines))
279 previous-columns)
280 previous-columns)))))
281 ;; go on collecting the item stencils into columns
282 (let* ((line (car lines))
283 (height (interval-length (ly:stencil-extent line Y))))
284 (cond ((car sub-sections)
285 ;; this is new subsection, and the current column is not
286 ;; yet full => go on filling this column
287 (fill-columns (cdr lines)
288 (cdr sub-sections)
289 current-column-index
290 (+ current-column-height height sub-section-padding)
291 (cons line
292 ;; if this is not the first line in the column,
293 ;; add padding before
294 (if (not (null? current-column-lines))
295 (cons (ly:make-stencil "" '(0 . 0)
296 (cons 0 sub-section-padding))
297 current-column-lines)
298 current-column-lines))
299 previous-columns))
300 ((and (> current-column-height 0)
301 (< current-column-index column-number)
302 (>= (+ current-column-height height) average-height))
303 ;; this is a new line, which ends filling this column
304 ;; => start a new column after it
305 (fill-columns (cdr lines)
306 (cdr sub-sections)
307 (1+ current-column-index)
308 0
309 '()
310 (cons (ly:make-stencil
311 "" (cons 0 inter-column-padding) '(0 . 0))
312 (cons (stack-lines
313 DOWN 0 0
314 (reverse! (cons line current-column-lines)))
315 previous-columns))))
316 (else
317 ;; this is a new line, and there is still room is this
318 ;; column => go on filling it
319 (fill-columns (cdr lines)
320 (cdr sub-sections)
321 current-column-index
322 (+ current-column-height height)
323 (cons line current-column-lines)
324 previous-columns))))))))
326 #(define-markup-list-command (table-of-contents layout props) ()
327 #:properties ((section-markup 'tocActMarkup)
328 (column-number 2)
329 (inter-column-padding 2)
330 (line-width #f)
331 (baseline-skip 0.3))
332 (let collect-by-section ((toc-items (toc-items))
333 (previous-lines '())
334 (current-section-title '())
335 (current-section-items '()))
336 (if (null? toc-items)
337 ;; finalize last section and return the markup list
338 (cons (interpret-markup layout props
339 (ly:output-def-lookup layout 'tocTitleMarkup))
340 (reverse!
341 (cons (interpret-markup
342 layout props
343 (markup #:toc-section current-section-title
344 (reverse! current-section-items)))
345 previous-lines)))
346 ;; go on collecting toc items
347 (let* ((toc-item (car toc-items))
348 (toc-markup (cadr toc-item)))
349 (if (eqv? toc-markup section-markup)
350 ;; a new section => end the previous one
351 (collect-by-section
352 (cdr toc-items)
353 (if (and (null? current-section-title)
354 (null? current-section-items))
355 previous-lines
356 (cons (interpret-markup
357 layout props
358 (markup #:toc-section current-section-title
359 (reverse! current-section-items)))
360 previous-lines))
361 toc-item
362 '())
363 ;; a new item for current section
364 (collect-by-section
365 (cdr toc-items)
366 previous-lines
367 current-section-title
368 (cons toc-item current-section-items)))))))