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