Markup command indexing: don't use internal function names.
[lilypond.git] / scm / layout-page-layout.scm
blob1686d9613a11d7ac097e484f797f462282feb372
1 ;;;; layout-page-layout.scm -- page breaking and page layout
2 ;;;;
3 ;;;;  source file of the GNU LilyPond music typesetter
4 ;;;;
5 ;;;; (c) 2004--2007 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;;          Han-Wen Nienhuys <hanwen@xs4all.nl>
8 (define-module (scm layout-page-layout)
9   #:use-module (srfi srfi-1)
10   #:use-module (oop goops describe)
11   #:use-module (oop goops)
12   #:use-module (scm paper-system)
13   #:use-module (scm page)
14   #:use-module (scm layout-page-dump)
15   #:use-module (lily)
16   #:export (post-process-pages optimal-page-breaks make-page-from-systems
17             page-breaking-wrapper
18             stretchable-line? ; delete me
19             ;; utilities for writing custom page breaking functions
20             line-height line-next-space line-next-padding
21             line-minimum-distance line-ideal-distance
22             first-line-position
23             line-ideal-relative-position line-minimum-relative-position
24             page-maximum-space-to-fill page-maximum-space-left space-systems))
26 ; this is for 2-pass spacing. Delete me.
27 (define (stretchable-line? line)
28   "Say whether a system can be stretched."
29   (not (or (ly:prob-property? line 'is-title)
30            (let ((system-extent (paper-system-staff-extents line)))
31             (= (interval-start system-extent)
32                (interval-end   system-extent))))))
34 (define (stretch-and-draw-page paper-book systems page-number ragged last)
35   (define (max-stretch sys)
36     (if (ly:grob? sys)
37         (ly:grob-property sys 'max-stretch)
38         0.0))
40   (define (stretchable? sys)
41     (and (ly:grob? sys)
42          (> (max-stretch sys) 0.0)))
44   (define (height-estimate sys)
45     (interval-length
46      (if (ly:grob? sys)
47          (ly:grob-property sys 'pure-Y-extent)
48          (paper-system-extent sys Y))))
50   (define (print-system sys)
51     (if (ly:grob? sys)
52         (ly:system-print sys)
53         sys))
55   (define (set-line-stretch! sorted-lines rest-height space-left)
56     (if (not (null? sorted-lines))
57         (let* ((line (first sorted-lines))
58                (height (height-estimate line))
59                (stretch (min (max-stretch line)
60                              (if (positive? rest-height)
61                                  (/ (* height space-left) rest-height)
62                                    0.0))))
63           (if (stretchable? line)
64               (ly:system-stretch line stretch))
65           (set-line-stretch! (cdr sorted-lines)
66                              (if (stretchable? line)
67                                  (- rest-height height)
68                                  rest-height)
69                              (- space-left stretch)))))
71   (define (total-padding systems)
72     (let ((layout (ly:paper-book-paper paper-book)))
73       (if (or (null? systems)
74               (null? (cdr systems)))
75           0.0
76           (+ (line-next-padding (car systems) (cadr systems) layout)
77              (total-padding (cdr systems))))))
79   (let* ((page (make-page paper-book
80                           'page-number page-number
81                           'is-last last))
82          (paper (ly:paper-book-paper paper-book))
83          (height (page-printable-height page))
84          ; there is a certain amount of impreciseness going on here:
85          ; the system heights are estimated, we aren't using skyline distances
86          ; yet, etc. If we overstretch because of underestimation, the result
87          ; is very bad. So we stick in some extra space, just to be sure.
88          (buffer (/ height 10.0))
89          (total-system-height (+ (apply + (map height-estimate systems))
90                                  (total-padding systems)))
91          (height-left (- height total-system-height buffer)))
93     (if (and
94          (not ragged)
95          (> height-left 0))
96         (set-line-stretch! (sort systems
97                                  (lambda (s1 s2)
98                                    (< (height-estimate s1)
99                                       (height-estimate s2))))
100                            (apply + (map height-estimate
101                                          (filter stretchable? systems)))
102                            height-left))
104     (let ((lines (map print-system systems)))
105       (page-set-property! page 'lines lines)
106       (page-set-property!
107        page 'configuration 
108        (if (null? lines)
109            (list)
110            (let* ((paper (ly:paper-book-paper paper-book))
111                   (max-space-to-fill (page-maximum-space-to-fill page lines paper))
112                   (space-to-fill (if (ly:output-def-lookup
113                                       paper 'page-limit-inter-system-space #f)
114                                      (min max-space-to-fill
115                                           (* (ly:output-def-lookup
116                                               paper 'page-limit-inter-system-space-factor 1.4)
117                                              (- max-space-to-fill
118                                                 (or (page-ideal-space-left page) 0))))
119                                      max-space-to-fill))
120                   (spacing (space-systems space-to-fill lines ragged paper #f)))
121              (if (and (> (length lines) 1)
122                       (or (not (car spacing)) (inf? (car spacing))))
123                  (begin
124                    (ly:warning (_ "Can't fit systems on page -- ignoring between-system-padding"))
125                    (cdr (space-systems space-to-fill lines ragged paper #t)))
126                  (cdr spacing)))))
127       page)))
129 (define (page-breaking-wrapper paper-book)
130   "Compute line and page breaks by calling the page-breaking paper variable,
131   then performs the post process function using the page-post-process paper
132   variable. Finally, return the pages."
133   (let* ((paper (ly:paper-book-paper paper-book))
134          (pages ((ly:output-def-lookup paper 'page-breaking) paper-book)))
135     ((ly:output-def-lookup paper 'page-post-process) paper pages)
136     pages))
138 (define (post-process-pages layout pages)
139   "If the write-page-layout paper variable is true, dumps page breaks
140   and tweaks."
142   (let*
143       ((parser (ly:modules-lookup (list (current-module)) 'parser))
144        (output-name (ly:parser-output-name parser)) 
145        )
147     (if (ly:output-def-lookup layout 'write-page-layout #f)
148         (write-page-breaks pages output-name))))
151 ;;; Utilities for computing line distances and positions
153 (define (line-extent line)
154   "Return the extent of the line (its lowest and highest Y-coordinates)."
155   (paper-system-extent line Y))
157 (define (line-height line)
158   "Return the system height, that is the length of its vertical extent."
159   (interval-length (line-extent line)))
161 (define (line-next-space line next-line layout)
162   "Return space to use between `line' and `next-line'.
163   `next-line' can be #f, meaning that `line' is the last line."
164   (let* ((title (paper-system-title? line))
165          (next-title (and next-line (paper-system-title? next-line))))
166     (ly:prob-property
167      line 'next-space
168      (ly:output-def-lookup layout 
169                            (cond ((and title next-title) 'between-title-space)
170                                  (title 'after-title-space)
171                                  (next-title 'before-title-space)
172                                  (else 'between-system-space))))))
174 (define (line-next-padding line next-line layout)
175   "Return padding to use between `line' and `next-line'.
176   `next-line' can be #f, meaning that `line' is the last line."
177   (let ((default (ly:output-def-lookup layout 'between-system-padding)))
178     (if (ly:grob? line)
179         (let* ((details (ly:grob-property line 'line-break-system-details))
180                (padding (assq 'next-padding details)))
181           (if padding
182               (cdr padding)
183               default))
184         (ly:prob-property line 'next-padding default))))
187 (define (line-minimum-distance line next-line layout ignore-padding)
188   "Minimum distance between `line' reference position and `next-line'
189  reference position. If next-line is #f, return #f."
190   (and next-line
191        (let ((padding (if ignore-padding
192                           0
193                           (line-next-padding line next-line layout))))
194          (if (or (ly:grob? line) (ly:grob? next-line))
195              (max 0 (+ padding
196                        (- (interval-start (line-extent line))
197                           (interval-end (line-extent next-line)))))
198              (max 0 (+ padding
199                        (ly:paper-system-minimum-distance line next-line)))))))
201 (define (line-ideal-distance line next-line layout ignore-padding)
202   "Ideal distance between `line' reference position and `next-line'
203  reference position. If next-line is #f, return #f."
204   (and next-line
205        (max 0
206             (+ (- (+ (interval-end (paper-system-staff-extents next-line))
207                      (if ignore-padding 0 (line-next-padding line next-line layout)))
208                   (interval-start (paper-system-staff-extents line)))
209                (line-next-space line next-line layout)))))
211 (define (first-line-position line layout)
212   "Position of the first line on page"
213   (max (+ (if (ly:prob-property? line 'is-title)
214               ;; do not use page-top-space if first line is a title
215               0.0
216             (ly:output-def-lookup layout 'page-top-space))
217           (interval-end (paper-system-staff-extents line)))
218        (interval-end (line-extent line))))
220 (define (line-ideal-relative-position line prev-line layout ignore-padding)
221   "Return ideal position of `line', relative to `prev-line' position.
222   `prev-line' can be #f, meaning that `line' is the first line."
223   (if (not prev-line)
224       ;; first line on page
225       (first-line-position line layout)
226       ;; not the first line on page
227       (max (line-minimum-distance prev-line line layout ignore-padding)
228            (line-ideal-distance prev-line line layout ignore-padding))))
230 (define (line-minimum-relative-position line prev-line layout ignore-padding)
231   "Return position of `line', relative to `prev-line' position.
232   `prev-line' can be #f, meaning that `line' is the first line."
233   (if (not prev-line)
234       ;; first line on page
235       (first-line-position line layout)
236       ;; not the first line on page
237       (line-minimum-distance prev-line line layout ignore-padding)))
239 (define (line-position-on-page line prev-line prev-position page relative-positionning-fn)
240   "If `line' fits on `page' after `prev-line', which position on page is
241   `prev-position', then return the line's postion on page, otherwise #f.
242   `prev-line' can be #f, meaning that `line' is the first line."
243   (let* ((layout (ly:paper-book-paper (page-property page 'paper-book)))
244          (position (+ (relative-positionning-fn line prev-line layout #f)
245                       (if prev-line prev-position 0.0)))
246          (bottom-position (- position
247                              (interval-start (line-extent line)))))
248     position))
250 (define (page-maximum-space-to-fill page lines paper)
251   "Return the space between the first line top position and the last line
252   bottom position. This constitutes the maximum space to fill on `page'
253   with `lines'."
254   (let ((last-line (car (last-pair lines))))
255     (- (page-printable-height page)
256        (first-line-position (first lines) paper)
257        (ly:prob-property last-line
258                          'bottom-space 0.0)
259        (- (interval-start (line-extent last-line))))))
261 (define (page-space-left page relative-positionning-fn)
262   (let ((paper (ly:paper-book-paper (page-property page 'paper-book))))
263     (let bottom-position ((lines (page-property page 'lines))
264                           (prev-line #f)
265                           (prev-position #f))
266       (if (null? lines)
267           (page-printable-height page)
268           (let* ((line (first lines))
269                  (position (line-position-on-page
270                             line prev-line prev-position page relative-positionning-fn)))
271             (if (null? (cdr lines))
272                 (max 0
273                      (- (page-printable-height page)
274                         (- position
275                            (interval-start (line-extent line)))))
276                 (bottom-position (cdr lines) line position)))))))
278 (define (page-maximum-space-left page)
279   (page-space-left page line-minimum-relative-position))
281 (define (page-ideal-space-left page)
282   (page-space-left page line-ideal-relative-position))
285 ;;; Utilities for distributing systems on a page
288 (define (space-systems space-to-fill lines ragged paper ignore-padding)
289   "Compute lines positions on page: return force and line positions as a pair.
290  force is #f if lines do not fit on page."
291   (let* ((empty-stencil (ly:make-stencil '() '(0 . 0) '(0 . 0)))
292          (empty-prob (ly:make-prob 'paper-system (list `(stencil . ,empty-stencil))))
293          (cdr-lines (append (cdr lines)
294                             (if (<= (length lines) 1)
295                                 (list empty-prob)
296                                 '())))
297          (springs (map (lambda (prev-line line)
298                          (list (line-ideal-distance prev-line line paper ignore-padding)
299                                (line-next-space prev-line line paper)))
300                        lines
301                        cdr-lines))
302          (rods (map (let ((i -1))
303                       (lambda (prev-line line)
304                         (set! i (1+ i))
305                         (list i (1+ i)
306                               (line-minimum-distance prev-line line paper ignore-padding))))
307                        lines
308                        cdr-lines))
309          (space-result
310           (ly:solve-spring-rod-problem springs rods space-to-fill ragged)))
311     (cons (car space-result)
312           (map (let ((topskip (first-line-position (first lines) paper)))
313                  (lambda (y)
314                    (+ y topskip)))
315                (cdr space-result)))))
319 ;;; Page breaking function
322 ;; Optimal distribution of
323 ;; lines over pages; line breaks are a given.
325 ;; TODO:
327 ;; - density scoring
328 ;; - separate function for word-wrap style breaking?
329 ;; - ragged-bottom? ragged-last-bottom?
331 (define (get-path node done)
332   "Follow NODE.PREV, and return as an ascending list of pages. DONE
333 is what have collected so far, and has ascending page numbers."
334   (if (page? node)
335       (get-path (page-prev node) (cons node done))
336       done))
338 (define (combine-penalties force user best-paths
339                            inter-system-space force-equalization-factor)
340   (let* ((prev-force (if (null? best-paths)
341                          0.0
342                          (page-force (car best-paths))))
343          (prev-penalty (if (null? best-paths)
344                            0.0
345                            (page-penalty (car best-paths))))
346          (relative-force (/ force inter-system-space))
347          (abs-relative-force (abs relative-force)))
348     (+ (* abs-relative-force (+ abs-relative-force 1))
349        prev-penalty
350        (* force-equalization-factor (/ (abs (- prev-force force))
351                                        inter-system-space))
352        user)))
354 (define (walk-paths done-lines best-paths current-lines last current-best
355                     paper-book page-alist)
356   "Return the best optimal-page-break-node that contains
357 CURRENT-LINES. DONE-LINES.reversed ++ CURRENT-LINES is a consecutive
358 ascending range of lines, and BEST-PATHS contains the optimal breaks
359 corresponding to DONE-LINES.
361 CURRENT-BEST is the best result sofar, or #f."
362   (let* ((paper (ly:paper-book-paper paper-book))
363          (this-page (make-page
364                      paper-book
365                      'is-last last
366                      'page-number (if (null? best-paths)
367                                       (ly:output-def-lookup paper 'first-page-number)
368                                       (1+ (page-page-number (first best-paths))))))
369          (ragged-all (eq? #t (ly:output-def-lookup paper 'ragged-bottom)))
370          (ragged-last (eq? #t (ly:output-def-lookup paper 'ragged-last-bottom)))
371          (ragged (or ragged-all (and ragged-last last)))
372          (space-to-fill (page-maximum-space-to-fill this-page current-lines paper))
373          (vertical-spacing (space-systems space-to-fill current-lines ragged paper #f))
374          (satisfied-constraints (car vertical-spacing))
375          (force (if satisfied-constraints
376                     (if (and last ragged-last)
377                         0.0
378                         satisfied-constraints)
379                     10000))
380          (positions (cdr vertical-spacing))
381          (get-break-penalty (lambda (sys)
382                               (ly:prob-property sys 'penalty 0.0)))
383          (user-nobreak-penalties (- (apply + (filter negative?
384                                                      (map get-break-penalty
385                                                           (cdr current-lines))))))
386          (user-penalty (+ (max (get-break-penalty (car current-lines)) 0.0)
387                           user-nobreak-penalties))
388          (total-penalty (combine-penalties
389                          force user-penalty best-paths
390                          (ly:output-def-lookup paper 'between-system-space)
391                          (ly:output-def-lookup paper 'verticalequalizationfactor 0.3)))
392          (new-best (if (or (not current-best)
393                            (and satisfied-constraints
394                                 (< total-penalty (page-penalty current-best))))
395                        (begin
396                          (map (lambda (x)
397                                 (page-set-property! this-page
398                                                     (car x)
399                                                     (cdr x)))
400                               (list (cons 'prev (if (null? best-paths)
401                                                     #f
402                                                     (car best-paths)))
403                                     (cons 'lines current-lines)
404                                     (cons 'force force)
405                                     (cons 'configuration positions)
406                                     (cons 'penalty total-penalty)))
407                          this-page)
408                        current-best)))
409     (if #f ;; debug
410         (display
411          (list
412           "\nuser pen " user-penalty
413           "\nsatisfied-constraints" satisfied-constraints
414           "\nlast? " last "ragged?" ragged
415           "\nis-better " is-better " total-penalty " total-penalty "\n"
416           "\nconfig " positions
417           "\nforce " force
418           "\nlines: " current-lines "\n")))
419     (if #f ; debug
420         (display (list "\nnew-best is " (page-lines new-best)
421                        "\ncontinuation of "
422                        (if (null? best-paths)
423                            "start"
424                            (page-lines (car best-paths))))))
425     (if (and (pair? done-lines)
426              ;; if this page is too full, adding another line won't help
427              satisfied-constraints)
428         (walk-paths (cdr done-lines) (cdr best-paths)
429                     (cons (car done-lines) current-lines)
430                     last new-best
431                     paper-book page-alist)
432         new-best)))
434 (define (walk-lines done best-paths todo paper-book page-alist)
435   "Return the best page breaking as a single
436 page node for optimally breaking TODO ++
437 DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
438 DONE."
439   (if (null? todo)
440       (car best-paths)
441       (let* ((this-line (car todo))
442              (last (null? (cdr todo)))
443              (next (walk-paths done best-paths (list this-line) last #f
444                                paper-book page-alist)))
445         (walk-lines (cons this-line done)
446                     (cons next best-paths)
447                     (cdr todo)
448                     paper-book
449                     page-alist))))
451 (define-public (optimal-page-breaks paper-book)
452   "Return pages as a list starting with 1st page. Each page is a 'page Prob."
453   (let* ((paper (ly:paper-book-paper paper-book))
454          (lines (ly:paper-book-systems paper-book))
455          (page-alist (layout->page-init paper)) 
456          (force-equalization-factor (ly:output-def-lookup
457                                      paper 'verticalequalizationfactor 0.3)))
458     (ly:message (_ "Calculating page breaks..."))
459     (let* ((best-break-node (walk-lines '() '() lines paper-book page-alist))
460            (break-nodes (get-path best-break-node '())))
461       (page-set-property! (car (last-pair break-nodes)) 'is-last #t)
462       (if #f; (ly:get-option 'verbose)
463           (begin
464             (display (list
465                       "\nbreaks: " (map (lambda (node)
466                                           (ly:prob-property (car (page-lines node))
467                                                             'number))
468                                         break-nodes)
469                       "\nsystems " (map page-lines break-nodes)
470                       "\npenalties " (map page-penalty break-nodes)
471                       "\nconfigs " (map page-configuration break-nodes)))))
472       ;; construct page stencils.
473       (for-each page-stencil break-nodes)
474       break-nodes)))