;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
(use-modules (oop goops describe)
- (oop goops))
+ (oop goops)
+ (scm paper-system)
+ (scm page)
+ )
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-class <optimally-broken-page-node> ()
- (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 <optimally-broken-page-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 <optimally-broken-page-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)))
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(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
;; - 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 <optimally-broken-page-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)))
(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?)
(better? (or
(not current-best)
- (< total-penalty (node-penalty current-best))))
+ (< total-penalty (page-penalty current-best))))
(new-best (if better?
- (make <optimally-broken-page-node>
- #: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)
"\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
(define (walk-lines done best-paths todo)
"Return the best page breaking as a single
-<optimal-page-break-node> for optimally breaking TODO ++
+page node for optimally breaking TODO ++
DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
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)))
--- /dev/null
+;;
+;; page.scm -- implement Page stuff.
+;;
+;; source file of the GNU LilyPond music typesetter
+;;
+;; (c) 2006 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;
+
+(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)))
+
+\f
+
+
+(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))
projects / lilypond.git / commitdiff