-;;;; stencil.scm --
+;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2003--2009 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2003--2011 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
(define-public (stack-stencils axis dir padding stils)
- "Stack stencils STILS in direction AXIS, DIR, using PADDING."
+ "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
+@var{padding}."
(cond
((null? stils) empty-stencil)
((null? (cdr stils)) (car stils))
padding))))
(define-public (stack-stencils-padding-list axis dir padding stils)
- "Stack stencils STILS in direction AXIS, DIR, using a list of PADDING."
+ "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
+a list of @var{padding}."
(cond
((null? stils) empty-stencil)
((null? (cdr stils)) (car stils))
(car padding)))))
(define-public (centered-stencil stencil)
- "Center stencil @var{stencil} in both the X and Y directions"
+ "Center stencil @var{stencil} in both the X and Y directions."
(ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
(define-public (stack-lines dir padding baseline stils)
- "Stack vertically with a baseline-skip."
+ "Stack vertically with a baseline skip."
(define result empty-stencil)
(define last-y #f)
(do
((last-stencil #f (car p))
(p stils (cdr p)))
-
+
((null? p))
(if (number? last-y)
(* (- dir) (interval-bound (ly:stencil-extent (car p) Y) (- dir))))
baseline))
(y (+ last-y (* dir dy))))
-
-
-
+
+
+
(set! result
(ly:stencil-add result (ly:stencil-translate-axis (car p) y Y)))
(set! last-y y)))
(set! result (car p)))))
result)
-
-(define-public (bracketify-stencil stil axis thick protusion padding)
- "Add brackets around STIL, producing a new stencil."
+
+(define-public (bracketify-stencil stil axis thick protrusion padding)
+ "Add brackets around @var{stil}, producing a new stencil."
(let* ((ext (ly:stencil-extent stil axis))
- (lb (ly:bracket axis ext thick (- protusion)))
- (rb (ly:bracket axis ext thick protusion)))
+ (lb (ly:bracket axis ext thick protrusion))
+ (rb (ly:bracket axis ext thick (- protrusion))))
(set! stil
- (ly:stencil-combine-at-edge stil (other-axis axis) 1 lb padding))
+ (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
(set! stil
- (ly:stencil-combine-at-edge stil (other-axis axis) -1 rb padding))
+ (ly:stencil-combine-at-edge lb (other-axis axis) 1 stil padding))
stil))
+(define (make-parenthesis-stencil
+ y-extent half-thickness width angularity)
+ "Create a parenthesis stencil.
+@var{y-extent} is the Y extent of the markup inside the parenthesis.
+@var{half-thickness} is the half thickness of the parenthesis.
+@var{width} is the width of a parenthesis.
+The higher the value of number @var{angularity},
+the more angular the shape of the parenthesis."
+ (let* ((line-width 0.1)
+ ;; Horizontal position of baseline that end points run through.
+ (base-x
+ (if (< width 0)
+ (- width)
+ 0))
+ ;; X value farthest from baseline on outside of curve
+ (outer-x (+ base-x width))
+ ;; X extent of bezier sandwich centerline curves
+ (x-extent (ordered-cons base-x outer-x))
+ (bottom-y (interval-start y-extent))
+ (top-y (interval-end y-extent))
+
+ (lower-end-point (cons base-x bottom-y))
+ (upper-end-point (cons base-x top-y))
+
+ (outer-control-x (+ base-x (* 4/3 width)))
+ (inner-control-x (+ outer-control-x
+ (if (< width 0)
+ half-thickness
+ (- half-thickness))))
+
+ ;; Vertical distance between a control point
+ ;; and the end point it connects to.
+ (offset-index (- (* 0.6 angularity) 0.8))
+ (lower-control-y (interval-index y-extent offset-index))
+ (upper-control-y (interval-index y-extent (- offset-index)))
+
+ (lower-outer-control-point
+ (cons outer-control-x lower-control-y))
+ (upper-outer-control-point
+ (cons outer-control-x upper-control-y))
+ (upper-inner-control-point
+ (cons inner-control-x upper-control-y))
+ (lower-inner-control-point
+ (cons inner-control-x lower-control-y)))
+
+ (ly:make-stencil
+ (list 'bezier-sandwich
+ `(quote ,(list
+ ;; Step 4: curve through inner control points
+ ;; to lower end point.
+ upper-inner-control-point
+ lower-inner-control-point
+ lower-end-point
+ ;; Step 3: move to upper end point.
+ upper-end-point
+ ;; Step 2: curve through outer control points
+ ;; to upper end point.
+ lower-outer-control-point
+ upper-outer-control-point
+ upper-end-point
+ ;; Step 1: move to lower end point.
+ lower-end-point))
+ line-width)
+ (interval-widen x-extent (/ line-width 2))
+ (interval-widen y-extent (/ line-width 2)))))
+
+(define-public (parenthesize-stencil
+ stencil half-thickness width angularity padding)
+ "Add parentheses around @var{stencil}, returning a new stencil."
+ (let* ((y-extent (ly:stencil-extent stencil Y))
+ (lp (make-parenthesis-stencil
+ y-extent half-thickness (- width) angularity))
+ (rp (make-parenthesis-stencil
+ y-extent half-thickness width angularity)))
+ (set! stencil (ly:stencil-combine-at-edge lp X RIGHT stencil padding))
+ (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding))
+ stencil))
+
(define-public (make-line-stencil width startx starty endx endy)
- "Make a line stencil of given linewidth and set its extents accordingly"
+ "Make a line stencil of given linewidth and set its extents accordingly."
(let ((xext (cons (min startx endx) (max startx endx)))
(yext (cons (min starty endy) (max starty endy))))
(ly:make-stencil
(list 'draw-line width startx starty endx endy)
- ; Since the line has rounded edges, we have to / can safely add half the
+ ; Since the line has rounded edges, we have to / can safely add half the
; width to all coordinates!
(interval-widen xext (/ width 2))
(interval-widen yext (/ width 2)))))
(define-public (make-filled-box-stencil xext yext)
"Make a filled box."
-
+
(ly:make-stencil
(list 'round-filled-box (- (car xext)) (cdr xext)
(- (car yext)) (cdr yext) 0.0)
xext yext))
(define-public (make-circle-stencil radius thickness fill)
- "Make a circle of radius @var{radius} and thickness @var{thickness}"
+ "Make a circle of radius @var{radius} and thickness @var{thickness}."
(let*
((out-radius (+ radius (/ thickness 2.0))))
-
+
(ly:make-stencil
- (list 'circle radius thickness fill)
+ (list 'circle radius thickness fill)
(cons (- out-radius) out-radius)
(cons (- out-radius) out-radius))))
(define-public (make-oval-stencil x-radius y-radius thickness fill)
- "Make an oval from two Bezier curves, of x radius @var{x-radius},
- y radius @code{y-radius},
- and thickness @var{thickness} with fill defined by @code{fill}."
+ "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius},
+y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill
+defined by @code{fill}."
(let*
- ((x-out-radius (+ x-radius (/ thickness 2.0)))
+ ((x-out-radius (+ x-radius (/ thickness 2.0)))
(y-out-radius (+ y-radius (/ thickness 2.0))) )
-
+
(ly:make-stencil
- (list 'oval x-radius y-radius thickness fill)
+ (list 'oval x-radius y-radius thickness fill)
(cons (- x-out-radius) x-out-radius)
(cons (- y-out-radius) y-out-radius))))
+(define-public
+ (make-partial-ellipse-stencil
+ x-radius y-radius start-angle end-angle thick connect fill)
+
+ (define (make-radius-list x-radius y-radius)
+ (apply append
+ (map (lambda (adder)
+ (map (lambda (quadrant)
+ (cons (+ adder (car quadrant))
+ (cdr quadrant)))
+ `((0.0 . (,x-radius . 0.0))
+ (,PI-OVER-TWO . (0.0 . ,y-radius))
+ (,PI . (,(- x-radius) . 0.0))
+ (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
+ `(0.0 ,TWO-PI))))
+
+ (define
+ (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
+ (define
+ (helper ordering-function value left-list right-list cutl? cutr?)
+ (if (null? right-list)
+ (append
+ (if cutl? '() left-list)
+ (list value)
+ (if cutr? '() right-list))
+ (if (ordering-function value (car right-list))
+ (append
+ (if cutl? '() left-list)
+ (list value)
+ (if cutr? '() right-list))
+ (helper
+ ordering-function
+ value
+ (append left-list (list (car right-list)))
+ (cdr right-list)
+ cutl?
+ cutr?))))
+ (helper ordering-function value '() inlist cutl? cutr?))
+
+ (define (ordering-function-1 a b) (car< a b))
+
+ (define (ordering-function-2 a b) (car<= a b))
+
+ (define (min-max-crawler min-max side l)
+ (reduce min-max
+ (if (eq? min-max min) 100000 -100000)
+ (map (lambda (x) (side x)) l)))
+
+ (let*
+ ((x-out-radius (+ x-radius (/ thick 2.0)))
+ (y-out-radius (+ y-radius (/ thick 2.0)))
+ (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
+ (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
+ (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
+ (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
+ (radius-list (make-radius-list x-out-radius y-out-radius))
+ (rectangular-end-radius (polar->rectangular end-radius end-angle))
+ (rectangular-start-radius (polar->rectangular start-radius start-angle))
+ (new-end-angle
+ (if (<= new-end-angle new-start-angle)
+ (+ TWO-PI new-end-angle)
+ new-end-angle))
+ (possible-extrema
+ (insert-in-ordered-list
+ ordering-function-2
+ (cons new-end-angle rectangular-end-radius)
+ (insert-in-ordered-list
+ ordering-function-1
+ (cons new-start-angle rectangular-start-radius)
+ radius-list
+ #t
+ #f)
+ #f
+ #t)))
+ (ly:make-stencil
+ (list
+ 'partial-ellipse
+ x-radius
+ y-radius
+ start-angle
+ end-angle
+ thick
+ connect
+ fill)
+ (cons (min-max-crawler min cadr possible-extrema)
+ (min-max-crawler max cadr possible-extrema))
+ (cons (min-max-crawler min cddr possible-extrema)
+ (min-max-crawler max cddr possible-extrema)))))
+
+(define (path-min-max origin pointlist)
+
+ (define (line-part-min-max x1 x2)
+ (list (min x1 x2) (max x1 x2)))
+
+ (define (bezier-part-min-max x1 x2 x3 x4)
+ ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
+ (map
+ (lambda (x)
+ (+ (* x1 (expt (- 1 x) 3))
+ (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
+ (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
+ (* x4 (expt x 3))))))
+ (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
+ (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
+ (list 0.0 1.0)
+ (filter
+ (lambda (x) (and (>= x 0) (<= x 1)))
+ (append
+ (list 0.0 1.0)
+ (map (lambda (op)
+ (if (not (eqv? 0.0
+ (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2)))))
+ ;; Zeros of the bezier curve
+ (/ (+ (- x1 (* 2 x2))
+ (op x3
+ (sqrt (- (+ (expt x2 2)
+ (+ (expt x3 2) (* x1 x4)))
+ (+ (* x1 x3)
+ (+ (* x2 x4) (* x2 x3)))))))
+ (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
+ ;; Apply L'hopital's rule to get the zeros if 0/0
+ (* (op 0 1)
+ (/ (/ (- x4 x3) 2)
+ (sqrt (- (+ (* x2 x2)
+ (+ (* x3 x3) (* x1 x4)))
+ (+ (* x1 x3)
+ (+ (* x2 x4) (* x2 x3)))))))))
+ (list + -))))))))
+
+ (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
+ (map (lambda (x)
+ (apply bezier-part-min-max x))
+ `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
+
+ (define (line-min-max x1 y1 x2 y2)
+ (map (lambda (x)
+ (apply line-part-min-max x))
+ `((,x1 ,x2) (,y1 ,y2))))
+
+ ((lambda (x)
+ (list
+ (reduce min +inf.0 (map caar x))
+ (reduce max -inf.0 (map cadar x))
+ (reduce min +inf.0 (map caadr x))
+ (reduce max -inf.0 (map cadadr x))))
+ (map (lambda (x)
+ (if (eq? (length x) 8)
+ (apply bezier-min-max x)
+ (apply line-min-max x)))
+ (map (lambda (x y)
+ (append (list (cadr (reverse x)) (car (reverse x))) y))
+ (append (list origin)
+ (reverse (cdr (reverse pointlist)))) pointlist))))
+
+(define-public (make-connected-path-stencil pointlist thickness
+ x-scale y-scale connect fill)
+ "Make a connected path described by the list @var{pointlist}, with
+thickness @var{thickness}, and scaled by @var{x-scale} in the X direction
+and @var{y-scale} in the Y direction. @var{connect} and @var{fill} are
+boolean arguments that specify if the path should be connected or filled,
+respectively."
+
+ ;; paths using this routine are designed to begin at point '(0 . 0)
+ (let* ((origin (list 0 0))
+ (boundlist (path-min-max origin pointlist))
+ ;; modify pointlist to scale the coordinates
+ (path (map (lambda (x)
+ (apply
+ (if (eq? 6 (length x))
+ (lambda (x1 x2 x3 x4 x5 x6)
+ (list 'curveto
+ (* x1 x-scale)
+ (* x2 y-scale)
+ (* x3 x-scale)
+ (* x4 y-scale)
+ (* x5 x-scale)
+ (* x6 y-scale)))
+ (lambda (x1 x2)
+ (list 'lineto
+ (* x1 x-scale)
+ (* x2 y-scale))))
+ x))
+ pointlist))
+ ;; a path must begin with a `moveto'
+ (prepend-origin (apply list (cons 'moveto origin) path))
+ ;; if this path is connected, add closepath to the end
+ (final-path (if connect
+ (append prepend-origin (list 'closepath))
+ prepend-origin))
+ (command-list (fold-right append '() final-path)))
+
+ (ly:make-stencil
+ `(path ,thickness
+ `(,@',command-list)
+ 'round
+ 'round
+ ,(if fill #t #f))
+ (coord-translate
+ ((if (< x-scale 0) reverse-interval identity)
+ (cons (* x-scale (list-ref boundlist 0))
+ (* x-scale (list-ref boundlist 1))))
+ `(,(/ thickness -2) . ,(/ thickness 2)))
+ (coord-translate
+ ((if (< y-scale 0) reverse-interval identity)
+ (cons (* y-scale (list-ref boundlist 2))
+ (* y-scale (list-ref boundlist 3))))
+ `(,(/ thickness -2) . ,(/ thickness 2))))))
+
(define-public (make-ellipse-stencil x-radius y-radius thickness fill)
- "Make an ellipse of x radius @var{x-radius}, y radius @code{y-radius},
- and thickness @var{thickness} with fill defined by @code{fill}."
+ "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
+@code{y-radius}, and thickness @var{thickness} with fill defined by
+@code{fill}."
(let*
- ((x-out-radius (+ x-radius (/ thickness 2.0)))
+ ((x-out-radius (+ x-radius (/ thickness 2.0)))
(y-out-radius (+ y-radius (/ thickness 2.0))) )
-
+
(ly:make-stencil
- (list 'ellipse x-radius y-radius thickness fill)
+ (list 'ellipse x-radius y-radius thickness fill)
(cons (- x-out-radius) x-out-radius)
(cons (- y-out-radius) y-out-radius))))
(define-public (box-grob-stencil grob)
"Make a box of exactly the extents of the grob. The box precisely
-encloses the contents.
-"
+encloses the contents."
(let* ((xext (ly:grob-extent grob grob 0))
(yext (ly:grob-extent grob grob 1))
(thick 0.01))
(make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
(make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
-;; TODO merge this and prev function.
+;; TODO merge this and prev function.
(define-public (box-stencil stencil thickness padding)
- "Add a box around STENCIL, producing a new stencil."
+ "Add a box around @var{stencil}, producing a new stencil."
(let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
(y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
(y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
(interval-widen x-ext thickness) (cons 0 thickness))))
(set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
(set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
- (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
+ (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
(set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
stencil))
(define-public (circle-stencil stencil thickness padding)
- "Add a circle around STENCIL, producing a new stencil."
+ "Add a circle around @var{stencil}, producing a new stencil."
(let* ((x-ext (ly:stencil-extent stencil X))
(y-ext (ly:stencil-extent stencil Y))
(diameter (max (interval-length x-ext)
- (interval-length y-ext)))
+ (interval-length y-ext)))
(radius (+ (/ diameter 2) padding thickness))
(circle (make-circle-stencil radius thickness #f)))
(interval-center y-ext))))))
(define-public (oval-stencil stencil thickness x-padding y-padding)
- "Add an oval around @code{stencil}, padded by the padding pair,
- producing a new stencil."
+ "Add an oval around @code{stencil}, padded by the padding pair,
+producing a new stencil."
(let* ((x-ext (ly:stencil-extent stencil X))
(y-ext (ly:stencil-extent stencil Y))
(x-length (+ (interval-length x-ext) x-padding thickness))
(interval-center y-ext))))))
(define-public (ellipse-stencil stencil thickness x-padding y-padding)
- "Add an ellipse around STENCIL, padded by the padding pair,
- producing a new stencil."
+ "Add an ellipse around @var{stencil}, padded by the padding pair,
+producing a new stencil."
(let* ((x-ext (ly:stencil-extent stencil X))
(y-ext (ly:stencil-extent stencil Y))
(x-length (+ (interval-length x-ext) x-padding thickness))
(interval-center y-ext))))))
(define-public (rounded-box-stencil stencil thickness padding blot)
- "Add a rounded box around STENCIL, producing a new stencil."
+ "Add a rounded box around @var{stencil}, producing a new stencil."
(let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
(yext (interval-widen (ly:stencil-extent stencil 1) padding))
(ideal-blot (min blot (/ min-ext 2)))
(ideal-thickness (min thickness (/ min-ext 2)))
(outer (ly:round-filled-box
- (interval-widen xext ideal-thickness)
- (interval-widen yext ideal-thickness)
+ (interval-widen xext ideal-thickness)
+ (interval-widen yext ideal-thickness)
ideal-blot))
- (inner (ly:make-stencil (list 'color (x11-color 'white)
- (ly:stencil-expr (ly:round-filled-box
+ (inner (ly:make-stencil (list 'color (x11-color 'white)
+ (ly:stencil-expr (ly:round-filled-box
xext yext (- ideal-blot ideal-thickness)))))))
(set! stencil (ly:stencil-add outer inner))
stencil))
-
-(define-public (fontify-text font-metric text)
- "Set TEXT with font FONT-METRIC, returning a stencil."
- (let* ((b (ly:text-dimension font-metric text)))
- (ly:make-stencil
- `(text ,font-metric ,text) (car b) (cdr b))))
-
-(define-public (fontify-text-white scale font-metric text)
- "Set TEXT with scale factor SCALE"
- (let* ((b (ly:text-dimension font-metric text))
- ;;urg -- workaround for using ps font
- (c `(white-text ,(* 2 scale) ,text)))
- ;;urg -- extent is not from ps font, but we hope it's close
- (ly:make-stencil c (car b) (cdr b))))
-
(define-public (stencil-with-color stencil color)
(ly:make-stencil
(list 'color color (ly:stencil-expr stencil))
(ly:stencil-extent stencil X)
(ly:stencil-extent stencil Y)))
-
+
(define-public (stencil-whiteout stencil)
(let*
((x-ext (ly:stencil-extent stencil X))
(y-ext (ly:stencil-extent stencil Y))
)
-
+
(ly:stencil-add
(stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
white)
stencil)
))
-(define-public (dimension-arrows destination)
- "Draw twosided arrow from here to @var{destination}"
-
+(define-public (arrow-stencil-maker start? end?)
+ "Return a function drawing a line from current point to @code{destination},
+with optional arrows of @code{max-size} on start and end controlled by
+@var{start?} and @var{end?}."
+ (lambda (destination max-size)
(let*
((e_x 1+0i)
(e_y 0+1i)
+ (distance (sqrt (+ (* (car destination) (car destination))
+ (* (cdr destination) (cdr destination)))))
+ (size (min max-size (/ distance 3)))
(rotate (lambda (z ang)
(* (make-polar 1 ang)
z)))
(complex-to-offset (lambda (z)
(list (real-part z) (imag-part z))))
-
+
(z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
(e_z (/ z-dest (magnitude z-dest)))
- (triangle-points '(-1+0.25i
- 0
- -1-0.25i))
+ (triangle-points (list
+ (* size -1+0.25i)
+ 0
+ (* size -1-0.25i)))
(p1s (map (lambda (z)
(+ z-dest (rotate z (angle z-dest))))
triangle-points))
(p2s (map (lambda (z)
(rotate z (angle (- z-dest))))
triangle-points))
- (null (cons 0 0))
- (arrow-1
+ (null (cons 0 0))
+ (arrow-1
(ly:make-stencil
`(polygon (quote ,(concatenate (map complex-to-offset p1s)))
0.0
`(polygon (quote ,(concatenate (map complex-to-offset p2s)))
0.0
#t) null null ) )
- (thickness 0.1)
- (shorten-line 0.5)
+ (thickness (min (/ distance 12) 0.1))
+ (shorten-line (min (/ distance 3) 0.5))
(start (complex-to-offset (/ (* e_z shorten-line) 2)))
(end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
-
+
(line (ly:make-stencil
`(draw-line ,thickness
,(car start) ,(cadr start)
(min 0 (cdr destination)))
(cons (max 0 (car destination))
(max 0 (cdr destination)))))
-
- (result (ly:stencil-add arrow-2 arrow-1 line)))
+ (result
+ (ly:stencil-add
+ (if start? arrow-2 empty-stencil)
+ (if end? arrow-1 empty-stencil)
+ line)))
+
+ result)))
- result))
+(define-public dimension-arrows (arrow-stencil-maker #t #t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ANNOTATIONS
;;
;; annotations are arrows indicating the numerical value of
-;; spacing variables
+;; spacing variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define*-public (annotate-y-interval layout name extent is-length
(define (center-stencil-on-extent stil)
(ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
(cons 0 (interval-center extent))))
- ;; do something sensible for 0,0 intervals.
+ ;; do something sensible for 0,0 intervals.
(set! extent (interval-widen extent 0.001))
(if (not (interval-sane? extent))
(set! annotation (interpret-markup
(else
(ly:format "(~$,~$)"
(car extent) (cdr extent)))))))
- (arrows (ly:stencil-translate-axis
- (dimension-arrows (cons 0 (interval-length extent)))
+ (arrows (ly:stencil-translate-axis
+ (dimension-arrows (cons 0 (interval-length extent)) 1.0)
(interval-start extent) Y)))
(set! annotation
(center-stencil-on-extent text-stencil))
annotation))
+(define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset prev-system-end
+ #:key (base-color blue))
+ (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
+ (space (get-spacing-var 'space))
+ (padding (get-spacing-var 'padding))
+ (min-dist (get-spacing-var 'minimum-distance))
+ (contrast-color (append (cdr base-color) (list (car base-color)))))
+ (stack-stencils X RIGHT 0.0
+ (list
+ (annotate-y-interval layout
+ "space"
+ (cons (- start-Y-offset space) start-Y-offset)
+ #t
+ #:color (map (lambda (x) (* x 0.25)) base-color))
+ (annotate-y-interval layout
+ "min-dist"
+ (cons (- start-Y-offset min-dist) start-Y-offset)
+ #t
+ #:color (map (lambda (x) (* x 0.5)) base-color))
+ (ly:stencil-add
+ (annotate-y-interval layout
+ "bottom-of-extent"
+ (cons prev-system-end start-Y-offset)
+ #t
+ #:color base-color)
+ (annotate-y-interval layout
+ "padding"
+ (cons (- prev-system-end padding) prev-system-end)
+ #t
+ #:color contrast-color))))))
+
+
(define-public (eps-file->stencil axis size file-name)
(let*
((contents (ly:gulp-file file-name))
0))
(scaled-bbox
(map (lambda (x) (* factor x)) bbox))
+ ; We need to shift the whole eps to (0,0), otherwise it will appear
+ ; displaced in lilypond (displacement will depend on the scaling!)
+ (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
(clip-rect-string (ly:format
"~a ~a ~a ~a rectclip"
- (list-ref bbox 0)
- (list-ref bbox 1)
+ (list-ref bbox 0)
+ (list-ref bbox 1)
(- (list-ref bbox 2) (list-ref bbox 0))
(- (list-ref bbox 3) (list-ref bbox 1)))))
-
+
(if bbox
(ly:make-stencil
currentpoint translate
BeginEPSF
~a dup scale
-~a
+~a
+~a
%%BeginDocument: ~a
-" factor clip-rect-string
+" factor translate-string clip-rect-string
file-name
)
EndEPSF
grestore
"))
-
- (cons (list-ref scaled-bbox 0) (list-ref scaled-bbox 2))
- (cons (list-ref scaled-bbox 1) (list-ref scaled-bbox 3)))
-
+ ; Stencil starts at (0,0), since we have shifted the eps, and its
+ ; size is exactly the size of the scaled bounding box
+ (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
+ (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
+
(ly:make-stencil "" '(0 . 0) '(0 . 0)))
))
(begin
(let*
((outname (simple-format #f "~a-~a.signature" basename count)) )
-
+
(ly:message "Writing ~a" outname)
(write-system-signature outname (car paper-systems))
(write-system-signatures basename (cdr paper-systems) (1+ count))))))
(define system-grob
(paper-system-system-grob paper-system))
-
+
(define output (open-output-file filename))
;; todo: optionally use a command line flag? Or just junk this?
(cons (fold-false-pairs first) rest)
rest))
expr))
-
+
(define (raw-string expr)
"escape quotes and slashes for python consumption"
(regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
(define (raw-pair expr)
(simple-format #f "~a ~a"
(car expr) (cdr expr)))
-
+
(define (found-grob expr)
(let*
((grob (car expr))
(for-each (lambda (e) (interpret e)) (cdr expr)))
(else
(collect (fold-false-pairs (strip-floats expr))))
-
+
)))
(interpret expr))
;; should be superfluous, but leaking "too many open files"?
(close-port output))
-
+
projects / lilypond.git / blobdiff