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