From 1c8bf71154e0b0a126d85154a14d375bc82e251b Mon Sep 17 00:00:00 2001 From: janneke Date: Fri, 11 Jun 2004 18:36:48 +0000 Subject: [PATCH] *** empty log message *** --- scm/page-breaking.scm | 158 +++++++++++++++++------------------------- scm/page-layout.scm | 155 +++++++++++++++++++---------------------- 2 files changed, 136 insertions(+), 177 deletions(-) diff --git a/scm/page-breaking.scm b/scm/page-breaking.scm index 776439b894..39f2a05f32 100644 --- a/scm/page-breaking.scm +++ b/scm/page-breaking.scm @@ -1,6 +1,12 @@ +;;;; page-breaking.scm -- page breaking functions +;;;; +;;;; source file of the GNU LilyPond music typesetter +;;;; +;;;; (c) 2004 Jan Nieuwenhuizen +;;;; Han-Wen Nienhuys + (use-modules (oop goops describe) - (oop goops) - ) + (oop goops)) ;;; optimal page breaking @@ -22,37 +28,25 @@ (lines #:init-value 0 #:accessor node-lines #:init-keyword #:lines)) (define-method (display (node ) port) - (map - (lambda (x) - (display x port)) - - (list - "Page " (node-page-number node) - " Lines: " (node-lines node) - " Penalty " (node-penalty node) - "\n" - ))) - -;; + (map (lambda (x) (display x port)) + (list + "Page " (node-page-number node) + " Lines: " (node-lines node) + " Penalty " (node-penalty node) + "\n"))) + ;; TODO: first-diff and last-diff are slightly arbitrary interface -;; For the future, we might want to invoke a function from PAPER-BOOK to +;; For the future, we might want to invoke a function from PAPER-BOOK to ;; determine available height given -;; -(define-public (ly:optimal-page-breaks lines - paper-book - text-height - first-diff last-diff) - +(define-public (ly:optimal-page-breaks + lines paper-book text-height first-diff last-diff) "Return pages as a list starting with 1st page. Each page is a list of lines. TEXT-HEIGHT is the height of the printable area, FIRST-DIFF and LAST-DIFF are decrements for the 1st and last page. PAPER-BOOK is -unused, at the moment. - -" +unused, at the moment." - (define (make-node prev lines page-num penalty) (make #:prev prev @@ -61,36 +55,29 @@ unused, at the moment. #:penalty penalty)) (define MAXPENALTY 1e9) - + (define (line-height line) (ly:paper-line-extent line Y)) ;; FIXME: may need some tweaking: square, cubic (define (height-penalty available used) ;; FIXME, simplistic - (let* - ((left (- available used)) - - ;; scale independent - (relative-empty (/ left available))) - + (let* ((left (- available used)) + ;; scale-independent + (relative-empty (/ left available))) (if (negative? left) - - ; - ; too full + ;; too full MAXPENALTY - ;; Convexity: two half-empty pages is better than 1 completely ;; empty page (* (1+ relative-empty) relative-empty)))) - (define (page-height page-number last?) (let ((h text-height)) (if (= page-number 1) (set! h (+ h first-diff))) (if last? - (set! h (+ h last-diff))) + (set! h (+ h last-diff))) h)) (define (cumulative-height lines) @@ -102,11 +89,10 @@ is what have collected so far, and has ascending page numbers." (if (is-a? node ) (get-path (node-prev node) (cons node done)) done)) - - + (define (add-penalties . lst) - (if (find negative? lst) ;; todo: rm support for this - -1 + (if (find negative? lst) ;; todo: rm support for this + -1 (apply + lst))) (define (walk-paths done-lines best-paths current-lines last? current-best) @@ -117,85 +103,69 @@ corresponding to DONE-LINES. CURRENT-BEST is the best result sofar, or #f." - (let* - ((this-page-num (if (null? best-paths) - 1 - (1+ (node-page-number (car best-paths))))) - (prev-penalty (if (null? best-paths) - 0.0 - (node-penalty (car best-paths)))) - - (page-height (page-height this-page-num last?)) - (space-used (cumulative-height current-lines)) - - (this-page-penalty (height-penalty page-height space-used)) - (user-penalty (ly:paper-line-break-penalty (car current-lines))) - (total-penalty (add-penalties - user-penalty - this-page-penalty - prev-penalty)) - (better? (or - (not current-best) - (< total-penalty (node-penalty current-best)))) - (new-best (if better? - (make-node (if (null? best-paths) - #f - (car best-paths)) - current-lines - this-page-num total-penalty) - current-best))) - - (if #f ; debug + (let* ((this-page-num (if (null? best-paths) + 1 + (1+ (node-page-number (car best-paths))))) + (prev-penalty (if (null? best-paths) + 0.0 + (node-penalty (car best-paths)))) + (page-height (page-height this-page-num last?)) + (space-used (cumulative-height current-lines)) + (this-page-penalty (height-penalty page-height space-used)) + (user-penalty (ly:paper-line-break-penalty (car current-lines))) + (total-penalty (add-penalties + user-penalty this-page-penalty prev-penalty)) + (better? (or + (not current-best) + (< total-penalty (node-penalty current-best)))) + (new-best (if better? + (make-node (if (null? best-paths) + #f + (car best-paths)) + current-lines + this-page-num total-penalty) + current-best))) + + (if #f ;; debug (display (list "user pen " user-penalty " prev-penalty " prev-penalty "\n" "better? " better? " total-penalty " total-penalty "\n" "height " page-height " spc used: " space-used "\n" - "pen " this-page-penalty " lines: " current-lines "\n"))) - + "pen " this-page-penalty " lines: " current-lines "\n"))) (if (and (pair? done-lines) - ;; if this page is too full, adding another line won't help (< this-page-penalty MAXPENALTY)) - (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 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))) - + (let* ((this-line (car todo)) + (last? (null? (cdr todo))) + (next (walk-paths done best-paths (list this-line) last? #f))) + (walk-lines (cons this-line done) (cons next best-paths) - (cdr todo)) - ))) + (cdr todo))))) (define (line-number node) (ly:paper-line-number (car (node-lines node)))) - (let* - ((best-break-node - (walk-lines '() '() lines)) - (break-nodes (get-path best-break-node '())) - (break-lines (map node-lines break-nodes)) - (break-numbers (map line-number break-nodes))) - + (let* ((best-break-node (walk-lines '() '() lines)) + (break-nodes (get-path best-break-node '())) + (break-lines (map node-lines break-nodes)) + (break-numbers (map line-number break-nodes))) + (if (ly:get-option 'verbose) (begin (format (current-error-port) "breaks: ~S\n" break-numbers) diff --git a/scm/page-layout.scm b/scm/page-layout.scm index 71256d678f..a0cad09496 100644 --- a/scm/page-layout.scm +++ b/scm/page-layout.scm @@ -1,9 +1,9 @@ ;;;; page-layout.scm -- page layout functions ;;;; ;;;; source file of the GNU LilyPond music typesetter -;;;; +;;;; ;;;; (c) 2004 Jan Nieuwenhuizen - +;;;; Han-Wen Nienhuys (define-public (page-properties paper) (list (append `((linewidth . ,(ly:paper-get-number @@ -40,7 +40,7 @@ (define-public (copyright-from-header paper scopes) (let ((props (page-properties paper)) (copyright (ly:modules-lookup scopes 'copyright))) - + (cond ((string? copyright) (if (not (equal? copyright "")) (interpret-markup paper props @@ -49,86 +49,84 @@ ;;;;;;;;;;;;;;;;;; -; titling. + ; titling. (define-public (default-book-title paper scopes) "Generate book title from header strings." - + (define (get sym) (let ((x (ly:modules-lookup scopes sym))) (if (markup? x) x ""))) (define (has sym) (markup? (ly:modules-lookup scopes sym))) - + (let ((props (page-properties paper))) - + (interpret-markup paper props (make-override-markup - '(baseline-skip . 4) - (make-column-markup - (append - (if (has 'dedication) - (list (markup #:fill-line - (#:normalsize (get 'dedication)))) - '()) - - (if (has 'title) - (list (markup (#:fill-line - (#:huge #:bigger #:bigger #:bigger #:bigger #:bold (get 'title))))) + '(baseline-skip . 4) + (make-column-markup + (append + (if (has 'dedication) + (list (markup #:fill-line + (#:normalsize (get 'dedication)))) '()) - - (if (or (has 'subtitle) (has 'subsubtitle)) - (list - (make-override-markup - '(baseline-skip . 3) + (if (has 'title) + (list + (markup (#:fill-line + (#:huge #:bigger #:bigger #:bigger #:bigger #:bold + (get 'title))))) + '()) + (if (or (has 'subtitle) (has 'subsubtitle)) + (list + (make-override-markup + '(baseline-skip . 3) (make-column-markup (list - (markup #:fill-line - (#:large #:bigger #:bigger #:bold (get 'subtitle))) - (markup #:fill-line (#:bigger #:bigger #:bold (get 'subsubtitle))) - (markup #:override '(baseline-skip . 5) - #:column (""))) + (markup #:fill-line + (#:large #:bigger #:bigger #:bold (get 'subtitle))) + (markup #:fill-line (#:bigger #:bigger #:bold (get 'subsubtitle))) + (markup #:override '(baseline-skip . 5) + #:column (""))) )) ) - '()) - - (list - (make-override-markup + '()) + + (list + (make-override-markup '(baseline-skip . 2.5) (make-column-markup - (append - (if (or (has 'poet) (has 'composer)) + (append + (if (or (has 'poet) (has 'composer)) (list (markup #:fill-line (#:bigger (get 'poet) #:large #:bigger #:caps (get 'composer)))) '()) - (if (or (has 'texttranslator) (has 'opus)) - (list - (markup - #:fill-line (#:bigger (get 'texttranslator) #:bigger (get 'opus)))) - '()) - (if (or (has 'meter) (has 'arranger)) - (list - (markup #:fill-line - (#:bigger (get 'meter) #:bigger (get 'arranger)))) - '()) - - (if (has 'instrument) - (list "" - (markup #:fill-line (#:large #:bigger (get 'instrument)))) - '()) - - ;; piece is done in the score-title -; (if (has 'piece) -; (list "" -; (markup #:fill-line (#:large #:bigger #:caps (get 'piece) ""))) -; '()) - - ))))))) - ))) - - + (if (or (has 'texttranslator) (has 'opus)) + (list + (markup + #:fill-line + (#:bigger (get 'texttranslator) #:bigger (get 'opus)))) + '()) + (if (or (has 'meter) (has 'arranger)) + (list + (markup #:fill-line + (#:bigger (get 'meter) #:bigger (get 'arranger)))) + '()) + (if (has 'instrument) + (list + "" + (markup #:fill-line (#:large #:bigger (get 'instrument)))) + '()) +;;; piece is done in the score-title +;;; (if (has 'piece) +;;; (list "" +;;; (markup #:fill-line (#:large #:bigger #:caps (get 'piece) ""))) +;;; '()) + )))))))))) + + (define-public (default-user-title paper markup) "Generate book title from header markup." (if (markup? markup) @@ -139,34 +137,25 @@ (define-public (default-score-title paper scopes) "Generate score title from header strings." - + (define (get sym) (let ((x (ly:modules-lookup scopes sym))) (if (markup? x) x ""))) - + (define (has sym) (markup? (ly:modules-lookup scopes sym))) - + (let ((props (page-properties paper))) - (interpret-markup paper props - (make-override-markup - '(baseline-skip . 4) - (make-column-markup - (append - (if (has 'opus) - (list (markup #:fill-line ("" (get 'opus)))) - '()) - (if (has 'piece) - (list (markup #:fill-line (#:large #:bigger #:caps (get 'piece) ""))) - '())) - - ))))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;NEW;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - + (make-override-markup + '(baseline-skip . 4) + (make-column-markup + (append + (if (has 'opus) + (list (markup #:fill-line ("" (get 'opus)))) + '()) + (if (has 'piece) + (list + (markup #:fill-line (#:large #:bigger #:caps (get 'piece) ""))) + '()))))))) -- 2.39.2