scm/layout-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--2006 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;;          Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8 (use-modules (oop goops describe)
   9              (oop goops)
  10              (scm paper-system)
  11              (scm page)
  12              )
  13
  14
  15 (define (write-page-breaks pages)
  16   "Dump page breaks"
  17
  18   (define tweaks (make-hash-table 23))
  19
  20   (define (record what property-pairs)
  21     (let*
  22         ((key (ly:output-def-lookup (ly:grob-layout what)
  23                                     'tweak-key
  24                                     "tweaks"
  25                                     ))
  26          (when (ly:grob-property what 'when))
  27          )
  28
  29       (if (not (hash-ref tweaks key))
  30           (hash-set! tweaks key '()))
  31
  32       (hash-set! tweaks key
  33                  (acons when property-pairs
  34                         (hash-ref tweaks key)))
  35
  36       ))
  37
  38   (define (graceless-moment mom)
  39     (ly:make-moment
  40      (ly:moment-main-numerator mom)
  41      (ly:moment-main-denominator mom)
  42      0 0))
  43
  44   (define (moment->skip mom)
  45     (let*
  46         ((main (if (> (ly:moment-main-numerator mom) 0)
  47                    (format "\\skip 1*~a/~a"
  48                            (ly:moment-main-numerator mom)
  49                            (ly:moment-main-denominator mom))
  50                    ""))
  51          (grace (if (< (ly:moment-grace-numerator mom) 0)
  52                     (format "\\grace { \\skip 1*~a/~a }"
  53                             (- (ly:moment-grace-numerator mom))
  54                             (ly:moment-grace-denominator mom))
  55                     "")))
  56
  57       (format "~a~a" main grace)))
  58
  59   (define (dump-tweaks out-port tweak-list last-moment)
  60     (if (not (null? tweak-list))
  61         (let*
  62             ((now (caar tweak-list))
  63              (diff (ly:moment-sub now last-moment))
  64              (these-tweaks (cdar tweak-list))
  65              (skip (moment->skip diff))
  66              (line-break-str (if (assoc-get 'line-break these-tweaks #f)
  67                                  "\\break\n"
  68                                  ""))
  69              (page-break-str (if (assoc-get 'page-break these-tweaks #f)
  70                                  "\\pageBreak\n"
  71                                  ""))
  72              (space-tweaks (format "\\spacingTweaks #'~a\n"
  73                                    (with-output-to-string
  74                                      (lambda ()
  75                                        (pretty-print
  76
  77                                         (assoc-get 'spacing-parameters these-tweaks '()))))
  78                                      ))
  79              (base (format "~a~a~a"
  80                            line-break-str
  81                            page-break-str
  82                            space-tweaks))
  83              )
  84
  85           (format out-port "~a\n~a\n" skip base)
  86           (dump-tweaks out-port (cdr tweak-list) (graceless-moment now))
  87         )))
  88
  89   (define (dump-all-tweaks)
  90     (let*
  91      ((paper (ly:paper-book-paper (page-property  (car pages) 'paper-book)))
  92       (parser (ly:output-def-parser paper))
  93       (name  (format "~a-page-layout.ly"
  94                      (ly:parser-output-name parser)))
  95       (out-port (open-output-file name)))
  96
  97      (ly:progress "Writing page layout to ~a" name)
  98      (hash-for-each
  99       (lambda (key val)
 100         (format out-port "~a = {" key)
 101         (dump-tweaks out-port (reverse val) (ly:make-moment 0 1))
 102          (display "}" out-port))
 103        tweaks)
 104      (close-port out-port)
 105      ))
 106
 107   (define (handle-page page)
 108     (define index 0)
 109     (define music-system-heights
 110       (map-in-order (lambda (sys)
 111                       (* -1 (car (paper-system-extent sys Y))))
 112                     (remove (lambda (sys)
 113                               (ly:prob-property? sys 'is-title))
 114                             (page-lines page))))
 115     (define (handle-system sys)
 116       (let*
 117           ((props `((line-break . #t)
 118                     (spacing-parameters
 119                      . ((system-Y-extent . ,(paper-system-extent sys Y))
 120                         (system-refpoint-Y-extent . ,(paper-system-staff-extents sys))
 121                         (system-index . ,index)
 122                         (music-system-heights . ,music-system-heights)
 123                         (page-system-count . ,(length (page-lines page)))
 124                         (page-printable-height . ,(page-printable-height page))
 125                         (page-space-left . ,(page-property page 'space-left))))
 126                     )))
 127
 128         (if (equal? (car (page-lines page)) sys)
 129             (set! props (cons '(page-break . #t)
 130                               props)))
 131         (if (not (ly:prob-property? sys 'is-title))
 132             (record  (ly:spanner-bound (ly:prob-property sys 'system-grob) LEFT)
 133                      props))
 134
 135         (set! index (1+ index))
 136         ))
 137     (for-each handle-system (page-lines page)))
 138
 139   (for-each handle-page pages)
 140   (dump-all-tweaks))
 141
 142 (define (post-process-pages layout pages)
 143   (if (ly:output-def-lookup layout 'write-page-layout #f)
 144       (write-page-breaks pages)))
 145
 146 ;; Optimal distribution of
 147 ;; lines over pages; line breaks are a given.
 148
 149 ;; TODO:
 150 ;;
 151 ;; - density scoring
 152 ;; - separate function for word-wrap style breaking?
 153 ;; - ragged-bottom? ragged-last-bottom?
 154
 155 (define-public (optimal-page-breaks lines paper-book)
 156   "Return pages as a list starting with 1st page. Each page is a 'page Prob."
 157
 158   (define MAXPENALTY 1e9)
 159   (define paper (ly:paper-book-paper paper-book))
 160
 161   ;; ugh.
 162   (define page-alist (layout->page-init (ly:paper-book-paper paper-book)))
 163   (define scopes (ly:paper-book-scopes paper-book))
 164   (define force-equalization-factor #f)
 165   (define (get-path node done)
 166
 167     "Follow NODE.PREV, and return as an ascending list of pages. DONE
 168 is what have collected so far, and has ascending page numbers."
 169
 170     (if (page? node)
 171         (get-path (page-prev node) (cons node done))
 172         done))
 173
 174   (define (combine-penalties force user best-paths)
 175     (let* ((prev-force (if (null? best-paths)
 176                            0.0
 177                            (page-force (car best-paths))))
 178            (prev-penalty (if (null? best-paths)
 179                              0.0
 180                              (page-penalty (car best-paths))))
 181          (inter-system-space (ly:output-def-lookup paper 'between-system-space))
 182          (relative-force (/ force inter-system-space))
 183          (abs-relative-force (abs relative-force)))
 184
 185       (+ (* abs-relative-force (+ abs-relative-force 1))
 186          prev-penalty
 187          (* force-equalization-factor (/ (abs (- prev-force force))
 188                                          inter-system-space))
 189          user)))
 190
 191   (define (space-systems page-height lines ragged?)
 192     (let* ((global-inter-system-space
 193             (ly:output-def-lookup paper 'between-system-space))
 194            (top-space
 195             (ly:output-def-lookup paper 'page-top-space))
 196            (global-fixed-dist (ly:output-def-lookup paper 'between-system-padding))
 197
 198            (system-vector (list->vector
 199                            (append lines
 200                                    (if (= (length lines) 1)
 201                                        '(#f)
 202                                        '()))))
 203            (staff-extents
 204             (list->vector
 205              (append (map paper-system-staff-extents lines)
 206                      (if (= (length lines) 1)
 207                          '((0 . 0))
 208                          '()))))
 209
 210            (real-extents
 211             (list->vector
 212              (append
 213               (map
 214                (lambda (sys) (paper-system-extent sys Y)) lines)
 215               (if (= (length lines) 1)
 216                   '((0 .  0))
 217                   '()))))
 218
 219            (system-count (vector-length real-extents))
 220            (topskip (max
 221                      (+
 222                       top-space
 223                       (interval-end (vector-ref staff-extents 0)))
 224                      (interval-end (vector-ref real-extents 0))
 225                      ))
 226            (last-system (vector-ref system-vector (1- system-count)))
 227            (bottom-space (if (ly:prob? last-system)
 228                              (ly:prob-property last-system 'bottom-space 0.0)
 229                              0.0))
 230            (space-left (- page-height
 231                           bottom-space
 232                           (apply + (map interval-length
 233                                         (vector->list real-extents)))))
 234
 235            (space (- page-height
 236                      topskip
 237                      bottom-space
 238                      (-  (interval-start
 239                           (vector-ref real-extents (1- system-count))))))
 240
 241            (calc-spring
 242             (lambda (idx)
 243               (let* (
 244                      (upper-system (vector-ref system-vector idx))
 245                      (between-space (ly:prob-property upper-system 'next-space
 246                                                               global-inter-system-space))
 247                      (fixed-dist (ly:prob-property upper-system 'next-padding
 248                                                            global-fixed-dist))
 249
 250                      (this-system-ext (vector-ref staff-extents idx))
 251                      (next-system-ext (vector-ref staff-extents (1+ idx)))
 252                      (fixed (max 0 (- (+ (interval-end next-system-ext)
 253                                          fixed-dist)
 254                                       (interval-start this-system-ext))))
 255                      (title1? (and (vector-ref system-vector idx)
 256                                    (paper-system-title? (vector-ref system-vector idx)
 257                                                              )))
 258                      (title2? (and
 259                                (vector-ref system-vector (1+ idx))
 260                                (paper-system-title? (vector-ref system-vector (1+ idx)))))
 261                      (ideal (+
 262                              (cond
 263                               ((and title2? title1?)
 264                                (ly:output-def-lookup paper 'between-title-space))
 265                               (title1?
 266                                (ly:output-def-lookup paper 'after-title-space))
 267                               (title2?
 268                                (ly:output-def-lookup paper 'before-title-space))
 269                               (else between-space))
 270                              fixed))
 271                      (hooke (/ 1 (- ideal fixed))))
 272                 (list ideal hooke))))
 273
 274            (springs (map calc-spring (iota (1- system-count))))
 275            (calc-rod
 276             (lambda (idx)
 277               (let* (
 278                      (upper-system (vector-ref system-vector idx))
 279                      (fixed-dist (ly:prob-property upper-system 'next-padding
 280                                                            global-fixed-dist))
 281                      (this-system-ext (vector-ref real-extents idx))
 282                      (next-system-ext (vector-ref real-extents (1+ idx)))
 283
 284                      (distance (max  (- (+ (interval-end next-system-ext)
 285                                            fixed-dist)
 286                                         (interval-start this-system-ext)
 287                                         ) 0))
 288                      (entry (list idx (1+ idx) distance)))
 289                 entry)))
 290            (rods (map calc-rod (iota (1- system-count))))
 291
 292            ;; we don't set ragged based on amount space left.
 293            ;; ragged-bottomlast = ##T is much more predictable
 294            (result (ly:solve-spring-rod-problem
 295                     springs rods space
 296                     ragged?))
 297
 298            (force (car result))
 299            (positions
 300             (map (lambda (y)
 301                    (+ y topskip))
 302                  (cdr  result))))
 303
 304       (if #f ;; debug.
 305           (begin
 306             (display (list "\n# systems: " system-count
 307                            "\nreal-ext" real-extents "\nstaff-ext" staff-extents
 308                            "\ninterscore" global-inter-system-space
 309                            "\nspace-left" space-left
 310                            "\nspring,rod" springs rods
 311                            "\ntopskip " topskip
 312                            " space " space
 313                            "\npage-height" page-height
 314                            "\nragged" ragged?
 315                            "\nforce" force
 316                            "\nres" (cdr result)
 317                            "\npositions" positions "\n"))))
 318
 319       (cons force positions)))
 320
 321   (define (walk-paths done-lines best-paths current-lines  last? current-best)
 322     "Return the best optimal-page-break-node that contains
 323 CURRENT-LINES.  DONE-LINES.reversed ++ CURRENT-LINES is a consecutive
 324 ascending range of lines, and BEST-PATHS contains the optimal breaks
 325 corresponding to DONE-LINES.
 326
 327 CURRENT-BEST is the best result sofar, or #f."
 328
 329     (let* ((this-page-num (if (null? best-paths)
 330                               (ly:output-def-lookup paper 'first-page-number)
 331                               (1+ (page-page-number (car best-paths)))))
 332
 333            (this-page (make-page
 334                        page-alist
 335                        'paper-book paper-book
 336                        'is-last last?
 337                        'page-number this-page-num))
 338
 339            (ragged-all? (eq? #t (ly:output-def-lookup paper 'ragged-bottom)))
 340            (ragged-last? (eq? #t (ly:output-def-lookup paper 'ragged-last-bottom)))
 341            (ragged? (or ragged-all?
 342                         (and ragged-last?
 343                              last?)))
 344            (height (page-printable-height this-page))
 345            (vertical-spacing (space-systems height current-lines ragged?))
 346            (satisfied-constraints (car vertical-spacing))
 347            (force (if satisfied-constraints
 348                       (if (and last? ragged-last?)
 349                           0.0
 350                           satisfied-constraints)
 351                       10000))
 352            (positions (cdr vertical-spacing))
 353            (get-break-penalty (lambda (sys)
 354                                 (ly:prob-property sys 'penalty 0.0)))
 355            (user-nobreak-penalties
 356             (-
 357              (apply + (filter negative?
 358                               (map get-break-penalty
 359                                    (cdr current-lines))))))
 360            (user-penalty
 361             (+
 362              (max (get-break-penalty (car current-lines)) 0.0)
 363              user-nobreak-penalties))
 364
 365            (total-penalty (combine-penalties
 366                            force user-penalty
 367                            best-paths))
 368
 369            (is-better (or
 370                        (not current-best)
 371                        (and
 372                         satisfied-constraints
 373                         (< total-penalty (page-penalty current-best)))))
 374            (new-best (if is-better
 375                          (begin
 376                            (map
 377                             (lambda (x)
 378                               (page-set-property! this-page
 379                                                   (car x)
 380                                                   (cdr x)))
 381                             (list
 382                              (cons 'prev (if (null? best-paths)
 383                                              #f
 384                                              (car best-paths)))
 385                              (cons 'lines current-lines)
 386                              (cons 'force force)
 387                              (cons 'configuration positions)
 388                              (cons 'penalty total-penalty)))
 389                            this-page)
 390                          current-best)))
 391
 392 ;;      (display total-penalty) (newline)
 393       (if #f ;; debug
 394           (display
 395            (list
 396             "\nuser pen " user-penalty
 397             "\nsatisfied-constraints" satisfied-constraints
 398             "\nlast? " last? "ragged?" ragged?
 399             "\nis-better " is-better " total-penalty " total-penalty "\n"
 400             "\nconfig " positions
 401             "\nforce " force
 402             "\nlines: " current-lines "\n")))
 403
 404       (if #f ; debug
 405           (display (list "\nnew-best is " (page-lines new-best)
 406                          "\ncontinuation of "
 407                          (if (null? best-paths)
 408                              "start"
 409                              (page-lines (car best-paths))))))
 410
 411       (if (and (pair? done-lines)
 412                ;; if this page is too full, adding another line won't help
 413                satisfied-constraints)
 414           (walk-paths (cdr done-lines) (cdr best-paths)
 415                       (cons (car done-lines) current-lines)
 416                       last? new-best)
 417           new-best)))
 418
 419   (define (walk-lines done best-paths todo)
 420     "Return the best page breaking as a single
 421 page node for optimally breaking TODO ++
 422 DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
 423 DONE."
 424
 425     (if (null? todo)
 426         (car best-paths)
 427         (let* ((this-line (car todo))
 428                (last? (null? (cdr todo)))
 429                (next (walk-paths done best-paths (list this-line) last? #f)))
 430
 431           ;; (display "\n***************")
 432           (walk-lines (cons this-line done)
 433                       (cons next best-paths)
 434                       (cdr todo)))))
 435
 436   (define (line-number node)
 437     (ly:prob-property (car (page-lines node)) 'number))
 438
 439   (ly:message (_ "Calculating page breaks..."))
 440   (set! force-equalization-factor
 441         (ly:output-def-lookup paper 'verticalequalizationfactor 0.3))
 442
 443   (let* ((best-break-node (walk-lines '() '() lines))
 444          (break-nodes (get-path best-break-node '())))
 445
 446     (page-set-property! (car (last-pair break-nodes)) 'is-last #t)
 447     (if #f; (ly:get-option 'verbose)
 448         (begin
 449           (display (list
 450                     "\nbreaks: " (map line-number break-nodes))
 451                    "\nsystems " (map page-lines break-nodes)
 452                    "\npenalties " (map page-penalty break-nodes)
 453                    "\nconfigs " (map page-configuration break-nodes))))
 454
 455     ;; construct page stencils.
 456     (for-each page-stencil break-nodes)
 457     (post-process-pages paper break-nodes)
 458
 459     break-nodes))