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