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      ))
 105
 106   (define (handle-page page)
 107     (define index 0)
 108     (define (handle-system sys)
 109       (let*
 110           ((props `((line-break . #t)
 111                     (spacing-parameters
 112                      . ((system-Y-extent . ,(paper-system-extent sys Y))
 113                         (system-refpoint-Y-extent . ,(paper-system-staff-extents sys))
 114                         (system-index . ,index)
 115                         (page-system-count . ,(length (page-lines page)))
 116                         (page-printable-height . ,(page-printable-height page))
 117                         (page-space-left . ,(page-property page 'space-left))))
 118                     )))
 119
 120         (if (equal? (car (page-lines page)) sys)
 121             (set! props (cons '(page-break . #t)
 122                               props)))
 123         (if (not (ly:prob-property? sys 'is-title))
 124             (record  (ly:spanner-bound (ly:prob-property sys 'system-grob) LEFT)
 125                      props))
 126
 127         (set! index (1+ index))
 128         ))
 129     (for-each handle-system (page-lines page)))
 130
 131   (for-each handle-page pages)
 132   (dump-all-tweaks))
 133
 134 (define (post-process-pages layout pages)
 135   (if (ly:output-def-lookup layout 'write-page-layout #f)
 136       (write-page-breaks pages)))
 137
 138 ;;; optimal page breaking
 139
 140 ;;; This is not optimal page breaking, this is optimal distribution of
 141 ;;; lines over pages; line breaks are a given.
 142
 143 ;; TODO:
 144 ;;
 145 ;; - density scoring
 146 ;; - separate function for word-wrap style breaking?
 147 ;; - raggedbottom? raggedlastbottom?
 148
 149 (define-public (optimal-page-breaks lines paper-book)
 150   "Return pages as a list starting with 1st page. Each page is a 'page Prob."
 151
 152   (define MAXPENALTY 1e9)
 153   (define paper (ly:paper-book-paper paper-book))
 154
 155   ;; ugh.
 156   (define page-alist (layout->page-init (ly:paper-book-paper paper-book)))
 157   (define scopes (ly:paper-book-scopes paper-book))
 158   (define force-equalization-factor #f)
 159   (define (get-path node done)
 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 'betweensystemspace))
 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 'betweensystemspace))
 187            (top-space
 188             (ly:output-def-lookup paper 'pagetopspace))
 189            (global-fixed-dist (ly:output-def-lookup paper 'betweensystempadding))
 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 'betweentitlespace))
 258                               (title1?
 259                                (ly:output-def-lookup paper 'aftertitlespace))
 260                               (title2?
 261                                (ly:output-def-lookup paper 'beforetitlespace))
 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            ;; raggedbottomlast = ##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
 323     (let* ((this-page-num (if (null? best-paths)
 324                               (ly:output-def-lookup paper 'firstpagenumber)
 325                               (1+ (page-page-number (car best-paths)))))
 326
 327            (this-page (make-page
 328                        page-alist
 329                        'paper-book paper-book
 330                        'is-last last?
 331                        'page-number this-page-num))
 332
 333            (ragged-all? (eq? #t (ly:output-def-lookup paper 'raggedbottom)))
 334            (ragged-last? (eq? #t (ly:output-def-lookup paper 'raggedlastbottom)))
 335            (ragged? (or ragged-all?
 336                         (and ragged-last?
 337                              last?)))
 338            (height (page-printable-height this-page))
 339            (vertical-spacing (space-systems height current-lines ragged?))
 340            (satisfied-constraints (car vertical-spacing))
 341            (force (if satisfied-constraints
 342                       (if (and last? ragged-last?)
 343                           0.0
 344                           satisfied-constraints)
 345                       10000))
 346            (positions (cdr vertical-spacing))
 347            (get-break-penalty (lambda (sys)
 348                                 (ly:prob-property sys 'penalty 0.0)))
 349            (user-nobreak-penalties
 350             (-
 351              (apply + (filter negative?
 352                               (map get-break-penalty
 353                                    (cdr current-lines))))))
 354            (user-penalty
 355             (+
 356              (max (get-break-penalty (car current-lines)) 0.0)
 357              user-nobreak-penalties))
 358
 359            (total-penalty (combine-penalties
 360                            force user-penalty
 361                            best-paths))
 362
 363            (better? (or
 364                      (not current-best)
 365                      (< total-penalty (page-penalty current-best))))
 366            (new-best (if better?
 367                          (begin
 368                            (map
 369                             (lambda (x)
 370                               (page-set-property! this-page
 371                                                   (car x)
 372                                                   (cdr x)))
 373                             (list
 374                              (cons 'prev (if (null? best-paths)
 375                                              #f
 376                                              (car best-paths)))
 377                              (cons 'lines current-lines)
 378                              (cons 'force force)
 379                              (cons 'configuration positions)
 380                              (cons 'penalty total-penalty)))
 381                            this-page)
 382                          current-best)))
 383
 384 ;;      (display total-penalty) (newline)
 385       (if #f ;; debug
 386           (display
 387            (list
 388             "\nuser pen " user-penalty
 389             "\nsatisfied-constraints" satisfied-constraints
 390             "\nlast? " last? "ragged?" ragged?
 391             "\nbetter? " better? " total-penalty " total-penalty "\n"
 392             "\nconfig " positions
 393             "\nforce " force
 394             "\nlines: " current-lines "\n")))
 395
 396       (if #f ; debug
 397           (display (list "\nnew-best is " (page-lines new-best)
 398                          "\ncontinuation of "
 399                          (if (null? best-paths)
 400                              "start"
 401                              (page-lines (car best-paths))))))
 402
 403       (if (and (pair? done-lines)
 404                ;; if this page is too full, adding another line won't help
 405                satisfied-constraints)
 406           (walk-paths (cdr done-lines) (cdr best-paths)
 407                       (cons (car done-lines) current-lines)
 408                       last? new-best)
 409           new-best)))
 410
 411   (define (walk-lines done best-paths todo)
 412     "Return the best page breaking as a single
 413 page node for optimally breaking TODO ++
 414 DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
 415 DONE."
 416
 417     (if (null? todo)
 418         (car best-paths)
 419         (let* ((this-line (car todo))
 420                (last? (null? (cdr todo)))
 421                (next (walk-paths done best-paths (list this-line) last? #f)))
 422
 423           ;; (display "\n***************")
 424           (walk-lines (cons this-line done)
 425                       (cons next best-paths)
 426                       (cdr todo)))))
 427
 428   (define (line-number node)
 429     (ly:prob-property (car (page-lines node)) 'number))
 430
 431   (ly:message (_ "Calculating page breaks..."))
 432   (set! force-equalization-factor
 433         (ly:output-def-lookup paper 'verticalequalizationfactor 0.3))
 434
 435   (let* ((best-break-node (walk-lines '() '() lines))
 436          (break-nodes (get-path best-break-node '()))
 437          )
 438
 439     (page-set-property! (car (last-pair break-nodes)) 'is-last #t)
 440     (if #f; (ly:get-option 'verbose)
 441         (begin
 442           (display (list
 443                     "\nbreaks: " (map line-number break-nodes))
 444                    "\nsystems " (map page-lines break-nodes)
 445                    "\npenalties " (map page-penalty break-nodes)
 446                    "\nconfigs " (map page-configuration break-nodes))))
 447
 448     ;; construct page stencils.
 449     (for-each page-stencil break-nodes)
 450     (post-process-pages paper break-nodes)
 451
 452     break-nodes))