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