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 (handle-system sys)
 110       (let*
 111           ((props `((line-break . #t)
 112                     (spacing-parameters
 113                      . ((system-Y-extent . ,(paper-system-extent sys Y))
 114                         (system-refpoint-Y-extent . ,(paper-system-staff-extents sys))
 115                         (system-index . ,index)
 116                         (page-system-count . ,(length (page-lines page)))
 117                         (page-printable-height . ,(page-printable-height page))
 118                         (page-space-left . ,(page-property page 'space-left))))
 119                     )))
 120
 121         (if (equal? (car (page-lines page)) sys)
 122             (set! props (cons '(page-break . #t)
 123                               props)))
 124         (if (not (ly:prob-property? sys 'is-title))
 125             (record  (ly:spanner-bound (ly:prob-property sys 'system-grob) LEFT)
 126                      props))
 127
 128         (set! index (1+ index))
 129         ))
 130     (for-each handle-system (page-lines page)))
 131
 132   (for-each handle-page pages)
 133   (dump-all-tweaks))
 134
 135 (define (post-process-pages layout pages)
 136   (if (ly:output-def-lookup layout 'write-page-layout #f)
 137       (write-page-breaks pages)))
 138
 139 ;; Optimal distribution of
 140 ;; lines over pages; line breaks are a given.
 141
 142 ;; TODO:
 143 ;;
 144 ;; - density scoring
 145 ;; - separate function for word-wrap style breaking?
 146 ;; - ragged-bottom? ragged-last-bottom?
 147
 148 (define-public (optimal-page-breaks lines paper-book)
 149   "Return pages as a list starting with 1st page. Each page is a 'page Prob."
 150
 151   (define MAXPENALTY 1e9)
 152   (define paper (ly:paper-book-paper paper-book))
 153
 154   ;; ugh.
 155   (define page-alist (layout->page-init (ly:paper-book-paper paper-book)))
 156   (define scopes (ly:paper-book-scopes paper-book))
 157   (define force-equalization-factor #f)
 158   (define (get-path node done)
 159
 160     "Follow NODE.PREV, and return as an ascending list of pages. DONE
 161 is what have collected so far, and has ascending page numbers."
 162
 163     (if (page? node)
 164         (get-path (page-prev node) (cons node done))
 165         done))
 166
 167   (define (combine-penalties force user best-paths)
 168     (let* ((prev-force (if (null? best-paths)
 169                            0.0
 170                            (page-force (car best-paths))))
 171            (prev-penalty (if (null? best-paths)
 172                              0.0
 173                              (page-penalty (car best-paths))))
 174          (inter-system-space (ly:output-def-lookup paper 'between-system-space))
 175          (relative-force (/ force inter-system-space))
 176          (abs-relative-force (abs relative-force)))
 177
 178       (+ (* abs-relative-force (+ abs-relative-force 1))
 179          prev-penalty
 180          (* force-equalization-factor (/ (abs (- prev-force force))
 181                                          inter-system-space))
 182          user)))
 183
 184   (define (space-systems page-height lines ragged?)
 185     (let* ((global-inter-system-space
 186             (ly:output-def-lookup paper 'between-system-space))
 187            (top-space
 188             (ly:output-def-lookup paper 'page-top-space))
 189            (global-fixed-dist (ly:output-def-lookup paper 'between-system-padding))
 190
 191            (system-vector (list->vector
 192                            (append lines
 193                                    (if (= (length lines) 1)
 194                                        '(#f)
 195                                        '()))))
 196            (staff-extents
 197             (list->vector
 198              (append (map paper-system-staff-extents lines)
 199                      (if (= (length lines) 1)
 200                          '((0 . 0))
 201                          '()))))
 202
 203            (real-extents
 204             (list->vector
 205              (append
 206               (map
 207                (lambda (sys) (paper-system-extent sys Y)) lines)
 208               (if (= (length lines) 1)
 209                   '((0 .  0))
 210                   '()))))
 211
 212            (system-count (vector-length real-extents))
 213            (topskip (max
 214                      (+
 215                       top-space
 216                       (interval-end (vector-ref staff-extents 0)))
 217                      (interval-end (vector-ref real-extents 0))
 218                      ))
 219            (last-system (vector-ref system-vector (1- system-count)))
 220            (bottom-space (if (ly:prob? last-system)
 221                              (ly:prob-property last-system 'bottom-space 0.0)
 222                              0.0))
 223            (space-left (- page-height
 224                           bottom-space
 225                           (apply + (map interval-length
 226                                         (vector->list real-extents)))))
 227
 228            (space (- page-height
 229                      topskip
 230                      bottom-space
 231                      (-  (interval-start
 232                           (vector-ref real-extents (1- system-count))))))
 233
 234            (calc-spring
 235             (lambda (idx)
 236               (let* (
 237                      (upper-system (vector-ref system-vector idx))
 238                      (between-space (ly:prob-property upper-system 'next-space
 239                                                               global-inter-system-space))
 240                      (fixed-dist (ly:prob-property upper-system 'next-padding
 241                                                            global-fixed-dist))
 242
 243                      (this-system-ext (vector-ref staff-extents idx))
 244                      (next-system-ext (vector-ref staff-extents (1+ idx)))
 245                      (fixed (max 0 (- (+ (interval-end next-system-ext)
 246                                          fixed-dist)
 247                                       (interval-start this-system-ext))))
 248                      (title1? (and (vector-ref system-vector idx)
 249                                    (paper-system-title? (vector-ref system-vector idx)
 250                                                              )))
 251                      (title2? (and
 252                                (vector-ref system-vector (1+ idx))
 253                                (paper-system-title? (vector-ref system-vector (1+ idx)))))
 254                      (ideal (+
 255                              (cond
 256                               ((and title2? title1?)
 257                                (ly:output-def-lookup paper 'between-title-space))
 258                               (title1?
 259                                (ly:output-def-lookup paper 'after-title-space))
 260                               (title2?
 261                                (ly:output-def-lookup paper 'before-title-space))
 262                               (else between-space))
 263                              fixed))
 264                      (hooke (/ 1 (- ideal fixed))))
 265                 (list ideal hooke))))
 266
 267            (springs (map calc-spring (iota (1- system-count))))
 268            (calc-rod
 269             (lambda (idx)
 270               (let* (
 271                      (upper-system (vector-ref system-vector idx))
 272                      (fixed-dist (ly:prob-property upper-system 'next-padding
 273                                                            global-fixed-dist))
 274                      (this-system-ext (vector-ref real-extents idx))
 275                      (next-system-ext (vector-ref real-extents (1+ idx)))
 276
 277                      (distance (max  (- (+ (interval-end next-system-ext)
 278                                            fixed-dist)
 279                                         (interval-start this-system-ext)
 280                                         ) 0))
 281                      (entry (list idx (1+ idx) distance)))
 282                 entry)))
 283            (rods (map calc-rod (iota (1- system-count))))
 284
 285            ;; we don't set ragged based on amount space left.
 286            ;; ragged-bottomlast = ##T is much more predictable
 287            (result (ly:solve-spring-rod-problem
 288                     springs rods space
 289                     ragged?))
 290
 291            (force (car result))
 292            (positions
 293             (map (lambda (y)
 294                    (+ y topskip))
 295                  (cdr  result))))
 296
 297       (if #f ;; debug.
 298           (begin
 299             (display (list "\n# systems: " system-count
 300                            "\nreal-ext" real-extents "\nstaff-ext" staff-extents
 301                            "\ninterscore" global-inter-system-space
 302                            "\nspace-left" space-left
 303                            "\nspring,rod" springs rods
 304                            "\ntopskip " topskip
 305                            " space " space
 306                            "\npage-height" page-height
 307                            "\nragged" ragged?
 308                            "\nforce" force
 309                            "\nres" (cdr result)
 310                            "\npositions" positions "\n"))))
 311
 312       (cons force positions)))
 313
 314   (define (walk-paths done-lines best-paths current-lines  last? current-best)
 315     "Return the best optimal-page-break-node that contains
 316 CURRENT-LINES.  DONE-LINES.reversed ++ CURRENT-LINES is a consecutive
 317 ascending range of lines, and BEST-PATHS contains the optimal breaks
 318 corresponding to DONE-LINES.
 319
 320 CURRENT-BEST is the best result sofar, or #f."
 321
 322     (let* ((this-page-num (if (null? best-paths)
 323                               (ly:output-def-lookup paper 'first-page-number)
 324                               (1+ (page-page-number (car best-paths)))))
 325
 326            (this-page (make-page
 327                        page-alist
 328                        'paper-book paper-book
 329                        'is-last last?
 330                        'page-number this-page-num))
 331
 332            (ragged-all? (eq? #t (ly:output-def-lookup paper 'ragged-bottom)))
 333            (ragged-last? (eq? #t (ly:output-def-lookup paper 'ragged-last-bottom)))
 334            (ragged? (or ragged-all?
 335                         (and ragged-last?
 336                              last?)))
 337            (height (page-printable-height this-page))
 338            (vertical-spacing (space-systems height current-lines ragged?))
 339            (satisfied-constraints (car vertical-spacing))
 340            (force (if satisfied-constraints
 341                       (if (and last? ragged-last?)
 342                           0.0
 343                           satisfied-constraints)
 344                       10000))
 345            (positions (cdr vertical-spacing))
 346            (get-break-penalty (lambda (sys)
 347                                 (ly:prob-property sys 'penalty 0.0)))
 348            (user-nobreak-penalties
 349             (-
 350              (apply + (filter negative?
 351                               (map get-break-penalty
 352                                    (cdr current-lines))))))
 353            (user-penalty
 354             (+
 355              (max (get-break-penalty (car current-lines)) 0.0)
 356              user-nobreak-penalties))
 357
 358            (total-penalty (combine-penalties
 359                            force user-penalty
 360                            best-paths))
 361
 362            (better? (or
 363                      (not current-best)
 364                      (< total-penalty (page-penalty current-best))))
 365            (new-best (if better?
 366                          (begin
 367                            (map
 368                             (lambda (x)
 369                               (page-set-property! this-page
 370                                                   (car x)
 371                                                   (cdr x)))
 372                             (list
 373                              (cons 'prev (if (null? best-paths)
 374                                              #f
 375                                              (car best-paths)))
 376                              (cons 'lines current-lines)
 377                              (cons 'force force)
 378                              (cons 'configuration positions)
 379                              (cons 'penalty total-penalty)))
 380                            this-page)
 381                          current-best)))
 382
 383 ;;      (display total-penalty) (newline)
 384       (if #f ;; debug
 385           (display
 386            (list
 387             "\nuser pen " user-penalty
 388             "\nsatisfied-constraints" satisfied-constraints
 389             "\nlast? " last? "ragged?" ragged?
 390             "\nbetter? " better? " total-penalty " total-penalty "\n"
 391             "\nconfig " positions
 392             "\nforce " force
 393             "\nlines: " current-lines "\n")))
 394
 395       (if #f ; debug
 396           (display (list "\nnew-best is " (page-lines new-best)
 397                          "\ncontinuation of "
 398                          (if (null? best-paths)
 399                              "start"
 400                              (page-lines (car best-paths))))))
 401
 402       (if (and (pair? done-lines)
 403                ;; if this page is too full, adding another line won't help
 404                satisfied-constraints)
 405           (walk-paths (cdr done-lines) (cdr best-paths)
 406                       (cons (car done-lines) current-lines)
 407                       last? new-best)
 408           new-best)))
 409
 410   (define (walk-lines done best-paths todo)
 411     "Return the best page breaking as a single
 412 page node for optimally breaking TODO ++
 413 DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
 414 DONE."
 415
 416     (if (null? todo)
 417         (car best-paths)
 418         (let* ((this-line (car todo))
 419                (last? (null? (cdr todo)))
 420                (next (walk-paths done best-paths (list this-line) last? #f)))
 421
 422           ;; (display "\n***************")
 423           (walk-lines (cons this-line done)
 424                       (cons next best-paths)
 425                       (cdr todo)))))
 426
 427   (define (line-number node)
 428     (ly:prob-property (car (page-lines node)) 'number))
 429
 430   (ly:message (_ "Calculating page breaks..."))
 431   (set! force-equalization-factor
 432         (ly:output-def-lookup paper 'verticalequalizationfactor 0.3))
 433
 434   (let* ((best-break-node (walk-lines '() '() lines))
 435          (break-nodes (get-path best-break-node '())))
 436
 437     (page-set-property! (car (last-pair break-nodes)) 'is-last #t)
 438     (if #f; (ly:get-option 'verbose)
 439         (begin
 440           (display (list
 441                     "\nbreaks: " (map line-number break-nodes))
 442                    "\nsystems " (map page-lines break-nodes)
 443                    "\npenalties " (map page-penalty break-nodes)
 444                    "\nconfigs " (map page-configuration break-nodes))))
 445
 446     ;; construct page stencils.
 447     (for-each page-stencil break-nodes)
 448     (post-process-pages paper break-nodes)
 449
 450     break-nodes))