scm/layout-page-layout.scm

   1 ;;;; layout-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 (define-module (scm layout-page-layout)
   9   #:use-module (srfi srfi-1)
  10   #:use-module (oop goops describe)
  11   #:use-module (oop goops)
  12   #:use-module (scm paper-system)
  13   #:use-module (scm page)
  14   #:use-module (scm layout-page-dump)
  15   #:use-module (lily)
  16   #:export (post-process-pages optimal-page-breaks make-page-from-systems))
  17
  18 (define (post-process-pages layout pages)
  19   (if (ly:output-def-lookup layout 'write-page-layout #f)
  20       (write-page-breaks pages)))
  21
  22 ;;;
  23 ;;; Utilities for computing line distances and positions
  24 ;;;
  25 (define (line-next-space line next-line layout)
  26   "Return space to use between `line' and `next-line'.
  27   `next-line' can be #f, meaning that `line' is the last line."
  28   (let* ((title? (paper-system-title? line))
  29          (next-title? (and next-line (paper-system-title? next-line))))
  30     (cond ((and title? next-title?)
  31            (ly:output-def-lookup layout 'between-title-space))
  32           (title?
  33            (ly:output-def-lookup layout 'after-title-space))
  34           (next-title?
  35            (ly:output-def-lookup layout 'before-title-space))
  36           (else
  37            (ly:prob-property
  38             line 'next-space
  39             (ly:output-def-lookup layout 'between-system-space))))))
  40
  41 (define (line-next-padding line next-line layout)
  42   "Return padding to use between `line' and `next-line'.
  43   `next-line' can be #f, meaning that `line' is the last line."
  44   (ly:prob-property
  45    line 'next-padding
  46    (ly:output-def-lookup layout 'between-system-padding)))
  47
  48
  49 (define (line-minimum-distance line next-line layout ignore-padding)
  50   "Minimum distance between `line' reference position and `next-line'
  51  reference position. If next-line is #f, return #f."
  52   (and next-line
  53        (max 0 (- (+ (interval-end (paper-system-extent next-line Y))
  54                     (if ignore-padding 0 (line-next-padding line next-line layout)))
  55                  (interval-start (paper-system-extent line Y))))))
  56
  57 (define (line-ideal-distance line next-line layout ignore-padding)
  58   "Ideal distance between `line' reference position and `next-line'
  59  reference position. If next-line is #f, return #f."
  60   (and next-line
  61        (+ (max 0 (- (+ (interval-end (paper-system-staff-extents next-line))
  62                        (if ignore-padding 0 (line-next-padding line next-line layout)))
  63                     (interval-start (paper-system-staff-extents line))))
  64           (line-next-space line next-line layout))))
  65
  66 (define (first-line-position line layout)
  67   "Position of the first line on page"
  68   (max (+ (ly:output-def-lookup layout 'page-top-space)
  69           (interval-end (paper-system-staff-extents line)))
  70        (interval-end (paper-system-extent line Y))))
  71
  72 (define (line-ideal-relative-position line prev-line layout ignore-padding)
  73   "Return ideal position of `line', relative to `prev-line' position.
  74   `prev-line' can be #f, meaning that `line' is the first line."
  75   (if (not prev-line)
  76       ;; first line on page
  77       (first-line-position line layout)
  78       ;; not the first line on page
  79       (max (line-minimum-distance prev-line line layout ignore-padding)
  80            (line-ideal-distance prev-line line layout ignore-padding))))
  81
  82 (define (line-minimum-relative-position line prev-line layout ignore-padding)
  83   "Return position of `line', relative to `prev-line' position.
  84   `prev-line' can be #f, meaning that `line' is the first line."
  85   (if (not prev-line)
  86       ;; first line on page
  87       (first-line-position line layout)
  88       ;; not the first line on page
  89       (line-minimum-distance prev-line line layout ignore-padding)))
  90
  91 ;;;
  92 ;;; Page breaking functions
  93 ;;;
  94
  95 ;; Optimal distribution of
  96 ;; lines over pages; line breaks are a given.
  97
  98 ;; TODO:
  99 ;;
 100 ;; - density scoring
 101 ;; - separate function for word-wrap style breaking?
 102 ;; - ragged-bottom? ragged-last-bottom?
 103
 104 (define (get-path node done)
 105   "Follow NODE.PREV, and return as an ascending list of pages. DONE
 106 is what have collected so far, and has ascending page numbers."
 107   (if (page? node)
 108       (get-path (page-prev node) (cons node done))
 109       done))
 110
 111 (define (combine-penalties force user best-paths
 112                            inter-system-space force-equalization-factor)
 113   (let* ((prev-force (if (null? best-paths)
 114                          0.0
 115                          (page-force (car best-paths))))
 116          (prev-penalty (if (null? best-paths)
 117                            0.0
 118                            (page-penalty (car best-paths))))
 119          (relative-force (/ force inter-system-space))
 120          (abs-relative-force (abs relative-force)))
 121     (+ (* abs-relative-force (+ abs-relative-force 1))
 122        prev-penalty
 123        (* force-equalization-factor (/ (abs (- prev-force force))
 124                                        inter-system-space))
 125        user)))
 126
 127 (define (space-systems page-height lines ragged paper ignore-padding)
 128   "Compute lines positions on page: return force and line positions as a pair.
 129  force is #f if lines do not fit on page."
 130   (let* ((empty-stencil (ly:make-stencil '() '(0 . 0) '(0 . 0)))
 131          (empty-prob (ly:make-prob 'paper-system (list `(stencil . ,empty-stencil))))
 132          (cdr-lines (append (cdr lines)
 133                             (if (<= (length lines) 1)
 134                                 (list empty-prob)
 135                                 '())))
 136          (springs (map (lambda (prev-line line)
 137                          (list (line-ideal-distance prev-line line paper ignore-padding)
 138                                (/ 1.0 (line-next-space prev-line line paper))))
 139                        lines
 140                        cdr-lines))
 141          (rods (map (let ((i -1))
 142                       (lambda (prev-line line)
 143                         (set! i (1+ i))
 144                         (list i (1+ i)
 145                               (line-minimum-distance prev-line line paper ignore-padding))))
 146                        lines
 147                        cdr-lines))
 148          (last-line (car (last-pair lines)))
 149          (topskip (first-line-position (first lines) paper))
 150          (space-to-fill (- page-height
 151                            topskip
 152                            (ly:prob-property last-line
 153                                              'bottom-space 0.0)
 154                            (- (interval-start (paper-system-extent
 155                                                last-line Y)))))
 156          (space-result
 157           (ly:solve-spring-rod-problem springs rods space-to-fill ragged)))
 158     (cons (car space-result)
 159           (map (lambda (y)
 160                  (+ y topskip))
 161                (cdr space-result)))))
 162
 163 (define (make-page-from-systems paper-book lines page-number ragged last)
 164   (let*
 165     ((page (make-page
 166             paper-book
 167             'lines lines
 168             'page-number page-number
 169             'is-last last))
 170      (height (page-printable-height page))
 171      (posns (if (> (length lines) 0)
 172                 (let* ((paper (ly:paper-book-paper paper-book))
 173                        (spacing (space-systems height lines ragged paper #f)))
 174                   (if (inf? (car spacing))
 175                       (cdr (space-systems height lines ragged paper #t))
 176                       (cdr spacing)))
 177                 '())))
 178     (page-set-property! page 'configuration posns)
 179     page))
 180
 181 (define (walk-paths done-lines best-paths current-lines last current-best
 182                     paper-book page-alist)
 183   "Return the best optimal-page-break-node that contains
 184 CURRENT-LINES.  DONE-LINES.reversed ++ CURRENT-LINES is a consecutive
 185 ascending range of lines, and BEST-PATHS contains the optimal breaks
 186 corresponding to DONE-LINES.
 187
 188 CURRENT-BEST is the best result sofar, or #f."
 189   (let* ((paper (ly:paper-book-paper paper-book))
 190          (this-page (make-page
 191                      paper-book
 192                      'is-last last
 193                      'page-number (if (null? best-paths)
 194                                       (ly:output-def-lookup paper 'first-page-number)
 195                                       (1+ (page-page-number (first best-paths))))))
 196          (ragged-all (eq? #t (ly:output-def-lookup paper 'ragged-bottom)))
 197          (ragged-last (eq? #t (ly:output-def-lookup paper 'ragged-last-bottom)))
 198          (ragged (or ragged-all (and ragged-last last)))
 199          (height (page-printable-height this-page))
 200          (vertical-spacing (space-systems height current-lines ragged paper #f))
 201          (satisfied-constraints (car vertical-spacing))
 202          (force (if satisfied-constraints
 203                     (if (and last ragged-last)
 204                         0.0
 205                         satisfied-constraints)
 206                     10000))
 207          (positions (cdr vertical-spacing))
 208          (get-break-penalty (lambda (sys)
 209                               (ly:prob-property sys 'penalty 0.0)))
 210          (user-nobreak-penalties (- (apply + (filter negative?
 211                                                      (map get-break-penalty
 212                                                           (cdr current-lines))))))
 213          (user-penalty (+ (max (get-break-penalty (car current-lines)) 0.0)
 214                           user-nobreak-penalties))
 215          (total-penalty (combine-penalties
 216                          force user-penalty best-paths
 217                          (ly:output-def-lookup paper 'between-system-space)
 218                          (ly:output-def-lookup paper 'verticalequalizationfactor 0.3)))
 219          (new-best (if (or (not current-best)
 220                            (and satisfied-constraints
 221                                 (< total-penalty (page-penalty current-best))))
 222                        (begin
 223                          (map (lambda (x)
 224                                 (page-set-property! this-page
 225                                                     (car x)
 226                                                     (cdr x)))
 227                               (list (cons 'prev (if (null? best-paths)
 228                                                     #f
 229                                                     (car best-paths)))
 230                                     (cons 'lines current-lines)
 231                                     (cons 'force force)
 232                                     (cons 'configuration positions)
 233                                     (cons 'penalty total-penalty)))
 234                          this-page)
 235                        current-best)))
 236     (if #f ;; debug
 237         (display
 238          (list
 239           "\nuser pen " user-penalty
 240           "\nsatisfied-constraints" satisfied-constraints
 241           "\nlast? " last "ragged?" ragged
 242           "\nis-better " is-better " total-penalty " total-penalty "\n"
 243           "\nconfig " positions
 244           "\nforce " force
 245           "\nlines: " current-lines "\n")))
 246     (if #f ; debug
 247         (display (list "\nnew-best is " (page-lines new-best)
 248                        "\ncontinuation of "
 249                        (if (null? best-paths)
 250                            "start"
 251                            (page-lines (car best-paths))))))
 252     (if (and (pair? done-lines)
 253              ;; if this page is too full, adding another line won't help
 254              satisfied-constraints)
 255         (walk-paths (cdr done-lines) (cdr best-paths)
 256                     (cons (car done-lines) current-lines)
 257                     last new-best
 258                     paper-book page-alist)
 259         new-best)))
 260
 261 (define (walk-lines done best-paths todo paper-book page-alist)
 262   "Return the best page breaking as a single
 263 page node for optimally breaking TODO ++
 264 DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
 265 DONE."
 266   (if (null? todo)
 267       (car best-paths)
 268       (let* ((this-line (car todo))
 269              (last (null? (cdr todo)))
 270              (next (walk-paths done best-paths (list this-line) last #f
 271                                paper-book page-alist)))
 272         (walk-lines (cons this-line done)
 273                     (cons next best-paths)
 274                     (cdr todo)
 275                     paper-book
 276                     page-alist))))
 277
 278 (define-public (optimal-page-breaks paper-book)
 279   "Return pages as a list starting with 1st page. Each page is a 'page Prob."
 280   (let* ((paper (ly:paper-book-paper paper-book))
 281          (lines (ly:paper-book-systems paper-book))
 282          (page-alist (layout->page-init paper))
 283          (force-equalization-factor (ly:output-def-lookup
 284                                      paper 'verticalequalizationfactor 0.3)))
 285     (ly:message (_ "Calculating page breaks..."))
 286     (let* ((best-break-node (walk-lines '() '() lines paper-book page-alist))
 287            (break-nodes (get-path best-break-node '())))
 288       (page-set-property! (car (last-pair break-nodes)) 'is-last #t)
 289       (if #f; (ly:get-option 'verbose)
 290           (begin
 291             (display (list
 292                       "\nbreaks: " (map (lambda (node)
 293                                           (ly:prob-property (car (page-lines node))
 294                                                             'number))
 295                                         break-nodes)
 296                       "\nsystems " (map page-lines break-nodes)
 297                       "\npenalties " (map page-penalty break-nodes)
 298                       "\nconfigs " (map page-configuration break-nodes)))))
 299       ;; construct page stencils.
 300       (for-each page-stencil break-nodes)
 301       (post-process-pages paper break-nodes)
 302       break-nodes)))