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