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