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