]> git.donarmstrong.com Git - lilypond.git/blob - scm/layout-page-layout.scm
Third phase of tutorial rewrite.
[lilypond.git] / scm / layout-page-layout.scm
1 ;;;; layout-page-layout.scm -- page breaking and page layout
2 ;;;;
3 ;;;;  source file of the GNU LilyPond music typesetter
4 ;;;;
5 ;;;; (c) 2004--2006 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;;          Han-Wen Nienhuys <hanwen@xs4all.nl>
7
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             ;; utilities for writing custom page breaking functions
19             line-height line-next-space line-next-padding
20             line-minimum-distance line-ideal-distance
21             first-line-position
22             line-ideal-relative-position line-minimum-relative-position
23             line-minimum-position-on-page stretchable-line?
24             page-maximum-space-to-fill page-maximum-space-left space-systems))
25
26 (define (page-breaking-wrapper paper-book)
27   "Compute line and page breaks by calling the page-breaking paper variable,
28   then performs the post process function using the page-post-process paper
29   variable. Finally, return the pages."
30   (let* ((paper (ly:paper-book-paper paper-book))
31          (pages ((ly:output-def-lookup paper 'page-breaking) paper-book)))
32     ((ly:output-def-lookup paper 'page-post-process) paper pages)
33     pages))
34
35 (define (post-process-pages layout pages)
36   "If the write-page-layout paper variable is true, dumps page breaks
37   and tweaks."
38
39   (let*
40       ((parser (ly:modules-lookup (list (current-module)) 'parser))
41        (output-name (ly:parser-output-name parser)) 
42        )
43
44     (if (ly:output-def-lookup layout 'write-page-layout #f)
45         (write-page-breaks pages output-name))))
46
47 ;;;
48 ;;; Utilities for computing line distances and positions
49 ;;;
50 (define (line-height line)
51   "Return the system height, that is the length of its vertical extent."
52   (interval-length (paper-system-extent line Y)))
53
54 (define (line-next-space line next-line layout)
55   "Return space to use between `line' and `next-line'.
56   `next-line' can be #f, meaning that `line' is the last line."
57   (let* ((title (paper-system-title? line))
58          (next-title (and next-line (paper-system-title? next-line))))
59     (cond ((and title next-title)
60            (ly:output-def-lookup layout 'between-title-space))
61           (title
62            (ly:output-def-lookup layout 'after-title-space))
63           (next-title
64            (ly:output-def-lookup layout 'before-title-space))
65           (else
66            (ly:prob-property
67             line 'next-space
68             (ly:output-def-lookup layout 'between-system-space))))))
69
70 (define (line-next-padding line next-line layout)
71   "Return padding to use between `line' and `next-line'.
72   `next-line' can be #f, meaning that `line' is the last line."
73   (ly:prob-property
74    line 'next-padding
75    (ly:output-def-lookup layout 'between-system-padding)))
76
77
78 (define (line-minimum-distance line next-line layout ignore-padding)
79   "Minimum distance between `line' reference position and `next-line'
80  reference position. If next-line is #f, return #f."
81   (and next-line
82        (let ((non-skyline-distance (- (interval-end (paper-system-extent next-line Y))
83                                       (interval-start (paper-system-extent line Y)))))
84          (max 0 (+ (ly:prob-property next-line 'skyline-distance non-skyline-distance)
85                    (if ignore-padding 0 (line-next-padding line next-line layout)))))))
86
87 (define (line-ideal-distance line next-line layout ignore-padding)
88   "Ideal distance between `line' reference position and `next-line'
89  reference position. If next-line is #f, return #f."
90   (and next-line
91        (+ (max 0 (- (+ (interval-end (paper-system-staff-extents next-line))
92                        (if ignore-padding 0 (line-next-padding line next-line layout)))
93                     (interval-start (paper-system-staff-extents line))))
94           (line-next-space line next-line layout))))
95
96 (define (first-line-position line layout)
97   "Position of the first line on page"
98   (max (+ (if (ly:prob-property? line 'is-title)
99               ;; do not use page-top-space if first line is a title
100               0.0
101             (ly:output-def-lookup layout 'page-top-space))
102           (interval-end (paper-system-staff-extents line)))
103        (interval-end (paper-system-extent line Y))))
104
105 (define (line-ideal-relative-position line prev-line layout ignore-padding)
106   "Return ideal position of `line', relative to `prev-line' position.
107   `prev-line' can be #f, meaning that `line' is the first line."
108   (if (not prev-line)
109       ;; first line on page
110       (first-line-position line layout)
111       ;; not the first line on page
112       (max (line-minimum-distance prev-line line layout ignore-padding)
113            (line-ideal-distance prev-line line layout ignore-padding))))
114
115 (define (line-minimum-relative-position line prev-line layout ignore-padding)
116   "Return position of `line', relative to `prev-line' position.
117   `prev-line' can be #f, meaning that `line' is the first line."
118   (if (not prev-line)
119       ;; first line on page
120       (first-line-position line layout)
121       ;; not the first line on page
122       (line-minimum-distance prev-line line layout ignore-padding)))
123
124 (define (line-minimum-position-on-page line prev-line prev-position page)
125   "If `line' fits on `page' after `prev-line', which position on page is
126   `prev-position', then return the line's postion on page, otherwise #f.
127   `prev-line' can be #f, meaning that `line' is the first line."
128   (let* ((layout (ly:paper-book-paper (page-property page 'paper-book)))
129          (position (+ (line-minimum-relative-position line prev-line layout #f)
130                       (if prev-line prev-position 0.0)))
131          (bottom-position (- position
132                              (interval-start (paper-system-extent line Y)))))
133     (and (or (not prev-line)
134              (< bottom-position (page-printable-height page)))
135          position)))
136
137 (define (stretchable-line? line)
138   "Say whether a system can be stretched."
139   (not (or (ly:prob-property? line 'is-title)
140            (let ((system-extent (paper-system-staff-extents line)))
141              (= (interval-start system-extent)
142                 (interval-end   system-extent))))))
143
144 (define (page-maximum-space-to-fill page lines paper)
145   "Return the space between the first line top position and the last line
146   bottom position. This constitutes the maximum space to fill on `page'
147   with `lines'."
148   (let ((last-line (car (last-pair lines))))
149     (- (page-printable-height page)
150        (first-line-position (first lines) paper)
151        (ly:prob-property last-line
152                          'bottom-space 0.0)
153        (- (interval-start (paper-system-extent last-line Y))))))
154
155 (define (page-maximum-space-left page)
156   (let ((paper (ly:paper-book-paper (page-property page 'paper-book))))
157     (let bottom-position ((lines (page-property page 'lines))
158                           (prev-line #f)
159                           (prev-position #f))
160       (if (null? lines)
161           (page-printable-height page)
162           (let* ((line (first lines))
163                  (position (line-minimum-position-on-page
164                             line prev-line prev-position page)))
165             (if (null? (cdr lines))
166                 (and position
167                      (- (page-printable-height page)
168                         (- position
169                            (interval-start (paper-system-extent line Y)))))
170                 (bottom-position (cdr lines) line position)))))))
171
172 ;;;
173 ;;; Utilities for distributing systems on a page
174 ;;;
175
176 (define (space-systems space-to-fill lines ragged paper ignore-padding)
177   "Compute lines positions on page: return force and line positions as a pair.
178  force is #f if lines do not fit on page."
179   (let* ((empty-stencil (ly:make-stencil '() '(0 . 0) '(0 . 0)))
180          (empty-prob (ly:make-prob 'paper-system (list `(stencil . ,empty-stencil))))
181          (cdr-lines (append (cdr lines)
182                             (if (<= (length lines) 1)
183                                 (list empty-prob)
184                                 '())))
185          (springs (map (lambda (prev-line line)
186                          (list (line-ideal-distance prev-line line paper ignore-padding)
187                                (/ 1.0 (line-next-space prev-line line paper))))
188                        lines
189                        cdr-lines))
190          (rods (map (let ((i -1))
191                       (lambda (prev-line line)
192                         (set! i (1+ i))
193                         (list i (1+ i)
194                               (line-minimum-distance prev-line line paper ignore-padding))))
195                        lines
196                        cdr-lines))
197          (space-result
198           (ly:solve-spring-rod-problem springs rods space-to-fill ragged)))
199     (cons (car space-result)
200           (map (let ((topskip (first-line-position (first lines) paper)))
201                  (lambda (y)
202                    (+ y topskip)))
203                (cdr space-result)))))
204
205 (define (make-page-from-systems paper-book lines page-number ragged last)
206   "Return a new page, filled with `lines'."
207   (let* ((page (make-page paper-book
208                           'lines lines
209                           'page-number page-number
210                           'is-last last))
211          (posns (if (null? lines)
212                     (list)
213                     (let* ((paper (ly:paper-book-paper paper-book))
214                            (space-to-fill (page-maximum-space-to-fill
215                                             page lines paper))
216                            (spacing (space-systems space-to-fill lines ragged paper #f)))
217                       (if (and (> (length lines) 1)
218                                (or (not (car spacing)) (inf? (car spacing))))
219                           (begin
220                             (ly:warning (_ "Can't fit systems on page -- ignoring between-system-padding"))
221                             (cdr (space-systems space-to-fill lines ragged paper #t)))
222                           (cdr spacing))))))
223     (page-set-property! page 'configuration posns)
224     page))
225
226 ;;;
227 ;;; Page breaking function
228 ;;;
229
230 ;; Optimal distribution of
231 ;; lines over pages; line breaks are a given.
232
233 ;; TODO:
234 ;;
235 ;; - density scoring
236 ;; - separate function for word-wrap style breaking?
237 ;; - ragged-bottom? ragged-last-bottom?
238
239 (define (get-path node done)
240   "Follow NODE.PREV, and return as an ascending list of pages. DONE
241 is what have collected so far, and has ascending page numbers."
242   (if (page? node)
243       (get-path (page-prev node) (cons node done))
244       done))
245
246 (define (combine-penalties force user best-paths
247                            inter-system-space force-equalization-factor)
248   (let* ((prev-force (if (null? best-paths)
249                          0.0
250                          (page-force (car best-paths))))
251          (prev-penalty (if (null? best-paths)
252                            0.0
253                            (page-penalty (car best-paths))))
254          (relative-force (/ force inter-system-space))
255          (abs-relative-force (abs relative-force)))
256     (+ (* abs-relative-force (+ abs-relative-force 1))
257        prev-penalty
258        (* force-equalization-factor (/ (abs (- prev-force force))
259                                        inter-system-space))
260        user)))
261
262 (define (walk-paths done-lines best-paths current-lines last current-best
263                     paper-book page-alist)
264   "Return the best optimal-page-break-node that contains
265 CURRENT-LINES. DONE-LINES.reversed ++ CURRENT-LINES is a consecutive
266 ascending range of lines, and BEST-PATHS contains the optimal breaks
267 corresponding to DONE-LINES.
268
269 CURRENT-BEST is the best result sofar, or #f."
270   (let* ((paper (ly:paper-book-paper paper-book))
271          (this-page (make-page
272                      paper-book
273                      'is-last last
274                      'page-number (if (null? best-paths)
275                                       (ly:output-def-lookup paper 'first-page-number)
276                                       (1+ (page-page-number (first best-paths))))))
277          (ragged-all (eq? #t (ly:output-def-lookup paper 'ragged-bottom)))
278          (ragged-last (eq? #t (ly:output-def-lookup paper 'ragged-last-bottom)))
279          (ragged (or ragged-all (and ragged-last last)))
280          (space-to-fill (page-maximum-space-to-fill this-page current-lines paper))
281          (vertical-spacing (space-systems space-to-fill current-lines ragged paper #f))
282          (satisfied-constraints (car vertical-spacing))
283          (force (if satisfied-constraints
284                     (if (and last ragged-last)
285                         0.0
286                         satisfied-constraints)
287                     10000))
288          (positions (cdr vertical-spacing))
289          (get-break-penalty (lambda (sys)
290                               (ly:prob-property sys 'penalty 0.0)))
291          (user-nobreak-penalties (- (apply + (filter negative?
292                                                      (map get-break-penalty
293                                                           (cdr current-lines))))))
294          (user-penalty (+ (max (get-break-penalty (car current-lines)) 0.0)
295                           user-nobreak-penalties))
296          (total-penalty (combine-penalties
297                          force user-penalty best-paths
298                          (ly:output-def-lookup paper 'between-system-space)
299                          (ly:output-def-lookup paper 'verticalequalizationfactor 0.3)))
300          (new-best (if (or (not current-best)
301                            (and satisfied-constraints
302                                 (< total-penalty (page-penalty current-best))))
303                        (begin
304                          (map (lambda (x)
305                                 (page-set-property! this-page
306                                                     (car x)
307                                                     (cdr x)))
308                               (list (cons 'prev (if (null? best-paths)
309                                                     #f
310                                                     (car best-paths)))
311                                     (cons 'lines current-lines)
312                                     (cons 'force force)
313                                     (cons 'configuration positions)
314                                     (cons 'penalty total-penalty)))
315                          this-page)
316                        current-best)))
317     (if #f ;; debug
318         (display
319          (list
320           "\nuser pen " user-penalty
321           "\nsatisfied-constraints" satisfied-constraints
322           "\nlast? " last "ragged?" ragged
323           "\nis-better " is-better " total-penalty " total-penalty "\n"
324           "\nconfig " positions
325           "\nforce " force
326           "\nlines: " current-lines "\n")))
327     (if #f ; debug
328         (display (list "\nnew-best is " (page-lines new-best)
329                        "\ncontinuation of "
330                        (if (null? best-paths)
331                            "start"
332                            (page-lines (car best-paths))))))
333     (if (and (pair? done-lines)
334              ;; if this page is too full, adding another line won't help
335              satisfied-constraints)
336         (walk-paths (cdr done-lines) (cdr best-paths)
337                     (cons (car done-lines) current-lines)
338                     last new-best
339                     paper-book page-alist)
340         new-best)))
341
342 (define (walk-lines done best-paths todo paper-book page-alist)
343   "Return the best page breaking as a single
344 page node for optimally breaking TODO ++
345 DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
346 DONE."
347   (if (null? todo)
348       (car best-paths)
349       (let* ((this-line (car todo))
350              (last (null? (cdr todo)))
351              (next (walk-paths done best-paths (list this-line) last #f
352                                paper-book page-alist)))
353         (walk-lines (cons this-line done)
354                     (cons next best-paths)
355                     (cdr todo)
356                     paper-book
357                     page-alist))))
358
359 (define-public (optimal-page-breaks paper-book)
360   "Return pages as a list starting with 1st page. Each page is a 'page Prob."
361   (let* ((paper (ly:paper-book-paper paper-book))
362          (lines (ly:paper-book-systems paper-book))
363          (page-alist (layout->page-init paper)) 
364          (force-equalization-factor (ly:output-def-lookup
365                                      paper 'verticalequalizationfactor 0.3)))
366     (ly:message (_ "Calculating page breaks..."))
367     (let* ((best-break-node (walk-lines '() '() lines paper-book page-alist))
368            (break-nodes (get-path best-break-node '())))
369       (page-set-property! (car (last-pair break-nodes)) 'is-last #t)
370       (if #f; (ly:get-option 'verbose)
371           (begin
372             (display (list
373                       "\nbreaks: " (map (lambda (node)
374                                           (ly:prob-property (car (page-lines node))
375                                                             'number))
376                                         break-nodes)
377                       "\nsystems " (map page-lines break-nodes)
378                       "\npenalties " (map page-penalty break-nodes)
379                       "\nconfigs " (map page-configuration break-nodes)))))
380       ;; construct page stencils.
381       (for-each page-stencil break-nodes)
382       break-nodes)))