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
 347            (satisfied-constraints (car vertical-spacing))
 348            (force (if satisfied-constraints
 349                       (if (and last? ragged-last?)
 350                           0.0
 351                           satisfied-constraints)
 352                       10000))
 353            (positions (cdr vertical-spacing))
 354            (get-break-penalty (lambda (sys)
 355                                 (ly:prob-property sys 'penalty 0.0)))
 356            (user-nobreak-penalties
 357             (-
 358              (apply + (filter negative?
 359                               (map get-break-penalty
 360                                    (cdr current-lines))))))
 361            (user-penalty
 362             (+
 363              (max (get-break-penalty (car current-lines)) 0.0)
 364              user-nobreak-penalties))
 365
 366            (total-penalty (combine-penalties
 367                            force user-penalty
 368                            best-paths))
 369
 370            (is-better (or
 371                        (not current-best)
 372                        (and
 373                         satisfied-constraints
 374                         (< total-penalty (page-penalty current-best)))))
 375            (new-best (if is-better
 376                          (begin
 377                            (map
 378                             (lambda (x)
 379                               (page-set-property! this-page
 380                                                   (car x)
 381                                                   (cdr x)))
 382                             (list
 383                              (cons 'prev (if (null? best-paths)
 384                                              #f
 385                                              (car best-paths)))
 386                              (cons 'lines current-lines)
 387                              (cons 'force force)
 388                              (cons 'configuration positions)
 389                              (cons 'penalty total-penalty)))
 390                            this-page)
 391                          current-best)))
 392
 393 ;;      (display total-penalty) (newline)
 394       (if #f ;; debug
 395           (display
 396            (list
 397             "\nuser pen " user-penalty
 398             "\nsatisfied-constraints" satisfied-constraints
 399             "\nlast? " last? "ragged?" ragged?
 400             "\nis-better " is-better " total-penalty " total-penalty "\n"
 401             "\nconfig " positions
 402             "\nforce " force
 403             "\nlines: " current-lines "\n")))
 404
 405       (if #f ; debug
 406           (display (list "\nnew-best is " (page-lines new-best)
 407                          "\ncontinuation of "
 408                          (if (null? best-paths)
 409                              "start"
 410                              (page-lines (car best-paths))))))
 411
 412       (if (and (pair? done-lines)
 413                ;; if this page is too full, adding another line won't help
 414                satisfied-constraints)
 415           (walk-paths (cdr done-lines) (cdr best-paths)
 416                       (cons (car done-lines) current-lines)
 417                       last? new-best)
 418           new-best)))
 419
 420   (define (walk-lines done best-paths todo)
 421     "Return the best page breaking as a single
 422 page node for optimally breaking TODO ++
 423 DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
 424 DONE."
 425
 426     (if (null? todo)
 427         (car best-paths)
 428         (let* ((this-line (car todo))
 429                (last? (null? (cdr todo)))
 430                (next (walk-paths done best-paths (list this-line) last? #f)))
 431
 432           ;; (display "\n***************")
 433           (walk-lines (cons this-line done)
 434                       (cons next best-paths)
 435                       (cdr todo)))))
 436
 437   (define (line-number node)
 438     (ly:prob-property (car (page-lines node)) 'number))
 439
 440   (ly:message (_ "Calculating page breaks..."))
 441   (set! force-equalization-factor
 442         (ly:output-def-lookup paper 'verticalequalizationfactor 0.3))
 443
 444   (let* ((best-break-node (walk-lines '() '() lines))
 445          (break-nodes (get-path best-break-node '())))
 446
 447     (page-set-property! (car (last-pair break-nodes)) 'is-last #t)
 448     (if #f; (ly:get-option 'verbose)
 449         (begin
 450           (display (list
 451                     "\nbreaks: " (map line-number break-nodes))
 452                    "\nsystems " (map page-lines break-nodes)
 453                    "\npenalties " (map page-penalty break-nodes)
 454                    "\nconfigs " (map page-configuration break-nodes))))
 455
 456     ;; construct page stencils.
 457     (for-each page-stencil break-nodes)
 458     (post-process-pages paper break-nodes)
 459
 460     break-nodes))