;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
-;;;; Copyright (C) 2003--2010 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2003--2012 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
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
+(define (make-bezier-sandwich-stencil coords thick xext yext)
+ (let* ((command-list `(moveto
+ ,(car (list-ref coords 3))
+ ,(cdr (list-ref coords 3))
+ curveto
+ ,(car (list-ref coords 0))
+ ,(cdr (list-ref coords 0))
+ ,(car (list-ref coords 1))
+ ,(cdr (list-ref coords 1))
+ ,(car (list-ref coords 2))
+ ,(cdr (list-ref coords 2))
+ curveto
+ ,(car (list-ref coords 4))
+ ,(cdr (list-ref coords 4))
+ ,(car (list-ref coords 5))
+ ,(cdr (list-ref coords 5))
+ ,(car (list-ref coords 6))
+ ,(cdr (list-ref coords 6))
+ closepath)))
+ (ly:make-stencil
+ `(path ,thick `(,@' ,command-list) 'round 'round #t)
+ xext
+ yext)))
+
(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
(define-public (bracketify-stencil stil axis thick protrusion padding)
- "Add brackets around STIL, producing a new stencil."
+ "Add brackets around @var{stil}, producing a new stencil."
(let* ((ext (ly:stencil-extent stil axis))
(lb (ly:bracket axis ext thick protrusion))
(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)))))
+ (make-bezier-sandwich-stencil
+ (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)
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
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))))
(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)))
- (y-out-radius (+ y-radius (/ thickness 2.0))) )
-
+ (y-out-radius (+ y-radius (/ thickness 2.0)))
+ (x-max x-radius)
+ (x-min (- x-radius))
+ (y-max y-radius)
+ (y-min (- y-radius))
+ (commands `(,(list 'moveto x-max 0)
+ ,(list 'curveto x-max y-max x-min y-max x-min 0)
+ ,(list 'curveto x-min y-min x-max y-min x-max 0)
+ ,(list 'closepath)))
+ (command-list (fold-right append '() commands)))
(ly:make-stencil
- (list 'oval x-radius y-radius thickness fill)
- (cons (- x-out-radius) x-out-radius)
- (cons (- y-out-radius) y-out-radius))))
+ `(path ,thickness `(,@',command-list) 'round 'round ,fill)
+ (cons (- x-out-radius) x-out-radius)
+ (cons (- y-out-radius) y-out-radius))))
(define-public
(make-partial-ellipse-stencil
(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-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
+ (exact->inexact (- (+ 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))))
- (define (line-min-max x1 y1 x2 y2)
- (map (lambda (x)
- (apply line-part-min-max x))
- `((,x1 ,x2) (,y1 ,y2))))
+(define (path-min-max origin pointlist)
((lambda (x)
(list
(reduce min +inf.0 (map caadr x))
(reduce max -inf.0 (map cadadr x))))
(map (lambda (x)
- (if (eq? (length x) 8)
+ (if (= (length x) 8)
(apply bezier-min-max x)
(apply line-min-max x)))
(map (lambda (x y)
;; modify pointlist to scale the coordinates
(path (map (lambda (x)
(apply
- (if (eq? 6 (length x))
+ (if (= 6 (length x))
(lambda (x1 x2 x3 x4 x5 x6)
(list 'curveto
(* x1 x-scale)
(append prepend-origin (list 'closepath))
prepend-origin))
(command-list (fold-right append '() final-path)))
-
(ly:make-stencil
`(path ,thickness
`(,@',command-list)
`(,(/ 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)))
(y-out-radius (+ y-radius (/ thickness 2.0))) )
(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))
;; 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))
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)
(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."
+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))
))
(define-public (arrow-stencil-maker start? end?)
- "Returns a function drawing a line from current point to @var{destination},
- with optional arrows of @var{max-size} on start and end controlled by
- @var{start?} and @var{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)
(markup #:whiteout
#:simple (cond
((interval-empty? extent)
- (format "empty"))
+ "empty")
(is-length
(ly:format "~$" (interval-length extent)))
(else
(center-stencil-on-extent dim-stencil)
0.5))
(set! annotation
- (ly:make-stencil (list 'color color (ly:stencil-expr annotation))
- (ly:stencil-extent annotation X)
- (cons 10000 -10000)))))
+ (stencil-with-color annotation color))))
annotation))
-(define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset prev-system-end
+;; TODO: figure out how to annotate padding nicely
+;; TODO: emphasize either padding or min-dist depending on which constraint was active
+(define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset next-staff-Y
#:key (base-color blue))
- (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
- (space (get-spacing-var 'space))
+ (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
+ (space (get-spacing-var 'basic-distance))
(padding (get-spacing-var 'padding))
(min-dist (get-spacing-var 'minimum-distance))
- (contrast-color (append (cdr base-color) (list (car base-color)))))
+ (contrast-color (append (cdr base-color) (list (car base-color))))
+ (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
+ (min-dist-color (if min-dist-blocks contrast-color base-color))
+ (basic-annotation (annotate-y-interval layout
+ "basic-dist"
+ (cons (- start-Y-offset space) start-Y-offset)
+ #t
+ #:color (map (lambda (x) (* x 0.25)) base-color)))
+ (min-annotation (annotate-y-interval layout
+ "min-dist"
+ (cons (- start-Y-offset min-dist) start-Y-offset)
+ #t
+ #:color min-dist-color))
+ (extra-annotation (annotate-y-interval layout
+ "extra dist"
+ (cons next-staff-Y (- start-Y-offset min-dist))
+ #t
+ #:color (map (lambda (x) (* x 0.5)) min-dist-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))))))
-
+ basic-annotation
+ (if min-dist-blocks
+ min-annotation
+ (ly:stencil-add min-annotation extra-annotation))))))
(define-public (eps-file->stencil axis size file-name)
(let*
projects / lilypond.git / blobdiff