? scm/layout-page-dump.scm Index: ChangeLog =================================================================== RCS file: /cvsroot/lilypond/lilypond/ChangeLog,v retrieving revision 1.5167 diff -u -r1.5167 ChangeLog --- ChangeLog 14 Jul 2006 09:49:40 -0000 1.5167 +++ ChangeLog 14 Jul 2006 18:44:33 -0000 @@ -1,3 +1,16 @@ +2006-07-14 Nicolas Sceaux + + * scm/layout-page-layout.scm: Define module, tidy code, use more + functions iso. a single big one. + + * scm/layout-page-dump.scm: move page dump functions used in two + pass spacing to this file. Define module. + + * scm/lily.scm (ly:load): don't load layout-page-layout.scm + (separate module) + + * ly/paper-defaults.ly: use module layout-page-layout. + 2006-07-14 Erik Sandberg * lily/music.cc: Revised MusicEvent event class. It now contains Index: ly/paper-defaults.ly =================================================================== RCS file: /cvsroot/lilypond/lilypond/ly/paper-defaults.ly,v retrieving revision 1.24 diff -u -r1.24 paper-defaults.ly --- ly/paper-defaults.ly 16 Mar 2006 14:39:46 -0000 1.24 +++ ly/paper-defaults.ly 14 Jul 2006 18:44:35 -0000 @@ -1,5 +1,5 @@ \version "2.7.39" - +#(use-modules (scm layout-page-layout)) \paper { %%%% WARNING Index: scm/layout-page-layout.scm =================================================================== RCS file: /cvsroot/lilypond/lilypond/scm/layout-page-layout.scm,v retrieving revision 1.17 diff -u -r1.17 layout-page-layout.scm --- scm/layout-page-layout.scm 27 May 2006 01:07:55 -0000 1.17 +++ scm/layout-page-layout.scm 14 Jul 2006 18:44:36 -0000 @@ -1,148 +1,97 @@ -;;;; page-layout.scm -- page breaking and page layout +;;;; layout-page-layout.scm -- page breaking and page layout ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; ;;;; (c) 2004--2006 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys -(use-modules (oop goops describe) - (oop goops) - (scm paper-system) - (scm page) - ) - - -(define (write-page-breaks pages) - "Dump page breaks" - - (define tweaks (make-hash-table 23)) - - (define (record what property-pairs) - (let* - ((key (ly:output-def-lookup (ly:grob-layout what) - 'tweak-key - "tweaks" - )) - (when (ly:grob-property what 'when)) - ) - - (if (not (hash-ref tweaks key)) - (hash-set! tweaks key '())) - - (hash-set! tweaks key - (acons when property-pairs - (hash-ref tweaks key))) - - )) - - (define (graceless-moment mom) - (ly:make-moment - (ly:moment-main-numerator mom) - (ly:moment-main-denominator mom) - 0 0)) - - (define (moment->skip mom) - (let* - ((main (if (> (ly:moment-main-numerator mom) 0) - (format "\\skip 1*~a/~a" - (ly:moment-main-numerator mom) - (ly:moment-main-denominator mom)) - "")) - (grace (if (< (ly:moment-grace-numerator mom) 0) - (format "\\grace { \\skip 1*~a/~a }" - (- (ly:moment-grace-numerator mom)) - (ly:moment-grace-denominator mom)) - ""))) - - (format "~a~a" main grace))) - - (define (dump-tweaks out-port tweak-list last-moment) - (if (not (null? tweak-list)) - (let* - ((now (caar tweak-list)) - (diff (ly:moment-sub now last-moment)) - (these-tweaks (cdar tweak-list)) - (skip (moment->skip diff)) - (line-break-str (if (assoc-get 'line-break these-tweaks #f) - "\\break\n" - "")) - (page-break-str (if (assoc-get 'page-break these-tweaks #f) - "\\pageBreak\n" - "")) - (space-tweaks (format "\\spacingTweaks #'~a\n" - (with-output-to-string - (lambda () - (pretty-print - - (assoc-get 'spacing-parameters these-tweaks '())))) - )) - (base (format "~a~a~a" - line-break-str - page-break-str - space-tweaks)) - ) - - (format out-port "~a\n~a\n" skip base) - (dump-tweaks out-port (cdr tweak-list) (graceless-moment now)) - ))) - - (define (dump-all-tweaks) - (let* - ((paper (ly:paper-book-paper (page-property (car pages) 'paper-book))) - (parser (ly:output-def-parser paper)) - (name (format "~a-page-layout.ly" - (ly:parser-output-name parser))) - (out-port (open-output-file name))) - - (ly:progress "Writing page layout to ~a" name) - (hash-for-each - (lambda (key val) - (format out-port "~a = {" key) - (dump-tweaks out-port (reverse val) (ly:make-moment 0 1)) - (display "}" out-port)) - tweaks) - (close-port out-port) - )) - - (define (handle-page page) - (define index 0) - (define music-system-heights - (map-in-order (lambda (sys) - (* -1 (car (paper-system-extent sys Y)))) - (remove (lambda (sys) - (ly:prob-property? sys 'is-title)) - (page-lines page)))) - (define (handle-system sys) - (let* - ((props `((line-break . #t) - (spacing-parameters - . ((system-Y-extent . ,(paper-system-extent sys Y)) - (system-refpoint-Y-extent . ,(paper-system-staff-extents sys)) - (system-index . ,index) - (music-system-heights . ,music-system-heights) - (page-system-count . ,(length (page-lines page))) - (page-printable-height . ,(page-printable-height page)) - (page-space-left . ,(page-property page 'space-left)))) - ))) - - (if (equal? (car (page-lines page)) sys) - (set! props (cons '(page-break . #t) - props))) - (if (not (ly:prob-property? sys 'is-title)) - (record (ly:spanner-bound (ly:prob-property sys 'system-grob) LEFT) - props)) - - (set! index (1+ index)) - )) - (for-each handle-system (page-lines page))) - - (for-each handle-page pages) - (dump-all-tweaks)) +(define-module (scm layout-page-layout) + #:use-module (srfi srfi-1) + #:use-module (oop goops describe) + #:use-module (oop goops) + #:use-module (scm paper-system) + #:use-module (scm page) + #:use-module (scm layout-page-dump) + #:use-module (lily) + #:export (post-process-pages optimal-page-breaks)) (define (post-process-pages layout pages) (if (ly:output-def-lookup layout 'write-page-layout #f) (write-page-breaks pages))) +;;; +;;; Utilities for computing line distances and positions +;;; +(define (line-next-space line next-line layout) + "Return space to use between `line' and `next-line'. + `next-line' can be #f, meaning that `line' is the last line." + (let* ((title? (paper-system-title? line)) + (next-title? (and next-line (paper-system-title? next-line)))) + (cond ((and title? next-title?) + (ly:output-def-lookup layout 'between-title-space)) + (title? + (ly:output-def-lookup layout 'after-title-space)) + (next-title? + (ly:output-def-lookup layout 'before-title-space)) + (else + (ly:prob-property + line 'next-space + (ly:output-def-lookup layout 'between-system-space)))))) + +(define (line-next-padding line next-line layout) + "Return padding to use between `line' and `next-line'. + `next-line' can be #f, meaning that `line' is the last line." + (ly:prob-property + line 'next-padding + (ly:output-def-lookup layout 'between-system-padding))) + + +(define (line-minimum-distance line next-line layout) + "Minimum distance between `line' reference position and `next-line' + reference position. If next-line is #f, return #f." + (and next-line + (max 0 (- (+ (interval-end (paper-system-extent next-line Y)) + (line-next-padding line next-line layout)) + (interval-start (paper-system-extent line Y)))))) + +(define (line-ideal-distance line next-line layout) + "Ideal distance between `line' reference position and `next-line' + reference position. If next-line is #f, return #f." + (and next-line + (+ (max 0 (- (+ (interval-end (paper-system-staff-extents next-line)) + (line-next-padding line next-line layout)) + (interval-start (paper-system-staff-extents line)))) + (line-next-space line next-line layout)))) + +(define (first-line-position line layout) + "Position of the first line on page" + (max (+ (ly:output-def-lookup layout 'page-top-space) + (interval-end (paper-system-staff-extents line))) + (interval-end (paper-system-extent line Y)))) + +(define (line-ideal-relative-position line prev-line layout) + "Return ideal position of `line', relative to `prev-line' position. + `prev-line' can be #f, meaning that `line' is the first line." + (if (not prev-line) + ;; first line on page + (first-line-position line layout) + ;; not the first line on page + (max (line-minimum-distance prev-line line layout) + (line-ideal-distance prev-line line layout)))) + +(define (line-minimum-relative-position line prev-line layout) + "Return position of `line', relative to `prev-line' position. + `prev-line' can be #f, meaning that `line' is the first line." + (if (not prev-line) + ;; first line on page + (first-line-position line layout) + ;; not the first line on page + (line-minimum-distance prev-line line layout))) + +;;; +;;; Page breaking functions +;;; + ;; Optimal distribution of ;; lines over pages; line breaks are a given. @@ -152,309 +101,178 @@ ;; - separate function for word-wrap style breaking? ;; - ragged-bottom? ragged-last-bottom? -(define-public (optimal-page-breaks lines paper-book) - "Return pages as a list starting with 1st page. Each page is a 'page Prob." - - (define MAXPENALTY 1e9) - (define paper (ly:paper-book-paper paper-book)) - - ;; ugh. - (define page-alist (layout->page-init (ly:paper-book-paper paper-book))) - (define scopes (ly:paper-book-scopes paper-book)) - (define force-equalization-factor #f) - (define (get-path node done) - - "Follow NODE.PREV, and return as an ascending list of pages. DONE +(define (get-path node done) + "Follow NODE.PREV, and return as an ascending list of pages. DONE is what have collected so far, and has ascending page numbers." - - (if (page? node) - (get-path (page-prev node) (cons node done)) - done)) - - (define (combine-penalties force user best-paths) - (let* ((prev-force (if (null? best-paths) - 0.0 - (page-force (car best-paths)))) - (prev-penalty (if (null? best-paths) - 0.0 - (page-penalty (car best-paths)))) - (inter-system-space (ly:output-def-lookup paper 'between-system-space)) + (if (page? node) + (get-path (page-prev node) (cons node done)) + done)) + +(define (combine-penalties force user best-paths + inter-system-space force-equalization-factor) + (let* ((prev-force (if (null? best-paths) + 0.0 + (page-force (car best-paths)))) + (prev-penalty (if (null? best-paths) + 0.0 + (page-penalty (car best-paths)))) (relative-force (/ force inter-system-space)) (abs-relative-force (abs relative-force))) - - (+ (* abs-relative-force (+ abs-relative-force 1)) - prev-penalty - (* force-equalization-factor (/ (abs (- prev-force force)) - inter-system-space)) - user))) - - (define (space-systems page-height lines ragged?) - (let* ((global-inter-system-space - (ly:output-def-lookup paper 'between-system-space)) - (top-space - (ly:output-def-lookup paper 'page-top-space)) - (global-fixed-dist (ly:output-def-lookup paper 'between-system-padding)) - - (system-vector (list->vector - (append lines - (if (= (length lines) 1) - '(#f) - '())))) - (staff-extents - (list->vector - (append (map paper-system-staff-extents lines) - (if (= (length lines) 1) - '((0 . 0)) - '())))) - - (real-extents - (list->vector - (append - (map - (lambda (sys) (paper-system-extent sys Y)) lines) - (if (= (length lines) 1) - '((0 . 0)) - '())))) - - (system-count (vector-length real-extents)) - (topskip (max - (+ - top-space - (interval-end (vector-ref staff-extents 0))) - (interval-end (vector-ref real-extents 0)) - )) - (last-system (vector-ref system-vector (1- system-count))) - (bottom-space (if (ly:prob? last-system) - (ly:prob-property last-system 'bottom-space 0.0) - 0.0)) - (space-left (- page-height - bottom-space - (apply + (map interval-length - (vector->list real-extents))))) - - (space (- page-height - topskip - bottom-space - (- (interval-start - (vector-ref real-extents (1- system-count)))))) - - (calc-spring - (lambda (idx) - (let* ( - (upper-system (vector-ref system-vector idx)) - (between-space (ly:prob-property upper-system 'next-space - global-inter-system-space)) - (fixed-dist (ly:prob-property upper-system 'next-padding - global-fixed-dist)) - - (this-system-ext (vector-ref staff-extents idx)) - (next-system-ext (vector-ref staff-extents (1+ idx))) - (fixed (max 0 (- (+ (interval-end next-system-ext) - fixed-dist) - (interval-start this-system-ext)))) - (title1? (and (vector-ref system-vector idx) - (paper-system-title? (vector-ref system-vector idx) - ))) - (title2? (and - (vector-ref system-vector (1+ idx)) - (paper-system-title? (vector-ref system-vector (1+ idx))))) - (ideal (+ - (cond - ((and title2? title1?) - (ly:output-def-lookup paper 'between-title-space)) - (title1? - (ly:output-def-lookup paper 'after-title-space)) - (title2? - (ly:output-def-lookup paper 'before-title-space)) - (else between-space)) - fixed)) - (hooke (/ 1 (- ideal fixed)))) - (list ideal hooke)))) - - (springs (map calc-spring (iota (1- system-count)))) - (calc-rod - (lambda (idx) - (let* ( - (upper-system (vector-ref system-vector idx)) - (fixed-dist (ly:prob-property upper-system 'next-padding - global-fixed-dist)) - (this-system-ext (vector-ref real-extents idx)) - (next-system-ext (vector-ref real-extents (1+ idx))) - - (distance (max (- (+ (interval-end next-system-ext) - fixed-dist) - (interval-start this-system-ext) - ) 0)) - (entry (list idx (1+ idx) distance))) - entry))) - (rods (map calc-rod (iota (1- system-count)))) - - ;; we don't set ragged based on amount space left. - ;; ragged-bottomlast = ##T is much more predictable - (result (ly:solve-spring-rod-problem - springs rods space - ragged?)) - - (force (car result)) - (positions - (map (lambda (y) - (+ y topskip)) - (cdr result)))) - - (if #f ;; debug. - (begin - (display (list "\n# systems: " system-count - "\nreal-ext" real-extents "\nstaff-ext" staff-extents - "\ninterscore" global-inter-system-space - "\nspace-left" space-left - "\nspring,rod" springs rods - "\ntopskip " topskip - " space " space - "\npage-height" page-height - "\nragged" ragged? - "\nforce" force - "\nres" (cdr result) - "\npositions" positions "\n")))) - - (cons force positions))) - - (define (walk-paths done-lines best-paths current-lines last? current-best) - "Return the best optimal-page-break-node that contains + (+ (* abs-relative-force (+ abs-relative-force 1)) + prev-penalty + (* force-equalization-factor (/ (abs (- prev-force force)) + inter-system-space)) + user))) + +(define (space-systems page-height lines ragged? paper) + "Compute lines positions on page: return force and line positions as a pair. + force is #f if lines do not fit on page." + (let* ((springs (map (lambda (prev-line line) + (list (line-ideal-distance prev-line line paper) + (/ 1.0 (line-next-space prev-line line paper)))) + lines + (cdr lines))) + (rods (map (let ((i -1)) + (lambda (prev-line line) + (set! i (1+ i)) + (list i (1+ i) + (line-minimum-distance prev-line line paper)))) + lines + (cdr lines))) + (last-line (car (last-pair lines))) + (topskip (first-line-position (first lines) paper)) + (space-to-fill (- page-height + topskip + (ly:prob-property last-line + 'bottom-space 0.0) + (- (interval-start (paper-system-extent + last-line Y))))) + (space-result + (ly:solve-spring-rod-problem springs rods space-to-fill ragged?))) + (cons (car space-result) + (map (lambda (y) + (+ y topskip)) + (cdr space-result))))) + +(define (walk-paths done-lines best-paths current-lines last? current-best + paper-book page-alist) + "Return the best optimal-page-break-node that contains CURRENT-LINES. DONE-LINES.reversed ++ CURRENT-LINES is a consecutive ascending range of lines, and BEST-PATHS contains the optimal breaks corresponding to DONE-LINES. CURRENT-BEST is the best result sofar, or #f." + (let* ((paper (ly:paper-book-paper paper-book)) + (this-page (make-page + page-alist + 'paper-book paper-book + 'is-last last? + 'page-number (if (null? best-paths) + (ly:output-def-lookup paper 'first-page-number) + (1+ (page-page-number (first best-paths)))))) + (ragged-all? (eq? #t (ly:output-def-lookup paper 'ragged-bottom))) + (ragged-last? (eq? #t (ly:output-def-lookup paper 'ragged-last-bottom))) + (ragged? (or ragged-all? (and ragged-last? last?))) + (height (page-printable-height this-page)) + (vertical-spacing (space-systems height current-lines ragged? paper)) + (satisfied-constraints (car vertical-spacing)) + (force (if satisfied-constraints + (if (and last? ragged-last?) + 0.0 + satisfied-constraints) + 10000)) + (positions (cdr vertical-spacing)) + (get-break-penalty (lambda (sys) + (ly:prob-property sys 'penalty 0.0))) + (user-nobreak-penalties (- (apply + (filter negative? + (map get-break-penalty + (cdr current-lines)))))) + (user-penalty (+ (max (get-break-penalty (car current-lines)) 0.0) + user-nobreak-penalties)) + (total-penalty (combine-penalties + force user-penalty best-paths + (ly:output-def-lookup paper 'between-system-space) + (ly:output-def-lookup paper 'verticalequalizationfactor 0.3))) + (new-best (if (or (not current-best) + (and satisfied-constraints + (< total-penalty (page-penalty current-best)))) + (begin + (map (lambda (x) + (page-set-property! this-page + (car x) + (cdr x))) + (list (cons 'prev (if (null? best-paths) + #f + (car best-paths))) + (cons 'lines current-lines) + (cons 'force force) + (cons 'configuration positions) + (cons 'penalty total-penalty))) + this-page) + current-best))) + (if #f ;; debug + (display + (list + "\nuser pen " user-penalty + "\nsatisfied-constraints" satisfied-constraints + "\nlast? " last? "ragged?" ragged? + "\nis-better " is-better " total-penalty " total-penalty "\n" + "\nconfig " positions + "\nforce " force + "\nlines: " current-lines "\n"))) + (if #f ; debug + (display (list "\nnew-best is " (page-lines new-best) + "\ncontinuation of " + (if (null? best-paths) + "start" + (page-lines (car best-paths)))))) + (if (and (pair? done-lines) + ;; if this page is too full, adding another line won't help + satisfied-constraints) + (walk-paths (cdr done-lines) (cdr best-paths) + (cons (car done-lines) current-lines) + last? new-best + paper-book page-alist) + new-best))) - (let* ((this-page-num (if (null? best-paths) - (ly:output-def-lookup paper 'first-page-number) - (1+ (page-page-number (car best-paths))))) - - (this-page (make-page - page-alist - 'paper-book paper-book - 'is-last last? - 'page-number this-page-num)) - - (ragged-all? (eq? #t (ly:output-def-lookup paper 'ragged-bottom))) - (ragged-last? (eq? #t (ly:output-def-lookup paper 'ragged-last-bottom))) - (ragged? (or ragged-all? - (and ragged-last? - last?))) - (height (page-printable-height this-page)) - (vertical-spacing (space-systems height current-lines ragged?)) - - (satisfied-constraints (car vertical-spacing)) - (force (if satisfied-constraints - (if (and last? ragged-last?) - 0.0 - satisfied-constraints) - 10000)) - (positions (cdr vertical-spacing)) - (get-break-penalty (lambda (sys) - (ly:prob-property sys 'penalty 0.0))) - (user-nobreak-penalties - (- - (apply + (filter negative? - (map get-break-penalty - (cdr current-lines)))))) - (user-penalty - (+ - (max (get-break-penalty (car current-lines)) 0.0) - user-nobreak-penalties)) - - (total-penalty (combine-penalties - force user-penalty - best-paths)) - - (is-better (or - (not current-best) - (and - satisfied-constraints - (< total-penalty (page-penalty current-best))))) - (new-best (if is-better - (begin - (map - (lambda (x) - (page-set-property! this-page - (car x) - (cdr x))) - (list - (cons 'prev (if (null? best-paths) - #f - (car best-paths))) - (cons 'lines current-lines) - (cons 'force force) - (cons 'configuration positions) - (cons 'penalty total-penalty))) - this-page) - current-best))) - -;; (display total-penalty) (newline) - (if #f ;; debug - (display - (list - "\nuser pen " user-penalty - "\nsatisfied-constraints" satisfied-constraints - "\nlast? " last? "ragged?" ragged? - "\nis-better " is-better " total-penalty " total-penalty "\n" - "\nconfig " positions - "\nforce " force - "\nlines: " current-lines "\n"))) - - (if #f ; debug - (display (list "\nnew-best is " (page-lines new-best) - "\ncontinuation of " - (if (null? best-paths) - "start" - (page-lines (car best-paths)))))) - - (if (and (pair? done-lines) - ;; if this page is too full, adding another line won't help - satisfied-constraints) - (walk-paths (cdr done-lines) (cdr best-paths) - (cons (car done-lines) current-lines) - last? new-best) - new-best))) - - (define (walk-lines done best-paths todo) - "Return the best page breaking as a single +(define (walk-lines done best-paths todo paper-book page-alist) + "Return the best page breaking as a single page node for optimally breaking TODO ++ DONE.reversed. BEST-PATHS is a list of break nodes corresponding to DONE." - - (if (null? todo) - (car best-paths) - (let* ((this-line (car todo)) - (last? (null? (cdr todo))) - (next (walk-paths done best-paths (list this-line) last? #f))) - - ;; (display "\n***************") - (walk-lines (cons this-line done) - (cons next best-paths) - (cdr todo))))) - - (define (line-number node) - (ly:prob-property (car (page-lines node)) 'number)) - - (ly:message (_ "Calculating page breaks...")) - (set! force-equalization-factor - (ly:output-def-lookup paper 'verticalequalizationfactor 0.3)) - - (let* ((best-break-node (walk-lines '() '() lines)) - (break-nodes (get-path best-break-node '()))) - - (page-set-property! (car (last-pair break-nodes)) 'is-last #t) - (if #f; (ly:get-option 'verbose) - (begin - (display (list - "\nbreaks: " (map line-number break-nodes)) - "\nsystems " (map page-lines break-nodes) - "\npenalties " (map page-penalty break-nodes) - "\nconfigs " (map page-configuration break-nodes)))) - - ;; construct page stencils. - (for-each page-stencil break-nodes) - (post-process-pages paper break-nodes) - - break-nodes)) + (if (null? todo) + (car best-paths) + (let* ((this-line (car todo)) + (last? (null? (cdr todo))) + (next (walk-paths done best-paths (list this-line) last? #f + paper-book page-alist))) + (walk-lines (cons this-line done) + (cons next best-paths) + (cdr todo) + paper-book + page-alist)))) + +(define-public (optimal-page-breaks lines paper-book) + "Return pages as a list starting with 1st page. Each page is a 'page Prob." + (let* ((paper (ly:paper-book-paper paper-book)) + (page-alist (layout->page-init paper)) + (force-equalization-factor (ly:output-def-lookup + paper 'verticalequalizationfactor 0.3))) + (ly:message (_ "Calculating page breaks...")) + (let* ((best-break-node (walk-lines '() '() lines paper-book page-alist)) + (break-nodes (get-path best-break-node '()))) + (page-set-property! (car (last-pair break-nodes)) 'is-last #t) + (if #f; (ly:get-option 'verbose) + (begin + (display (list + "\nbreaks: " (map (lambda (node) + (ly:prob-property (car (page-lines node)) + 'number)) + break-nodes) + "\nsystems " (map page-lines break-nodes) + "\npenalties " (map page-penalty break-nodes) + "\nconfigs " (map page-configuration break-nodes))))) + ;; construct page stencils. + (for-each page-stencil break-nodes) + (post-process-pages paper break-nodes) + break-nodes))) Index: scm/lily.scm =================================================================== RCS file: /cvsroot/lilypond/lilypond/scm/lily.scm,v retrieving revision 1.399 diff -u -r1.399 lily.scm --- scm/lily.scm 27 May 2006 01:13:06 -0000 1.399 +++ scm/lily.scm 14 Jul 2006 18:44:36 -0000 @@ -263,7 +263,6 @@ "define-grobs.scm" "define-grob-interfaces.scm" "define-stencil-commands.scm" - "layout-page-layout.scm" "titling.scm" "paper.scm"