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