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