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