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