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