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