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