X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;ds=sidebyside;f=scm%2Fstencil.scm;h=678ba7c2e2d8912bd5bbe5a7c9945525ba6b8a8a;hb=c7d8081aeedd9d35cc2131c2e2a4ad34e9265245;hp=4a0a26bd6cd342186fc6150e679d5e69bc541071;hpb=e1a149d0cc60b02e86209387958f4028567dd366;p=lilypond.git diff --git a/scm/stencil.scm b/scm/stencil.scm index 4a0a26bd6c..678ba7c2e2 100644 --- a/scm/stencil.scm +++ b/scm/stencil.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2003--2010 Han-Wen Nienhuys +;;;; Copyright (C) 2003--2012 Han-Wen Nienhuys ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -15,8 +15,33 @@ ;;;; You should have received a copy of the GNU General Public License ;;;; along with LilyPond. If not, see . +(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)) @@ -25,7 +50,8 @@ 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)) @@ -36,11 +62,11 @@ (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 @@ -70,7 +96,7 @@ (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)) @@ -126,26 +152,25 @@ the more angular the shape of the parenthesis." (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) @@ -160,7 +185,7 @@ the more angular the shape of the parenthesis." 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 @@ -180,7 +205,7 @@ the more angular the shape of the parenthesis." 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)))) @@ -190,23 +215,45 @@ the more angular the shape of the parenthesis." (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 x-radius y-radius start-angle end-angle thick connect fill) - + "Create an elliptical arc +@var{x-radius} is the X radius of the arc. +@var{y-radius} is the Y radius of the arc. +@var{start-angle} is the starting angle of the arc in degrees. +@var{end-angle} is the ending angle of the arc in degrees. +@var{thick} is the thickness of the line. +@var{connect} is a boolean flag indicating if the end should +be connected to the start by a line. +@var{fill} is a boolean flag indicating if the shape should be filled." (define (make-radius-list x-radius y-radius) + "Makes a list of angle/radius pairs at intervals of PI/2 for +the partial ellipse until 7*PI/2. For example, in pseudo-code: +> (make-radius-list 2 3) +((0.0 . 2) (PI/2 . 3) (PI . -2) (3*PI/2 . -3) +(2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3)) +" (apply append (map (lambda (adder) (map (lambda (quadrant) @@ -220,6 +267,16 @@ the more angular the shape of the parenthesis." (define (insert-in-ordered-list ordering-function value inlist cutl? cutr?) + "Insert @var{value} in ordered list @var{inlist}. If @var{cutl?}, we +cut away any parts of @var{inlist} before @var{value}. @var{cutr?} works +the same way but for the right side. For example: +> (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #f) +'(1 2 3 4 6 7) +> (insert-in-ordered-list < 4 '(1 2 3 6 7) #t #f) +'(4 6 7) +> (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #t) +'(1 2 3 4) +" (define (helper ordering-function value left-list right-list cutl? cutr?) (if (null? right-list) @@ -246,24 +303,45 @@ the more angular the shape of the parenthesis." (define (ordering-function-2 a b) (car<= a b)) (define (min-max-crawler min-max side l) + "Apply function @var{side} to each member of list and +then reduce using @var{min-max}: +> (min-max-crawler min car '((0 . 3) (-1 . 4) (1 . 2))) +-1 +> (min-max-crawler min cdr '((0 . 3) (-1 . 4) (1 . 2))) +2 +" (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))) + (;; the outside limit of the x-radius + (x-out-radius (+ x-radius (/ thick 2.0))) + ;; the outside limit of the y-radius (y-out-radius (+ y-radius (/ thick 2.0))) + ;; end angle to radians (new-end-angle (angle-0-2pi (degrees->radians end-angle))) + ;; length of the radius at the end angle (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle)) + ;; start angle to radians (new-start-angle (angle-0-2pi (degrees->radians start-angle))) + ;; length of the radius at the start angle (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle)) + ;; points that the arc passes through at 90 degree intervals (radius-list (make-radius-list x-out-radius y-out-radius)) + ;; rectangular coordinates of arc endpoint (rectangular-end-radius (polar->rectangular end-radius end-angle)) + ;; rectangular coordinates of arc begin point (rectangular-start-radius (polar->rectangular start-radius start-angle)) + ;; we want the end angle to always be bigger than the start angle + ;; so we redefine it here just in case it is less (new-end-angle (if (<= new-end-angle new-start-angle) (+ TWO-PI new-end-angle) new-end-angle)) + ;; all the points that may be extrema of the arc + ;; this is the 90 degree points plus the beginning and end points + ;; we use this to calculate extents (possible-extrema (insert-in-ordered-list ordering-function-2 @@ -286,60 +364,63 @@ the more angular the shape of the parenthesis." thick connect fill) + ; we know the extrema points by crawling through the + ; list of possible extrema and finding the min and max + ; for x and y (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 + (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-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)))) +(define (path-min-max origin pointlist) ((lambda (x) (list @@ -348,7 +429,7 @@ the more angular the shape of the parenthesis." (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) @@ -370,7 +451,7 @@ respectively." ;; 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) @@ -392,7 +473,6 @@ respectively." (append prepend-origin (list 'closepath)) prepend-origin)) (command-list (fold-right append '() final-path))) - (ly:make-stencil `(path ,thickness `(,@',command-list) @@ -411,8 +491,9 @@ respectively." `(,(/ 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))) ) @@ -424,8 +505,7 @@ respectively." (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)) @@ -438,7 +518,7 @@ encloses the contents. ;; 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)) @@ -451,7 +531,7 @@ encloses the contents. 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) @@ -468,7 +548,7 @@ encloses the contents. (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)) @@ -485,8 +565,8 @@ encloses the contents. (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)) @@ -507,7 +587,7 @@ encloses the contents. (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)) @@ -544,9 +624,9 @@ encloses the contents. )) (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) @@ -638,7 +718,7 @@ encloses the contents. (markup #:whiteout #:simple (cond ((interval-empty? extent) - (format "empty")) + "empty") (is-length (ly:format "~$" (interval-length extent))) (else @@ -656,43 +736,43 @@ encloses the contents. (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*