Abstracted render-thread into worker-thread (preparing for animated 2D plots)
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
parent
5bd8481aa7
commit
8b93de59c6
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
;; 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"
|
||||
"contract.rkt"
|
||||
"contract-doc.rkt"
|
||||
|
|
@ -352,3 +352,189 @@
|
|||
transform rotate scale translate
|
||||
try-color)
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -135,13 +135,20 @@
|
|||
|
||||
(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
|
||||
;; the forseeable future) this is much faster than using a pen-list%, because it doesn't have to
|
||||
;; synchronize access to be thread-safe.
|
||||
(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))
|
||||
(->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
|
||||
(hash-ref! pen-hash (vector 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-color (plot-background))
|
||||
(define brush-style 'solid)
|
||||
|
||||
;; Sets the brush. Same idea as set-pen.
|
||||
(define/public (set-brush color style)
|
||||
(match-define (list (app real->color-byte r) (app real->color-byte g) (app real->color-byte b))
|
||||
(->brush-color color))
|
||||
(let ([style (->brush-style style)])
|
||||
(set! brush-color color)
|
||||
(set! brush-style style)
|
||||
(send dc set-brush
|
||||
(hash-ref! brush-hash (vector r g b style)
|
||||
(λ () (make-object brush% (make-object color% r g b) style))))))
|
||||
|
||||
(define alpha (plot-foreground-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.
|
||||
(define/public (set-background color)
|
||||
|
|
@ -250,9 +266,21 @@
|
|||
(match-define (vector x y) v)
|
||||
(send dc draw-point x y)))
|
||||
|
||||
(define/public (draw-polygon vs [fill-style 'winding])
|
||||
(define/public (draw-polygon 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)
|
||||
(when (rect-regular? r)
|
||||
|
|
@ -261,13 +289,13 @@
|
|||
|
||||
(define/public (draw-lines 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)
|
||||
(when (and (vregular? v1) (vregular? v2))
|
||||
(match-define (vector x1 y1) v1)
|
||||
(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])
|
||||
(when (vregular? v)
|
||||
|
|
|
|||
78
collects/plot/common/worker-thread.rkt
Normal file
78
collects/plot/common/worker-thread.rkt
Normal 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))
|
||||
|
|
@ -135,14 +135,11 @@
|
|||
(let ([colors (map ->brush-color (maybe-apply colors z-ivls))]
|
||||
[styles (map ->brush-style (maybe-apply styles 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)]
|
||||
[zb (in-list (rest zs))]
|
||||
[color (in-cycle colors)]
|
||||
[style (in-cycle styles)]
|
||||
[alpha (in-cycle alphas)]
|
||||
[line-style (in-cycle line-styles)])
|
||||
[alpha (in-cycle alphas)])
|
||||
(define polys
|
||||
(append*
|
||||
(for/list ([ya (in-list ys)]
|
||||
|
|
@ -159,26 +156,11 @@
|
|||
(for/list ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))])
|
||||
(map (λ (v) (vector-take v 2)) poly)))))
|
||||
|
||||
(define (draw-polys)
|
||||
(for ([poly (in-list polys)])
|
||||
(send area put-pen color 1 'transparent)
|
||||
(send area put-brush color style)
|
||||
(send area put-alpha alpha)
|
||||
(for ([poly (in-list polys)])
|
||||
(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)
|
||||
area)
|
||||
|
|
@ -194,7 +176,7 @@
|
|||
|
||||
(cond [label (interval-legend-entries
|
||||
label z-ivls ivl-labels
|
||||
colors styles colors '(1) line-styles
|
||||
colors styles colors '(1) '(transparent)
|
||||
contour-colors* contour-widths* contour-styles*
|
||||
(rest contour-colors*) (rest contour-widths*) (rest contour-styles*))]
|
||||
[else empty]))))
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
unstable/lazy-require
|
||||
"../common/contract.rkt"
|
||||
"../common/math.rkt"
|
||||
"../common/draw.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"../common/plot-element.rkt"
|
||||
"../common/file-type.rkt"
|
||||
|
|
@ -19,11 +20,62 @@
|
|||
;; cannot instantiate `racket/gui/base' a second time in the same process
|
||||
(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
|
||||
|
||||
(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?))]
|
||||
[dc (is-a?/c dc<%>)]
|
||||
[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)]
|
||||
[#:y-label y-label (or/c string? #f) (plot-y-label)]
|
||||
[#: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 rs (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 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)))
|
||||
(define renderer-list (get-renderer-list renderer-tree))
|
||||
(define bounds-rect (get-bounds-rect renderer-list x-min x-max y-min y-max))
|
||||
(define-values (x-ticks x-far-ticks y-ticks y-far-ticks)
|
||||
(get-ticks renderer-list bounds-rect))
|
||||
|
||||
(parameterize ([plot-title title]
|
||||
[plot-x-label x-label]
|
||||
[plot-y-label y-label]
|
||||
[plot-legend-anchor legend-anchor])
|
||||
(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 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-dc renderer-list bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks
|
||||
dc x y width height)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Plot to various other backends
|
||||
|
|
@ -100,12 +115,16 @@
|
|||
[#:y-label y-label (or/c string? #f) (plot-y-label)]
|
||||
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]
|
||||
) (is-a?/c bitmap%)
|
||||
(define bm (make-bitmap width height))
|
||||
(define dc (make-object bitmap-dc% bm))
|
||||
(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)
|
||||
bm)
|
||||
(define renderer-list (get-renderer-list renderer-tree))
|
||||
(define bounds-rect (get-bounds-rect renderer-list x-min x-max y-min y-max))
|
||||
(define-values (x-ticks x-far-ticks y-ticks y-far-ticks)
|
||||
(get-ticks renderer-list bounds-rect))
|
||||
((if (plot-animating?) draw-bitmap draw-bitmap/supersampling)
|
||||
(λ (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?))]
|
||||
[#:x-min x-min (or/c regular-real? #f) #f]
|
||||
|
|
@ -122,10 +141,10 @@
|
|||
(define saved-values (plot-parameters))
|
||||
(dc (λ (dc x y)
|
||||
(parameterize/group
|
||||
([plot-parameters saved-values])
|
||||
(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
|
||||
#:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor)))
|
||||
([plot-parameters saved-values])
|
||||
(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
|
||||
#:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor)))
|
||||
width height))
|
||||
|
||||
;; Plot to a snip
|
||||
|
|
|
|||
|
|
@ -4,7 +4,10 @@
|
|||
|
||||
(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
|
||||
|
|
@ -132,3 +135,59 @@
|
|||
[_ (when (empty? vs) (return empty))]
|
||||
[vs (clip-polygon-z-max z-max 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))
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -167,7 +167,7 @@
|
|||
(define (x-axis-angle) (plot-dir->dc-angle #(1 0 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)))
|
||||
(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)
|
||||
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])
|
||||
(when (and (vregular? v) (in-bounds? v))
|
||||
(add-shape!
|
||||
(text (get-alpha) (plot->view/no-rho v) anchor angle str
|
||||
(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)
|
||||
(for ([v (in-list vs)])
|
||||
(when (and (vregular? v) (in-bounds? v))
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
unstable/lazy-require
|
||||
"../common/contract.rkt"
|
||||
"../common/math.rkt"
|
||||
"../common/draw.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"../common/plot-element.rkt"
|
||||
"../common/file-type.rkt"
|
||||
|
|
@ -20,11 +21,75 @@
|
|||
(lazy-require ["snip.rkt" (make-3d-plot-snip)]
|
||||
["../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
|
||||
|
||||
(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?))]
|
||||
[dc (is-a?/c dc<%>)]
|
||||
[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)]
|
||||
[#:z-label z-label (or/c string? #f) (plot-z-label)]
|
||||
[#: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 rs (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 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)))
|
||||
(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))
|
||||
|
||||
(parameterize ([plot3d-angle angle]
|
||||
[plot3d-altitude altitude]
|
||||
|
|
@ -83,28 +117,9 @@
|
|||
[plot-y-label y-label]
|
||||
[plot-z-label z-label]
|
||||
[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)
|
||||
(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 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)))
|
||||
(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)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Plot to various other backends
|
||||
|
|
@ -127,13 +142,13 @@
|
|||
[#:z-label z-label (or/c string? #f) (plot-z-label)]
|
||||
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]
|
||||
) (is-a?/c bitmap%)
|
||||
(define bm (make-bitmap width height))
|
||||
(define dc (make-object bitmap-dc% bm))
|
||||
(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
|
||||
#:angle angle #:altitude altitude #:title title #:x-label x-label #:y-label y-label
|
||||
#:z-label z-label #:legend-anchor legend-anchor)
|
||||
bm)
|
||||
((if (plot-animating?) draw-bitmap draw-bitmap/supersampling)
|
||||
(λ (dc)
|
||||
(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
|
||||
#:angle angle #:altitude altitude #:title title #:x-label x-label #:y-label y-label
|
||||
#:z-label z-label #:legend-anchor legend-anchor))
|
||||
width height))
|
||||
|
||||
(defproc (plot3d-pict [renderer-tree (treeof (or/c renderer3d? non-renderer?))]
|
||||
[#:x-min x-min (or/c regular-real? #f) #f]
|
||||
|
|
@ -154,12 +169,11 @@
|
|||
) pict?
|
||||
(define saved-values (plot-parameters))
|
||||
(dc (λ (dc x y)
|
||||
(parameterize/group
|
||||
([plot-parameters saved-values])
|
||||
(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
|
||||
#: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)))
|
||||
(parameterize/group ([plot-parameters saved-values])
|
||||
(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
|
||||
#: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)))
|
||||
width height))
|
||||
|
||||
;; Plot to a snip
|
||||
|
|
@ -180,14 +194,26 @@
|
|||
[#:z-label z-label (or/c string? #f) (plot-z-label)]
|
||||
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]
|
||||
) (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
|
||||
(λ (angle altitude anim?)
|
||||
(parameterize ([plot-animating? (if anim? #t (plot-animating?))])
|
||||
(plot3d-bitmap
|
||||
renderer-tree
|
||||
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min #:z-max z-max
|
||||
#:width width #:height height #:angle angle #:altitude altitude #:title title
|
||||
#:x-label x-label #:y-label y-label #:z-label z-label #:legend-anchor legend-anchor)))
|
||||
(λ (anim? angle altitude)
|
||||
(parameterize ([plot-animating? (if anim? #t (plot-animating?))]
|
||||
[plot3d-angle angle]
|
||||
[plot3d-altitude altitude]
|
||||
[plot-title title]
|
||||
[plot-x-label x-label]
|
||||
[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))
|
||||
|
||||
;; Plot to a frame
|
||||
|
|
|
|||
|
|
@ -1,69 +1,30 @@
|
|||
#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/math.rkt")
|
||||
"../common/math.rkt"
|
||||
"../common/worker-thread.rkt"
|
||||
"plot-area.rkt")
|
||||
|
||||
(provide 3d-plot-snip% make-3d-plot-snip)
|
||||
|
||||
(define update-delay 33) ; about 30 fps (just over)
|
||||
|
||||
(struct render-thread (state command-channel response-channel thread) #:mutable #:transparent)
|
||||
|
||||
(struct draw-command (angle altitude animating?) #:transparent)
|
||||
(struct draw-command (animating? angle altitude) #:transparent)
|
||||
(struct copy-command () #:transparent)
|
||||
|
||||
(define (make-render-thread make-bm)
|
||||
(define com-ch (make-channel))
|
||||
(define res-ch (make-async-channel))
|
||||
(define th
|
||||
(thread
|
||||
(λ ()
|
||||
(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))
|
||||
(make-worker-thread
|
||||
(match-lambda
|
||||
[(draw-command animating? angle altitude) (make-bm animating? angle altitude)]
|
||||
[(copy-command) (make-render-thread make-bm)])))
|
||||
|
||||
(define (clamp x mn mx) (min* (max* x mn) mx))
|
||||
|
||||
(define 3d-plot-snip%
|
||||
(class image-snip%
|
||||
(init-field make-bm angle altitude
|
||||
[bm (make-bm angle altitude #f)]
|
||||
[bm (make-bm #f angle altitude)]
|
||||
[rth (make-render-thread make-bm)])
|
||||
(inherit set-bitmap)
|
||||
|
||||
|
|
@ -72,28 +33,29 @@
|
|||
(define width (send bm get-width))
|
||||
(define height (send bm get-height))
|
||||
|
||||
(define click-x 0)
|
||||
(define click-y 0)
|
||||
(define drag-x 0)
|
||||
(define drag-y 0)
|
||||
(define left-click-x 0)
|
||||
(define left-click-y 0)
|
||||
(define left-drag-x 0)
|
||||
(define left-drag-y 0)
|
||||
|
||||
(define (new-angle) (real-modulo (+ angle (* (- drag-x click-x) (/ 180 width))) 360))
|
||||
(define (new-altitude) (clamp (+ altitude (* (- drag-y click-y) (/ 180 height))) 0 90))
|
||||
(define (new-angle) (real-modulo (+ angle (* (- left-drag-x left-click-x) (/ 180 width))) 360))
|
||||
(define (new-altitude) (clamp (+ altitude (* (- left-drag-y left-click-y) (/ 180 height))) 0 90))
|
||||
|
||||
(define draw? #t)
|
||||
(define timer #f)
|
||||
|
||||
(define ((update animating?))
|
||||
(define can-draw? (case (render-thread-state rth)
|
||||
[(wait) #t]
|
||||
[(drawing) (define new-bm (render-thread-try-get-bitmap rth))
|
||||
(cond [(is-a? new-bm bitmap%) (set! bm new-bm)
|
||||
(set-bitmap bm)
|
||||
#t]
|
||||
[else #f])]))
|
||||
(define can-draw?
|
||||
(cond [(worker-thread-working? rth)
|
||||
(define new-bm (worker-thread-try-get rth))
|
||||
(cond [(is-a? new-bm bitmap%) (set! bm new-bm)
|
||||
(set-bitmap bm)
|
||||
#t]
|
||||
[else #f])]
|
||||
[else #t]))
|
||||
(when (and draw? can-draw?)
|
||||
(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)
|
||||
(when timer
|
||||
|
|
@ -106,38 +68,40 @@
|
|||
|
||||
(define/override (on-event dc x y editorx editory evt)
|
||||
(case (send evt get-event-type)
|
||||
[(left-down) (render-thread-wait rth)
|
||||
[(left-down) (worker-thread-wait rth)
|
||||
(set! angle (new-angle))
|
||||
(set! altitude (new-altitude))
|
||||
(set! click-x (send evt get-x))
|
||||
(set! click-y (send evt get-y))
|
||||
(set! drag-x click-x)
|
||||
(set! drag-y click-y)
|
||||
(set! left-click-x (send evt get-x))
|
||||
(set! left-click-y (send evt get-y))
|
||||
(set! left-drag-x left-click-x)
|
||||
(set! left-drag-y left-click-y)
|
||||
(set! draw? #t)
|
||||
(start-timer)]
|
||||
[(left-up) (stop-timer)
|
||||
(set! draw? #f)
|
||||
(render-thread-wait rth)
|
||||
(set! drag-x (send evt get-x))
|
||||
(set! drag-y (send evt get-y))
|
||||
(worker-thread-wait rth)
|
||||
(set! left-drag-x (send evt get-x))
|
||||
(set! left-drag-y (send evt get-y))
|
||||
(set! angle (new-angle))
|
||||
(set! altitude (new-altitude))
|
||||
(set! click-x 0)
|
||||
(set! click-y 0)
|
||||
(set! drag-x 0)
|
||||
(set! drag-y 0)
|
||||
(render-thread-draw rth angle altitude #f)
|
||||
(define new-bm (render-thread-get-bitmap rth))
|
||||
(set! left-click-x 0)
|
||||
(set! left-click-y 0)
|
||||
(set! left-drag-x 0)
|
||||
(set! left-drag-y 0)
|
||||
(worker-thread-put rth (draw-command #f angle altitude))
|
||||
(define new-bm (worker-thread-get rth))
|
||||
(when (is-a? new-bm bitmap%)
|
||||
(set! bm new-bm)
|
||||
(set-bitmap bm))]
|
||||
[(motion) (when (and timer (send evt get-left-down))
|
||||
(set! drag-x (send evt get-x))
|
||||
(set! drag-y (send evt get-y))
|
||||
(set! draw? #t))]))
|
||||
[(motion) (when timer
|
||||
(cond [(send evt get-left-down)
|
||||
(set! left-drag-x (send evt get-x))
|
||||
(set! left-drag-y (send evt get-y))
|
||||
(set! draw? #t)]))]))
|
||||
|
||||
(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/override (adjust-cursor dc x y editorx editory evt) cross-cursor)
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
(time
|
||||
(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")
|
||||
#:x-min -0.8 #:x-max 0.8
|
||||
#:y-min -0.8 #:y-max 0.8
|
||||
|
|
|
|||
|
|
@ -14,7 +14,8 @@
|
|||
seconds-per-day
|
||||
seconds-per-week)
|
||||
(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? #f) '(0 2/3))
|
||||
|
|
@ -321,3 +322,35 @@
|
|||
(check-false (vector-ormap (λ (x y) (and (= x 1) (= y 2)))
|
||||
#(0 0 1 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)))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -192,7 +192,7 @@
|
|||
(contour-intervals3d f5 -4 0 -4 4
|
||||
#:colors '(0 1 5)
|
||||
#:line-colors '(0 4 2)
|
||||
#:line-widths '(1) #:line-styles '(dot)
|
||||
#:line-widths '(1.5) #:line-styles '(dot)
|
||||
#:contour-colors '(0)
|
||||
#:contour-widths '(0)
|
||||
#:contour-styles '(transparent)
|
||||
|
|
@ -205,7 +205,7 @@
|
|||
(parameterize ([plot3d-samples 81])
|
||||
(plot3d (contour-intervals3d
|
||||
f5 -4 4 -4 4 #:label "z"
|
||||
#:line-colors default-contour-fill-colors))))
|
||||
#:line-styles '(transparent)))))
|
||||
|
||||
(time
|
||||
(plot3d (list (contours3d f5 -4 4 -4 4)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user