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