]> git.donarmstrong.com Git - lilypond.git/blob - scm/page.scm
typo
[lilypond.git] / scm / page.scm
1 ;;
2 ;; page.scm -- implement Page stuff.
3 ;;
4 ;; source file of the GNU LilyPond music typesetter
5 ;;
6 ;; (c) 2006 Han-Wen Nienhuys <hanwen@xs4all.nl>
7 ;;
8
9 (define-module (scm page)
10
11   #:export (make-page
12             page-property
13             page-set-property!
14             page-prev
15             page-printable-height
16             layout->page-init
17             page-lines
18             page-force 
19             page-penalty
20             page-configuration
21             page-lines
22             page-page-number
23             page-system-numbers
24             page-stencil
25             page-free-height
26             page? 
27             ))
28
29 (use-modules (lily)
30              (scm paper-system)
31              (srfi srfi-1))
32
33
34 (define (annotate? layout)
35   (eq? #t (ly:output-def-lookup layout 'annotate-spacing)))
36
37
38 (define page-module (current-module))
39
40 (define (make-page paper-book  . args)
41   (let*
42       ((p (apply ly:make-prob (append
43                                (list 'page (layout->page-init (ly:paper-book-paper paper-book))
44                                      'paper-book paper-book)
45                                args))))
46
47     (page-set-property! p 'head-stencil (page-header p))
48     (page-set-property! p 'foot-stencil (page-footer p))
49     
50     p))
51         
52 (define page-property ly:prob-property)
53 (define page-set-property! ly:prob-set-property!)
54 (define (page-property? page sym)
55   (eq? #t (page-property page sym)))
56 (define (page? x)  (ly:prob-type? x 'page))
57
58
59 ;; define accessors. 
60 (for-each
61  (lambda (j)
62    (module-define!
63     page-module
64     (string->symbol (format "page-~a" j))
65     (lambda (pg)
66       (page-property pg j))))
67  
68  '(page-number prev lines force penalty lines))
69
70 (define (page-system-numbers page)
71   (map (lambda (ps) (ly:prob-property ps 'number))
72        (page-lines page)))
73
74 (define (page-translate-systems page)
75   (for-each
76
77    (lambda (sys-off)
78      (let*
79          ((sys (car sys-off))
80           (off (cadr sys-off)))
81
82        (if (not (number? (ly:prob-property sys 'Y-offset)))
83            (ly:prob-set-property! sys 'Y-offset off))))
84    
85    (zip (page-property page 'lines)
86         (page-property page 'configuration))))
87
88 (define (annotate-page layout stencil)
89   (let ((top-margin (ly:output-def-lookup layout 'top-margin))
90         (paper-height (ly:output-def-lookup layout 'paper-height))
91         (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
92         (add-stencil (lambda (y)
93                        (set! stencil
94                              (ly:stencil-add stencil
95                                              (ly:stencil-translate-axis y 6 X))))))
96     (add-stencil
97      (ly:stencil-translate-axis 
98       (annotate-y-interval layout "paper-height"
99                            (cons (- paper-height) 0)
100                            #t)
101       1 X))
102     (add-stencil
103      (ly:stencil-translate-axis 
104       (annotate-y-interval layout "top-margin"
105                            (cons (- top-margin) 0)
106                            #t)
107       2 X))
108     (add-stencil
109      (ly:stencil-translate-axis 
110       (annotate-y-interval layout "bottom-margin"
111                            (cons (- paper-height) (- bottom-margin paper-height))
112                            #t)
113       2 X))
114     stencil))
115
116 (define (annotate-space-left page)
117   (let*
118       ((paper-book (page-property page 'paper-book))
119        (layout (ly:paper-book-paper paper-book))
120        (arrow (annotate-y-interval layout
121                                    "space left"
122                                    (cons (- 0.0
123                                             (page-property page 'bottom-edge)
124                                             (let ((foot (page-property page 'foot-stencil)))
125                                               (if (and (ly:stencil? foot)
126                                                        (not (ly:stencil-empty? foot)))
127                                                   (car (ly:stencil-extent foot Y))
128                                                   0.0)))
129                                          (page-property page  'bottom-system-edge))
130                                    #t)))
131
132     (set! arrow (ly:stencil-translate-axis arrow 8 X))
133
134     arrow))
135
136 \f
137
138
139 (define (page-headfoot layout scopes number
140                        sym separation-symbol dir last?)
141   
142   "Create a stencil including separating space."
143
144   (let* ((header-proc (ly:output-def-lookup layout sym))
145          (sep (ly:output-def-lookup layout separation-symbol))
146          (stencil (ly:make-stencil "" '(0 . 0) '(0 . 0)))
147          (head-stencil
148           (if (procedure? header-proc)
149               (header-proc layout scopes number last?)
150               #f))
151          )
152     
153     (if (and (number? sep)
154              (ly:stencil? head-stencil)
155              (not (ly:stencil-empty? head-stencil)))
156
157         (begin
158           (set! head-stencil
159                 (ly:stencil-combine-at-edge
160                  stencil Y dir head-stencil
161                  sep 0.0))
162
163           
164           ;; add arrow markers 
165           (if (or (annotate? layout)
166                   (ly:output-def-lookup layout 'annotate-headers #f)) 
167               (set! head-stencil
168                     (ly:stencil-add
169                      (ly:stencil-translate-axis
170                       (annotate-y-interval layout 
171                                            (symbol->string separation-symbol)
172                                            (cons (min 0 (* dir sep))
173                                                  (max 0 (* dir sep)))
174                                            #t)
175                       (/ (ly:output-def-lookup layout 'line-width) 2)
176                       X)
177                      (if (= dir UP)
178                          (ly:stencil-translate-axis
179                           (annotate-y-interval layout
180                                               "page-top-space"
181                                               (cons
182                                                (- (min 0 (* dir sep))
183                                                   (ly:output-def-lookup layout 'page-top-space))
184                                                (min 0 (* dir sep)))
185                                               #t)
186                           (+ 7 (interval-center (ly:stencil-extent head-stencil X))) X)
187                          empty-stencil
188                          )
189                      head-stencil
190                      ))
191               )))
192
193     head-stencil))
194
195 (define (page-header-or-footer page dir)
196     (let*
197       ((paper-book (page-property page 'paper-book))
198        (layout (ly:paper-book-paper paper-book))
199        (scopes (ly:paper-book-scopes paper-book))
200        (number (page-page-number page))
201        (last? (page-property page 'is-last))
202        )
203        
204       (page-headfoot layout scopes number
205                 (if (= dir UP)
206                     'make-header
207                     'make-footer)
208                 (if (= dir UP)
209                     'head-separation
210                     'foot-separation)
211                 dir last?)))
212
213 (define (page-header page)
214   (page-header-or-footer page UP))
215
216 (define (page-footer page)
217   (page-header-or-footer page DOWN))
218
219 (define (layout->page-init layout)
220   "Alist of settings for page layout"
221   (let*
222       ((paper-height (ly:output-def-lookup layout 'paper-height))
223        (paper-width (ly:output-def-lookup layout 'paper-width))
224        (lmargin (ly:output-def-lookup layout 'left-margin #f))
225        (left-margin (if lmargin
226                        lmargin
227                        (/ (- paper-width
228                              (ly:output-def-lookup layout 'line-width)) 2)))
229        (bottom-edge (- paper-height
230                        (ly:output-def-lookup layout 'bottom-margin)) )
231        (top-margin (ly:output-def-lookup layout 'top-margin))
232        )
233     
234     `((paper-height . ,paper-height)
235       (paper-width . ,paper-width)
236       (left-margin . ,left-margin)
237       (top-margin . ,top-margin)
238       (bottom-edge . ,bottom-edge)
239       )))
240
241 (define (make-page-stencil page)
242   "Construct a stencil representing the page from PAGE."
243   
244
245   (page-translate-systems page)
246   (let*
247       ((paper-book (page-property page 'paper-book))
248        (prop (lambda (sym) (page-property page sym)))
249        (layout (ly:paper-book-paper paper-book))
250        (scopes (ly:paper-book-scopes paper-book))
251        (lines (page-lines page))
252        (number (page-page-number page))
253
254        ;; TODO: naming paper-height/paper-width not analogous to TeX.
255        
256        (system-xoffset (ly:output-def-lookup layout 'horizontal-shift 0.0))
257        (system-separator-markup (ly:output-def-lookup layout 'systemSeparatorMarkup))
258        (system-separator-stencil (if (markup? system-separator-markup)
259                                      (interpret-markup layout
260                                                        (layout-extract-page-properties layout)
261                                                        system-separator-markup)
262                                      #f))
263        
264        (head-height (if (ly:stencil? (prop 'head-stencil))
265                         (interval-length (ly:stencil-extent (prop 'head-stencil) Y))
266                         0.0))
267
268        (page-stencil (ly:make-stencil '()))
269
270        (last-system #f)
271        (last-y 0.0)
272        (add-to-page (lambda (stencil x y)
273                       (set! page-stencil
274                             (ly:stencil-add page-stencil
275                                             (ly:stencil-translate stencil
276                                                                   (cons
277                                                                    (+ system-xoffset x)
278                                                                    (- 0 head-height y (prop 'top-margin)))
279                                                                   
280                                                                   )))))
281        (add-system
282         (lambda (system)
283           (let* ((stencil (paper-system-stencil system))
284                  (y (ly:prob-property system 'Y-offset))
285                  (is-title (paper-system-title?
286                             system)))
287             (add-to-page stencil
288                          (ly:prob-property system 'X-offset 0.0)
289                          y)
290             (if (and (ly:stencil? system-separator-stencil)
291                      last-system
292                      (not (paper-system-title? system))
293                      (not (paper-system-title? last-system)))
294                 (add-to-page
295                  system-separator-stencil
296                  0
297                  (average (- last-y
298                              (car (paper-system-staff-extents last-system)))
299                           (- y
300                              (cdr (paper-system-staff-extents system))))))
301             (set! last-system system)
302             (set! last-y y))))
303        (head (prop 'head-stencil))
304        (foot (prop 'foot-stencil))
305        )
306
307     (if (and
308          (or (annotate? layout)
309              (ly:output-def-lookup layout 'annotate-systems #f))
310          (pair? lines))
311
312         (begin
313           (for-each (lambda (sys next-sys)
314                       (paper-system-annotate sys next-sys layout))
315                     lines
316                     (append (cdr lines) (list #f)))
317           (paper-system-annotate-last (car (last-pair lines)) layout)))
318
319     (if (and
320          (ly:stencil? head)
321          (not (ly:stencil-empty? head)))
322         
323         (set! page-stencil (ly:stencil-add page-stencil 
324                                            (ly:stencil-translate-axis head
325                                                                       (- 0 head-height (prop 'top-margin)) Y))))
326                                            
327     (map add-system lines)
328
329
330     (ly:prob-set-property! page 'bottom-system-edge
331                            (car (ly:stencil-extent page-stencil Y)))
332     (ly:prob-set-property! page 'space-left
333                            (+ (prop 'bottom-edge)
334                               (prop 'bottom-system-edge)
335                               (if (and (ly:stencil? foot)
336                                        (not (ly:stencil-empty? foot)))
337                                   (car (ly:stencil-extent foot Y))
338                                   0.0)))
339
340     (if (annotate? layout)
341         (set! page-stencil
342               (ly:stencil-add page-stencil
343                               (annotate-space-left page))))
344     
345     (if (and (ly:stencil? foot)
346              (not (ly:stencil-empty? foot)))
347         (set! page-stencil
348               (ly:stencil-add
349                page-stencil
350                (ly:stencil-translate
351                 foot
352                 (cons 0
353                       (+ (- (prop 'bottom-edge))
354                          (- (car (ly:stencil-extent foot Y)))))))))
355
356     (set! page-stencil
357           (ly:stencil-translate page-stencil (cons (prop 'left-margin) 0)))
358
359     ;; annotation.
360     (if (or (annotate? layout)
361             (ly:output-def-lookup layout 'annotate-page #f))
362         (set! page-stencil (annotate-page layout page-stencil)))
363
364
365     page-stencil))
366               
367
368 (define-public (page-stencil page)
369   (if (not (ly:stencil? (page-property page 'stencil)))
370
371       ;; todo: make tweakable.
372       ;; via property + callbacks.
373       
374       (page-set-property! page 'stencil (make-page-stencil page)))
375   (page-property page 'stencil))
376
377 (define (calc-printable-height page)
378   "Printable area for music and titles; matches default-page-make-stencil."
379   (let*
380       ((paper-book (page-property page 'paper-book))
381        (layout (ly:paper-book-paper paper-book))
382        (h (- (ly:output-def-lookup layout 'paper-height)
383                (ly:output-def-lookup layout 'top-margin)
384                (ly:output-def-lookup layout 'bottom-margin)))
385        
386        (head (page-property page 'head-stencil))
387        (foot (page-property page 'foot-stencil))
388        (available
389         (- h (if (ly:stencil? head)
390                  (interval-length (ly:stencil-extent head Y))
391                  0)
392            (if (ly:stencil? foot)
393                (interval-length (ly:stencil-extent foot Y))
394                0))))
395     
396     ;; (display (list "\n available" available head foot))
397     available))
398
399 (define (page-printable-height page)
400   (if (not (number? (page-property page 'printable-height)))
401       (page-set-property! page 'printable-height (calc-printable-height page)))
402   
403   (page-property page 'printable-height))
404