From: Han-Wen Nienhuys Date: Tue, 24 Jan 2006 17:40:26 +0000 (+0000) Subject: * scm/stencil.scm (annotate-y-interval): move from layout-page-layout.scm X-Git-Tag: release/2.7.29~25 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=0fa943af67565b567d7f99946b6d3cce9188f830;p=lilypond.git * scm/stencil.scm (annotate-y-interval): move from layout-page-layout.scm * scm/paper-system.scm (paper-system-annotate): new file. Handle paper-system. * scm/layout-page-layout.scm (optimal-page-breaks): move all page handling to page.scm --- diff --git a/scm/layout-page-layout.scm b/scm/layout-page-layout.scm index 5d307da64f..9d7ab8288b 100644 --- a/scm/layout-page-layout.scm +++ b/scm/layout-page-layout.scm @@ -6,422 +6,15 @@ ;;;; Han-Wen Nienhuys (use-modules (oop goops describe) - (oop goops)) + (oop goops) + (scm paper-system) + (scm page) + ) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-class () - (prev #:init-value '() #:accessor node-prev #:init-keyword #:prev) - (page #:init-value 0 #:accessor node-page-number #:init-keyword #:pageno) - (force #:init-value 0 #:accessor node-force #:init-keyword #:force) - (penalty #:init-value 0 #:accessor node-penalty #:init-keyword #:penalty) - (configuration #:init-value '() #:accessor node-configuration #:init-keyword #:configuration) - (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"))) -(define-method (node-system-numbers (node )) - (map (lambda (ps) (ly:prob-property ps 'number)) - (node-lines node))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (annotate? layout) - (eq? #t (ly:output-def-lookup layout 'annotatespacing))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-public (paper-system-staff-extents ps) - (ly:prob-property ps 'refpoint-Y-extent '(0 . 0))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ANNOTATIONS -;; -;; annotations are arrows indicating the numerical value of -;; spacing variables -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (annotate-y-interval layout name extent is-length?) - ;; do something sensible for 0,0 intervals. - (set! extent (interval-widen extent 0.001)) - (let* - ((text-props (cons - '((font-size . -3) - (font-family . typewriter)) - (layout-extract-page-properties layout))) - (annotation (interpret-markup - layout text-props - (make-column-markup - (list - (make-whiteout-markup (make-simple-markup name)) - (make-whiteout-markup - (make-simple-markup - (if is-length? - (format "~$" (interval-length extent)) - (format "(~$,~$)" (car extent) - (cdr extent))))))))) - (arrows - (ly:stencil-translate-axis - (dimension-arrows (cons 0 (interval-length extent))) - (interval-start extent) Y))) - - (set! annotation - (ly:stencil-aligned-to annotation Y CENTER)) - - (set! annotation (ly:stencil-translate annotation - (cons 0 (interval-center extent)))) - - (set! annotation - (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5 0)) - - (set! annotation - (ly:make-stencil (ly:stencil-expr annotation) - (ly:stencil-extent annotation X) - (cons 10000 -10000))) - annotation)) - -(define (paper-system-annotate-last system layout) - (let* - ((bottomspace (ly:prob-property system 'bottom-space)) - (y-extent (paper-system-extent system Y)) - (x-extent (paper-system-extent system X)) - (stencil (ly:prob-property system 'stencil)) - - (arrow (if (number? bottomspace) - (annotate-y-interval layout - "bottom-space" - (cons (- (car y-extent) bottomspace) - (car y-extent)) - #t) - #f))) - - (if arrow - (set! stencil - (ly:stencil-add stencil arrow))) - - (set! (ly:prob-property system 'stencil) - stencil) - )) - -(define (paper-system-annotate system layout) - "Add arrows and texts to indicate which lengths are set." - (let* - ((annotations (ly:make-stencil '() (cons 0 2) (cons 0 0))) - (append-stencil - (lambda (a b) - (ly:stencil-combine-at-edge a X RIGHT b 0.5 0))) - - (annotate-property - (lambda (name extent is-length?) - (set! annotations - (append-stencil annotations - (annotate-y-interval layout - name extent is-length?))))) - - (bbox-extent (paper-system-extent system Y)) - (refp-extent (ly:prob-property system 'refpoint-Y-extent)) - (next-space (ly:prob-property system 'next-space - (ly:output-def-lookup layout 'betweensystemspace) - )) - (next-padding (ly:prob-property system 'next-padding - (ly:output-def-lookup layout 'betweensystempadding) - )) - - ) - - (if (number-pair? bbox-extent) - (begin - (annotate-property "Y-extent" - bbox-extent #f) - (annotate-property "next-padding" - (interval-translate (cons (- next-padding) 0) (car bbox-extent)) - #t))) - - ;; titles don't have a refpoint-Y-extent. - (if (number-pair? refp-extent) - (begin - (annotate-property "refpoint-Y-extent" - refp-extent #f) - - (annotate-property "next-space" - (interval-translate (cons (- next-space) 0) (car refp-extent)) - #t))) - - - - (set! (ly:prob-property system 'stencil) - (ly:stencil-add - (ly:prob-property system 'stencil) - (ly:make-stencil - (ly:stencil-expr annotations) - (ly:stencil-extent empty-stencil X) - (ly:stencil-extent empty-stencil Y) - ))) - - )) - -(define (annotate-page layout stencil) - (let* - ((topmargin (ly:output-def-lookup layout 'topmargin)) - (vsize (ly:output-def-lookup layout 'vsize)) - (bottommargin (ly:output-def-lookup layout 'bottommargin)) - (add-stencil (lambda (y) - (set! stencil - (ly:stencil-add stencil y)) - ))) - - (add-stencil - (ly:stencil-translate-axis - (annotate-y-interval layout "vsize" - (cons (- vsize) 0) - #t) - 1 X)) - - - (add-stencil - (ly:stencil-translate-axis - (annotate-y-interval layout "topmargin" - (cons (- topmargin) 0) - #t) - 2 X)) - - (add-stencil - (ly:stencil-translate-axis - (annotate-y-interval layout "bottommargin" - (cons (- vsize) (- bottommargin vsize)) - #t) - 2 X)) - - stencil)) - -(define (annotate-space-left page-stencil layout bottom-edge) - (let* - ((arrow (annotate-y-interval layout - "space left" - (cons (- bottom-edge) (car (ly:stencil-extent page-stencil Y))) - #t))) - - (set! arrow (ly:stencil-translate-axis arrow 8 X)) - (ly:stencil-add page-stencil arrow))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(define (page-headfoot layout scopes number - sym separation-symbol dir last?) - "Create a stencil including separating space." - - (let* ((header-proc (ly:output-def-lookup layout sym)) - (sep (ly:output-def-lookup layout separation-symbol)) - (stencil (ly:make-stencil "" '(0 . 0) '(0 . 0))) - (head-stencil - (if (procedure? header-proc) - (header-proc layout scopes number last?) - #f)) - ) - - (if (and (number? sep) - (ly:stencil? head-stencil) - (not (ly:stencil-empty? head-stencil))) - - (begin - (set! head-stencil - (ly:stencil-combine-at-edge - stencil Y dir head-stencil - sep 0.0)) - - - ;; add arrow markers - (if (annotate? layout) - (set! head-stencil - (ly:stencil-add - (ly:stencil-translate-axis - (annotate-y-interval layout - (symbol->string separation-symbol) - (cons (min 0 (* dir sep)) - (max 0 (* dir sep))) - #t) - (/ (ly:output-def-lookup layout 'linewidth) 2) - X) - (if (= dir UP) - (ly:stencil-translate-axis - (annotate-y-interval layout - "pagetopspace" - (cons - (- (min 0 (* dir sep)) - (ly:output-def-lookup layout 'pagetopspace)) - (min 0 (* dir sep))) - #t) - (+ 7 (interval-center (ly:stencil-extent head-stencil X))) X) - empty-stencil - ) - head-stencil - )) - ))) - - head-stencil)) - -(define-public (default-page-music-height layout scopes number last?) - "Printable area for music and titles; matches default-page-make-stencil." - (let* ((h (- (ly:output-def-lookup layout 'vsize) - (ly:output-def-lookup layout 'topmargin) - (ly:output-def-lookup layout 'bottommargin))) - - (head (page-headfoot layout scopes number 'make-header 'headsep UP last?)) - (foot (page-headfoot layout scopes number 'make-footer 'footsep DOWN last?)) - (available - (- h (if (ly:stencil? head) - (interval-length (ly:stencil-extent head Y)) - 0) - (if (ly:stencil? foot) - (interval-length (ly:stencil-extent foot Y)) - 0)))) - - ;; (display (list "\n available" available head foot)) - available)) - -(define-public (default-page-make-stencil - lines offsets layout scopes number last?) - "Construct a stencil representing the page from LINES. - - Offsets is a list of increasing numbers. They must be negated to -create offsets. - " - - (let* ((topmargin (ly:output-def-lookup layout 'topmargin)) - - ;; TODO: naming vsize/hsize not analogous to TeX. - - (vsize (ly:output-def-lookup layout 'vsize)) - (hsize (ly:output-def-lookup layout 'hsize)) - - (system-xoffset (ly:output-def-lookup layout 'horizontalshift 0.0)) - (system-separator-markup (ly:output-def-lookup layout 'systemSeparatorMarkup)) - (system-separator-stencil (if (markup? system-separator-markup) - (interpret-markup layout - (layout-extract-page-properties layout) - system-separator-markup) - #f)) - (lmargin (ly:output-def-lookup layout 'leftmargin)) - (leftmargin (if lmargin - lmargin - (/ (- hsize - (ly:output-def-lookup layout 'linewidth)) 2))) - - (rightmargin (ly:output-def-lookup layout 'rightmargin)) - (bottom-edge (- vsize - (ly:output-def-lookup layout 'bottommargin))) - - (head (page-headfoot layout scopes number 'make-header 'headsep UP last?)) - (foot (page-headfoot layout scopes number 'make-footer 'footsep DOWN last?)) - - (head-height (if (ly:stencil? head) - (interval-length (ly:stencil-extent head Y)) - 0.0)) - - (height-proc (ly:output-def-lookup layout 'page-music-height)) - - (page-stencil (ly:make-stencil '() - (cons leftmargin hsize) - (cons (- topmargin) 0))) - (last-system #f) - (last-y 0.0) - (add-to-page (lambda (stencil y) - (set! page-stencil - (ly:stencil-add page-stencil - (ly:stencil-translate stencil - (cons - system-xoffset - (- 0 head-height y topmargin)) - - ))))) - (add-system - (lambda (stencil-position) - (let* ((system (car stencil-position)) - (stencil (paper-system-stencil system)) - (y (cadr stencil-position)) - (is-title (paper-system-title? - (car stencil-position)))) - (add-to-page stencil y) - (if (and (ly:stencil? system-separator-stencil) - last-system - (not (paper-system-title? system)) - (not (paper-system-title? last-system))) - (add-to-page - system-separator-stencil - (average (- last-y - (car (paper-system-staff-extents last-system))) - (- y - (cdr (paper-system-staff-extents system)))))) - (set! last-system system) - (set! last-y y)))) - ) - - - (if (annotate? layout) - (begin - (for-each (lambda (sys) (paper-system-annotate sys layout)) - lines) - (paper-system-annotate-last (car (last-pair lines)) layout))) - - - (if #f - (display (list - "leftmargin " leftmargin "rightmargin " rightmargin - ))) - - (set! page-stencil (ly:stencil-combine-at-edge - page-stencil Y DOWN - (if (and - (ly:stencil? head) - (not (ly:stencil-empty? head))) - head - (ly:make-stencil "" (cons 0 0) (cons 0 0))) - 0. 0.)) - - (map add-system (zip lines offsets)) - - (if (annotate? layout) - (set! - page-stencil - (annotate-space-left page-stencil layout - (- bottom-edge - (if (ly:stencil? foot) - (interval-length (ly:stencil-extent foot Y)) - 0))) - )) - - - (if (and (ly:stencil? foot) - (not (ly:stencil-empty? foot))) - (set! page-stencil - (ly:stencil-add - page-stencil - (ly:stencil-translate - foot - (cons 0 - (+ (- bottom-edge) - (- (car (ly:stencil-extent foot Y))))))))) - - (set! page-stencil - (ly:stencil-translate page-stencil (cons leftmargin 0))) - - ;; annotation. - (if (annotate? layout) - (set! page-stencil (annotate-page layout page-stencil))) - - - page-stencil)) ;;; optimal page breaking @@ -435,36 +28,29 @@ create offsets. ;; - raggedbottom? raggedlastbottom? (define-public (optimal-page-breaks lines paper-book) - "Return pages as a list starting with 1st page. Each page is a list -of lines. " + "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)) (define scopes (ly:paper-book-scopes paper-book)) (define force-equalization-factor #f) - - (define (page-height page-number last?) - (let ((p (ly:output-def-lookup paper 'page-music-height))) - - (if (procedure? p) - (p paper scopes page-number last?) - 10000))) - (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 (is-a? node ) - (get-path (node-prev node) (cons node done)) + (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 - (node-force (car best-paths)))) + (page-force (car best-paths)))) (prev-penalty (if (null? best-paths) 0.0 - (node-penalty (car best-paths)))) + (page-penalty (car best-paths)))) (inter-system-space (ly:output-def-lookup paper 'betweensystemspace)) (relative-force (/ force inter-system-space)) (abs-relative-force (abs relative-force))) @@ -617,15 +203,20 @@ CURRENT-BEST is the best result sofar, or #f." (let* ((this-page-num (if (null? best-paths) (ly:output-def-lookup paper 'firstpagenumber) - (1+ (node-page-number (car best-paths))))) + (1+ (page-page-number (car best-paths))))) + (this-page (make-page + 'paper-book paper-book + 'is-last last? + 'page-number this-page-num)) + (ragged-all? (eq? #t (ly:output-def-lookup paper 'raggedbottom))) (ragged-last? (eq? #t (ly:output-def-lookup paper 'raggedlastbottom))) (ragged? (or ragged-all? (and ragged-last? last?))) - (page-height (page-height this-page-num last?)) - (vertical-spacing (space-systems page-height current-lines ragged?)) + (height (page-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?) @@ -651,17 +242,23 @@ CURRENT-BEST is the best result sofar, or #f." (better? (or (not current-best) - (< total-penalty (node-penalty current-best)))) + (< total-penalty (page-penalty current-best)))) (new-best (if better? - (make - #:prev (if (null? best-paths) - #f - (car best-paths)) - #:lines current-lines - #:pageno this-page-num - #:force force - #:configuration positions - #:penalty total-penalty) + (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) @@ -677,11 +274,11 @@ CURRENT-BEST is the best result sofar, or #f." "\nlines: " current-lines "\n"))) (if #f ; debug - (display (list "\nnew-best is " (node-lines new-best) + (display (list "\nnew-best is " (page-lines new-best) "\ncontinuation of " (if (null? best-paths) "start" - (node-lines (car best-paths)))))) + (page-lines (car best-paths)))))) (if (and (pair? done-lines) ;; if this page is too full, adding another line won't help @@ -693,7 +290,7 @@ CURRENT-BEST is the best result sofar, or #f." (define (walk-lines done best-paths todo) "Return the best page breaking as a single - for optimally breaking TODO ++ +page node for optimally breaking TODO ++ DONE.reversed. BEST-PATHS is a list of break nodes corresponding to DONE." @@ -709,42 +306,27 @@ DONE." (cdr todo))))) (define (line-number node) - (ly:prob-property (car (node-lines node)) 'number)) - + (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 '())) - (last-node (car (last-pair break-nodes)))) - - (define (node->page-stencil node) - (if (not (eq? node last-node)) - (ly:progress "[")) - (let ((stencil - ((ly:output-def-lookup paper 'page-make-stencil) - (node-lines node) - (node-configuration node) - paper - scopes - (node-page-number node) - (eq? node best-break-node)))) - (if (not (eq? node last-node)) - (begin - (ly:progress (number->string - (car (last-pair (node-system-numbers node))))) - (ly:progress "]"))) - stencil)) + ) + + + (set! (page-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 node-lines break-nodes) - "\npenalties " (map node-penalty break-nodes) - "\nconfigs " (map node-configuration break-nodes)))) + "\nsystems " (map page-lines break-nodes) + "\npenalties " (map page-penalty break-nodes) + "\nconfigs " (map page-configuration break-nodes)))) - (let ((stencils (map node->page-stencil break-nodes))) + (let ((stencils (map page-stencil break-nodes))) (ly:progress "\n") stencils))) diff --git a/scm/lily-library.scm b/scm/lily-library.scm index 8a5b28d227..5b42e4f420 100644 --- a/scm/lily-library.scm +++ b/scm/lily-library.scm @@ -1,3 +1,4 @@ +;;;; ;;;; lily-library.scm -- utilities ;;;; ;;;; source file of the GNU LilyPond music typesetter @@ -117,16 +118,6 @@ )) -(define-public (paper-system-title? system) - (equal? #t (ly:prob-property system 'is-title) - )) - -(define-public (paper-system-stencil system) - (ly:prob-property system 'stencil)) - -(define-public (paper-system-extent system axis) - (ly:stencil-extent (paper-system-stencil system) axis)) - ;;;;;;;;;;;;;;;; ;; alist (define-public assoc-get ly:assoc-get) diff --git a/scm/page.scm b/scm/page.scm new file mode 100644 index 0000000000..aff8dfa67e --- /dev/null +++ b/scm/page.scm @@ -0,0 +1,373 @@ +;; +;; page.scm -- implement Page stuff. +;; +;; source file of the GNU LilyPond music typesetter +;; +;; (c) 2006 Han-Wen Nienhuys +;; + +(define-module (scm page) + + #:export (make-page + page-property + page-set-property! + page-prev + page-height + page-lines + page-force + page-penalty + page-configuration + page-lines + page-page-number + page-system-numbers + page-stencil + page? + )) + +(use-modules (lily) + (scm paper-system) + (srfi srfi-1)) + + +(define (annotate? layout) + (eq? #t (ly:output-def-lookup layout 'annotatespacing))) + + +(define page-module (current-module)) + +(define (make-page . args) + (apply ly:make-prob (append + (list 'page '()) + args))) + +(define page-property ly:prob-property) +(define (page-property? page sym) + (eq? #t (page-property page sym))) + +(define (page? x) (ly:prob-type? x 'page)) + +(define page-set-property! ly:prob-set-property!) + +;; define accessors. +(for-each + (lambda (j) + (module-define! + page-module + (string->symbol (format "page-~a" j)) + (lambda (pg) + (page-property pg j)))) + + '(page-number prev lines force penalty configuration lines)) + +(define (page-system-numbers node) + (map (lambda (ps) (ly:prob-property ps 'number)) + (page-lines node))) + + + +(define (annotate-page stencil layout) + (let* + ((topmargin (ly:output-def-lookup layout 'topmargin)) + (vsize (ly:output-def-lookup layout 'vsize)) + (bottommargin (ly:output-def-lookup layout 'bottommargin)) + (add-stencil (lambda (y) + (set! stencil + (ly:stencil-add stencil y)) + ))) + + (add-stencil + (ly:stencil-translate-axis + (annotate-y-interval layout "vsize" + (cons (- vsize) 0) + #t) + 1 X)) + + + (add-stencil + (ly:stencil-translate-axis + (annotate-y-interval layout "topmargin" + (cons (- topmargin) 0) + #t) + 2 X)) + + (add-stencil + (ly:stencil-translate-axis + (annotate-y-interval layout "bottommargin" + (cons (- vsize) (- bottommargin vsize)) + #t) + 2 X)) + + stencil)) + +(define (annotate-space-left page-stencil layout bottom-edge) + (let* + ((arrow (annotate-y-interval layout + "space left" + (cons (- bottom-edge) (car (ly:stencil-extent page-stencil Y))) + #t))) + + (set! arrow (ly:stencil-translate-axis arrow 8 X)) + (ly:stencil-add page-stencil arrow))) + + + + +(define (page-headfoot layout scopes number + sym separation-symbol dir last?) + + "Create a stencil including separating space." + + (let* ((header-proc (ly:output-def-lookup layout sym)) + (sep (ly:output-def-lookup layout separation-symbol)) + (stencil (ly:make-stencil "" '(0 . 0) '(0 . 0))) + (head-stencil + (if (procedure? header-proc) + (header-proc layout scopes number last?) + #f)) + ) + + (if (and (number? sep) + (ly:stencil? head-stencil) + (not (ly:stencil-empty? head-stencil))) + + (begin + (set! head-stencil + (ly:stencil-combine-at-edge + stencil Y dir head-stencil + sep 0.0)) + + + ;; add arrow markers + (if (annotate? layout) + (set! head-stencil + (ly:stencil-add + (ly:stencil-translate-axis + (annotate-y-interval layout + (symbol->string separation-symbol) + (cons (min 0 (* dir sep)) + (max 0 (* dir sep))) + #t) + (/ (ly:output-def-lookup layout 'linewidth) 2) + X) + (if (= dir UP) + (ly:stencil-translate-axis + (annotate-y-interval layout + "pagetopspace" + (cons + (- (min 0 (* dir sep)) + (ly:output-def-lookup layout 'pagetopspace)) + (min 0 (* dir sep))) + #t) + (+ 7 (interval-center (ly:stencil-extent head-stencil X))) X) + empty-stencil + ) + head-stencil + )) + ))) + + head-stencil)) + +(define (page-header-or-footer page dir) + (let* + ((p-book (page-property page 'paper-book)) + (layout (ly:paper-book-paper p-book)) + (scopes (ly:paper-book-scopes p-book)) + (lines (page-lines page)) + (offsets (page-configuration page)) + (number (page-page-number page)) + (last? (page-property page 'is-last)) + + ) + + (page-headfoot layout scopes number + (if (= dir UP) + 'make-header + 'make-footer) + (if (= dir UP) + 'headsep + 'footsep) + dir last?))) + +(define (page-footer page) + (page-header-or-footer page UP)) + +(define (page-header page) + (page-header-or-footer page DOWN)) + +(define (make-page-stencil page) + "Construct a stencil representing the page from LINES. + + Offsets is a list of increasing numbers. They must be negated to +create offsets. + " + + (let* + ((p-book (page-property page 'paper-book)) + (layout (ly:paper-book-paper p-book)) + (scopes (ly:paper-book-scopes p-book)) + (lines (page-lines page)) + (offsets (page-configuration page)) + (number (page-page-number page)) + (last? (page-property page 'is-last)) + + (topmargin (ly:output-def-lookup layout 'topmargin)) + + ;; TODO: naming vsize/hsize not analogous to TeX. + + (vsize (ly:output-def-lookup layout 'vsize)) + (hsize (ly:output-def-lookup layout 'hsize)) + + (system-xoffset (ly:output-def-lookup layout 'horizontalshift 0.0)) + (system-separator-markup (ly:output-def-lookup layout 'systemSeparatorMarkup)) + (system-separator-stencil (if (markup? system-separator-markup) + (interpret-markup layout + (layout-extract-page-properties layout) + system-separator-markup) + #f)) + (lmargin (ly:output-def-lookup layout 'leftmargin)) + (leftmargin (if lmargin + lmargin + (/ (- hsize + (ly:output-def-lookup layout 'linewidth)) 2))) + + (rightmargin (ly:output-def-lookup layout 'rightmargin)) + (bottom-edge (- vsize + (ly:output-def-lookup layout 'bottommargin))) + + (head (page-header page)) + + (foot (page-footer page)) + + (head-height (if (ly:stencil? head) + (interval-length (ly:stencil-extent head Y)) + 0.0)) + + (height-proc (ly:output-def-lookup layout 'page-music-height)) + + (page-stencil (ly:make-stencil '() + (cons leftmargin hsize) + (cons (- topmargin) 0))) + (last-system #f) + (last-y 0.0) + (add-to-page (lambda (stencil y) + (set! page-stencil + (ly:stencil-add page-stencil + (ly:stencil-translate stencil + (cons + system-xoffset + (- 0 head-height y topmargin)) + + ))))) + (add-system + (lambda (stencil-position) + (let* ((system (car stencil-position)) + (stencil (paper-system-stencil system)) + (y (cadr stencil-position)) + (is-title (paper-system-title? + (car stencil-position)))) + (add-to-page stencil y) + (if (and (ly:stencil? system-separator-stencil) + last-system + (not (paper-system-title? system)) + (not (paper-system-title? last-system))) + (add-to-page + system-separator-stencil + (average (- last-y + (car (paper-system-staff-extents last-system))) + (- y + (cdr (paper-system-staff-extents system)))))) + (set! last-system system) + (set! last-y y)))) + ) + + + (if (annotate? layout) + (begin + (for-each (lambda (sys) (paper-system-annotate sys layout)) + lines) + (paper-system-annotate-last (car (last-pair lines)) layout))) + + + (if #f + (display (list + "leftmargin " leftmargin "rightmargin " rightmargin + ))) + + (set! page-stencil (ly:stencil-combine-at-edge + page-stencil Y DOWN + (if (and + (ly:stencil? head) + (not (ly:stencil-empty? head))) + head + (ly:make-stencil "" (cons 0 0) (cons 0 0))) + 0. 0.)) + + (map add-system (zip lines offsets)) + + (if (annotate? layout) + (set! + page-stencil + (annotate-space-left page-stencil layout + (- bottom-edge + (if (ly:stencil? foot) + (interval-length (ly:stencil-extent foot Y)) + 0))) + )) + + + (if (and (ly:stencil? foot) + (not (ly:stencil-empty? foot))) + (set! page-stencil + (ly:stencil-add + page-stencil + (ly:stencil-translate + foot + (cons 0 + (+ (- bottom-edge) + (- (car (ly:stencil-extent foot Y))))))))) + + (set! page-stencil + (ly:stencil-translate page-stencil (cons leftmargin 0))) + + ;; annotation. + (if (annotate? layout) + (set! page-stencil (annotate-page layout page-stencil))) + + + page-stencil)) + + + +(define (page-stencil page) + (if (not (ly:stencil? (page-property page 'stencil))) + + ;; todo: make tweakable. + ;; via property + callbacks. + + (page-set-property! page 'stencil (make-page-stencil page))) + (page-property page 'stencil)) + +(define (page-height page) + "Printable area for music and titles; matches default-page-make-stencil." + (let* + ((p-book (page-property page 'paper-book)) + (layout (ly:paper-book-paper p-book)) + (scopes (ly:paper-book-scopes p-book)) + (number (page-page-number page)) + (last? (page-property page 'is-last)) + (h (- (ly:output-def-lookup layout 'vsize) + (ly:output-def-lookup layout 'topmargin) + (ly:output-def-lookup layout 'bottommargin))) + + (head (page-headfoot layout scopes number 'make-header 'headsep UP last?)) + (foot (page-headfoot layout scopes number 'make-footer 'footsep DOWN last?)) + (available + (- h (if (ly:stencil? head) + (interval-length (ly:stencil-extent head Y)) + 0) + (if (ly:stencil? foot) + (interval-length (ly:stencil-extent foot Y)) + 0)))) + + ;; (display (list "\n available" available head foot)) + available)) diff --git a/scm/paper-system.scm b/scm/paper-system.scm new file mode 100644 index 0000000000..e72795516e --- /dev/null +++ b/scm/paper-system.scm @@ -0,0 +1,104 @@ +;; +;; paper-system.scm -- implement paper-system objects. +;; +;; source file of the GNU LilyPond music typesetter +;; +;; (c) 2006 Han-Wen Nienhuys +;; + +(define-module (scm paper-system)) + +(use-modules (lily)) + +(define-public (paper-system-title? system) + (equal? #t (ly:prob-property system 'is-title) + )) + +(define-public (paper-system-stencil system) + (ly:prob-property system 'stencil)) + +(define-public (paper-system-extent system axis) + (ly:stencil-extent (paper-system-stencil system) axis)) + +(define-public (paper-system-staff-extents ps) + (ly:prob-property ps 'refpoint-Y-extent '(0 . 0))) + +(define-public (paper-system-annotate-last system layout) + (let* + ((bottomspace (ly:prob-property system 'bottom-space)) + (y-extent (paper-system-extent system Y)) + (x-extent (paper-system-extent system X)) + (stencil (ly:prob-property system 'stencil)) + + (arrow (if (number? bottomspace) + (annotate-y-interval layout + "bottom-space" + (cons (- (car y-extent) bottomspace) + (car y-extent)) + #t) + #f))) + + (if arrow + (set! stencil + (ly:stencil-add stencil arrow))) + + (set! (ly:prob-property system 'stencil) + stencil) + )) + +(define-public (paper-system-annotate system layout) + "Add arrows and texts to indicate which lengths are set." + (let* + ((annotations (ly:make-stencil '() (cons 0 2) (cons 0 0))) + (append-stencil + (lambda (a b) + (ly:stencil-combine-at-edge a X RIGHT b 0.5 0))) + + (annotate-property + (lambda (name extent is-length?) + (set! annotations + (append-stencil annotations + (annotate-y-interval layout + name extent is-length?))))) + + (bbox-extent (paper-system-extent system Y)) + (refp-extent (ly:prob-property system 'refpoint-Y-extent)) + (next-space (ly:prob-property system 'next-space + (ly:output-def-lookup layout 'betweensystemspace) + )) + (next-padding (ly:prob-property system 'next-padding + (ly:output-def-lookup layout 'betweensystempadding) + )) + + ) + + (if (number-pair? bbox-extent) + (begin + (annotate-property "Y-extent" + bbox-extent #f) + (annotate-property "next-padding" + (interval-translate (cons (- next-padding) 0) (car bbox-extent)) + #t))) + + ;; titles don't have a refpoint-Y-extent. + (if (number-pair? refp-extent) + (begin + (annotate-property "refpoint-Y-extent" + refp-extent #f) + + (annotate-property "next-space" + (interval-translate (cons (- next-space) 0) (car refp-extent)) + #t))) + + + + (set! (ly:prob-property system 'stencil) + (ly:stencil-add + (ly:prob-property system 'stencil) + (ly:make-stencil + (ly:stencil-expr annotations) + (ly:stencil-extent empty-stencil X) + (ly:stencil-extent empty-stencil Y) + ))) + + )) diff --git a/scm/stencil.scm b/scm/stencil.scm index 1aff0c12ff..d0e220d26b 100644 --- a/scm/stencil.scm +++ b/scm/stencil.scm @@ -169,3 +169,49 @@ encloses the contents. result)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ANNOTATIONS +;; +;; annotations are arrows indicating the numerical value of +;; spacing variables +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-public (annotate-y-interval layout name extent is-length?) + ;; do something sensible for 0,0 intervals. + (set! extent (interval-widen extent 0.001)) + (let* + ((text-props (cons + '((font-size . -3) + (font-family . typewriter)) + (layout-extract-page-properties layout))) + (annotation (interpret-markup + layout text-props + (make-column-markup + (list + (make-whiteout-markup (make-simple-markup name)) + (make-whiteout-markup + (make-simple-markup + (if is-length? + (format "~$" (interval-length extent)) + (format "(~$,~$)" (car extent) + (cdr extent))))))))) + (arrows + (ly:stencil-translate-axis + (dimension-arrows (cons 0 (interval-length extent))) + (interval-start extent) Y))) + + (set! annotation + (ly:stencil-aligned-to annotation Y CENTER)) + + (set! annotation (ly:stencil-translate annotation + (cons 0 (interval-center extent)))) + + (set! annotation + (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5 0)) + + (set! annotation + (ly:make-stencil (ly:stencil-expr annotation) + (ly:stencil-extent annotation X) + (cons 10000 -10000))) + annotation))