suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Subdivide nonlinearly transformed 3D shapes

Browse Source 
Detect possible nonconvergence in plot bounds fixpoint calculation
Collapse nearby 3D ticks
This commit is contained in:
Neil Toronto 2011-11-02 18:16:00 -06:00
parent 639ec15125
commit 4ae9ecf28e
14 changed files with 369 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/plot/common/area.rkt
View File

@ -547,7 +547,7 @@
;; ===============================================================================================
;; Legend
(define/public (draw-legend legend-entries x-min x-max y-min y-max)
(define/public (draw-legend-box legend-entries x-min x-max y-min y-max)
(define n (length legend-entries))
(match-define (list (legend-entry labels draws) ...) legend-entries)

45
collects/plot/common/math.rkt
View File

@ -209,6 +209,14 @@
[_ (raise-type-error 'vcross "vector of 3 reals" 1 v1 v2)])]
[_ (raise-type-error 'vcross "vector of 3 reals" 0 v1 v2)]))
(defproc (vcross2 [v1 (vector/c real? real?)] [v2 (vector/c real? real?)]) real?
(match v1
[(vector (? real? x1) (? real? y1))
(match v2
[(vector (? real? x2) (? real? y2)) (- (* x1 y2) (* y1 x2))]
[_ (raise-type-error 'vcross "vector of 2 reals" 1 v1 v2)])]
[_ (raise-type-error 'vcross "vector of 2 reals" 0 v1 v2)]))
(define-syntax-rule (vmap name f v)
(let ()
(unless (vector? v)
@ -313,6 +321,11 @@
(raise-type-error 'vdot "vector of real" 1 v1 v2))
(raise-type-error 'vdot "vector of real" 0 v1 v2)))]))
(defproc (vcos-angle [v1 (vectorof real?)] [v2 (vectorof real?)]) real?
(define d (vdot v1 v2))
(cond [(= d 0) 0]
[else (/ d (vmag v1) (vmag v2))]))
(define-syntax-rule (unsafe-flspecial? x)
(or (unsafe-fl= x +inf.0) (unsafe-fl= x -inf.0) (eqv? x +nan.0)))
@ -391,7 +404,7 @@
[else
(let*-values ([(last vs)
(for/fold ([last (first vs)] [vs (list (first vs))])
([v (in-list (rest vs))])
([v (in-list (rest vs))])
(cond [(v= last v) (values v vs)]
[else (values v (cons v vs))]))]
[(vs) (reverse vs)])
@ -408,11 +421,20 @@
(for ([v1 (in-list vs)]
[v2 (in-list (rest vs))]
[v3 (in-list (rest (rest vs)))])
(define n (vcross (v- v3 v2) (v- v1 v2)))
(define m (vmag^2 n))
(when (m . > . 0)
(break (v/ n (sqrt m)))))
default-normal))])))
(define norm (vcross (v- v3 v2) (v- v1 v2)))
(define m (vmag norm))
(when (m . > . 0) (break (v/ norm m))))
default-normal)
#;
(begin
(define n
(for/fold ([norm (vector 0 0 0)])
([v1 (in-list vs)]
[v2 (in-list (rest vs))]
[v3 (in-list (rest (rest vs)))])
(v+ norm (vcross (v- v3 v2) (v- v1 v2)))))
(define m (vmag norm))
(if (= m 0) default-normal (v/ norm m))))])))
;; ===================================================================================================
;; Intervals
@ -449,6 +471,10 @@
(match-define (ivl a b) i)
(and a b (= a b)))
(defproc (ivl-length [i ivl?]) (or/c real? #f)
(match-define (ivl a b) i)
(if (and a b) (- b a) #f))
(defproc (ivl-zero-length? [i ivl?]) boolean?
(or (ivl-empty? i) (ivl-singular? i)))
@ -548,6 +574,13 @@
(defproc (rect-regular? [r (vectorof ivl?)]) boolean?
(vector-andmap ivl-regular? r))
(defproc (rect-area [r (vectorof ivl?)]) (or/c real? #f)
(let/ec break
(for/fold ([area 1]) ([i (in-vector r)])
(define len (ivl-length i))
(when (or (not len) (zero? len)) (break len))
(* area (ivl-length i)))))
(defproc (rect-zero-area? [r (vectorof ivl?)]) boolean?
(vector-ormap ivl-zero-length? r))

24
collects/plot/common/plot-element.rkt
View File

@ -96,13 +96,23 @@
;; Objective: find the fixpoint of F starting at plot-bounds-rect
(define (F bounds-rect) (rect-meet plot-bounds-rect (apply-bounds* elems bounds-rect)))
;; Iterate joint bounds to (hopefully) a fixpoint
(for/fold ([bounds-rect plot-bounds-rect]) ([n (in-range max-iters)])
;(printf "bounds-rect = ~v~n" bounds-rect)
;; Get new bounds from the elements' bounds functions
(define new-bounds-rect (F bounds-rect))
;; Shortcut eval: if the bounds haven't changed, we have a fixpoint
(cond [(equal? bounds-rect new-bounds-rect) (break bounds-rect)]
[else new-bounds-rect]))))
(define-values (bounds-rect area delta-area)
(for/fold ([bounds-rect plot-bounds-rect]
[area (rect-area plot-bounds-rect)] [delta-area #f]
) ([n (in-range max-iters)])
;(printf "bounds-rect = ~v~n" bounds-rect)
;; Get new bounds from the elements' bounds functions
(define new-bounds-rect (F bounds-rect))
(define new-area (rect-area new-bounds-rect))
(define new-delta-area (and area new-area (- new-area area)))
(cond
;; Shortcut eval: if the bounds haven't changed, we have a fixpoint
[(equal? bounds-rect new-bounds-rect) (break bounds-rect)]
;; If the area grew more this iteration than last, it may not converge, so stop now
[(and delta-area new-delta-area (new-delta-area . > . delta-area)) (break bounds-rect)]
;; All good - one more iteration
[else (values new-bounds-rect new-area new-delta-area)])))
bounds-rect))
;; Applies the bounds functions of multiple plot elements, in parallel, and returns the smallest
;; bounds containing all the new bounds. This function is monotone and increasing regardless of

18
collects/plot/common/ticks.rkt
View File

@ -620,3 +620,21 @@
(defproc (linear-scale [m real?] [b real? 0]) invertible-function?
(invertible-function (λ (x) (+ (* m x) b))
(λ (y) (/ (- y b) m))))
;; ===================================================================================================
;; Tick utils
(defproc (collapse-nearby-ticks [ts (listof tick?)]
[near? (tick? tick? . -> . boolean?)]
[format-string string? "~a|~a"]) (listof tick?)
(let* ([ts (remove-duplicates (filter pre-tick-major? ts) #:key pre-tick-value)]
[ts (sort ts < #:key pre-tick-value)])
(append*
(for/list ([ts (in-list (group-neighbors ts near?))])
(define n (length ts))
(cond [(n . <= . 1) ts]
[else
(match-define (list (tick xs _ labels) ...) ts)
(define x (/ (apply + xs) n))
(define label (format format-string (first labels) (last labels)))
(list (tick x #t label))])))))

6
collects/plot/contracted/math.rkt
View File

@ -13,7 +13,7 @@
floor-log/base ceiling-log/base
polar->cartesian 3d-polar->3d-cartesian
;; Vectors
vcross v+ v- vneg v* v/ vmag^2 vmag vnormalize vdot vregular? v= vcenter)
vcross vcross2 v+ v- vneg v* v/ vmag^2 vmag vnormalize vdot vcos-angle vregular? v= vcenter)
;; Intervals
(provide (contract-out (struct ivl ([min (or/c real? #f)] [max (or/c real? #f)]))
@ -21,7 +21,7 @@
[ivl-join (->* () () #:rest (listof ivl?) ivl?)])
empty-ivl unknown-ivl
(activate-contract-out
ivl-empty? ivl-known? ivl-regular? ivl-singular? ivl-zero-length?
ivl-empty? ivl-known? ivl-regular? ivl-singular? ivl-length ivl-zero-length?
ivl-inexact->exact ivl-contains? bounds->intervals))
;; Rectangles
@ -29,5 +29,5 @@
[rect-join (->* () () #:rest (listof (vectorof ivl?)) (vectorof ivl?))])
(activate-contract-out
empty-rect unknown-rect bounding-rect
rect-empty? rect-known? rect-regular? rect-zero-area? rect-singular?
rect-empty? rect-known? rect-regular? rect-area rect-zero-area? rect-singular?
rect-inexact->exact rect-contains?))

3
collects/plot/contracted/ticks.rkt
View File

@ -21,4 +21,5 @@
bit/byte-ticks-format bit/byte-ticks
currency-ticks-scales currency-ticks-formats
currency-ticks-layout currency-ticks-format currency-ticks
fraction-ticks-format fraction-ticks))
fraction-ticks-format fraction-ticks
collapse-nearby-ticks))

117
collects/plot/plot2d/area.rkt
View File

@ -12,7 +12,9 @@
"../common/utils.rkt"
"clip.rkt")
(provide 2d-plot-area%)
(provide (all-defined-out))
(define plot2d-subdivisions (make-parameter 0))
(define 2d-plot-area%
(class plot-area%
@ -25,7 +27,7 @@
get-text-width get-text-extent get-char-height get-char-baseline
set-clipping-rect clear-clipping-rect
clear draw-polygon draw-rectangle draw-line draw-lines draw-text draw-glyphs draw-arrow
draw-tick draw-legend)
draw-tick draw-legend-box)
(super-make-object dc dc-x-min dc-y-min dc-x-size dc-y-size)
@ -88,15 +90,13 @@
(and (equal? (plot-x-transform) id-transform)
(equal? (plot-y-transform) id-transform)))
(match-define (invertible-function fx _) (apply-transform (plot-x-transform) x-min x-max))
(match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max))
(define plot->view
(cond
[identity-transforms? (λ (v) v)]
[else
(match-define (invertible-function fx _) (apply-transform (plot-x-transform) x-min x-max))
(match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max))
(λ (v)
(match-define (vector x y) v)
(vector (fx x) (fy y)))]))
(cond [identity-transforms? (λ (v) v)]
[else (λ (v) (match-let ([(vector x y) v])
(vector (fx x) (fy y))))]))
(define view->dc #f)
(define/public (plot->dc v) (view->dc (plot->view v)))
@ -135,41 +135,28 @@
;; ===============================================================================================
;; Tick and label constants
(define (collapse-ticks ts dc-pos)
(define (dc-dist t1 t2) (abs (- (dc-pos t1) (dc-pos t2))))
(let ([ts (sort ts < #:key pre-tick-value)])
(define tss
(group-neighbors ts (λ (t1 t2) ((dc-dist t1 t2) . <= . (* 2 (plot-line-width))))))
(for/list ([ts (in-list tss)])
(match-define (list (tick xs majors labels) ...) ts)
(define x (let ([xs (remove-duplicates xs)])
(/ (apply + xs) (length xs))))
(define major? (ormap values majors))
(define label (string-join (remove-duplicates (map tick-label (filter pre-tick-major? ts)))
"|"))
(tick x major? label))))
(define ((x-tick-near? y) t1 t2)
((vmag (v- (plot->dc (vector (pre-tick-value t1) y))
(plot->dc (vector (pre-tick-value t2) y))))
. <= . (* 3 (plot-line-width))))
(define ((x-tick-dc-pos y) t)
(vector-ref (plot->dc (vector (pre-tick-value t) y)) 0))
(define ((y-tick-dc-pos x) t)
(vector-ref (plot->dc (vector x (pre-tick-value t))) 1))
(define ((y-tick-near? x) t1 t2)
((vmag (v- (plot->dc (vector x (pre-tick-value t1)))
(plot->dc (vector x (pre-tick-value t2)))))
. <= . (* 3 (plot-line-width))))
(define x-ticks
(collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks)
(x-tick-dc-pos y-min)))
(collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks)
(x-tick-near? y-min)))
(define x-far-ticks
(collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks)
(x-tick-dc-pos y-max)))
(collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks)
(x-tick-near? y-max)))
(define y-ticks
(collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks)
(y-tick-dc-pos x-min)))
(collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks)
(y-tick-near? x-min)))
(define y-far-ticks
(collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks)
(y-tick-dc-pos x-min)))
(collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks)
(y-tick-near? x-max)))
(define draw-x-far-tick-labels? (not (and (plot-x-axis?) (equal? x-ticks x-far-ticks))))
(define draw-y-far-tick-labels? (not (and (plot-y-axis?) (equal? y-ticks y-far-ticks))))
@ -383,36 +370,36 @@
(draw-title)
(draw-labels))
(define/public (put-legend legend-entries)
(define/public (draw-legend legend-entries)
(define gap-size (+ (pen-gap) (* 1/2 (plot-tick-size))))
(draw-legend legend-entries
(+ area-x-min gap-size) (- area-x-max gap-size)
(+ area-y-min gap-size) (- area-y-max gap-size)))
(draw-legend-box legend-entries
(+ area-x-min gap-size) (- area-x-max gap-size)
(+ area-y-min gap-size) (- area-y-max gap-size)))
(define (subdivide-line v1 v2)
(define subdivide-fracs '(3/7 4/7 2/7 5/7 1/7 6/7))
(define (subdivide-line v1 v2 [depth 10])
(let/ec return
(match-define (vector dc-x1 dc-y1) (plot->dc v1))
(match-define (vector dc-x2 dc-y2) (plot->dc v2))
(define dc-dx (- dc-x2 dc-x1))
(define dc-dy (- dc-y2 dc-y1))
(when (or (zero? dc-dx) (zero? dc-dy)) (return (list v1 v2)))
(when (zero? depth) (return (list v1 v2)))
(match-define (vector x1 y1) v1)
(match-define (vector x2 y2) v2)
(cond [((abs dc-dx) . > . (abs dc-dy))
(define num (+ 1 (inexact->exact (ceiling (* 1/3 (abs dc-dx))))))
(define xs (nonlinear-seq x1 x2 num (plot-x-transform)))
(define m (/ (- y2 y1) (- x2 x1)))
(define b (- y1 (* m x1)))
(define ys (map (λ (x) (+ (* m x) b)) xs))
(map vector xs ys)]
[else
(define num (+ 1 (inexact->exact (ceiling (* 1/3 (abs dc-dy))))))
(define ys (nonlinear-seq y1 y2 num (plot-y-transform)))
(define m (/ (- x2 x1) (- y2 y1)))
(define b (- x1 (* m y1)))
(define xs (map (λ (y) (+ (* m y) b)) ys))
(map vector xs ys)])))
(define dc-v1 (plot->dc v1))
(define dc-v2 (plot->dc v2))
(define dc-dv (v- dc-v2 dc-v1))
(when ((vmag dc-dv) . <= . 3)
(return (list v1 v2)))
(define dv (v- v2 v1))
(define-values (max-area vc)
(for/fold ([max-area 0] [vc v1]) ([frac (in-list subdivide-fracs)])
(define test-vc (v+ (v* dv frac) v1))
(define test-area (abs (vcross2 dc-dv (v- (plot->dc test-vc) dc-v1))))
(cond [(test-area . > . max-area) (values test-area test-vc)]
[else (values max-area vc)])))
(when (max-area . <= . 3) (return (list v1 v2)))
;(plot2d-subdivisions (+ (plot2d-subdivisions) 1))
(append (subdivide-line v1 vc (- depth 1))
(rest (subdivide-line vc v2 (- depth 1))))))
(define (subdivide-lines vs)
(append

4
collects/plot/plot2d/contour.rkt
View File

@ -58,7 +58,7 @@
;; ===================================================================================================
;; Contour lines
(define ((contours-render-proc f g levels samples colors widths styles alphas label) area)
(define ((contours-render-proc g levels samples colors widths styles alphas label) area)
(let/ec return
(define-values (x-min x-max y-min y-max) (send area get-bounds))
(match-define (list xs ys zss) (g x-min x-max samples y-min y-max samples))
@ -114,7 +114,7 @@
) renderer2d?
(define g (2d-function->sampler f))
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(contours-render-proc f g levels samples colors widths styles alphas label)))
(contours-render-proc g levels samples colors widths styles alphas label)))
;; ===================================================================================================
;; Contour intervals

3
collects/plot/plot2d/decoration.rkt
View File

@ -224,8 +224,7 @@
(send area set-alpha alpha)
; label
(send area set-text-foreground color)
(send area set-font-size size)
(send area set-font-family family)
(send area set-font size family)
(send area put-text (string-append " " label " ") v anchor angle #:outline? #t)
; point
(send area set-pen color 1 'solid)

2
collects/plot/plot2d/plot.rkt
View File

@ -85,7 +85,7 @@
(send area end-plot)
(when (not (empty? legend-entries))
(send area put-legend legend-entries))
(send area draw-legend legend-entries))
(send area restore-drawing-params)))

326
collects/plot/plot3d/area.rkt
View File

@ -8,11 +8,14 @@
"../common/contract.rkt"
"../common/axis-transform.rkt"
"../common/parameters.rkt"
"../common/sample.rkt"
"matrix.rkt"
"shape.rkt"
"clip.rkt")
(provide 3d-plot-area%)
(provide (all-defined-out))
(define plot3d-subdivisions (make-parameter 0))
(define 3d-plot-area%
(class plot-area%
@ -25,7 +28,7 @@
get-text-width get-text-extent get-char-height get-char-baseline
set-clipping-rect clear-clipping-rect
clear draw-polygon draw-rectangle draw-line draw-lines draw-text draw-glyphs draw-arrow-glyph
draw-tick draw-legend)
draw-tick draw-legend-box)
(super-make-object dc dc-x-min dc-y-min dc-x-size dc-y-size)
@ -95,9 +98,7 @@
(define theta (+ (degrees->radians angle) 0.00001))
(define rho (degrees->radians altitude))
(define do-axis-transforms? #f)
(define identity-axis-transforms?
(define identity-transforms?
(and (equal? (plot-x-transform) id-transform)
(equal? (plot-y-transform) id-transform)
(equal? (plot-z-transform) id-transform)))
@ -106,28 +107,27 @@
(match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max))
(match-define (invertible-function fz _) (apply-transform (plot-z-transform) z-min z-max))
(define center
(define axis-transform
(cond
[identity-axis-transforms?
(λ (v)
(match-define (vector x y z) v)
(vector (- x x-mid) (- y y-mid) (- z z-mid)))]
[else
(λ (v)
(match-define (vector x y z) v)
(if do-axis-transforms?
(vector (- (fx x) x-mid) (- (fy y) y-mid) (- (fz z) z-mid))
(vector (- x x-mid) (- y y-mid) (- z z-mid))))]))
[identity-transforms? (λ (v) v)]
[else (λ (v)
(match-define (vector x y z) v)
(vector (fx x) (fy y) (fz z)))]))
(define (center v)
(match-define (vector x y z) v)
(vector (- x x-mid) (- y y-mid) (- z z-mid)))
(define transform-matrix/no-rho
(m3* (m3-rotate-z theta) (m3-scale (/ x-size) (/ y-size) (/ z-size))))
(define transform-matrix (m3* (m3-rotate-x rho) transform-matrix/no-rho))
(define (plot->view v) (m3-apply transform-matrix (center v)))
(define (plot->view/no-rho v) (m3-apply transform-matrix/no-rho (center v)))
(define (plot->view v) (m3-apply transform-matrix (center (axis-transform v))))
(define (plot->view/no-rho v) (m3-apply transform-matrix/no-rho (center (axis-transform v))))
(define (rotate/rho v) (m3-apply (m3-rotate-x rho) v))
(define view->dc #f)
(define (plot->dc/no-axis-trans v) (view->dc (m3-apply transform-matrix (center v))))
(define (plot->dc v) (view->dc (plot->view v)))
(define dc-x-max (+ dc-x-min dc-x-size))
@ -169,16 +169,53 @@
;; ===============================================================================================
;; Tick and label constants
(define x-labels-y-min? ((cos theta) . >= . 0))
(define y-labels-x-min? ((sin theta) . >= . 0))
(define x-axis-y-min? ((cos theta) . >= . 0)) ; #t iff x near labels should be drawn at y-min
(define y-axis-x-min? ((sin theta) . >= . 0)) ; #t iff y near labels should be drawn at x-min
(define x-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks))
(define y-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks))
(define z-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-ticks))
(define x-axis-y (if x-axis-y-min? y-min y-max))
(define x-far-axis-y (if x-axis-y-min? y-max y-min))
(define y-axis-x (if y-axis-x-min? x-min x-max))
(define y-far-axis-x (if y-axis-x-min? x-max x-min))
(define z-axis-x (if x-axis-y-min? x-min x-max))
(define z-axis-y (if y-axis-x-min? y-max y-min))
(define z-far-axis-x (if x-axis-y-min? x-max x-min))
(define z-far-axis-y (if y-axis-x-min? y-min y-max))
(define x-far-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks))
(define y-far-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks))
(define z-far-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-far-ticks))
(define near-dist^2 (sqr(* 3 (plot-line-width))))
(define (vnear? v1 v2)
((vmag^2 (v- (plot->dc v1) (plot->dc v2))) . <= . near-dist^2))
(define ((x-ticks-near? y) t1 t2)
(vnear? (vector (pre-tick-value t1) y z-min)
(vector (pre-tick-value t2) y z-min)))
(define ((y-ticks-near? x) t1 t2)
(vnear? (vector x (pre-tick-value t1) z-min)
(vector x (pre-tick-value t2) z-min)))
(define ((z-ticks-near? x y) t1 t2)
(vnear? (vector x y (pre-tick-value t1))
(vector x y (pre-tick-value t2))))
(define x-ticks
(collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks)
(x-ticks-near? x-axis-y)))
(define y-ticks
(collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks)
(y-ticks-near? y-axis-x)))
(define z-ticks
(collapse-nearby-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-ticks)
(z-ticks-near? z-axis-x z-axis-y)))
(define x-far-ticks
(collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks)
(x-ticks-near? x-far-axis-y)))
(define y-far-ticks
(collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks)
(y-ticks-near? y-far-axis-x)))
(define z-far-ticks
(collapse-nearby-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-far-ticks)
(z-ticks-near? z-far-axis-x z-far-axis-y)))
(define draw-x-far-tick-labels? (not (and (plot-x-axis?) (equal? x-ticks x-far-ticks))))
(define draw-y-far-tick-labels? (not (and (plot-y-axis?) (equal? y-ticks y-far-ticks))))
@ -227,8 +264,8 @@
(define (plot-dir->dc-angle v)
(match-define (vector dx dy)
(v- (plot->dc (v+ v (vector x-mid y-mid z-mid)))
(plot->dc (vector x-mid y-mid z-mid))))
(v- (plot->dc/no-axis-trans (v+ v (vector x-mid y-mid z-mid)))
(plot->dc/no-axis-trans (vector x-mid y-mid z-mid))))
(- (atan2 (- dy) dx)))
(define (axis-dc-angles)
@ -240,55 +277,51 @@
(define (get-x-label-params)
(define-values (x-axis-angle y-axis-angle) (axis-dc-angles))
(define v0 (plot->dc (vector x-mid (if x-labels-y-min? y-min y-max) z-min)))
(define v0 (plot->dc/no-axis-trans (vector x-mid x-axis-y z-min)))
(define dist (+ max-x-tick-offset
(max-x-tick-label-diag y-axis-angle)
(* 1/2 char-height)))
(list #t (plot-x-label) (v+ v0 (v* (vector (cos y-axis-angle) (sin y-axis-angle))
(if x-labels-y-min? (- dist) dist)))
'top (- (if x-labels-y-min? 0 pi) x-axis-angle)))
(if x-axis-y-min? (- dist) dist)))
'top (- (if x-axis-y-min? 0 pi) x-axis-angle)))
(define (get-y-label-params)
(define-values (x-axis-angle y-axis-angle) (axis-dc-angles))
(define v0 (plot->dc (vector (if y-labels-x-min? x-min x-max) y-mid z-min)))
(define v0 (plot->dc/no-axis-trans (vector y-axis-x y-mid z-min)))
(define dist (+ max-y-tick-offset
(max-y-tick-label-diag x-axis-angle)
(* 1/2 char-height)))
(list #t (plot-y-label) (v+ v0 (v* (vector (cos x-axis-angle) (sin x-axis-angle))
(if y-labels-x-min? (- dist) dist)))
'top (- (if y-labels-x-min? pi 0) y-axis-angle)))
(if y-axis-x-min? (- dist) dist)))
'top (- (if y-axis-x-min? pi 0) y-axis-angle)))
(define (get-z-label-params)
(define x (if x-labels-y-min? x-min x-max))
(define y (if y-labels-x-min? y-max y-min))
(list #t (plot-z-label) (v+ (plot->dc (vector x y z-max))
(list #t (plot-z-label) (v+ (plot->dc (vector z-axis-x z-axis-y z-max))
(vector 0 (* -1/2 char-height)))
'bottom-left 0))
(define (get-x-far-label-params)
(define-values (x-axis-angle y-axis-angle) (axis-dc-angles))
(define v0 (plot->dc (vector x-mid (if x-labels-y-min? y-max y-min) z-min)))
(define v0 (plot->dc/no-axis-trans (vector x-mid x-far-axis-y z-min)))
(define dist (+ max-x-far-tick-offset
(max-x-far-tick-label-diag y-axis-angle)
(* 1/2 char-height)))
(list #f (plot-x-far-label) (v+ v0 (v* (vector (cos y-axis-angle) (sin y-axis-angle))
(if x-labels-y-min? dist (- dist))))
'bottom (- (if x-labels-y-min? 0 pi) x-axis-angle)))
(if x-axis-y-min? dist (- dist))))
'bottom (- (if x-axis-y-min? 0 pi) x-axis-angle)))
(define (get-y-far-label-params)
(define-values (x-axis-angle y-axis-angle) (axis-dc-angles))
(define v0 (plot->dc (vector (if y-labels-x-min? x-max x-min) y-mid z-min)))
(define v0 (plot->dc/no-axis-trans (vector y-far-axis-x y-mid z-min)))
(define dist (+ max-y-far-tick-offset
(max-y-far-tick-label-diag x-axis-angle)
(* 1/2 char-height)))
(list #f (plot-y-far-label) (v+ v0 (v* (vector (cos x-axis-angle) (sin x-axis-angle))
(if y-labels-x-min? dist (- dist))))
'bottom (- (if y-labels-x-min? pi 0) y-axis-angle)))
(if y-axis-x-min? dist (- dist))))
'bottom (- (if y-axis-x-min? pi 0) y-axis-angle)))
(define (get-z-far-label-params)
(define x (if x-labels-y-min? x-max x-min))
(define y (if y-labels-x-min? y-min y-max))
(list #t (plot-z-far-label) (v+ (plot->dc (vector x y z-max))
(list #t (plot-z-far-label) (v+ (plot->dc (vector z-far-axis-x z-far-axis-y z-max))
(vector 0 (* -1/2 char-height)))
'bottom-right 0))
@ -302,19 +335,19 @@
(define x-tick-label-anchor
(let ([s (sin theta)])
(cond [(s . < . (sin (degrees->radians -67.5))) (if x-labels-y-min? 'top-right 'top-left)]
[(s . < . (sin (degrees->radians -22.5))) (if x-labels-y-min? 'top-right 'top-left)]
(cond [(s . < . (sin (degrees->radians -67.5))) (if x-axis-y-min? 'top-right 'top-left)]
[(s . < . (sin (degrees->radians -22.5))) (if x-axis-y-min? 'top-right 'top-left)]
[(s . < . (sin (degrees->radians 22.5))) 'top]
[(s . < . (sin (degrees->radians 67.5))) (if x-labels-y-min? 'top-left 'top-right)]
[else (if x-labels-y-min? 'top-left 'top-right)])))
[(s . < . (sin (degrees->radians 67.5))) (if x-axis-y-min? 'top-left 'top-right)]
[else (if x-axis-y-min? 'top-left 'top-right)])))
(define y-tick-label-anchor
(let ([c (cos theta)])
(cond [(c . > . (cos (degrees->radians 22.5))) (if y-labels-x-min? 'top-right 'top-left)]
[(c . > . (cos (degrees->radians 67.5))) (if y-labels-x-min? 'top-right 'top-left)]
(cond [(c . > . (cos (degrees->radians 22.5))) (if y-axis-x-min? 'top-right 'top-left)]
[(c . > . (cos (degrees->radians 67.5))) (if y-axis-x-min? 'top-right 'top-left)]
[(c . > . (cos (degrees->radians 112.5))) 'top]
[(c . > . (cos (degrees->radians 157.5))) (if y-labels-x-min? 'top-left 'top-right)]
[else (if y-labels-x-min? 'top-left 'top-right)])))
[(c . > . (cos (degrees->radians 157.5))) (if y-axis-x-min? 'top-left 'top-right)]
[else (if y-axis-x-min? 'top-left 'top-right)])))
(define x-far-tick-label-anchor (opposite-anchor x-tick-label-anchor))
(define y-far-tick-label-anchor (opposite-anchor y-tick-label-anchor))
@ -323,59 +356,56 @@
(define y-axis-angle (plot-dir->dc-angle (vector 0 1 0)))
(define dist (+ (pen-gap) (* 1/2 (plot-tick-size))))
(define offset (v* (vector (cos y-axis-angle) (sin y-axis-angle))
(if x-labels-y-min? (- dist) dist)))
(define y (if x-labels-y-min? y-min y-max))
(if x-axis-y-min? (- dist) dist)))
(for/list ([t (in-list x-ticks)] #:when (pre-tick-major? t))
(match-define (tick x _ label) t)
(list #f label (v+ (plot->dc (vector (fx x) y z-min)) offset) x-tick-label-anchor 0)))
(list #f label (v+ (plot->dc (vector x x-axis-y z-min)) offset)
x-tick-label-anchor 0)))
(define (get-y-tick-label-params)
(define x-axis-angle (plot-dir->dc-angle (vector 1 0 0)))
(define dist (+ (pen-gap) (* 1/2 (plot-tick-size))))
(define offset (v* (vector (cos x-axis-angle) (sin x-axis-angle))
(if y-labels-x-min? (- dist) dist)))
(define x (if y-labels-x-min? x-min x-max))
(if y-axis-x-min? (- dist) dist)))
(for/list ([t (in-list y-ticks)] #:when (pre-tick-major? t))
(match-define (tick y _ label) t)
(list #f label (v+ (plot->dc (vector x (fy y) z-min)) offset) y-tick-label-anchor 0)))
(list #f label (v+ (plot->dc (vector y-axis-x y z-min)) offset)
y-tick-label-anchor 0)))
(define (get-z-tick-label-params)
(define dist (+ (pen-gap) (* 1/2 (plot-tick-size))))
(define offset (vector (- dist) (* 2 (get-char-baseline))))
(define x (if x-labels-y-min? x-min x-max))
(define y (if y-labels-x-min? y-max y-min))
(for/list ([t (in-list z-ticks)] #:when (pre-tick-major? t))
(match-define (tick z _ label) t)
(list #t label (v+ (plot->dc (vector x y (fz z))) offset) 'bottom-right 0)))
(list #t label (v+ (plot->dc (vector z-axis-x z-axis-y z)) offset) 'bottom-right 0)))
(define (get-x-far-tick-label-params)
(define y-axis-angle (plot-dir->dc-angle (vector 0 1 0)))
(define dist (+ (pen-gap) (* 1/2 (plot-tick-size))))
(define offset (v* (vector (cos y-axis-angle) (sin y-axis-angle))
(if x-labels-y-min? dist (- dist))))
(define y (if x-labels-y-min? y-max y-min))
(if x-axis-y-min? dist (- dist))))
(for/list ([t (in-list x-far-ticks)] #:when (pre-tick-major? t))
(match-define (tick x _ label) t)
(list #f label (v+ (plot->dc (vector (fx x) y z-min)) offset) x-far-tick-label-anchor 0)))
(list #f label (v+ (plot->dc (vector x x-far-axis-y z-min)) offset)
x-far-tick-label-anchor 0)))
(define (get-y-far-tick-label-params)
(define x-axis-angle (plot-dir->dc-angle (vector 1 0 0)))
(define dist (+ (pen-gap) (* 1/2 (plot-tick-size))))
(define offset (v* (vector (cos x-axis-angle) (sin x-axis-angle))
(if y-labels-x-min? dist (- dist))))
(define x (if y-labels-x-min? x-max x-min))
(if y-axis-x-min? dist (- dist))))
(for/list ([t (in-list y-far-ticks)] #:when (pre-tick-major? t))
(match-define (tick y _ label) t)
(list #f label (v+ (plot->dc (vector x (fy y) z-min)) offset) y-far-tick-label-anchor 0)))
(list #f label (v+ (plot->dc (vector y-far-axis-x y z-min)) offset)
y-far-tick-label-anchor 0)))
(define (get-z-far-tick-label-params)
(define dist (+ (pen-gap) (* 1/2 (plot-tick-size))))
(define offset (vector dist (* 2 (get-char-baseline))))
(define x (if x-labels-y-min? x-max x-min))
(define y (if y-labels-x-min? y-min y-max))
(for/list ([t (in-list z-far-ticks)] #:when (pre-tick-major? t))
(match-define (tick z _ label) t)
(list #t label (v+ (plot->dc (vector x y (fz z))) offset) 'bottom-left 0)))
(list #t label (v+ (plot->dc (vector z-far-axis-x z-far-axis-y z)) offset)
'bottom-left 0)))
;; ===============================================================================================
;; Tick parameters
@ -383,50 +413,48 @@
(define (get-x-tick-params)
(define radius (* 1/2 (plot-tick-size)))
(define angle (plot-dir->dc-angle (vector 0 1 0)))
(define y (if x-labels-y-min? y-min y-max))
(for/list ([t (in-list x-ticks)])
(match-define (tick x major? _) t)
(list major? (plot->dc (vector (fx x) y z-min)) (if major? radius (* 1/2 radius)) angle)))
(list major? (plot->dc (vector x x-axis-y z-min))
(if major? radius (* 1/2 radius)) angle)))
(define (get-y-tick-params)
(define radius (* 1/2 (plot-tick-size)))
(define angle (plot-dir->dc-angle (vector 1 0 0)))
(define x (if y-labels-x-min? x-min x-max))
(for/list ([t (in-list y-ticks)])
(match-define (tick y major? _) t)
(list major? (plot->dc (vector x (fy y) z-min)) (if major? radius (* 1/2 radius)) angle)))
(list major? (plot->dc (vector y-axis-x y z-min))
(if major? radius (* 1/2 radius)) angle)))
(define (get-z-tick-params)
(define radius (* 1/2 (plot-tick-size)))
(define x (if x-labels-y-min? x-min x-max))
(define y (if y-labels-x-min? y-max y-min))
(for/list ([t (in-list z-ticks)])
(match-define (tick z major? _) t)
(list major? (plot->dc (vector x y (fz z))) (if major? radius (* 1/2 radius)) 0)))
(list major? (plot->dc (vector z-axis-x z-axis-y z))
(if major? radius (* 1/2 radius)) 0)))
(define (get-x-far-tick-params)
(define radius (* 1/2 (plot-tick-size)))
(define angle (plot-dir->dc-angle (vector 0 1 0)))
(define y (if x-labels-y-min? y-max y-min))
(for/list ([t (in-list x-ticks)])
(match-define (tick x major? _) t)
(list major? (plot->dc (vector (fx x) y z-min)) (if major? radius (* 1/2 radius)) angle)))
(list major? (plot->dc (vector x x-far-axis-y z-min))
(if major? radius (* 1/2 radius)) angle)))
(define (get-y-far-tick-params)
(define radius (* 1/2 (plot-tick-size)))
(define angle (plot-dir->dc-angle (vector 1 0 0)))
(define x (if y-labels-x-min? x-max x-min))
(for/list ([t (in-list y-ticks)])
(match-define (tick y major? _) t)
(list major? (plot->dc (vector x (fy y) z-min)) (if major? radius (* 1/2 radius)) angle)))
(list major? (plot->dc (vector y-far-axis-x y z-min))
(if major? radius (* 1/2 radius)) angle)))
(define (get-z-far-tick-params)
(define radius (* 1/2 (plot-tick-size)))
(define x (if x-labels-y-min? x-max x-min))
(define y (if y-labels-x-min? y-min y-max))
(for/list ([t (in-list z-ticks)])
(match-define (tick z major? _) t)
(list major? (plot->dc (vector x y (fz z))) (if major? radius (* 1/2 radius)) 0)))
(list major? (plot->dc (vector z-far-axis-x z-far-axis-y z))
(if major? radius (* 1/2 radius)) 0)))
;; ===============================================================================================
;; Fixpoint margin computation
@ -532,36 +560,28 @@
(define (draw-far-borders)
(when (plot-decorations?)
(set-minor-pen)
(define near-x (if y-labels-x-min? x-min x-max))
(define near-y (if x-labels-y-min? y-min y-max))
(define far-x (if y-labels-x-min? x-max x-min))
(define far-y (if x-labels-y-min? y-max y-min))
(when (plot-x-axis?)
(draw-line (plot->dc (vector x-min near-y z-min))
(plot->dc (vector x-max near-y z-min))))
(draw-line (plot->dc/no-axis-trans (vector x-min x-axis-y z-min))
(plot->dc/no-axis-trans (vector x-max x-axis-y z-min))))
(when (plot-x-far-axis?)
(draw-line (plot->dc (vector x-min far-y z-min))
(plot->dc (vector x-max far-y z-min))))
(draw-line (plot->dc/no-axis-trans (vector x-min x-far-axis-y z-min))
(plot->dc/no-axis-trans (vector x-max x-far-axis-y z-min))))
(when (plot-y-axis?)
(draw-line (plot->dc (vector near-x y-min z-min))
(plot->dc (vector near-x y-max z-min))))
(draw-line (plot->dc/no-axis-trans (vector y-axis-x y-min z-min))
(plot->dc/no-axis-trans (vector y-axis-x y-max z-min))))
(when (plot-y-far-axis?)
(draw-line (plot->dc (vector far-x y-min z-min))
(plot->dc (vector far-x y-max z-min))))))
(draw-line (plot->dc/no-axis-trans (vector y-far-axis-x y-min z-min))
(plot->dc/no-axis-trans (vector y-far-axis-x y-max z-min))))))
(define (draw-near-borders)
(when (plot-decorations?)
(set-minor-pen)
(define near-x (if x-labels-y-min? x-min x-max))
(define near-y (if y-labels-x-min? y-max y-min))
(define far-x (if x-labels-y-min? x-max x-min))
(define far-y (if y-labels-x-min? y-min y-max))
(when (plot-z-axis?)
(draw-line (plot->dc (vector near-x near-y z-min))
(plot->dc (vector near-x near-y z-max))))
(draw-line (plot->dc/no-axis-trans (vector z-axis-x z-axis-y z-min))
(plot->dc/no-axis-trans (vector z-axis-x z-axis-y z-max))))
(when (plot-z-far-axis?)
(draw-line (plot->dc (vector far-x far-y z-min))
(plot->dc (vector far-x far-y z-max))))))
(draw-line (plot->dc/no-axis-trans (vector z-far-axis-x z-far-axis-y z-min))
(plot->dc/no-axis-trans (vector z-far-axis-x z-far-axis-y z-max))))))
(define (draw-title)
(when (and (plot-decorations?) (plot-title))
@ -573,15 +593,13 @@
(set! render-list empty)
(draw-labels (get-far-label-params))
(draw-ticks (get-far-tick-params))
(draw-far-borders)
(set! do-axis-transforms? #t))
(draw-far-borders))
(define/public (start-renderer rx-min rx-max ry-min ry-max rz-min rz-max)
(reset-drawing-params)
(clip-to-bounds rx-min rx-max ry-min ry-max rz-min rz-max))
(define/public (end-plot)
(set! do-axis-transforms? #f)
(draw-render-list)
(clip-to-none)
(reset-drawing-params)
@ -593,7 +611,7 @@
(define (put-major-pen) (put-pen (plot-foreground) (plot-line-width) 'solid))
(define (put-minor-pen) (put-pen (plot-foreground) (* 1/2 (plot-line-width)) 'solid))
(define (put-angles*)
(define (draw-angles*)
(define angle-str (format " angle = ~a " (number->string (round angle))))
(define alt-str (format " altitude = ~a " (number->string (round altitude))))
(define-values (angle-width angle-height baseline _angle2) (get-text-extent angle-str))
@ -617,15 +635,15 @@
(draw-text alt-str (vector box-x-min (+ box-y-min baseline char-height))
'top-left #:outline? #t))
(define/public (put-angles) (put-angles*))
(define/public (draw-angles) (draw-angles*))
(define (put-legend* legend-entries)
(define (draw-legend* legend-entries)
(define gap (plot-line-width))
(draw-legend legend-entries
(+ dc-x-min gap) (- dc-x-max gap)
(+ area-y-min gap) (- dc-y-max gap)))
(draw-legend-box legend-entries
(+ dc-x-min gap) (- dc-x-max gap)
(+ area-y-min gap) (- dc-y-max gap)))
(define/public (put-legend legend-entries) (put-legend* legend-entries))
(define/public (draw-legend legend-entries) (draw-legend* legend-entries))
(define light (plot->view (vector x-mid y-mid (+ z-max (* 5 z-size)))))
(define view-dir (vector 0 -50 0))
@ -636,12 +654,11 @@
(define get-light-values
(cond
[(not (or diffuse-light? specular-light?)) (λ (s) (values 1.0 0.0))]
[(not (or diffuse-light? specular-light?)) (λ (v norm) (values 1.0 0.0))]
[else
(λ (s)
(λ (v norm)
; common lighting values
(define light-dir (vnormalize (v- light (rotate/rho (shape-center s)))))
(define norm (shape-normal s))
(define light-dir (vnormalize (v- light (rotate/rho v))))
; diffuse lighting: typical Lambertian surface model
(define diff (if diffuse-light? (abs (vdot norm light-dir)) 1.0))
; specular highlighting: Blinn-Phong model
@ -660,8 +677,8 @@
; shapes
[(shapes alpha center ss) (draw-shapes ss)]
; polygon
[(polygon alpha center vs pen-color pen-width pen-style brush-color brush-style)
(define-values (diff spec) (get-light-values s))
[(polygon alpha center vs normal pen-color pen-width pen-style brush-color brush-style)
(define-values (diff spec) (get-light-values center normal))
(let ([pen-color (map (λ (v) (+ (* v diff) spec)) pen-color)]
[brush-color (map (λ (v) (+ (* v diff) spec)) brush-color)])
(set-pen pen-color pen-width pen-style)
@ -760,19 +777,68 @@
(define (get-font-family) font-family)
(define (get-text-foreground) text-foreground)
;; ===============================================================================================
;; Subdividing nonlinearly transformed shapes
(define subdivide-fracs '(3/7 4/7 2/7 5/7 1/7 6/7))
(define (subdivide-line v1 v2 [depth 10])
(let/ec return
(when (zero? depth) (return (list v1 v2)))
(define dc-v1 (plot->dc v1))
(define dc-v2 (plot->dc v2))
(define dc-dv (v- dc-v2 dc-v1))
(when ((vmag dc-dv) . <= . 3)
(return (list v1 v2)))
(define dv (v- v2 v1))
(define-values (max-area vc)
(for/fold ([max-area 0] [vc v1]) ([frac (in-list subdivide-fracs)])
(define test-vc (v+ (v* dv frac) v1))
(define test-area (abs (vcross2 dc-dv (v- (plot->dc test-vc) dc-v1))))
(cond [(test-area . > . max-area) (values test-area test-vc)]
[else (values max-area vc)])))
(when (max-area . <= . 3) (return (list v1 v2)))
;(plot3d-subdivisions (+ (plot3d-subdivisions) 1))
(append (subdivide-line v1 vc (- depth 1))
(rest (subdivide-line vc v2 (- depth 1))))))
(define (subdivide-lines vs)
(append
(append*
(for/list ([v1 (in-list vs)] [v2 (in-list (rest vs))])
(define line-vs (subdivide-line v1 v2))
(take line-vs (sub1 (length line-vs)))))
(list (last vs))))
(define (subdivide-polygon vs)
(subdivide-lines (cons (last vs) vs)))
; shapes
(define/public (put-line v1 v2 [c (vcenter (list v1 v2))])
(when (and (vregular? v1) (vregular? v2))
(let/ec return
(unless (and (vregular? v1) (vregular? v2)) (return (void)))
(let-values ([(v1 v2) (if clipping?
(clip-line v1 v2 clip-x-min clip-x-max
clip-y-min clip-y-max
clip-z-min clip-z-max)
(values v1 v2))])
(when (and v1 v2)
(add-shape!
(line (get-alpha) (plot->view/no-rho c) (plot->view v1) (plot->view v2)
(get-pen-color) (get-pen-width) (get-pen-style)))))))
(unless (and v1 v2) (return (void)))
(define alpha (get-alpha))
(define pen-color (get-pen-color))
(define pen-width (get-pen-width))
(define pen-style (get-pen-style))
(cond [identity-transforms?
(add-shape! (line alpha (plot->view/no-rho c) (plot->view v1) (plot->view v2)
pen-color pen-width pen-style))]
[else
(define vs (map plot->view (subdivide-line v1 v2)))
(for ([v1 (in-list vs)] [v2 (in-list (rest vs))])
(add-shape! (line alpha (plot->view/no-rho c) v1 v2
pen-color pen-width pen-style)))]))))
(define/public (put-lines vs)
(for ([vs (vregular-sublists vs)])
@ -785,15 +851,15 @@
(when (or (empty? vs) (not (and (andmap vregular? vs) (vregular? c))))
(return lst))
(define norm (vnormal (map plot->view vs)))
(let* ([vs (if clipping?
(clip-polygon vs clip-x-min clip-x-max
clip-y-min clip-y-max
clip-z-min clip-z-max)
vs)]
[vs (map plot->view vs)])
[vs (map plot->view (if identity-transforms? vs (subdivide-polygon vs)))])
(when (empty? vs) (return lst))
(cons (polygon (get-alpha) (plot->view/no-rho c) vs
(cons (polygon (get-alpha) (plot->view/no-rho c) vs norm
(get-pen-color) (get-pen-width) (get-pen-style)
(get-brush-color) (get-brush-style))
lst))))

4
collects/plot/plot3d/plot.rkt
View File

@ -100,9 +100,9 @@
(when (and (not (empty? legend-entries))
(or (not (plot-animating?))
(not (equal? (plot-legend-anchor) 'center))))
(send area put-legend legend-entries))
(send area draw-legend legend-entries))
(when (plot-animating?) (send area put-angles))
(when (plot-animating?) (send area draw-angles))
(send area restore-drawing-params)))

11
collects/plot/plot3d/shape.rkt
View File

@ -7,22 +7,13 @@
(struct shape (alpha center) #:transparent)
(struct polygon shape (vs pen-color pen-width pen-style brush-color brush-style) #:transparent)
(struct polygon shape (vs normal pen-color pen-width pen-style brush-color brush-style) #:transparent)
(struct line shape (v1 v2 pen-color pen-width pen-style) #:transparent)
(struct text shape (anchor angle str font-size font-family color) #:transparent)
(struct glyph shape (symbol size pen-color pen-width pen-style brush-color brush-style) #:transparent)
(struct tick-glyph shape (radius angle pen-color pen-width pen-style) #:transparent)
(struct shapes shape (list) #:transparent)
(define (shape-normal s)
(cond [(polygon? s) (vnormal (polygon-vs s))]
[else (vector 0 -1 0)]))
(define (shape-coords s)
(cond [(polygon? s) (polygon-vs s)]
[(line? s) (list (line-v1 s) (line-v2 s))]
[else (list (shape-center s))]))
(define (draw-before? s1 s2)
(match-define (vector x1 y1 z1) (shape-center s1))
(match-define (vector x2 y2 z2) (shape-center s2))

34
collects/plot/tests/subdivision-tests.rkt Normal file
View File

@ -0,0 +1,34 @@
#lang racket
(require plot plot/plot2d/area plot/plot3d/area)
(parameterize ([plot-x-transform log-transform]
[plot-x-ticks (log-ticks)])
(values
(plot (lines '(#(1 1) #(200 200))))
(plot3d (lines3d '(#(1 1 1) #(200 200 200))))))
(plot2d-subdivisions)
(plot3d-subdivisions)
(time
(parameterize ([plot3d-samples 4]
[plot-x-transform log-transform]
[plot-x-ticks (log-ticks)]
[plot-y-transform log-transform]
[plot-y-ticks (log-ticks)])
(values
(plot (lines '(#(1 1) #(200 200))))
(plot3d (surface3d + 1 200 1 200)))))
(plot2d-subdivisions)
(plot3d-subdivisions)
(time
(parameterize ([plot-x-transform (collapse-transform -1 1)])
(values
(plot (lines '(#(-2 -2) #(2 2))))
(plot3d (surface3d + -2 2 -2 2)))))
(plot2d-subdivisions)
(plot3d-subdivisions)