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