scm/page-layout.scm

   1 ;;;; page-layout.scm -- page breaking and page layout
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2004--2005 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;;          Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8 (use-modules (oop goops describe)
   9              (oop goops))
  10
  11
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13
  14 (define-class <optimally-broken-page-node> ()
  15   (prev #:init-value '() #:accessor node-prev #:init-keyword #:prev)
  16   (page #:init-value 0 #:accessor node-page-number #:init-keyword #:pageno)
  17   (force #:init-value 0 #:accessor node-force #:init-keyword #:force)
  18   (penalty #:init-value 0 #:accessor node-penalty #:init-keyword #:penalty)
  19   (configuration #:init-value '() #:accessor node-configuration #:init-keyword #:configuration)
  20   (lines #:init-value 0 #:accessor node-lines #:init-keyword #:lines))
  21
  22 (define-method (display (node <optimally-broken-page-node>) port)
  23   (map (lambda (x) (display x port))
  24        (list
  25         "Page " (node-page-number node)
  26         " Lines: " (node-lines node)
  27         " Penalty " (node-penalty node)
  28         "\n")))
  29
  30 (define-method (node-system-numbers (node <optimally-broken-page-node>))
  31   (map ly:paper-system-number (node-lines node)))
  32
  33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34
  35 (define (page-headfoot layout scopes number sym sepsym dir last?)
  36   "Create a stencil including separating space."
  37   (let* ((header-proc (ly:output-def-lookup layout sym))
  38        (sep (ly:output-def-lookup layout sepsym))
  39        (stencil (ly:make-stencil "" '(0 . 0) '(0 . 0)))
  40        (head-stencil
  41         (if (procedure? header-proc)
  42             (header-proc layout scopes number last?)
  43             #f)))
  44
  45     (if (and (number? sep)
  46              (ly:stencil? head-stencil)
  47              (not (ly:stencil-empty? head-stencil)))
  48         (set! head-stencil
  49               (ly:stencil-combine-at-edge
  50                stencil Y dir head-stencil
  51                sep 0.0)))
  52
  53     head-stencil))
  54
  55 (define-public (default-page-music-height layout scopes number last?)
  56   "Printable area for music and titles; matches default-page-make-stencil."
  57   (let* ((h (- (ly:output-def-lookup layout 'vsize)
  58              (ly:output-def-lookup layout 'topmargin)
  59              (ly:output-def-lookup layout 'bottommargin)))
  60        (head (page-headfoot layout scopes number 'make-header 'headsep UP last?))
  61        (foot (page-headfoot layout scopes number 'make-footer 'footsep DOWN last?))
  62        (available
  63         (- h (if (ly:stencil? head)
  64                  (interval-length (ly:stencil-extent head Y))
  65                  0)
  66            (if (ly:stencil? foot)
  67                (interval-length (ly:stencil-extent foot Y))
  68                0))))
  69
  70     ;; (display (list "\n available" available head foot))
  71     available))
  72
  73 (define-public (default-page-make-stencil
  74                  lines offsets layout scopes number last?)
  75   "Construct a stencil representing the page from LINES.
  76
  77  Offsets is a list of increasing numbers. They must be negated to
  78 create offsets.
  79  "
  80
  81   (let* ((topmargin (ly:output-def-lookup layout 'topmargin))
  82
  83        ;; TODO: naming vsize/hsize not analogous to TeX.
  84
  85          (vsize (ly:output-def-lookup layout 'vsize))
  86          (hsize (ly:output-def-lookup layout 'hsize))
  87
  88          (system-xoffset (ly:output-def-lookup layout 'horizontalshift 0.0))
  89          (system-separator-markup (ly:output-def-lookup layout 'systemSeparatorMarkup))
  90          (system-separator-stencil (if (markup? system-separator-markup)
  91                                        (interpret-markup layout
  92                                                          (layout-extract-page-properties layout)
  93                                                          system-separator-markup)
  94                                        #f))
  95          (lmargin (ly:output-def-lookup layout 'leftmargin))
  96          (leftmargin (if lmargin
  97                          lmargin
  98                          (/ (- hsize
  99                                (ly:output-def-lookup layout 'linewidth)) 2)))
 100
 101          (rightmargin (ly:output-def-lookup layout 'rightmargin))
 102          (bottom-edge (- vsize
 103                          (ly:output-def-lookup layout 'bottommargin)))
 104
 105          (head (page-headfoot layout scopes number 'make-header 'headsep UP last?))
 106          (foot (page-headfoot layout scopes number 'make-footer 'footsep DOWN last?))
 107
 108          (head-height (if (ly:stencil? head)
 109                           (interval-length (ly:stencil-extent head Y))
 110                           0.0))
 111
 112          (height-proc (ly:output-def-lookup layout 'page-music-height))
 113
 114          (page-stencil (ly:make-stencil '()
 115                                         (cons leftmargin hsize)
 116                                         (cons (- topmargin) 0)))
 117          (last-system #f)
 118          (last-y 0.0)
 119          (add-to-page (lambda (stencil y)
 120                         (set! page-stencil
 121                               (ly:stencil-add page-stencil
 122                                               (ly:stencil-translate stencil
 123                                                                     (cons
 124                                                                      system-xoffset
 125                                                                      (- 0 head-height y topmargin))
 126
 127                                                                     )))))
 128          (add-system
 129           (lambda (stencil-position)
 130             (let* ((system (car stencil-position))
 131                    (stencil (ly:paper-system-stencil system))
 132                    (y (cadr stencil-position))
 133                    (is-title (ly:paper-system-title?
 134                               (car stencil-position))))
 135               (add-to-page stencil y)
 136               (if (and (ly:stencil? system-separator-stencil)
 137                        last-system
 138                        (not (ly:paper-system-title? system))
 139                        (not (ly:paper-system-title? last-system)))
 140                   (add-to-page
 141                    system-separator-stencil
 142                    (average (- last-y
 143                                (car (ly:paper-system-staff-extents last-system)))
 144                             (- y
 145                                (cdr (ly:paper-system-staff-extents system))))))
 146               (set! last-system system)
 147               (set! last-y y)))))
 148
 149     (if #f
 150         (display (list
 151                   "leftmargin " leftmargin "rightmargin " rightmargin
 152                   )))
 153
 154     (set! page-stencil (ly:stencil-combine-at-edge
 155                         page-stencil Y DOWN
 156                         (if (and
 157                              (ly:stencil? head)
 158                              (not (ly:stencil-empty? head)))
 159                             head
 160                             (ly:make-stencil "" (cons 0 0) (cons 0 0)))
 161                             0. 0.))
 162
 163     (map add-system (zip lines offsets))
 164     (if (and (ly:stencil? foot)
 165              (not (ly:stencil-empty? foot)))
 166         (set! page-stencil
 167               (ly:stencil-add
 168                page-stencil
 169                (ly:stencil-translate
 170                 foot
 171                 (cons 0
 172                       (+ (- bottom-edge)
 173                          (- (car (ly:stencil-extent foot Y)))))))))
 174
 175     (ly:stencil-translate page-stencil (cons leftmargin 0))))
 176
 177 ;;; optimal page breaking
 178
 179 ;;; This is not optimal page breaking, this is optimal distribution of
 180 ;;; lines over pages; line breaks are a given.
 181
 182 ;; TODO:
 183 ;;
 184 ;; - density scoring
 185 ;; - separate function for word-wrap style breaking?
 186 ;; - raggedbottom? raggedlastbottom?
 187
 188 (define-public (ly:optimal-page-breaks
 189                 lines paper-book)
 190   "Return pages as a list starting with 1st page. Each page is a list
 191 of lines. "
 192
 193
 194   (define MAXPENALTY 1e9)
 195   (define paper (ly:paper-book-paper paper-book))
 196   (define scopes (ly:paper-book-scopes paper-book))
 197
 198   (define (page-height page-number last?)
 199     (let ((p (ly:output-def-lookup paper 'page-music-height)))
 200
 201       (if (procedure? p)
 202           (p paper scopes page-number last?)
 203           10000)))
 204
 205   (define (get-path node done)
 206     "Follow NODE.PREV, and return as an ascending list of pages. DONE
 207 is what have collected so far, and has ascending page numbers."
 208
 209     (if (is-a? node <optimally-broken-page-node>)
 210         (get-path (node-prev node) (cons node done))
 211         done))
 212
 213   (define (combine-penalties force user best-paths)
 214     (let* ((prev-force (if (null? best-paths)
 215                            0.0
 216                            (node-force (car best-paths))))
 217            (prev-penalty (if (null? best-paths)
 218                              0.0
 219                              (node-penalty (car best-paths))))
 220          (inter-system-space (ly:output-def-lookup paper 'betweensystemspace))
 221          (force-equalization-factor 0.3)
 222          (relative-force (/ force inter-system-space))
 223          (abs-relative-force (abs relative-force)))
 224
 225
 226       (+ (* abs-relative-force (+ abs-relative-force 1))
 227          prev-penalty
 228          (* force-equalization-factor (/ (abs (- prev-force force)) inter-system-space))
 229          user)))
 230
 231   (define (space-systems page-height lines ragged?)
 232     (let* ((inter-system-space
 233             (ly:output-def-lookup paper 'betweensystemspace))
 234            (system-vector (list->vector
 235                            (append lines
 236                                    (if (= (length lines) 1)
 237                                        '(#f)
 238                                        '()))))
 239          (staff-extents
 240           (list->vector
 241            (append (map ly:paper-system-staff-extents lines)
 242                    (if (= (length lines) 1)
 243                        '((0 . 0))
 244                        '()))))
 245          (real-extents
 246           (list->vector
 247            (append
 248             (map
 249              (lambda (sys) (ly:paper-system-extent sys Y)) lines)
 250             (if (= (length lines) 1)
 251                 '((0 .  0))
 252                 '()))))
 253          (no-systems (vector-length real-extents))
 254          (topskip (interval-end (vector-ref real-extents 0)))
 255          (space-left (- page-height
 256                         (apply + (map interval-length (vector->list real-extents)))))
 257
 258          (space (- page-height
 259                    topskip
 260                    (-  (interval-start (vector-ref real-extents (1- no-systems))))))
 261
 262          (fixed-dist (ly:output-def-lookup paper 'betweensystempadding))
 263          (calc-spring
 264           (lambda (idx)
 265             (let* ((this-system-ext (vector-ref staff-extents idx))
 266                  (next-system-ext (vector-ref staff-extents (1+ idx)))
 267                  (fixed (max 0 (- (+ (interval-end next-system-ext)
 268                                       fixed-dist)
 269                                    (interval-start this-system-ext))))
 270                  (title1? (and (vector-ref system-vector idx)
 271                                (ly:paper-system-title? (vector-ref system-vector idx))))
 272                  (title2? (and
 273                            (vector-ref system-vector (1+ idx))
 274                            (ly:paper-system-title? (vector-ref system-vector (1+ idx)))))
 275                  (ideal (+
 276                          (cond
 277                           ((and title2? title1?)
 278                            (ly:output-def-lookup paper 'betweentitlespace))
 279                           (title1?
 280                            (ly:output-def-lookup paper 'aftertitlespace))
 281                           (title2?
 282                            (ly:output-def-lookup paper 'beforetitlespace))
 283                           (else inter-system-space))
 284                          fixed))
 285                  (hooke (/ 1 (- ideal fixed))))
 286               (list ideal hooke))))
 287
 288          (springs (map calc-spring (iota (1- no-systems))))
 289          (calc-rod
 290           (lambda (idx)
 291             (let* ((this-system-ext (vector-ref real-extents idx))
 292                  (next-system-ext (vector-ref real-extents (1+ idx)))
 293                  (distance (max  (- (+ (interval-end next-system-ext)
 294                                        fixed-dist)
 295                                     (interval-start this-system-ext)
 296                                     ) 0))
 297                  (entry (list idx (1+ idx) distance)))
 298               entry)))
 299          (rods (map calc-rod (iota (1- no-systems))))
 300
 301          ;; we don't set ragged based on amount space left.
 302          ;; raggedbottomlast = ##T is much more predictable
 303          (result (ly:solve-spring-rod-problem
 304                   springs rods space
 305                   ragged?))
 306
 307          (force (car result))
 308          (positions
 309           (map (lambda (y)
 310                  (+ y topskip))
 311                (cdr  result))))
 312
 313       (if #f ;; debug.
 314           (begin
 315             (display (list "\n# systems: " no-systems
 316                            "\nreal-ext" real-extents "\nstaff-ext" staff-extents
 317                            "\ninterscore" inter-system-space
 318                            "\nspace-letf" space-left
 319                            "\nspring,rod" springs rods
 320                            "\ntopskip " topskip
 321                            " space " space
 322                            "\npage-height" page-height
 323                            "\nragged" ragged?
 324                            "\nforce" force
 325                            "\nres" (cdr result)
 326                            "\npositions" positions "\n"))))
 327
 328       (cons force positions)))
 329
 330   (define (walk-paths done-lines best-paths current-lines  last? current-best)
 331     "Return the best optimal-page-break-node that contains
 332 CURRENT-LINES.  DONE-LINES.reversed ++ CURRENT-LINES is a consecutive
 333 ascending range of lines, and BEST-PATHS contains the optimal breaks
 334 corresponding to DONE-LINES.
 335
 336 CURRENT-BEST is the best result sofar, or #f."
 337
 338     (let* ((this-page-num (if (null? best-paths)
 339                               (ly:output-def-lookup paper 'firstpagenumber)
 340                               (1+ (node-page-number (car best-paths)))))
 341
 342            (ragged-all? (eq? #t (ly:output-def-lookup paper 'raggedbottom)))
 343            (ragged-last? (eq? #t (ly:output-def-lookup paper 'raggedlastbottom)))
 344            (ragged? (or ragged-all?
 345                         (and ragged-last?
 346                              last?)))
 347            (page-height (page-height this-page-num last?))
 348            (vertical-spacing (space-systems page-height current-lines ragged?))
 349            (satisfied-constraints (car vertical-spacing))
 350            (force (if satisfied-constraints
 351                       (if (and last? ragged-last?)
 352                           0.0
 353                           satisfied-constraints)
 354                       10000))
 355            (positions (cdr vertical-spacing))
 356            (user-nobreak-penalties
 357             (-
 358              (apply + (filter negative?
 359                               (map ly:paper-system-break-before-penalty
 360                                    (cdr current-lines))))))
 361            (user-penalty
 362             (+
 363              (max (ly:paper-system-break-before-penalty (car current-lines)) 0.0)
 364              user-nobreak-penalties))
 365            (total-penalty (combine-penalties
 366                            force user-penalty
 367                            best-paths))
 368
 369
 370            (better? (or
 371                      (not current-best)
 372                      (< total-penalty (node-penalty current-best))))
 373            (new-best (if better?
 374                          (make <optimally-broken-page-node>
 375                            #:prev (if (null? best-paths)
 376                                       #f
 377                                       (car best-paths))
 378                            #:lines current-lines
 379                            #:pageno this-page-num
 380                            #:force force
 381                            #:configuration positions
 382                            #:penalty total-penalty)
 383                          current-best)))
 384
 385       (if #f ;; debug
 386           (display
 387            (list
 388             "\nuser pen " user-penalty
 389             "\nsatisfied-constraints" satisfied-constraints
 390             "\nlast? " last? "ragged?" ragged?
 391             "\nbetter? " better? " total-penalty " total-penalty "\n"
 392             "\nconfig " positions
 393             "\nforce " force
 394             "\nlines: " current-lines "\n")))
 395
 396       (if #f ; debug
 397           (display (list "\nnew-best is " (node-lines new-best)
 398                          "\ncontinuation of "
 399                          (if (null? best-paths)
 400                              "start"
 401                              (node-lines (car best-paths))))))
 402
 403       (if (and (pair? done-lines)
 404                ;; if this page is too full, adding another line won't help
 405                satisfied-constraints)
 406           (walk-paths (cdr done-lines) (cdr best-paths)
 407                       (cons (car done-lines) current-lines)
 408                       last? new-best)
 409           new-best)))
 410
 411   (define (walk-lines done best-paths todo)
 412     "Return the best page breaking as a single
 413 <optimal-page-break-node> for optimally breaking TODO ++
 414 DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
 415 DONE."
 416     (if (null? todo)
 417         (car best-paths)
 418         (let* ((this-line (car todo))
 419                (last? (null? (cdr todo)))
 420                (next (walk-paths done best-paths (list this-line) last? #f)))
 421
 422           ;; (display "\n***************")
 423           (walk-lines (cons this-line done)
 424                       (cons next best-paths)
 425                       (cdr todo)))))
 426
 427   (define (line-number node)
 428     (ly:paper-system-number (car (node-lines node))))
 429
 430   (ly:message (_ "Calculating page breaks..."))
 431
 432   (let* ((best-break-node (walk-lines '() '() lines))
 433          (break-nodes (get-path best-break-node '()))
 434          (last-node (car (last-pair break-nodes))))
 435
 436     (define (node->page-stencil node)
 437       (if (not (eq? node last-node))
 438           (ly:progress "["))
 439       (let ((stencil
 440              ((ly:output-def-lookup paper 'page-make-stencil)
 441               (node-lines node)
 442               (node-configuration node)
 443               paper
 444               scopes
 445               (node-page-number node)
 446               (eq? node best-break-node))))
 447         (if (not (eq? node last-node))
 448             (begin
 449               (ly:progress (number->string
 450                             (car (last-pair (node-system-numbers node)))))
 451               (ly:progress "]")))
 452         stencil))
 453
 454     (if #f; (ly:get-option 'verbose)
 455         (begin
 456           (display (list
 457                     "\nbreaks: " (map line-number break-nodes))
 458                    "\nsystems " (map node-lines break-nodes)
 459                    "\npenalties " (map node-penalty break-nodes)
 460                    "\nconfigs " (map node-configuration break-nodes))))
 461
 462     (let ((stencils (map node->page-stencil break-nodes)))
 463       (ly:progress "\n")
 464       stencils)))