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 ;; 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)) (define n (length legend-entries))
(match-define (list (legend-entry labels draws) ...) legend-entries) (match-define (list (legend-entry labels draws) ...) legend-entries)

43
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" 1 v1 v2)])]
[_ (raise-type-error 'vcross "vector of 3 reals" 0 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) (define-syntax-rule (vmap name f v)
(let () (let ()
(unless (vector? v) (unless (vector? v)
@ -313,6 +321,11 @@
(raise-type-error 'vdot "vector of real" 1 v1 v2)) (raise-type-error 'vdot "vector of real" 1 v1 v2))
(raise-type-error 'vdot "vector of real" 0 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) (define-syntax-rule (unsafe-flspecial? x)
(or (unsafe-fl= x +inf.0) (unsafe-fl= x -inf.0) (eqv? x +nan.0))) (or (unsafe-fl= x +inf.0) (unsafe-fl= x -inf.0) (eqv? x +nan.0)))
@ -408,11 +421,20 @@
(for ([v1 (in-list vs)] (for ([v1 (in-list vs)]
[v2 (in-list (rest vs))] [v2 (in-list (rest vs))]
[v3 (in-list (rest (rest vs)))]) [v3 (in-list (rest (rest vs)))])
(define n (vcross (v- v3 v2) (v- v1 v2))) (define norm (vcross (v- v3 v2) (v- v1 v2)))
(define m (vmag^2 n)) (define m (vmag norm))
(when (m . > . 0) (when (m . > . 0) (break (v/ norm m))))
(break (v/ n (sqrt m))))) default-normal)
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 ;; Intervals
@ -449,6 +471,10 @@
(match-define (ivl a b) i) (match-define (ivl a b) i)
(and a b (= a b))) (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? (defproc (ivl-zero-length? [i ivl?]) boolean?
(or (ivl-empty? i) (ivl-singular? i))) (or (ivl-empty? i) (ivl-singular? i)))
@ -548,6 +574,13 @@
(defproc (rect-regular? [r (vectorof ivl?)]) boolean? (defproc (rect-regular? [r (vectorof ivl?)]) boolean?
(vector-andmap ivl-regular? r)) (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? (defproc (rect-zero-area? [r (vectorof ivl?)]) boolean?
(vector-ormap ivl-zero-length? r)) (vector-ormap ivl-zero-length? r))

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

@ -96,13 +96,23 @@
;; Objective: find the fixpoint of F starting at plot-bounds-rect ;; 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))) (define (F bounds-rect) (rect-meet plot-bounds-rect (apply-bounds* elems bounds-rect)))
;; Iterate joint bounds to (hopefully) a fixpoint ;; Iterate joint bounds to (hopefully) a fixpoint
(for/fold ([bounds-rect plot-bounds-rect]) ([n (in-range max-iters)]) (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) ;(printf "bounds-rect = ~v~n" bounds-rect)
;; Get new bounds from the elements' bounds functions ;; Get new bounds from the elements' bounds functions
(define new-bounds-rect (F bounds-rect)) (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 ;; Shortcut eval: if the bounds haven't changed, we have a fixpoint
(cond [(equal? bounds-rect new-bounds-rect) (break bounds-rect)] [(equal? bounds-rect new-bounds-rect) (break bounds-rect)]
[else new-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 ;; 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 ;; 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? (defproc (linear-scale [m real?] [b real? 0]) invertible-function?
(invertible-function (λ (x) (+ (* m x) b)) (invertible-function (λ (x) (+ (* m x) b))
(λ (y) (/ (- y b) m)))) (λ (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 floor-log/base ceiling-log/base
polar->cartesian 3d-polar->3d-cartesian polar->cartesian 3d-polar->3d-cartesian
;; Vectors ;; 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 ;; Intervals
(provide (contract-out (struct ivl ([min (or/c real? #f)] [max (or/c real? #f)])) (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?)]) [ivl-join (->* () () #:rest (listof ivl?) ivl?)])
empty-ivl unknown-ivl empty-ivl unknown-ivl
(activate-contract-out (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)) ivl-inexact->exact ivl-contains? bounds->intervals))
;; Rectangles ;; Rectangles
@ -29,5 +29,5 @@
[rect-join (->* () () #:rest (listof (vectorof ivl?)) (vectorof ivl?))]) [rect-join (->* () () #:rest (listof (vectorof ivl?)) (vectorof ivl?))])
(activate-contract-out (activate-contract-out
empty-rect unknown-rect bounding-rect 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?)) rect-inexact->exact rect-contains?))

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

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

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

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

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

@ -58,7 +58,7 @@
;; =================================================================================================== ;; ===================================================================================================
;; Contour lines ;; 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 (let/ec return
(define-values (x-min x-max y-min y-max) (send area get-bounds)) (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)) (match-define (list xs ys zss) (g x-min x-max samples y-min y-max samples))
@ -114,7 +114,7 @@
) renderer2d? ) renderer2d?
(define g (2d-function->sampler f)) (define g (2d-function->sampler f))
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun (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 ;; Contour intervals

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

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

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

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

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

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

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

@ -100,9 +100,9 @@
(when (and (not (empty? legend-entries)) (when (and (not (empty? legend-entries))
(or (not (plot-animating?)) (or (not (plot-animating?))
(not (equal? (plot-legend-anchor) 'center)))) (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))) (send area restore-drawing-params)))

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

@ -7,22 +7,13 @@
(struct shape (alpha center) #:transparent) (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 line shape (v1 v2 pen-color pen-width pen-style) #:transparent)
(struct text shape (anchor angle str font-size font-family color) #: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 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 tick-glyph shape (radius angle pen-color pen-width pen-style) #:transparent)
(struct shapes shape (list) #: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) (define (draw-before? s1 s2)
(match-define (vector x1 y1 z1) (shape-center s1)) (match-define (vector x1 y1 z1) (shape-center s1))
(match-define (vector x2 y2 z2) (shape-center s2)) (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)