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

Abstracted render-thread into worker-thread (preparing for animated 2D plots)

Browse Source 
Endpoint-indifferent line styles (allows styles in finely chopped lines)
Adjacent polygons now gapless (faces drawn w/o antialiasing; jaggies mitigated by supersampling)
This commit is contained in:
Neil Toronto 2011-11-08 21:40:50 -07:00
parent 5bd8481aa7
commit 8b93de59c6
12 changed files with 630 additions and 276 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

188
collects/plot/common/draw.rkt
View File

@ -2,7 +2,7 @@
;; Extra drawing, font, color and style functions. ;; Extra drawing, font, color and style functions.
(require racket/draw racket/class racket/match racket/list racket/contract racket/math (require racket/draw racket/class racket/match racket/list racket/contract racket/math racket/flonum
"math.rkt" "math.rkt"
"contract.rkt" "contract.rkt"
"contract-doc.rkt" "contract-doc.rkt"
@ -352,3 +352,189 @@
transform rotate scale translate transform rotate scale translate
try-color) try-color)
(super-new))) (super-new)))
;; ===================================================================================================
;; Visible faces of a 3D rectangle
(define (visible-rect-faces r theta)
(match-define (vector (ivl x1 x2) (ivl y1 y2) (ivl z1 z2)) r)
(list
;; Top
(list (vector x1 y1 z2) (vector x2 y1 z2) (vector x2 y2 z2) (vector x1 y2 z2))
;; Front
(if ((cos theta) . > . 0)
(list (vector x1 y1 z1) (vector x2 y1 z1) (vector x2 y1 z2) (vector x1 y1 z2))
empty)
;; Back
(if ((cos theta) . < . 0)
(list (vector x1 y2 z1) (vector x2 y2 z1) (vector x2 y2 z2) (vector x1 y2 z2))
empty)
;; Left
(if ((sin theta) . > . 0)
(list (vector x1 y1 z1) (vector x1 y2 z1) (vector x1 y2 z2) (vector x1 y1 z2))
empty)
;; Right
(if ((sin theta) . < . 0)
(list (vector x2 y1 z1) (vector x2 y2 z1) (vector x2 y2 z2) (vector x2 y1 z2))
empty)))
;; ===================================================================================================
;; Origin-neutral pen styles
(struct pen-style (length ps) #:transparent)
(define (make-pen-style diff-ps)
(let* ([diff-ps (map exact->inexact diff-ps)]
[diff-ps (if (even? (length diff-ps)) diff-ps (append diff-ps diff-ps))])
(define ps (reverse (foldl (λ (p ps) (cons (fl+ p (first ps)) ps)) '(0.0) diff-ps)))
(define len (last ps))
(pen-style len ps)))
(define long-dash-pen-style (make-pen-style '(5 4)))
(define short-dash-pen-style (make-pen-style '(3 2)))
(define dot-pen-style (make-pen-style '(1 2)))
(define dot-dash-pen-style (make-pen-style '(1 3 4 3)))
(define (scale-pen-style sty scale)
(let ([scale (exact->inexact scale)])
(match-define (pen-style len ps) sty)
(pen-style (fl* scale len) (map (λ (p) (fl* scale p)) ps))))
(define (cons-exact->inexact v)
(match-define (cons x1 y1) v)
(cons (exact->inexact x1) (exact->inexact y1)))
(define (cons=? v1 v2)
(match-define (cons x1 y1) v1)
(match-define (cons x2 y2) v2)
(and (fl= x1 x2) (fl= y1 y2)))
(define (segment-reverse seg)
(reverse (map reverse seg)))
(define (segment-join s1 s2)
(match-let ([(list s1 ... a) s1]
[(list b s2 ...) s2])
(append s1 (list (append a (rest b))) s2)))
(define (join-styled-segments segments)
(let ([segments (filter (compose not empty?) segments)])
(if (empty? segments)
empty
(match-let ([(cons current-segment segments) segments])
(let loop ([current-segment current-segment] [segments segments])
(cond [(empty? segments) (list current-segment)]
[else
(define lst (last (last current-segment)))
(match-let ([(cons segment segments) segments])
(define fst (first (first segment)))
(cond [(cons=? lst fst) (loop (segment-join current-segment segment) segments)]
[else (cons current-segment (loop segment segments))]))]))))))
(define (styled-segment* x1 y1 x2 y2 sty pair)
(match-define (pen-style len (cons p rest-ps)) sty)
(define start-x (fl* len (flfloor (fl/ x1 len))))
(define m (fl/ (fl- y2 y1) (fl- x2 x1)))
(define b (fl- y1 (fl* m x1)))
(let loop ([xa start-x] [base-x 0.0] [ps rest-ps] [on? #t] [res empty])
(let-values ([(base-x ps) (cond [(empty? ps) (values (fl+ base-x len) rest-ps)]
[else (values base-x ps)])])
(cond [(xa . fl>= . x2) (reverse res)]
[else
(match-let ([(cons p ps) ps])
(define xb (fl+ start-x (fl+ p base-x)))
(cond [(and on? (xb . fl>= . x1))
(define v (let ([xa (flmax x1 xa)]
[xb (flmin x2 xb)])
(define ya (if (fl= x1 xa) y1 (fl+ (fl* m xa) b)))
(define yb (if (fl= x2 xb) y2 (fl+ (fl* m xb) b)))
(list (pair xa ya) (pair xb yb))))
(loop xb base-x ps (not on?) (cons v res))]
[else (loop xb base-x ps (not on?) res)]))]))))
(define (styled-segment x1 y1 x2 y2 sty)
(define dx (flabs (fl- x2 x1)))
(define dy (flabs (fl- y2 y1)))
(cond [(and (fl= dx 0.0) (fl= dy 0.0)) (list (list (cons x1 y1) (cons x2 y2)))]
[(dx . > . dy)
(define reverse? (x1 . fl> . x2))
(let-values ([(x1 y1) (if reverse? (values x2 y2) (values x1 y1))]
[(x2 y2) (if reverse? (values x1 y1) (values x2 y2))])
(define segment (styled-segment* x1 y1 x2 y2 sty cons))
(if reverse? (segment-reverse segment) segment))]
[else
(define reverse? (y1 . fl> . y2))
(let-values ([(x1 y1) (if reverse? (values x2 y2) (values x1 y1))]
[(x2 y2) (if reverse? (values x1 y1) (values x2 y2))])
(define segment (styled-segment* y1 x1 y2 x2 sty (λ (y x) (cons x y))))
(if reverse? (segment-reverse segment) segment))]))
(define (symbol->style name style-sym)
(case style-sym
[(long-dash) long-dash-pen-style]
[(short-dash) short-dash-pen-style]
[(dot) dot-pen-style]
[(dot-dash) dot-dash-pen-style]
[else (error name "unknown pen style ~e" style-sym)]))
(define (draw-line/pen-style dc x1 y1 x2 y2 style-sym)
(case style-sym
[(transparent) (void)]
[(solid) (send dc draw-line x1 y1 x2 y2)]
[else
(let ([x1 (exact->inexact x1)]
[y1 (exact->inexact y1)]
[x2 (exact->inexact x2)]
[y2 (exact->inexact y2)])
(define sty (symbol->style 'draw-line style-sym))
(define pen (send dc get-pen))
(define scale (flmax 1.0 (exact->inexact (send pen get-width))))
(define vss (styled-segment x1 y1 x2 y2 (scale-pen-style sty scale)))
(for ([vs (in-list vss)] #:when (not (empty? vs)))
(match-define (list (cons xa ya) (cons xb yb)) vs)
(send dc draw-line xa ya xb yb)))]))
(define (draw-lines* dc vs sty)
(define vss
(append* (join-styled-segments
(for/list ([v1 (in-list vs)] [v2 (in-list (rest vs))])
(match-define (cons x1 y1) v1)
(match-define (cons x2 y2) v2)
(styled-segment x1 y1 x2 y2 sty)))))
(for ([vs (in-list vss)])
(match vs
[(list (cons x1 y1) (cons x2 y2)) (send dc draw-line x1 y1 x2 y2)]
[_ (send dc draw-lines vs)])))
(define (draw-lines/pen-style dc vs style-sym)
(cond [(or (empty? vs) (eq? style-sym 'transparent)) (void)]
[else
(let ([vs (map cons-exact->inexact vs)])
(cond [(eq? style-sym 'solid) (send dc draw-lines vs)]
[else
(define pen (send dc get-pen))
(define scale (flmax 1.0 (exact->inexact (send pen get-width))))
(define sty (scale-pen-style (symbol->style 'draw-lines style-sym) scale))
(draw-lines* dc vs sty)]))]))
;; ===================================================================================================
;; Drawing a bitmap using 2x supersampling
(define (draw-bitmap/supersampling draw width height)
(define bm2 (make-bitmap (* 2 width) (* 2 height)))
(define dc2 (make-object bitmap-dc% bm2))
(send dc2 set-scale 2 2)
(draw dc2)
(define bm (make-bitmap width height))
(define dc (make-object bitmap-dc% bm))
(send dc set-scale 1/2 1/2)
(send dc set-smoothing 'smoothed)
(send dc draw-bitmap bm2 0 0)
bm)
(define (draw-bitmap draw width height)
(define bm (make-bitmap width height))
(define dc (make-object bitmap-dc% bm))
(draw dc)
bm)

40
collects/plot/common/plot-device.rkt
View File

@ -135,13 +135,20 @@
(define pen-hash (make-hash)) (define pen-hash (make-hash))
(define pen-color (plot-foreground))
(define pen-width (plot-line-width))
(define pen-style 'solid)
;; Sets the pen, using a hash table to avoid making duplicate objects. At time of writing (and for ;; Sets the pen, using a hash table to avoid making duplicate objects. At time of writing (and for
;; the forseeable future) this is much faster than using a pen-list%, because it doesn't have to ;; the forseeable future) this is much faster than using a pen-list%, because it doesn't have to
;; synchronize access to be thread-safe. ;; synchronize access to be thread-safe.
(define/public (set-pen color width style) (define/public (set-pen color width style)
(match-define (list (app real->color-byte r) (app real->color-byte g) (app real->color-byte b)) (match-define (list (app real->color-byte r) (app real->color-byte g) (app real->color-byte b))
(->pen-color color)) (->pen-color color))
(let ([style (->pen-style style)]) (set! pen-color color)
(set! pen-width width)
(set! pen-style (->pen-style style))
(let ([style (if (eq? style 'transparent) 'transparent 'solid)])
(send dc set-pen (send dc set-pen
(hash-ref! pen-hash (vector r g b width style) (hash-ref! pen-hash (vector r g b width style)
(λ () (make-object pen% (make-object color% r g b) width style)))))) (λ () (make-object pen% (make-object color% r g b) width style))))))
@ -156,17 +163,26 @@
(define brush-hash (make-hash)) (define brush-hash (make-hash))
(define brush-color (plot-background))
(define brush-style 'solid)
;; Sets the brush. Same idea as set-pen. ;; Sets the brush. Same idea as set-pen.
(define/public (set-brush color style) (define/public (set-brush color style)
(match-define (list (app real->color-byte r) (app real->color-byte g) (app real->color-byte b)) (match-define (list (app real->color-byte r) (app real->color-byte g) (app real->color-byte b))
(->brush-color color)) (->brush-color color))
(let ([style (->brush-style style)]) (let ([style (->brush-style style)])
(set! brush-color color)
(set! brush-style style)
(send dc set-brush (send dc set-brush
(hash-ref! brush-hash (vector r g b style) (hash-ref! brush-hash (vector r g b style)
(λ () (make-object brush% (make-object color% r g b) style)))))) (λ () (make-object brush% (make-object color% r g b) style))))))
(define alpha (plot-foreground-alpha))
;; Sets alpha. ;; Sets alpha.
(define/public (set-alpha a) (send dc set-alpha a)) (define/public (set-alpha a)
(set! alpha a)
(send dc set-alpha a))
;; Sets the background color. ;; Sets the background color.
(define/public (set-background color) (define/public (set-background color)
@ -250,9 +266,21 @@
(match-define (vector x y) v) (match-define (vector x y) v)
(send dc draw-point x y))) (send dc draw-point x y)))
(define/public (draw-polygon vs [fill-style 'winding]) (define/public (draw-polygon vs)
(when (andmap vregular? vs) (when (andmap vregular? vs)
(send dc draw-polygon (map coord->cons vs) 0 0 fill-style))) (let ([vs (map coord->cons vs)])
(cond [(eq? pen-style 'transparent)
(send dc set-smoothing 'unsmoothed)
(send dc draw-polygon vs 0 0 'winding)
(send dc set-smoothing 'smoothed)]
[else
(define old-pen-style pen-style)
(set-pen pen-color pen-width 'transparent)
(send dc set-smoothing 'unsmoothed)
(send dc draw-polygon vs 0 0 'winding)
(send dc set-smoothing 'smoothed)
(set-pen pen-color pen-width old-pen-style)
(draw-lines/pen-style dc (cons (last vs) vs) old-pen-style)]))))
(define/public (draw-rect r) (define/public (draw-rect r)
(when (rect-regular? r) (when (rect-regular? r)
@ -261,13 +289,13 @@
(define/public (draw-lines vs) (define/public (draw-lines vs)
(when (andmap vregular? vs) (when (andmap vregular? vs)
(send dc draw-lines (map coord->cons vs)))) (draw-lines/pen-style dc (map coord->cons vs) pen-style)))
(define/public (draw-line v1 v2) (define/public (draw-line v1 v2)
(when (and (vregular? v1) (vregular? v2)) (when (and (vregular? v1) (vregular? v2))
(match-define (vector x1 y1) v1) (match-define (vector x1 y1) v1)
(match-define (vector x2 y2) v2) (match-define (vector x2 y2) v2)
(send dc draw-line x1 y1 x2 y2))) (draw-line/pen-style dc x1 y1 x2 y2 pen-style)))
(define/public (draw-text str v [anchor 'top-left] [angle 0] #:outline? [outline? #f]) (define/public (draw-text str v [anchor 'top-left] [angle 0] #:outline? [outline? #f])
(when (vregular? v) (when (vregular? v)

78
collects/plot/common/worker-thread.rkt Normal file
View File

@ -0,0 +1,78 @@
#lang racket
(require racket/async-channel
"contract-doc.rkt")
(provide make-worker-thread worker-thread? worker-thread-working? worker-thread-waiting?
worker-thread-put worker-thread-try-put
worker-thread-get worker-thread-try-get
worker-thread-wait
worker-thread-send)
(struct worker-thread (state message-channel result-channel thread) #:mutable #:transparent)
(struct values-result (value-list) #:transparent)
(struct error-result (value) #:transparent)
(define (make-worker-thread handle-message)
(define msg-ch (make-channel))
(define res-ch (make-async-channel))
(define (loop)
(with-handlers ([(λ (e) #t) (λ (e) (async-channel-put res-ch (error-result e)))])
(define msg (channel-get msg-ch))
(define res (call-with-values (λ () (handle-message msg))
(λ value-list (values-result value-list))))
(async-channel-put res-ch res))
(loop))
(worker-thread 'waiting msg-ch res-ch (thread loop)))
(define (worker-thread-working? r)
(symbol=? (worker-thread-state r) 'working))
(define (worker-thread-waiting? r)
(symbol=? (worker-thread-state r) 'waiting))
(define (worker-thread-get* r get fail-thunk)
(match-define (worker-thread state msg-ch res-ch th) r)
(case state
[(working) (define res (get res-ch))
(when res (set-worker-thread-state! r 'waiting))
(match res
[(values-result value-list) (apply values value-list)]
[(error-result value) (raise value)]
[#f (fail-thunk)])]
[(waiting) (fail-thunk)]))
(define (worker-thread-try-get r [fail-thunk (λ () #f)])
(worker-thread-get* r async-channel-try-get fail-thunk))
(define (worker-thread-get-fail)
(error 'worker-thread-get "cannot get a value from a waiting worker thread"))
(define (worker-thread-get r [fail-thunk worker-thread-get-fail])
(worker-thread-get* r async-channel-get fail-thunk))
(define (worker-thread-wait r)
(when (worker-thread-working? r) (worker-thread-get r))
(void))
(define (worker-thread-put* r msg fail-thunk)
(match-define (worker-thread state msg-ch res-ch th) r)
(case state
[(waiting) (channel-put msg-ch msg)
(set-worker-thread-state! r 'working)
#t]
[(working) (fail-thunk)]))
(define (worker-thread-try-put r msg [fail-thunk (λ () #f)])
(worker-thread-put* r msg fail-thunk))
(define (worker-thread-put-fail)
(error 'worker-thread-put "cannot send a message to a working worker thread"))
(define (worker-thread-put r msg [fail-thunk worker-thread-put-fail])
(worker-thread-put* r msg fail-thunk))
(define (worker-thread-send r msg)
(worker-thread-wait r)
(worker-thread-put r msg)
(worker-thread-get r))

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

@ -135,14 +135,11 @@
(let ([colors (map ->brush-color (maybe-apply colors z-ivls))] (let ([colors (map ->brush-color (maybe-apply colors z-ivls))]
[styles (map ->brush-style (maybe-apply styles z-ivls))] [styles (map ->brush-style (maybe-apply styles z-ivls))]
[alphas (maybe-apply alphas z-ivls)]) [alphas (maybe-apply alphas z-ivls)])
(define line-styles (map (λ (style) (if (eq? style 'solid) 'solid 'transparent)) styles))
(for ([za (in-list zs)] (for ([za (in-list zs)]
[zb (in-list (rest zs))] [zb (in-list (rest zs))]
[color (in-cycle colors)] [color (in-cycle colors)]
[style (in-cycle styles)] [style (in-cycle styles)]
[alpha (in-cycle alphas)] [alpha (in-cycle alphas)])
[line-style (in-cycle line-styles)])
(define polys (define polys
(append* (append*
(for/list ([ya (in-list ys)] (for/list ([ya (in-list ys)]
@ -159,27 +156,12 @@
(for/list ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))]) (for/list ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))])
(map (λ (v) (vector-take v 2)) poly))))) (map (λ (v) (vector-take v 2)) poly)))))
(define (draw-polys) (send area put-pen color 1 'transparent)
(for ([poly (in-list polys)]) (send area put-brush color style)
(send area put-alpha alpha)
(for ([poly (in-list polys)])
(send area put-polygon poly))) (send area put-polygon poly)))
(cond [(= alpha 1)
(send area put-pen color 1 line-style)
(send area put-brush color style)
(send area put-alpha 1)
(draw-polys)]
[else
;; draw the outlines with reduced alpha first
(send area put-pen color 1 line-style)
(send area put-brush color 'transparent)
(send area put-alpha (alpha-expt alpha 1/8))
(draw-polys)
;; now draw the centers
(send area put-pen color 1 'transparent)
(send area put-brush color style)
(send area put-alpha alpha)
(draw-polys)]))
((contours-render-proc g levels samples contour-colors contour-widths contour-styles alphas #f) ((contours-render-proc g levels samples contour-colors contour-widths contour-styles alphas #f)
area) area)
@ -194,7 +176,7 @@
(cond [label (interval-legend-entries (cond [label (interval-legend-entries
label z-ivls ivl-labels label z-ivls ivl-labels
colors styles colors '(1) line-styles colors styles colors '(1) '(transparent)
contour-colors* contour-widths* contour-styles* contour-colors* contour-widths* contour-styles*
(rest contour-colors*) (rest contour-widths*) (rest contour-styles*))] (rest contour-colors*) (rest contour-widths*) (rest contour-styles*))]
[else empty])))) [else empty]))))

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

@ -8,6 +8,7 @@
unstable/lazy-require unstable/lazy-require
"../common/contract.rkt" "../common/contract.rkt"
"../common/math.rkt" "../common/math.rkt"
"../common/draw.rkt"
"../common/parameters.rkt" "../common/parameters.rkt"
"../common/plot-element.rkt" "../common/plot-element.rkt"
"../common/file-type.rkt" "../common/file-type.rkt"
@ -19,11 +20,62 @@
;; cannot instantiate `racket/gui/base' a second time in the same process ;; cannot instantiate `racket/gui/base' a second time in the same process
(lazy-require ["../common/gui.rkt" (make-snip-frame)]) (lazy-require ["../common/gui.rkt" (make-snip-frame)])
(provide (all-defined-out)) (provide (except-out (all-defined-out) get-renderer-list get-bounds-rect get-ticks plot-dc))
;; =================================================================================================== ;; ===================================================================================================
;; Plot to a given device context ;; Plot to a given device context
(define (get-renderer-list renderer-tree)
(for/list ([r (flatten (list renderer-tree))])
(match r
[(non-renderer bounds-rect bounds-fun ticks-fun)
(renderer2d bounds-rect bounds-fun ticks-fun #f)]
[_ r])))
(define (get-bounds-rect renderer-list x-min x-max y-min y-max)
(define given-bounds-rect (vector (ivl x-min x-max) (ivl y-min y-max)))
(define plot-bounds-rect (bounds-fixpoint renderer-list given-bounds-rect))
(when (or (not (rect-regular? plot-bounds-rect))
(rect-zero-area? plot-bounds-rect))
(match-define (vector (ivl x-min x-max) (ivl y-min y-max)) plot-bounds-rect)
(error 'plot "could not determine sensible plot bounds; got x ∈ [~a,~a], y ∈ [~a,~a]"
x-min x-max y-min y-max))
(rect-inexact->exact plot-bounds-rect))
(define (get-ticks renderer-list bounds-rect)
(define-values (all-x-ticks all-x-far-ticks all-y-ticks all-y-far-ticks)
(for/lists (all-x-ticks all-x-far-ticks all-y-ticks all-y-far-ticks
) ([r (in-list renderer-list)])
(define ticks-fun (plot-element-ticks-fun r))
(cond [ticks-fun (ticks-fun bounds-rect)]
[else (values empty empty empty empty)])))
(values (remove-duplicates (append* all-x-ticks))
(remove-duplicates (append* all-x-far-ticks))
(remove-duplicates (append* all-y-ticks))
(remove-duplicates (append* all-y-far-ticks))))
(define (plot-dc renderer-list bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks
dc x y width height)
(define area (make-object 2d-plot-area%
bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks dc x y width height))
(send area start-plot)
(define legend-entries
(flatten (for/list ([rend (in-list renderer-list)])
(match-define (renderer2d rend-bounds-rect _bf _tf render-proc) rend)
(send area start-renderer (if rend-bounds-rect rend-bounds-rect (empty-rect 2)))
(if render-proc (render-proc area) empty))))
(send area end-renderers)
(when (not (empty? legend-entries))
(send area draw-legend legend-entries))
(send area end-plot))
(defproc (plot/dc [renderer-tree (treeof (or/c renderer2d? non-renderer?))] (defproc (plot/dc [renderer-tree (treeof (or/c renderer2d? non-renderer?))]
[dc (is-a?/c dc<%>)] [dc (is-a?/c dc<%>)]
[x real?] [y real?] [width (>=/c 0)] [height (>=/c 0)] [x real?] [y real?] [width (>=/c 0)] [height (>=/c 0)]
@ -35,54 +87,17 @@
[#:x-label x-label (or/c string? #f) (plot-x-label)] [#:x-label x-label (or/c string? #f) (plot-x-label)]
[#:y-label y-label (or/c string? #f) (plot-y-label)] [#:y-label y-label (or/c string? #f) (plot-y-label)]
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]) void? [#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]) void?
(define given-bounds-rect (vector (ivl x-min x-max) (ivl y-min y-max))) (define renderer-list (get-renderer-list renderer-tree))
(define rs (for/list ([r (flatten (list renderer-tree))]) (define bounds-rect (get-bounds-rect renderer-list x-min x-max y-min y-max))
(match r (define-values (x-ticks x-far-ticks y-ticks y-far-ticks)
[(non-renderer bounds-rect bounds-fun ticks-fun) (get-ticks renderer-list bounds-rect))
(renderer2d bounds-rect bounds-fun ticks-fun #f)]
[_ r])))
(define plot-bounds-rect (bounds-fixpoint rs given-bounds-rect))
(when (or (not (rect-regular? plot-bounds-rect))
(rect-zero-area? plot-bounds-rect))
(match-define (vector (ivl x-min x-max) (ivl y-min y-max)) plot-bounds-rect)
(error 'plot "could not determine sensible plot bounds; got x ∈ [~a,~a], y ∈ [~a,~a]"
x-min x-max y-min y-max))
(define bounds-rect (rect-inexact->exact plot-bounds-rect))
(define-values (all-x-ticks all-x-far-ticks all-y-ticks all-y-far-ticks)
(for/lists (all-x-ticks all-x-far-ticks all-y-ticks all-y-far-ticks) ([r (in-list rs)])
(define ticks-fun (plot-element-ticks-fun r))
(cond [ticks-fun (ticks-fun bounds-rect)]
[else (values empty empty empty empty)])))
(define x-ticks (remove-duplicates (append* all-x-ticks)))
(define y-ticks (remove-duplicates (append* all-y-ticks)))
(define x-far-ticks (remove-duplicates (append* all-x-far-ticks)))
(define y-far-ticks (remove-duplicates (append* all-y-far-ticks)))
(parameterize ([plot-title title] (parameterize ([plot-title title]
[plot-x-label x-label] [plot-x-label x-label]
[plot-y-label y-label] [plot-y-label y-label]
[plot-legend-anchor legend-anchor]) [plot-legend-anchor legend-anchor])
(define area (make-object 2d-plot-area% (plot-dc renderer-list bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks
bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks dc x y width height)) dc x y width height)))
(send area start-plot)
(define legend-entries
(flatten (for/list ([rend (in-list rs)])
(match-define (renderer2d rend-bounds-rect _bf _tf render-proc) rend)
(send area start-renderer (if rend-bounds-rect rend-bounds-rect (empty-rect 2)))
(if render-proc (render-proc area) empty))))
(send area end-renderers)
(when (not (empty? legend-entries))
(send area draw-legend legend-entries))
(send area end-plot)))
;; =================================================================================================== ;; ===================================================================================================
;; Plot to various other backends ;; Plot to various other backends
@ -100,12 +115,16 @@
[#:y-label y-label (or/c string? #f) (plot-y-label)] [#:y-label y-label (or/c string? #f) (plot-y-label)]
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)] [#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]
) (is-a?/c bitmap%) ) (is-a?/c bitmap%)
(define bm (make-bitmap width height)) (define renderer-list (get-renderer-list renderer-tree))
(define dc (make-object bitmap-dc% bm)) (define bounds-rect (get-bounds-rect renderer-list x-min x-max y-min y-max))
(plot/dc renderer-tree dc 0 0 width height (define-values (x-ticks x-far-ticks y-ticks y-far-ticks)
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max (get-ticks renderer-list bounds-rect))
#:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor) ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling)
bm) (λ (dc)
(plot/dc renderer-tree dc 0 0 width height
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
#:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor))
width height))
(defproc (plot-pict [renderer-tree (treeof (or/c renderer2d? non-renderer?))] (defproc (plot-pict [renderer-tree (treeof (or/c renderer2d? non-renderer?))]
[#:x-min x-min (or/c regular-real? #f) #f] [#:x-min x-min (or/c regular-real? #f) #f]
@ -122,10 +141,10 @@
(define saved-values (plot-parameters)) (define saved-values (plot-parameters))
(dc (λ (dc x y) (dc (λ (dc x y)
(parameterize/group (parameterize/group
([plot-parameters saved-values]) ([plot-parameters saved-values])
(plot/dc renderer-tree dc x y width height (plot/dc renderer-tree dc x y width height
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
#:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor))) #:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor)))
width height)) width height))
;; Plot to a snip ;; Plot to a snip

61
collects/plot/plot3d/clip.rkt
View File

@ -4,7 +4,10 @@
(require racket/match racket/list racket/unsafe/ops) (require racket/match racket/list racket/unsafe/ops)
(provide point-in-bounds? clip-line clip-polygon) (provide point-in-bounds? clip-line clip-polygon
clip-polygon-x-min clip-polygon-x-max
clip-polygon-y-min clip-polygon-y-max
clip-polygon-z-min clip-polygon-z-max)
;; =================================================================================================== ;; ===================================================================================================
;; Points ;; Points
@ -132,3 +135,59 @@
[_ (when (empty? vs) (return empty))] [_ (when (empty? vs) (return empty))]
[vs (clip-polygon-z-max z-max vs)]) [vs (clip-polygon-z-max z-max vs)])
vs))) vs)))
;; ===================================================================================================
#|
(define (chop-polygon-x vs)
(cond [(empty? vs) empty]
[else
(match-define (vector (ivl vx-min vx-max) y-ivl z-ivl) (bounding-rect vs))
(define n (animated-samples (plot3d-samples)))
(define xs (rest (nonlinear-seq x-min x-max n (plot-x-transform))))
(let-values ([(vss vs)
(for/fold ([vss empty] [vs vs]) ([x (in-list xs)])
(cond [(empty? vs) (values vss vs)]
#;[(vx-max . <= . x) (values vss vs)]
#;[(vx-min . >= . x) (values vss vs)]
[else (values (cons (clip-polygon-x-max x vs) vss)
(clip-polygon-x-min x vs))]))])
vss)]))
(define (chop-polygon-y vs)
(cond [(empty? vs) empty]
[else
(match-define (vector x-ivl (ivl vy-min vy-max) z-ivl) (bounding-rect vs))
(define n (animated-samples (plot3d-samples)))
(define ys (rest (nonlinear-seq y-min y-max n (plot-y-transform))))
(let-values ([(vss vs)
(for/fold ([vss empty] [vs vs]) ([y (in-list ys)])
(cond [(empty? vs) (values vss vs)]
#;[(vx-max . <= . x) (values vss vs)]
#;[(vx-min . >= . x) (values vss vs)]
[else (values (cons (clip-polygon-y-max y vs) vss)
(clip-polygon-y-min y vs))]))])
vss)]))
(define (chop-polygon-z vs)
(cond [(empty? vs) empty]
[else
(match-define (vector x-ivl y-ivl (ivl vz-min vz-max)) (bounding-rect vs))
(define n (animated-samples (plot3d-samples)))
(define zs (rest (nonlinear-seq z-min z-max n (plot-z-transform))))
(let-values ([(vss vs)
(for/fold ([vss empty] [vs vs]) ([z (in-list zs)])
(cond [(empty? vs) (values vss vs)]
#;[(vx-max . <= . x) (values vss vs)]
#;[(vx-min . >= . x) (values vss vs)]
[else (values (cons (clip-polygon-z-max z vs) vss)
(clip-polygon-z-min z vs))]))])
vss)]))
(define (chop-polygon vs)
(let* ([vss (chop-polygon-x vs)]
[vss (append* (map chop-polygon-y vss))]
[vss (append* (map chop-polygon-z vss))])
vss))
|#

31
collects/plot/plot3d/plot-area.rkt
View File

@ -167,7 +167,7 @@
(define (x-axis-angle) (plot-dir->dc-angle #(1 0 0))) (define (x-axis-angle) (plot-dir->dc-angle #(1 0 0)))
(define (y-axis-angle) (plot-dir->dc-angle #(0 1 0))) (define (y-axis-angle) (plot-dir->dc-angle #(0 1 0)))
(define (plot-dir->dc-dir v) (define/public (plot-dir->dc-dir v)
(vnormalize (v- (plot->dc/no-axis-trans (v+ v (vector x-mid y-mid z-mid))) (vnormalize (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))))) (plot->dc/no-axis-trans (vector x-mid y-mid z-mid)))))
@ -851,37 +851,16 @@
(set! render-list (cons (shapes (get-alpha) (plot->view/no-rho c) lst) (set! render-list (cons (shapes (get-alpha) (plot->view/no-rho c) lst)
render-list)))) render-list))))
(define/public (put-rect r [c (rect-center r)])
(when (rect-regular? r)
(put-polygons (visible-rect-faces r theta) c)))
(define/public (put-text str v [anchor 'center] [angle 0]) (define/public (put-text str v [anchor 'center] [angle 0])
(when (and (vregular? v) (in-bounds? v)) (when (and (vregular? v) (in-bounds? v))
(add-shape! (add-shape!
(text (get-alpha) (plot->view/no-rho v) anchor angle str (text (get-alpha) (plot->view/no-rho v) anchor angle str
(get-font-size) (get-font-family) (get-text-foreground))))) (get-font-size) (get-font-family) (get-text-foreground)))))
(define/public (put-rect r [c (rect-center r)])
(when (rect-regular? r)
(match-define (vector (ivl x1 x2) (ivl y1 y2) (ivl z1 z2)) r)
(put-polygons
(list
;; Top
(list (vector x1 y1 z2) (vector x2 y1 z2) (vector x2 y2 z2) (vector x1 y2 z2))
;; Front
(if ((cos theta) . > . 0)
(list (vector x1 y1 z1) (vector x2 y1 z1) (vector x2 y1 z2) (vector x1 y1 z2))
empty)
;; Back
(if ((cos theta) . < . 0)
(list (vector x1 y2 z1) (vector x2 y2 z1) (vector x2 y2 z2) (vector x1 y2 z2))
empty)
;; Left
(if ((sin theta) . > . 0)
(list (vector x1 y1 z1) (vector x1 y2 z1) (vector x1 y2 z2) (vector x1 y1 z2))
empty)
;; Right
(if ((sin theta) . < . 0)
(list (vector x2 y1 z1) (vector x2 y2 z1) (vector x2 y2 z2) (vector x2 y1 z2))
empty))
c)))
(define/public (put-glyphs vs symbol size) (define/public (put-glyphs vs symbol size)
(for ([v (in-list vs)]) (for ([v (in-list vs)])
(when (and (vregular? v) (in-bounds? v)) (when (and (vregular? v) (in-bounds? v))

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

@ -8,6 +8,7 @@
unstable/lazy-require unstable/lazy-require
"../common/contract.rkt" "../common/contract.rkt"
"../common/math.rkt" "../common/math.rkt"
"../common/draw.rkt"
"../common/parameters.rkt" "../common/parameters.rkt"
"../common/plot-element.rkt" "../common/plot-element.rkt"
"../common/file-type.rkt" "../common/file-type.rkt"
@ -20,11 +21,75 @@
(lazy-require ["snip.rkt" (make-3d-plot-snip)] (lazy-require ["snip.rkt" (make-3d-plot-snip)]
["../common/gui.rkt" (make-snip-frame)]) ["../common/gui.rkt" (make-snip-frame)])
(provide (all-defined-out)) (provide (except-out (all-defined-out) get-renderer-list get-bounds-rect get-ticks plot3d-dc))
;; =================================================================================================== ;; ===================================================================================================
;; Plot to a given device context ;; Plot to a given device context
(define (get-renderer-list renderer-tree)
(for/list ([r (flatten (list renderer-tree))])
(match r
[(non-renderer bounds-rect bounds-fun ticks-fun)
(renderer3d bounds-rect bounds-fun ticks-fun #f)]
[_ r])))
(define (get-bounds-rect renderer-list x-min x-max y-min y-max z-min z-max)
(define given-bounds-rect (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)))
(define plot-bounds-rect (bounds-fixpoint renderer-list given-bounds-rect))
(when (or (not (rect-regular? plot-bounds-rect))
(rect-zero-area? plot-bounds-rect))
(match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) plot-bounds-rect)
(error 'plot "could not determine sensible plot bounds; got x ∈ [~a,~a], y ∈ [~a,~a], z ∈ [~a,~a]"
x-min x-max y-min y-max z-min z-max))
(rect-inexact->exact plot-bounds-rect))
(define (get-ticks renderer-list bounds-rect)
(define-values (all-x-ticks all-x-far-ticks all-y-ticks all-y-far-ticks all-z-ticks all-z-far-ticks)
(for/lists (all-x-ticks
all-x-far-ticks
all-y-ticks
all-y-far-ticks
all-z-ticks
all-z-far-ticks) ([r (in-list renderer-list)])
(define ticks-fun (plot-element-ticks-fun r))
(cond [ticks-fun (ticks-fun bounds-rect)]
[else (values empty empty empty empty empty empty)])))
(values (remove-duplicates (append* all-x-ticks))
(remove-duplicates (append* all-x-far-ticks))
(remove-duplicates (append* all-y-ticks))
(remove-duplicates (append* all-y-far-ticks))
(remove-duplicates (append* all-z-ticks))
(remove-duplicates (append* all-z-far-ticks))))
(define (plot3d-dc renderer-list bounds-rect
x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks
dc x y width height)
(define area (make-object 3d-plot-area%
bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks
dc x y width height))
(send area start-plot)
(define legend-entries
(flatten (for/list ([rend (in-list renderer-list)])
(match-define (renderer3d rend-bounds-rect _bf _tf render-proc) rend)
(send area start-renderer (if rend-bounds-rect rend-bounds-rect (empty-rect 3)))
(if render-proc (render-proc area) empty))))
(send area end-renderers)
(when (and (not (empty? legend-entries))
(or (not (plot-animating?))
(not (equal? (plot-legend-anchor) 'center))))
(send area draw-legend legend-entries))
(when (plot-animating?) (send area draw-angles))
(send area end-plot))
(defproc (plot3d/dc [renderer-tree (treeof (or/c renderer3d? non-renderer?))] (defproc (plot3d/dc [renderer-tree (treeof (or/c renderer3d? non-renderer?))]
[dc (is-a?/c dc<%>)] [dc (is-a?/c dc<%>)]
[x real?] [y real?] [width (>=/c 0)] [height (>=/c 0)] [x real?] [y real?] [width (>=/c 0)] [height (>=/c 0)]
@ -40,41 +105,10 @@
[#:y-label y-label (or/c string? #f) (plot-y-label)] [#:y-label y-label (or/c string? #f) (plot-y-label)]
[#:z-label z-label (or/c string? #f) (plot-z-label)] [#:z-label z-label (or/c string? #f) (plot-z-label)]
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]) void? [#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]) void?
(define given-bounds-rect (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))) (define renderer-list (get-renderer-list renderer-tree))
(define rs (for/list ([r (flatten (list renderer-tree))]) (define bounds-rect (get-bounds-rect renderer-list x-min x-max y-min y-max z-min z-max))
(match r (define-values (x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks)
[(non-renderer bounds-rect bounds-fun ticks-fun) (get-ticks renderer-list bounds-rect))
(renderer3d bounds-rect bounds-fun ticks-fun #f)]
[_ r])))
(define plot-bounds-rect (bounds-fixpoint rs given-bounds-rect))
(when (or (not (rect-regular? plot-bounds-rect))
(rect-zero-area? plot-bounds-rect))
(match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) plot-bounds-rect)
(error 'plot "could not determine sensible plot bounds; got x ∈ [~a,~a], y ∈ [~a,~a], z ∈ [~a,~a]"
x-min x-max y-min y-max z-min z-max))
(define bounds-rect (rect-inexact->exact plot-bounds-rect))
(define-values (all-x-ticks all-x-far-ticks all-y-ticks all-y-far-ticks all-z-ticks all-z-far-ticks)
(for/lists (all-x-ticks
all-x-far-ticks
all-y-ticks
all-y-far-ticks
all-z-ticks
all-z-far-ticks) ([r (in-list rs)])
(define ticks-fun (plot-element-ticks-fun r))
(cond [ticks-fun (ticks-fun bounds-rect)]
[else (values empty empty empty empty empty empty)])))
(define x-ticks (remove-duplicates (append* all-x-ticks)))
(define y-ticks (remove-duplicates (append* all-y-ticks)))
(define z-ticks (remove-duplicates (append* all-z-ticks)))
(define x-far-ticks (remove-duplicates (append* all-x-far-ticks)))
(define y-far-ticks (remove-duplicates (append* all-y-far-ticks)))
(define z-far-ticks (remove-duplicates (append* all-z-far-ticks)))
(parameterize ([plot3d-angle angle] (parameterize ([plot3d-angle angle]
[plot3d-altitude altitude] [plot3d-altitude altitude]
@ -83,28 +117,9 @@
[plot-y-label y-label] [plot-y-label y-label]
[plot-z-label z-label] [plot-z-label z-label]
[plot-legend-anchor legend-anchor]) [plot-legend-anchor legend-anchor])
(match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) bounds-rect) (plot3d-dc renderer-list bounds-rect
(define area (make-object 3d-plot-area% x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks
bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks dc x y width height)))
dc x y width height))
(send area start-plot)
(define legend-entries
(flatten (for/list ([rend (in-list rs)])
(match-define (renderer3d rend-bounds-rect _bf _tf render-proc) rend)
(send area start-renderer (if rend-bounds-rect rend-bounds-rect (empty-rect 3)))
(if render-proc (render-proc area) empty))))
(send area end-renderers)
(when (and (not (empty? legend-entries))
(or (not (plot-animating?))
(not (equal? (plot-legend-anchor) 'center))))
(send area draw-legend legend-entries))
(when (plot-animating?) (send area draw-angles))
(send area end-plot)))
;; =================================================================================================== ;; ===================================================================================================
;; Plot to various other backends ;; Plot to various other backends
@ -127,13 +142,13 @@
[#:z-label z-label (or/c string? #f) (plot-z-label)] [#:z-label z-label (or/c string? #f) (plot-z-label)]
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)] [#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]
) (is-a?/c bitmap%) ) (is-a?/c bitmap%)
(define bm (make-bitmap width height)) ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling)
(define dc (make-object bitmap-dc% bm)) (λ (dc)
(plot3d/dc renderer-tree dc 0 0 width height (plot3d/dc renderer-tree dc 0 0 width height
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min #:z-max z-max #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min #:z-max z-max
#:angle angle #:altitude altitude #:title title #:x-label x-label #:y-label y-label #:angle angle #:altitude altitude #:title title #:x-label x-label #:y-label y-label
#:z-label z-label #:legend-anchor legend-anchor) #:z-label z-label #:legend-anchor legend-anchor))
bm) width height))
(defproc (plot3d-pict [renderer-tree (treeof (or/c renderer3d? non-renderer?))] (defproc (plot3d-pict [renderer-tree (treeof (or/c renderer3d? non-renderer?))]
[#:x-min x-min (or/c regular-real? #f) #f] [#:x-min x-min (or/c regular-real? #f) #f]
@ -154,12 +169,11 @@
) pict? ) pict?
(define saved-values (plot-parameters)) (define saved-values (plot-parameters))
(dc (λ (dc x y) (dc (λ (dc x y)
(parameterize/group (parameterize/group ([plot-parameters saved-values])
([plot-parameters saved-values]) (plot3d/dc renderer-tree dc x y width height
(plot3d/dc renderer-tree dc x y width height #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min #:z-max z-max #:angle angle #:altitude altitude #:title title #:x-label x-label
#:z-max z-max #:angle angle #:altitude altitude #:title title #:x-label x-label #:y-label y-label #:z-label z-label #:legend-anchor legend-anchor)))
#:y-label y-label #:z-label z-label #:legend-anchor legend-anchor)))
width height)) width height))
;; Plot to a snip ;; Plot to a snip
@ -180,14 +194,26 @@
[#:z-label z-label (or/c string? #f) (plot-z-label)] [#:z-label z-label (or/c string? #f) (plot-z-label)]
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)] [#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]
) (is-a?/c image-snip%) ) (is-a?/c image-snip%)
(define renderer-list (get-renderer-list renderer-tree))
(define bounds-rect (get-bounds-rect renderer-list x-min x-max y-min y-max z-min z-max))
(define-values (x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks)
(get-ticks renderer-list bounds-rect))
(make-3d-plot-snip (make-3d-plot-snip
(λ (angle altitude anim?) (λ (anim? angle altitude)
(parameterize ([plot-animating? (if anim? #t (plot-animating?))]) (parameterize ([plot-animating? (if anim? #t (plot-animating?))]
(plot3d-bitmap [plot3d-angle angle]
renderer-tree [plot3d-altitude altitude]
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min #:z-max z-max [plot-title title]
#:width width #:height height #:angle angle #:altitude altitude #:title title [plot-x-label x-label]
#:x-label x-label #:y-label y-label #:z-label z-label #:legend-anchor legend-anchor))) [plot-y-label y-label]
[plot-z-label z-label]
[plot-legend-anchor legend-anchor])
((if (plot-animating?) draw-bitmap draw-bitmap/supersampling)
(λ (dc) (plot3d-dc renderer-list bounds-rect
x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks
dc 0 0 width height))
width height)))
angle altitude)) angle altitude))
;; Plot to a frame ;; Plot to a frame

128
collects/plot/plot3d/snip.rkt
View File

@ -1,69 +1,30 @@
#lang racket/base #lang racket/base
(require racket/gui/base racket/class racket/match racket/bool racket/async-channel (require racket/gui/base racket/class racket/match racket/list
"../common/gui.rkt" "../common/gui.rkt"
"../common/math.rkt") "../common/math.rkt"
"../common/worker-thread.rkt"
"plot-area.rkt")
(provide 3d-plot-snip% make-3d-plot-snip) (provide 3d-plot-snip% make-3d-plot-snip)
(define update-delay 33) ; about 30 fps (just over) (define update-delay 33) ; about 30 fps (just over)
(struct render-thread (state command-channel response-channel thread) #:mutable #:transparent) (struct draw-command (animating? angle altitude) #:transparent)
(struct draw-command (angle altitude animating?) #:transparent)
(struct copy-command () #:transparent) (struct copy-command () #:transparent)
(define (make-render-thread make-bm) (define (make-render-thread make-bm)
(define com-ch (make-channel)) (make-worker-thread
(define res-ch (make-async-channel)) (match-lambda
(define th [(draw-command animating? angle altitude) (make-bm animating? angle altitude)]
(thread [(copy-command) (make-render-thread make-bm)])))
(λ ()
(let loop ()
(match (channel-get com-ch)
[(draw-command angle altitude animating?)
(define bm (with-handlers ([exn? (λ (e) (async-channel-put res-ch e))])
(make-bm angle altitude animating?)))
(async-channel-put res-ch bm)]
[(copy-command) (async-channel-put res-ch (make-render-thread make-bm))])
(loop)))))
(render-thread 'wait com-ch res-ch th))
(define (render-thread-get-bitmap r)
(match-define (render-thread state com-ch res-ch th) r)
(define res (async-channel-get res-ch))
(set-render-thread-state! r 'wait)
(if (exn? res) (raise res) res))
(define (render-thread-try-get-bitmap r)
(match-define (render-thread state com-ch res-ch th) r)
(define res (async-channel-try-get res-ch))
(when res (set-render-thread-state! r 'wait))
(if (exn? res) (raise res) res))
(define (render-thread-wait r)
(match-define (render-thread state com-ch res-ch th) r)
(when (symbol=? state 'drawing)
(render-thread-get-bitmap r)))
(define (render-thread-draw r angle altitude animating?)
(render-thread-wait r)
(match-define (render-thread state com-ch res-ch th) r)
(channel-put com-ch (draw-command angle altitude animating?))
(set-render-thread-state! r 'drawing))
(define (render-thread-copy r)
(render-thread-wait r)
(match-define (render-thread state com-ch res-ch th) r)
(channel-put com-ch (copy-command))
(async-channel-get res-ch))
(define (clamp x mn mx) (min* (max* x mn) mx)) (define (clamp x mn mx) (min* (max* x mn) mx))
(define 3d-plot-snip% (define 3d-plot-snip%
(class image-snip% (class image-snip%
(init-field make-bm angle altitude (init-field make-bm angle altitude
[bm (make-bm angle altitude #f)] [bm (make-bm #f angle altitude)]
[rth (make-render-thread make-bm)]) [rth (make-render-thread make-bm)])
(inherit set-bitmap) (inherit set-bitmap)
@ -72,28 +33,29 @@
(define width (send bm get-width)) (define width (send bm get-width))
(define height (send bm get-height)) (define height (send bm get-height))
(define click-x 0) (define left-click-x 0)
(define click-y 0) (define left-click-y 0)
(define drag-x 0) (define left-drag-x 0)
(define drag-y 0) (define left-drag-y 0)
(define (new-angle) (real-modulo (+ angle (* (- drag-x click-x) (/ 180 width))) 360)) (define (new-angle) (real-modulo (+ angle (* (- left-drag-x left-click-x) (/ 180 width))) 360))
(define (new-altitude) (clamp (+ altitude (* (- drag-y click-y) (/ 180 height))) 0 90)) (define (new-altitude) (clamp (+ altitude (* (- left-drag-y left-click-y) (/ 180 height))) 0 90))
(define draw? #t) (define draw? #t)
(define timer #f) (define timer #f)
(define ((update animating?)) (define ((update animating?))
(define can-draw? (case (render-thread-state rth) (define can-draw?
[(wait) #t] (cond [(worker-thread-working? rth)
[(drawing) (define new-bm (render-thread-try-get-bitmap rth)) (define new-bm (worker-thread-try-get rth))
(cond [(is-a? new-bm bitmap%) (set! bm new-bm) (cond [(is-a? new-bm bitmap%) (set! bm new-bm)
(set-bitmap bm) (set-bitmap bm)
#t] #t]
[else #f])])) [else #f])]
[else #t]))
(when (and draw? can-draw?) (when (and draw? can-draw?)
(set! draw? #f) (set! draw? #f)
(render-thread-draw rth (new-angle) (new-altitude) animating?))) (worker-thread-put rth (draw-command animating? (new-angle) (new-altitude)))))
(define (stop-timer) (define (stop-timer)
(when timer (when timer
@ -106,38 +68,40 @@
(define/override (on-event dc x y editorx editory evt) (define/override (on-event dc x y editorx editory evt)
(case (send evt get-event-type) (case (send evt get-event-type)
[(left-down) (render-thread-wait rth) [(left-down) (worker-thread-wait rth)
(set! angle (new-angle)) (set! angle (new-angle))
(set! altitude (new-altitude)) (set! altitude (new-altitude))
(set! click-x (send evt get-x)) (set! left-click-x (send evt get-x))
(set! click-y (send evt get-y)) (set! left-click-y (send evt get-y))
(set! drag-x click-x) (set! left-drag-x left-click-x)
(set! drag-y click-y) (set! left-drag-y left-click-y)
(set! draw? #t) (set! draw? #t)
(start-timer)] (start-timer)]
[(left-up) (stop-timer) [(left-up) (stop-timer)
(set! draw? #f) (set! draw? #f)
(render-thread-wait rth) (worker-thread-wait rth)
(set! drag-x (send evt get-x)) (set! left-drag-x (send evt get-x))
(set! drag-y (send evt get-y)) (set! left-drag-y (send evt get-y))
(set! angle (new-angle)) (set! angle (new-angle))
(set! altitude (new-altitude)) (set! altitude (new-altitude))
(set! click-x 0) (set! left-click-x 0)
(set! click-y 0) (set! left-click-y 0)
(set! drag-x 0) (set! left-drag-x 0)
(set! drag-y 0) (set! left-drag-y 0)
(render-thread-draw rth angle altitude #f) (worker-thread-put rth (draw-command #f angle altitude))
(define new-bm (render-thread-get-bitmap rth)) (define new-bm (worker-thread-get rth))
(when (is-a? new-bm bitmap%) (when (is-a? new-bm bitmap%)
(set! bm new-bm) (set! bm new-bm)
(set-bitmap bm))] (set-bitmap bm))]
[(motion) (when (and timer (send evt get-left-down)) [(motion) (when timer
(set! drag-x (send evt get-x)) (cond [(send evt get-left-down)
(set! drag-y (send evt get-y)) (set! left-drag-x (send evt get-x))
(set! draw? #t))])) (set! left-drag-y (send evt get-y))
(set! draw? #t)]))]))
(define/override (copy) (define/override (copy)
(make-object this% make-bm angle altitude bm (render-thread-copy rth))) (make-object this%
make-bm angle altitude bm (worker-thread-send rth (copy-command))))
(define cross-cursor (make-object cursor% 'cross)) (define cross-cursor (make-object cursor% 'cross))
(define/override (adjust-cursor dc x y editorx editory evt) cross-cursor) (define/override (adjust-cursor dc x y editorx editory evt) cross-cursor)

2
collects/plot/tests/isosurface-tests.rkt
View File

@ -4,7 +4,7 @@
(time (time
(plot3d (isosurface3d (λ (x y z) (sqrt (+ (sqr x) (sqr y) (sqr z)))) 1 (plot3d (isosurface3d (λ (x y z) (sqrt (+ (sqr x) (sqr y) (sqr z)))) 1
#:color 2 #:line-color (->brush-color 2) #:line-width 1 #:color 2 #:line-style 'transparent
#:label "Sphere") #:label "Sphere")
#:x-min -0.8 #:x-max 0.8 #:x-min -0.8 #:x-max 0.8
#:y-min -0.8 #:y-max 0.8 #:y-min -0.8 #:y-max 0.8

35
collects/plot/tests/low-level-tests.rkt
View File

@ -14,7 +14,8 @@
seconds-per-day seconds-per-day
seconds-per-week) seconds-per-week)
(only-in plot/common/format (only-in plot/common/format
int-str->e-str frac-str->e-str)) int-str->e-str frac-str->e-str)
plot/common/worker-thread)
(check-equal? (linear-seq 0 1 2 #:start? #t #:end? #t) '(0 1)) (check-equal? (linear-seq 0 1 2 #:start? #t #:end? #t) '(0 1))
(check-equal? (linear-seq 0 1 2 #:start? #t #:end? #f) '(0 2/3)) (check-equal? (linear-seq 0 1 2 #:start? #t #:end? #f) '(0 2/3))
@ -321,3 +322,35 @@
(check-false (vector-ormap (λ (x y) (and (= x 1) (= y 2))) (check-false (vector-ormap (λ (x y) (and (= x 1) (= y 2)))
#(0 0 1 0) #(0 0 1 0)
#(0 2 0 0))) #(0 2 0 0)))
;; ===================================================================================================
;; Worker threads
(let ()
(define wt (make-worker-thread (match-lambda
[(list x y z) (sleep 0.1)
(+ x y z)])))
(collect-garbage)
(collect-garbage)
(check-true (worker-thread-waiting? wt))
(check-true (worker-thread-put wt (list 1 2 3)))
(check-true (worker-thread-working? wt))
(check-equal? (worker-thread-get wt) 6)
(check-true (worker-thread-put wt (list 1 2 3)))
(check-false (worker-thread-try-put wt (list 10 20 30)))
(check-exn exn? (λ () (worker-thread-put wt (list 10 20 30))))
(check-false (worker-thread-try-get wt))
(sleep 0.2)
(check-equal? (worker-thread-try-get wt) 6)
(check-true (worker-thread-put wt (list 10 20 30)))
(check-equal? (worker-thread-send wt (list 1 2 3)) 6)
(check-exn exn? (λ () (worker-thread-get wt)))
(check-false (worker-thread-try-get wt))
(check-true (worker-thread-try-put wt (list 1 2 3)))
(sleep 0.2)
(check-false (worker-thread-try-put wt (list 10 20 30)))
(check-equal? (worker-thread-wait wt) (void))
(check-true (worker-thread-put wt (list 1 2)))
(check-exn exn? (λ () (worker-thread-get wt)))
)

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

@ -192,7 +192,7 @@
(contour-intervals3d f5 -4 0 -4 4 (contour-intervals3d f5 -4 0 -4 4
#:colors '(0 1 5) #:colors '(0 1 5)
#:line-colors '(0 4 2) #:line-colors '(0 4 2)
#:line-widths '(1) #:line-styles '(dot) #:line-widths '(1.5) #:line-styles '(dot)
#:contour-colors '(0) #:contour-colors '(0)
#:contour-widths '(0) #:contour-widths '(0)
#:contour-styles '(transparent) #:contour-styles '(transparent)
@ -205,7 +205,7 @@
(parameterize ([plot3d-samples 81]) (parameterize ([plot3d-samples 81])
(plot3d (contour-intervals3d (plot3d (contour-intervals3d
f5 -4 4 -4 4 #:label "z" f5 -4 4 -4 4 #:label "z"
#:line-colors default-contour-fill-colors)))) #:line-styles '(transparent)))))
(time (time
(plot3d (list (contours3d f5 -4 4 -4 4) (plot3d (list (contours3d f5 -4 4 -4 4)