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