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