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