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 (define (write-page-breaks pages)
  15   "Dump page breaks"
  16
  17
  18   (define tweaks '())
  19
  20   (define (record when property-pairs)
  21     (set! tweaks
  22           (acons when property-pairs
  23                  tweaks)))
  24   (define (graceless-moment mom)
  25     (ly:make-moment
  26      (ly:moment-main-numerator mom)
  27      (ly:moment-main-denominator mom)
  28      0 0))
  29
  30   (define (moment->skip mom)
  31     (let*
  32         ((main (if (> (ly:moment-main-numerator mom) 0)
  33                    (format "\\skip 1*~a/~a"
  34                            (ly:moment-main-numerator mom)
  35                            (ly:moment-main-denominator mom))
  36                    ""))
  37          (grace (if (< (ly:moment-grace-numerator mom) 0)
  38                     (format "\\grace { \\skip 1*~a/~a }"
  39                             (- (ly:moment-grace-numerator mom))
  40                             (ly:moment-grace-denominator mom))
  41                     "")))
  42
  43       (format "~a~a" main grace)))
  44
  45   (define (dump-tweaks out-port tweak-list last-moment)
  46     (if (not (null? tweak-list))
  47         (let*
  48             ((now (caar tweak-list))
  49              (diff (ly:moment-sub now last-moment))
  50              (these-tweaks (cdar tweak-list))
  51              (skip (moment->skip diff))
  52              (line-break-str (if (assoc-get 'line-break these-tweaks #f)
  53                                  "\\break\n"
  54                                  ""))
  55              (page-break-str (if (assoc-get 'page-break these-tweaks #f)
  56                                  "\\pageBreak\n"
  57                                  ""))
  58              (space-tweaks (format "\\spacingTweaks #'~a\n"
  59                                    (with-output-to-string
  60                                      (lambda ()
  61                                        (pretty-print
  62
  63                                         (assoc-get 'spacing-parameters these-tweaks '()))))
  64                                      ))
  65              (base (format "~a~a~a"
  66                            line-break-str
  67                            page-break-str
  68                            space-tweaks))
  69              )
  70
  71           (format out-port "~a\n~a\n" skip base)
  72           (dump-tweaks out-port (cdr tweak-list) (graceless-moment now))
  73         )))
  74
  75   (define (handle-page page)
  76     (define index 0)
  77     (define (handle-system sys)
  78       (let*
  79           ((props `((line-break . #t)
  80                     (spacing-parameters
  81                      . ((system-Y-extent . ,(paper-system-extent sys Y))
  82                         (system-refpoint-Y-extent . ,(paper-system-staff-extents sys))
  83                         (system-index . ,index)
  84                         (page-system-count . ,(length (page-lines page)))
  85                         (page-printable-height . ,(page-printable-height page))
  86                         (page-space-left . ,(page-property page 'space-left))))
  87                     )))
  88
  89         (if (equal? (car (page-lines page)) sys)
  90             (set! props (cons '(page-break . #t)
  91                               props)))
  92         (if (not (ly:prob-property? sys 'is-title))
  93             (record (ly:grob-property (ly:spanner-bound (ly:prob-property sys 'system-grob) LEFT) 'when)
  94                   props))
  95
  96         (set! index (1+ index))
  97         ))
  98     (for-each handle-system (page-lines page)))
  99
 100
 101   (for-each handle-page pages)
 102
 103   (let*
 104       ((out-port (open-output-file "breaks.ly")))
 105
 106     (display "{" out-port)
 107     (dump-tweaks out-port (reverse tweaks) (ly:make-moment 0 1))
 108     (display "}" out-port)
 109   ))
 110
 111
 112
 113 (define (post-process-pages layout pages)
 114   (if (ly:get-option 'write-page-layout)
 115       (write-page-breaks pages)))
 116
 117
 118
 119 ;;; optimal page breaking
 120
 121 ;;; This is not optimal page breaking, this is optimal distribution of
 122 ;;; lines over pages; line breaks are a given.
 123
 124 ;; TODO:
 125 ;;
 126 ;; - density scoring
 127 ;; - separate function for word-wrap style breaking?
 128 ;; - raggedbottom? raggedlastbottom?
 129
 130 (define-public (optimal-page-breaks lines paper-book)
 131   "Return pages as a list starting with 1st page. Each page is a 'page Prob."
 132
 133   (define MAXPENALTY 1e9)
 134   (define paper (ly:paper-book-paper paper-book))
 135
 136   ;; ugh.
 137   (define page-alist (layout->page-init (ly:paper-book-paper paper-book)))
 138   (define scopes (ly:paper-book-scopes paper-book))
 139   (define force-equalization-factor #f)
 140   (define (get-path node done)
 141     "Follow NODE.PREV, and return as an ascending list of pages. DONE
 142 is what have collected so far, and has ascending page numbers."
 143
 144     (if (page? node)
 145         (get-path (page-prev node) (cons node done))
 146         done))
 147
 148   (define (combine-penalties force user best-paths)
 149     (let* ((prev-force (if (null? best-paths)
 150                            0.0
 151                            (page-force (car best-paths))))
 152            (prev-penalty (if (null? best-paths)
 153                              0.0
 154                              (page-penalty (car best-paths))))
 155          (inter-system-space (ly:output-def-lookup paper 'betweensystemspace))
 156          (relative-force (/ force inter-system-space))
 157          (abs-relative-force (abs relative-force)))
 158
 159       (+ (* abs-relative-force (+ abs-relative-force 1))
 160          prev-penalty
 161          (* force-equalization-factor (/ (abs (- prev-force force))
 162                                          inter-system-space))
 163          user)))
 164
 165   (define (space-systems page-height lines ragged?)
 166     (let* ((global-inter-system-space
 167             (ly:output-def-lookup paper 'betweensystemspace))
 168            (top-space
 169             (ly:output-def-lookup paper 'pagetopspace))
 170            (global-fixed-dist (ly:output-def-lookup paper 'betweensystempadding))
 171
 172            (system-vector (list->vector
 173                            (append lines
 174                                    (if (= (length lines) 1)
 175                                        '(#f)
 176                                        '()))))
 177            (staff-extents
 178             (list->vector
 179              (append (map paper-system-staff-extents lines)
 180                      (if (= (length lines) 1)
 181                          '((0 . 0))
 182                          '()))))
 183
 184            (real-extents
 185             (list->vector
 186              (append
 187               (map
 188                (lambda (sys) (paper-system-extent sys Y)) lines)
 189               (if (= (length lines) 1)
 190                   '((0 .  0))
 191                   '()))))
 192
 193            (system-count (vector-length real-extents))
 194            (topskip (max
 195                      (+
 196                       top-space
 197                       (interval-end (vector-ref staff-extents 0)))
 198                      (interval-end (vector-ref real-extents 0))
 199                      ))
 200            (last-system (vector-ref system-vector (1- system-count)))
 201            (bottom-space (if (ly:prob? last-system)
 202                              (ly:prob-property last-system 'bottom-space 0.0)
 203                              0.0))
 204            (space-left (- page-height
 205                           bottom-space
 206                           (apply + (map interval-length
 207                                         (vector->list real-extents)))))
 208
 209            (space (- page-height
 210                      topskip
 211                      bottom-space
 212                      (-  (interval-start
 213                           (vector-ref real-extents (1- system-count))))))
 214
 215            (calc-spring
 216             (lambda (idx)
 217               (let* (
 218                      (upper-system (vector-ref system-vector idx))
 219                      (between-space (ly:prob-property upper-system 'next-space
 220                                                               global-inter-system-space))
 221                      (fixed-dist (ly:prob-property upper-system 'next-padding
 222                                                            global-fixed-dist))
 223
 224                      (this-system-ext (vector-ref staff-extents idx))
 225                      (next-system-ext (vector-ref staff-extents (1+ idx)))
 226                      (fixed (max 0 (- (+ (interval-end next-system-ext)
 227                                          fixed-dist)
 228                                       (interval-start this-system-ext))))
 229                      (title1? (and (vector-ref system-vector idx)
 230                                    (paper-system-title? (vector-ref system-vector idx)
 231                                                              )))
 232                      (title2? (and
 233                                (vector-ref system-vector (1+ idx))
 234                                (paper-system-title? (vector-ref system-vector (1+ idx)))))
 235                      (ideal (+
 236                              (cond
 237                               ((and title2? title1?)
 238                                (ly:output-def-lookup paper 'betweentitlespace))
 239                               (title1?
 240                                (ly:output-def-lookup paper 'aftertitlespace))
 241                               (title2?
 242                                (ly:output-def-lookup paper 'beforetitlespace))
 243                               (else between-space))
 244                              fixed))
 245                      (hooke (/ 1 (- ideal fixed))))
 246                 (list ideal hooke))))
 247
 248            (springs (map calc-spring (iota (1- system-count))))
 249            (calc-rod
 250             (lambda (idx)
 251               (let* (
 252                      (upper-system (vector-ref system-vector idx))
 253                      (fixed-dist (ly:prob-property upper-system 'next-padding
 254                                                            global-fixed-dist))
 255                      (this-system-ext (vector-ref real-extents idx))
 256                      (next-system-ext (vector-ref real-extents (1+ idx)))
 257
 258                      (distance (max  (- (+ (interval-end next-system-ext)
 259                                            fixed-dist)
 260                                         (interval-start this-system-ext)
 261                                         ) 0))
 262                      (entry (list idx (1+ idx) distance)))
 263                 entry)))
 264            (rods (map calc-rod (iota (1- system-count))))
 265
 266            ;; we don't set ragged based on amount space left.
 267            ;; raggedbottomlast = ##T is much more predictable
 268            (result (ly:solve-spring-rod-problem
 269                     springs rods space
 270                     ragged?))
 271
 272            (force (car result))
 273            (positions
 274             (map (lambda (y)
 275                    (+ y topskip))
 276                  (cdr  result))))
 277
 278       (if #f ;; debug.
 279           (begin
 280             (display (list "\n# systems: " system-count
 281                            "\nreal-ext" real-extents "\nstaff-ext" staff-extents
 282                            "\ninterscore" global-inter-system-space
 283                            "\nspace-left" space-left
 284                            "\nspring,rod" springs rods
 285                            "\ntopskip " topskip
 286                            " space " space
 287                            "\npage-height" page-height
 288                            "\nragged" ragged?
 289                            "\nforce" force
 290                            "\nres" (cdr result)
 291                            "\npositions" positions "\n"))))
 292
 293       (cons force positions)))
 294
 295   (define (walk-paths done-lines best-paths current-lines  last? current-best)
 296     "Return the best optimal-page-break-node that contains
 297 CURRENT-LINES.  DONE-LINES.reversed ++ CURRENT-LINES is a consecutive
 298 ascending range of lines, and BEST-PATHS contains the optimal breaks
 299 corresponding to DONE-LINES.
 300
 301 CURRENT-BEST is the best result sofar, or #f."
 302
 303
 304     (let* ((this-page-num (if (null? best-paths)
 305                               (ly:output-def-lookup paper 'firstpagenumber)
 306                               (1+ (page-page-number (car best-paths)))))
 307
 308            (this-page (make-page
 309                        page-alist
 310                        'paper-book paper-book
 311                        'is-last last?
 312                        'page-number this-page-num))
 313
 314            (ragged-all? (eq? #t (ly:output-def-lookup paper 'raggedbottom)))
 315            (ragged-last? (eq? #t (ly:output-def-lookup paper 'raggedlastbottom)))
 316            (ragged? (or ragged-all?
 317                         (and ragged-last?
 318                              last?)))
 319            (height (page-printable-height this-page))
 320            (vertical-spacing (space-systems height current-lines ragged?))
 321            (satisfied-constraints (car vertical-spacing))
 322            (force (if satisfied-constraints
 323                       (if (and last? ragged-last?)
 324                           0.0
 325                           satisfied-constraints)
 326                       10000))
 327            (positions (cdr vertical-spacing))
 328            (get-break-penalty (lambda (sys)
 329                                 (ly:prob-property sys 'penalty 0.0)))
 330            (user-nobreak-penalties
 331             (-
 332              (apply + (filter negative?
 333                               (map get-break-penalty
 334                                    (cdr current-lines))))))
 335            (user-penalty
 336             (+
 337              (max (get-break-penalty (car current-lines)) 0.0)
 338              user-nobreak-penalties))
 339
 340            (total-penalty (combine-penalties
 341                            force user-penalty
 342                            best-paths))
 343
 344            (better? (or
 345                      (not current-best)
 346                      (< total-penalty (page-penalty current-best))))
 347            (new-best (if better?
 348                          (begin
 349                            (map
 350                             (lambda (x)
 351                               (page-set-property! this-page
 352                                                   (car x)
 353                                                   (cdr x)))
 354                             (list
 355                              (cons 'prev (if (null? best-paths)
 356                                              #f
 357                                              (car best-paths)))
 358                              (cons 'lines current-lines)
 359                              (cons 'force force)
 360                              (cons 'configuration positions)
 361                              (cons 'penalty total-penalty)))
 362                            this-page)
 363                          current-best)))
 364
 365 ;;      (display total-penalty) (newline)
 366       (if #f ;; debug
 367           (display
 368            (list
 369             "\nuser pen " user-penalty
 370             "\nsatisfied-constraints" satisfied-constraints
 371             "\nlast? " last? "ragged?" ragged?
 372             "\nbetter? " better? " total-penalty " total-penalty "\n"
 373             "\nconfig " positions
 374             "\nforce " force
 375             "\nlines: " current-lines "\n")))
 376
 377       (if #f ; debug
 378           (display (list "\nnew-best is " (page-lines new-best)
 379                          "\ncontinuation of "
 380                          (if (null? best-paths)
 381                              "start"
 382                              (page-lines (car best-paths))))))
 383
 384       (if (and (pair? done-lines)
 385                ;; if this page is too full, adding another line won't help
 386                satisfied-constraints)
 387           (walk-paths (cdr done-lines) (cdr best-paths)
 388                       (cons (car done-lines) current-lines)
 389                       last? new-best)
 390           new-best)))
 391
 392   (define (walk-lines done best-paths todo)
 393     "Return the best page breaking as a single
 394 page node for optimally breaking TODO ++
 395 DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
 396 DONE."
 397
 398     (if (null? todo)
 399         (car best-paths)
 400         (let* ((this-line (car todo))
 401                (last? (null? (cdr todo)))
 402                (next (walk-paths done best-paths (list this-line) last? #f)))
 403
 404           ;; (display "\n***************")
 405           (walk-lines (cons this-line done)
 406                       (cons next best-paths)
 407                       (cdr todo)))))
 408
 409   (define (line-number node)
 410     (ly:prob-property (car (page-lines node)) 'number))
 411
 412   (ly:message (_ "Calculating page breaks..."))
 413   (set! force-equalization-factor
 414         (ly:output-def-lookup paper 'verticalequalizationfactor 0.3))
 415
 416   (let* ((best-break-node (walk-lines '() '() lines))
 417          (break-nodes (get-path best-break-node '()))
 418          )
 419
 420     (page-set-property! (car (last-pair break-nodes)) 'is-last #t)
 421     (if #f; (ly:get-option 'verbose)
 422         (begin
 423           (display (list
 424                     "\nbreaks: " (map line-number break-nodes))
 425                    "\nsystems " (map page-lines break-nodes)
 426                    "\npenalties " (map page-penalty break-nodes)
 427                    "\nconfigs " (map page-configuration break-nodes))))
 428
 429     ;; construct page stencils.
 430     (for-each page-stencil break-nodes)
 431     (post-process-pages paper break-nodes)
 432
 433     break-nodes))