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