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 (optimal-page-breaks lines paper-book)
 189   "Return pages as a list starting with 1st page. Each page is a list
 190 of lines. "
 191
 192
 193   (define MAXPENALTY 1e9)
 194   (define paper (ly:paper-book-paper paper-book))
 195   (define scopes (ly:paper-book-scopes paper-book))
 196   (define force-equalization-factor #f)
 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          (relative-force (/ force inter-system-space))
 222          (abs-relative-force (abs relative-force)))
 223
 224
 225       (+ (* abs-relative-force (+ abs-relative-force 1))
 226          prev-penalty
 227          (* force-equalization-factor (/ (abs (- prev-force force))
 228                                          inter-system-space))
 229          user)))
 230
 231   (define (space-systems page-height lines ragged?)
 232     (let* ((global-inter-system-space
 233             (ly:output-def-lookup paper 'betweensystemspace))
 234            (top-space
 235             (ly:output-def-lookup paper 'pagetopspace))
 236            (global-fixed-dist (ly:output-def-lookup paper 'betweensystempadding))
 237
 238            (system-vector (list->vector
 239                            (append lines
 240                                    (if (= (length lines) 1)
 241                                        '(#f)
 242                                        '()))))
 243            (staff-extents
 244             (list->vector
 245              (append (map ly:paper-system-staff-extents lines)
 246                      (if (= (length lines) 1)
 247                          '((0 . 0))
 248                          '()))))
 249
 250            (real-extents
 251             (list->vector
 252              (append
 253               (map
 254                (lambda (sys) (ly:paper-system-extent sys Y)) lines)
 255               (if (= (length lines) 1)
 256                   '((0 .  0))
 257                   '()))))
 258
 259            (system-count (vector-length real-extents))
 260            (topskip (max
 261                      (+
 262                       top-space
 263                       (interval-end (vector-ref staff-extents 0)))
 264                      (interval-end (vector-ref real-extents 0))
 265                      ))
 266            (last-system (vector-ref system-vector (1- system-count)))
 267            (bottom-space (if (ly:paper-system? last-system)
 268                              (ly:paper-system-property last-system 'bottom-space 0.0)
 269                              0.0))
 270            (space-left (- page-height
 271                           bottom-space
 272                           (apply + (map interval-length
 273                                         (vector->list real-extents)))))
 274
 275            (space (- page-height
 276                      topskip
 277                      bottom-space
 278                      (-  (interval-start
 279                           (vector-ref real-extents (1- system-count))))))
 280
 281            (calc-spring
 282             (lambda (idx)
 283               (let* (
 284                      (upper-system (vector-ref system-vector idx))
 285                      (between-space (ly:paper-system-property upper-system 'next-space
 286                                                               global-inter-system-space))
 287                      (fixed-dist (ly:paper-system-property upper-system 'next-padding
 288                                                            global-fixed-dist))
 289
 290                      (this-system-ext (vector-ref staff-extents idx))
 291                      (next-system-ext (vector-ref staff-extents (1+ idx)))
 292                      (fixed (max 0 (- (+ (interval-end next-system-ext)
 293                                          fixed-dist)
 294                                       (interval-start this-system-ext))))
 295                      (title1? (and (vector-ref system-vector idx)
 296                                    (ly:paper-system-title? (vector-ref system-vector idx))))
 297                      (title2? (and
 298                                (vector-ref system-vector (1+ idx))
 299                                (ly:paper-system-title? (vector-ref system-vector (1+ idx)))))
 300                      (ideal (+
 301                              (cond
 302                               ((and title2? title1?)
 303                                (ly:output-def-lookup paper 'betweentitlespace))
 304                               (title1?
 305                                (ly:output-def-lookup paper 'aftertitlespace))
 306                               (title2?
 307                                (ly:output-def-lookup paper 'beforetitlespace))
 308                               (else between-space))
 309                              fixed))
 310                      (hooke (/ 1 (- ideal fixed))))
 311                 (list ideal hooke))))
 312
 313            (springs (map calc-spring (iota (1- system-count))))
 314            (calc-rod
 315             (lambda (idx)
 316               (let* (
 317                      (upper-system (vector-ref system-vector idx))
 318                      (fixed-dist (ly:paper-system-property upper-system 'next-padding
 319                                                            global-fixed-dist))
 320                      (this-system-ext (vector-ref real-extents idx))
 321                      (next-system-ext (vector-ref real-extents (1+ idx)))
 322
 323                      (distance (max  (- (+ (interval-end next-system-ext)
 324                                            fixed-dist)
 325                                         (interval-start this-system-ext)
 326                                         ) 0))
 327                      (entry (list idx (1+ idx) distance)))
 328                 entry)))
 329            (rods (map calc-rod (iota (1- system-count))))
 330
 331            ;; we don't set ragged based on amount space left.
 332            ;; raggedbottomlast = ##T is much more predictable
 333            (result (ly:solve-spring-rod-problem
 334                     springs rods space
 335                     ragged?))
 336
 337            (force (car result))
 338            (positions
 339             (map (lambda (y)
 340                    (+ y topskip))
 341                  (cdr  result))))
 342
 343       (if #f ;; debug.
 344           (begin
 345             (display (list "\n# systems: " system-count
 346                            "\nreal-ext" real-extents "\nstaff-ext" staff-extents
 347                            "\ninterscore" inter-system-space
 348                            "\nspace-letf" space-left
 349                            "\nspring,rod" springs rods
 350                            "\ntopskip " topskip
 351                            " space " space
 352                            "\npage-height" page-height
 353                            "\nragged" ragged?
 354                            "\nforce" force
 355                            "\nres" (cdr result)
 356                            "\npositions" positions "\n"))))
 357
 358       (cons force positions)))
 359
 360   (define (walk-paths done-lines best-paths current-lines  last? current-best)
 361     "Return the best optimal-page-break-node that contains
 362 CURRENT-LINES.  DONE-LINES.reversed ++ CURRENT-LINES is a consecutive
 363 ascending range of lines, and BEST-PATHS contains the optimal breaks
 364 corresponding to DONE-LINES.
 365
 366 CURRENT-BEST is the best result sofar, or #f."
 367
 368
 369     (let* ((this-page-num (if (null? best-paths)
 370                               (ly:output-def-lookup paper 'firstpagenumber)
 371                               (1+ (node-page-number (car best-paths)))))
 372
 373            (ragged-all? (eq? #t (ly:output-def-lookup paper 'raggedbottom)))
 374            (ragged-last? (eq? #t (ly:output-def-lookup paper 'raggedlastbottom)))
 375            (ragged? (or ragged-all?
 376                         (and ragged-last?
 377                              last?)))
 378            (page-height (page-height this-page-num last?))
 379            (vertical-spacing (space-systems page-height current-lines ragged?))
 380            (satisfied-constraints (car vertical-spacing))
 381            (force (if satisfied-constraints
 382                       (if (and last? ragged-last?)
 383                           0.0
 384                           satisfied-constraints)
 385                       10000))
 386            (positions (cdr vertical-spacing))
 387            (user-nobreak-penalties
 388             (-
 389              (apply + (filter negative?
 390                               (map ly:paper-system-break-before-penalty
 391                                    (cdr current-lines))))))
 392            (user-penalty
 393             (+
 394              (max (ly:paper-system-break-before-penalty (car current-lines)) 0.0)
 395              user-nobreak-penalties))
 396            (total-penalty (combine-penalties
 397                            force user-penalty
 398                            best-paths))
 399
 400
 401            (better? (or
 402                      (not current-best)
 403                      (< total-penalty (node-penalty current-best))))
 404            (new-best (if better?
 405                          (make <optimally-broken-page-node>
 406                            #:prev (if (null? best-paths)
 407                                       #f
 408                                       (car best-paths))
 409                            #:lines current-lines
 410                            #:pageno this-page-num
 411                            #:force force
 412                            #:configuration positions
 413                            #:penalty total-penalty)
 414                          current-best)))
 415
 416 ;;      (display total-penalty) (newline)
 417       (if #f ;; debug
 418           (display
 419            (list
 420             "\nuser pen " user-penalty
 421             "\nsatisfied-constraints" satisfied-constraints
 422             "\nlast? " last? "ragged?" ragged?
 423             "\nbetter? " better? " total-penalty " total-penalty "\n"
 424             "\nconfig " positions
 425             "\nforce " force
 426             "\nlines: " current-lines "\n")))
 427
 428       (if #f ; debug
 429           (display (list "\nnew-best is " (node-lines new-best)
 430                          "\ncontinuation of "
 431                          (if (null? best-paths)
 432                              "start"
 433                              (node-lines (car best-paths))))))
 434
 435       (if (and (pair? done-lines)
 436                ;; if this page is too full, adding another line won't help
 437                satisfied-constraints)
 438           (walk-paths (cdr done-lines) (cdr best-paths)
 439                       (cons (car done-lines) current-lines)
 440                       last? new-best)
 441           new-best)))
 442
 443   (define (walk-lines done best-paths todo)
 444     "Return the best page breaking as a single
 445 <optimal-page-break-node> for optimally breaking TODO ++
 446 DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
 447 DONE."
 448     (if (null? todo)
 449         (car best-paths)
 450         (let* ((this-line (car todo))
 451                (last? (null? (cdr todo)))
 452                (next (walk-paths done best-paths (list this-line) last? #f)))
 453
 454           ;; (display "\n***************")
 455           (walk-lines (cons this-line done)
 456                       (cons next best-paths)
 457                       (cdr todo)))))
 458
 459   (define (line-number node)
 460     (ly:paper-system-number (car (node-lines node))))
 461
 462   (ly:message (_ "Calculating page breaks..."))
 463   (set! force-equalization-factor
 464         (ly:output-def-lookup paper 'verticalequalizationfactor 0.3))
 465
 466   (let* ((best-break-node (walk-lines '() '() lines))
 467          (break-nodes (get-path best-break-node '()))
 468          (last-node (car (last-pair break-nodes))))
 469
 470     (define (node->page-stencil node)
 471       (if (not (eq? node last-node))
 472           (ly:progress "["))
 473       (let ((stencil
 474              ((ly:output-def-lookup paper 'page-make-stencil)
 475               (node-lines node)
 476               (node-configuration node)
 477               paper
 478               scopes
 479               (node-page-number node)
 480               (eq? node best-break-node))))
 481         (if (not (eq? node last-node))
 482             (begin
 483               (ly:progress (number->string
 484                             (car (last-pair (node-system-numbers node)))))
 485               (ly:progress "]")))
 486         stencil))
 487
 488     (if #f; (ly:get-option 'verbose)
 489         (begin
 490           (display (list
 491                     "\nbreaks: " (map line-number break-nodes))
 492                    "\nsystems " (map node-lines break-nodes)
 493                    "\npenalties " (map node-penalty break-nodes)
 494                    "\nconfigs " (map node-configuration break-nodes))))
 495
 496     (let ((stencils (map node->page-stencil break-nodes)))
 497       (ly:progress "\n")
 498       stencils)))