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