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

Click and drag to zoom 2D plots

Browse Source 
Snip refactoring
This commit is contained in:
Neil Toronto 2011-11-22 13:12:39 -07:00
parent a7ae78f3cc
commit 2f308a5323
9 changed files with 477 additions and 177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -589,6 +589,10 @@
(for/fold ([res empty-ivl]) ([i (in-list is)]) (for/fold ([res empty-ivl]) ([i (in-list is)])
(ivl-join2 res i))) (ivl-join2 res i)))
(defproc (ivl-translate [i ivl?] [d real?]) ivl?
(match-define (ivl a b) i)
(ivl (and a (+ a d)) (and b (+ b d))))
(defproc (bounds->intervals [xs (listof real?)]) (listof ivl?) (defproc (bounds->intervals [xs (listof real?)]) (listof ivl?)
(cond [((length xs) . < . 2) (raise-type-error 'bounds->intervals "list with length >= 2" xs)] (cond [((length xs) . < . 2) (raise-type-error 'bounds->intervals "list with length >= 2" xs)]
[else [else
@ -650,3 +654,6 @@
(define (rect-join . rs) (define (rect-join . rs)
(apply vector-map ivl-join rs)) (apply vector-map ivl-join rs))
(defproc (rect-translate [r (vectorof ivl?)] [v (vectorof real?)]) (vectorof ivl?)
(vector-map ivl-translate r v))

83
collects/plot/common/snip.rkt Normal file
View File

@ -0,0 +1,83 @@
#lang racket/base
(require racket/gui/base racket/class racket/list unstable/parameter-group
"math.rkt"
"parameters.rkt"
"plot-device.rkt")
(provide plot-snip%)
(define message-timeout 2000)
(define plot-snip%
(class image-snip%
(init bm)
(init-field saved-plot-parameters)
(inherit set-bitmap get-bitmap)
(super-make-object bm)
(define/override (copy) (make-object this% (get-bitmap) saved-plot-parameters))
(define/public (get-saved-plot-parameters) saved-plot-parameters)
(define/public (refresh)
;(printf "~a: refresh~n" (current-milliseconds))
(set-bitmap (get-bitmap)))
(define message #f)
(define message-timer (make-object timer% (λ () (stop-message))))
(define/public (stop-message)
;(printf "~a: stop-message~n" (current-milliseconds))
(send message-timer stop)
(set! message #f)
(refresh))
(define/public (reset-message-timeout)
(send message-timer start message-timeout #t))
(define/public (set-message msg #:refresh? [refresh? #t])
(define refresh? (and refresh? (not (equal? msg message))))
(set! message msg)
(reset-message-timeout)
(when refresh? (refresh)))
(define (draw-message dc dc-x-min dc-y-min)
(define bm (get-bitmap))
(define width (send bm get-width))
(define height (send bm get-height))
(define pd (make-object plot-device% dc dc-x-min dc-y-min width height))
(send pd reset-drawing-params #f)
(define lines (map (λ (line) (format " ~a " line)) (regexp-split "\n" message)))
(define-values (_1 char-height baseline _2) (send pd get-text-extent (first lines)))
(define line-widths (map (λ (line) (send pd get-text-width line)) lines))
(define box-x-size (apply max line-widths))
(define box-y-size (+ baseline (* (length lines) (+ char-height baseline))))
(define box-x-min (+ dc-x-min (* 1/2 (- width box-x-size))))
(define box-y-min (+ dc-y-min (* 1/2 (- height box-y-size))))
(define box-x-max (+ box-x-min box-x-size))
(define box-y-max (+ box-y-min box-y-size))
(send pd set-alpha 2/3)
(send pd set-minor-pen)
(send pd draw-rect (vector (ivl box-x-min box-x-max) (ivl box-y-min box-y-max)))
(send pd set-alpha 1)
(for ([line (in-list lines)] [i (in-naturals)])
(send pd draw-text
line (vector box-x-min (+ box-y-min baseline (* i (+ char-height baseline))))
'top-left #:outline? #t))
(send pd restore-drawing-params))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
;(printf "~a: drawing~n" (current-milliseconds))
(super draw dc x y left top right bottom dx dy draw-caret)
;(send dc draw-bitmap-section bm x y 0 0 width height)
(when message
(parameterize/group ([plot-parameters saved-plot-parameters])
(draw-message dc x y))))))

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

@ -22,7 +22,7 @@
#:property prop:procedure #:property prop:procedure
(λ (t x-min x-max) (λ (t x-min x-max)
(match-define (ticks layout format) t) (match-define (ticks layout format) t)
(define ts (layout x-min x-max)) (define ts (map pre-tick-inexact->exact (layout x-min x-max)))
(match-define (list (pre-tick xs majors) ...) ts) (match-define (list (pre-tick xs majors) ...) ts)
(map tick xs majors (format x-min x-max ts)))) (map tick xs majors (format x-min x-max ts))))
@ -633,9 +633,11 @@
(pre-tick x major?)))) (pre-tick x major?))))
format)) format))
(defproc (linear-scale [m real?] [b real? 0]) invertible-function? #:document-body (defproc (linear-scale [m rational?] [b rational? 0]) invertible-function? #:document-body
(let ([m (inexact->exact m)]
[b (inexact->exact b)])
(invertible-function (λ (x) (+ (* m x) b)) (invertible-function (λ (x) (+ (* m x) b))
(λ (y) (/ (- y b) m)))) (λ (y) (/ (- y b) m)))))
;; =================================================================================================== ;; ===================================================================================================
;; Tick utils ;; Tick utils
@ -665,3 +667,11 @@
[(m . = . 0) (list (collapse-equiv-ticks ts near-format-string))] [(m . = . 0) (list (collapse-equiv-ticks ts near-format-string))]
[(m . = . 1) (filter pre-tick-major? ts)] [(m . = . 1) (filter pre-tick-major? ts)]
[else (list (collapse-equiv-ticks (filter pre-tick-major? ts) near-format-string))]))))) [else (list (collapse-equiv-ticks (filter pre-tick-major? ts) near-format-string))])))))
(defproc (pre-tick-inexact->exact [t tick?]) tick?
(match-define (pre-tick x major?) t)
(pre-tick (inexact->exact x) major?))
(defproc (tick-inexact->exact [t tick?]) tick?
(match-define (tick x major? label) t)
(tick (inexact->exact x) major? label))

35
collects/plot/plot2d/plot-area.rkt
View File

@ -83,8 +83,8 @@
(and (equal? (plot-x-transform) id-transform) (and (equal? (plot-x-transform) id-transform)
(equal? (plot-y-transform) id-transform))) (equal? (plot-y-transform) id-transform)))
(match-define (invertible-function fx _) (apply-axis-transform (plot-x-transform) x-min x-max)) (match-define (invertible-function fx gx) (apply-axis-transform (plot-x-transform) x-min x-max))
(match-define (invertible-function fy _) (apply-axis-transform (plot-y-transform) y-min y-max)) (match-define (invertible-function fy gy) (apply-axis-transform (plot-y-transform) y-min y-max))
(define plot->view (define plot->view
(cond [identity-transforms? (λ (v) v)] (cond [identity-transforms? (λ (v) v)]
@ -135,16 +135,20 @@
(vector x (pre-tick-value t2)))) (vector x (pre-tick-value t2))))
(define x-ticks (define x-ticks
(collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks) (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max))
(map tick-inexact->exact rx-ticks))
(x-tick-near? y-min))) (x-tick-near? y-min)))
(define x-far-ticks (define x-far-ticks
(collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks) (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max))
(map tick-inexact->exact rx-far-ticks))
(x-tick-near? y-max))) (x-tick-near? y-max)))
(define y-ticks (define y-ticks
(collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks) (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max))
(map tick-inexact->exact ry-ticks))
(y-tick-near? x-min))) (y-tick-near? x-min)))
(define y-far-ticks (define y-far-ticks
(collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks) (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max))
(map tick-inexact->exact ry-far-ticks))
(y-tick-near? x-max))) (y-tick-near? x-max)))
;; =============================================================================================== ;; ===============================================================================================
@ -305,6 +309,25 @@
(define area-y-min (+ dc-y-min top)) (define area-y-min (+ dc-y-min top))
(define area-y-max (- dc-y-max bottom)) (define area-y-max (- dc-y-max bottom))
(define/public (get-area-bounds-rect)
(vector (ivl area-x-min area-x-max) (ivl area-y-min area-y-max)))
(define view->plot
(cond [identity-transforms? (λ (v) v)]
[else (λ (v) (match-let ([(vector x y) v])
(vector (gx x) (gy y))))]))
(define dc->view
(let ([area-per-view-x (/ (- area-x-max area-x-min) view-x-size)]
[area-per-view-y (/ (- area-y-max area-y-min) view-y-size)])
(λ (v)
(match-define (vector x y) v)
(vector (+ x-min (/ (- x area-x-min) area-per-view-x))
(+ y-min (/ (- area-y-max y) area-per-view-y))))))
(define/public (dc->plot v)
(view->plot (dc->view v)))
;; =============================================================================================== ;; ===============================================================================================
;; Plot decoration ;; Plot decoration

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

@ -15,6 +15,7 @@
"../common/deprecation-warning.rkt" "../common/deprecation-warning.rkt"
"../common/contract-doc.rkt" "../common/contract-doc.rkt"
"../common/format.rkt" "../common/format.rkt"
"snip.rkt"
"plot-area.rkt") "plot-area.rkt")
;; Require lazily: without this, Racket complains while generating documentation: ;; Require lazily: without this, Racket complains while generating documentation:
@ -150,12 +151,56 @@
[#: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 image-snip%) ) (is-a?/c image-snip%)
(parameterize ([plot-title title]
[plot-x-label x-label]
[plot-y-label y-label]
[plot-legend-anchor legend-anchor])
(define saved-plot-parameters (plot-parameters))
(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 (make-plot bounds-rect)
(define area #f)
(define bm (define bm
(plot-bitmap (parameterize/group ([plot-parameters saved-plot-parameters])
renderer-tree ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling)
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:width width #:height height (λ (dc)
#:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor)) (define-values (x-ticks x-far-ticks y-ticks y-far-ticks)
(make-object image-snip% bm)) (get-ticks renderer-list bounds-rect))
(set! area (make-object 2d-plot-area%
bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks
dc 0 0 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))
width height)))
(define (area-bounds->plot-bounds rect)
(match-define (vector (ivl area-x-min area-x-max) (ivl area-y-min area-y-max)) rect)
(match-define (vector x-min y-min) (send area dc->plot (vector area-x-min area-y-min)))
(match-define (vector x-max y-max) (send area dc->plot (vector area-x-max area-y-max)))
(vector (ivl x-min x-max) (ivl y-min y-max)))
(values bm (send area get-area-bounds-rect) area-bounds->plot-bounds))
(define-values (bm area-bounds-rect area-bounds->plot-bounds) (make-plot bounds-rect))
(make-2d-plot-snip
bm saved-plot-parameters
make-plot bounds-rect area-bounds-rect area-bounds->plot-bounds)))
;; Plot to a frame ;; Plot to a frame
(defproc (plot-frame [renderer-tree (treeof (or/c renderer2d? nonrenderer?))] (defproc (plot-frame [renderer-tree (treeof (or/c renderer2d? nonrenderer?))]

189
collects/plot/plot2d/snip.rkt Normal file
View File

@ -0,0 +1,189 @@
#lang racket/base
(require racket/gui/base racket/class racket/match racket/list racket/math unstable/parameter-group
"../common/snip.rkt"
"../common/plot-device.rkt"
"../common/math.rkt"
"../common/format.rkt"
"../common/ticks.rkt"
"../common/parameters.rkt")
(provide 2d-plot-snip% make-2d-plot-snip)
(define zoom-delay 16) ; about 60 fps (just over)
(define 2d-plot-snip%
(class plot-snip%
(init bm saved-plot-parameters)
(init-field make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds)
(inherit set-bitmap get-bitmap
get-saved-plot-parameters
refresh set-message reset-message-timeout get-admin)
(super-make-object bm saved-plot-parameters)
(define/override (copy)
(make-object this%
(get-bitmap) (get-saved-plot-parameters)
make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds))
(define left-click-x 0)
(define left-click-y 0)
(define left-drag-x 0)
(define left-drag-y 0)
(define plot-bounds-rects empty)
(define (get-area-bounds-rect)
(rect-meet area-bounds-rect
(rect-inexact->exact
(vector (ivl left-click-x left-drag-x) (ivl left-click-y left-drag-y)))))
(define dragging? #f)
(define left-down? #f) ; only #t if left-down happened on this snip
(define zoom-timer #f)
(define (set-zoom-timer)
(when (not zoom-timer)
(set! zoom-timer (make-object timer% (λ ()
(set! zoom-timer #f)
(refresh))
zoom-delay #t))))
(define zoomed? #f)
(define unzoomed? #f)
(define (set-click-message)
(cond [(and zoomed? unzoomed?) (void)]
[zoomed? (set-message "Click to unzoom once")]
[unzoomed? (set-message "Click and drag to zoom")]
[else (set-message "Click and drag to zoom\n Click to unzoom once")]))
(define (update-plot new-plot-bounds-rect)
(define-values (new-bm new-area-bounds-rect new-area-bounds->plot-bounds)
(make-plot new-plot-bounds-rect))
(set! plot-bounds-rect new-plot-bounds-rect)
(set! area-bounds-rect new-area-bounds-rect)
(set! area-bounds->plot-bounds new-area-bounds->plot-bounds)
(set-bitmap new-bm))
(define/override (on-event dc x y editorx editory evt)
(define evt-type (send evt get-event-type))
(define mouse-x (- (send evt get-x) x))
(define mouse-y (- (send evt get-y) y))
(case evt-type
[(left-down) (set! left-click-x mouse-x)
(set! left-click-y mouse-y)
(set! left-drag-x mouse-x)
(set! left-drag-y mouse-y)
(set! dragging? #f)
(set! left-down? #t)
(set-message #f)
(set-zoom-timer)]
[(left-up) (set! left-drag-x mouse-x)
(set! left-drag-y mouse-y)
(set! left-down? #f)
(cond [dragging?
(set! dragging? #f)
(define new-rect (area-bounds->plot-bounds (get-area-bounds-rect)))
(cond [(and (rect-rational? new-rect) (not (rect-zero-area? new-rect)))
#;(printf "~a: new-plot-bounds-rect = ~v~n"
(current-milliseconds) new-rect)
(set! plot-bounds-rects (cons plot-bounds-rect plot-bounds-rects))
(update-plot new-rect)
(set! zoomed? #t)]
[else (refresh)])]
[(not (empty? plot-bounds-rects))
(define new-rect (first plot-bounds-rects))
(set! plot-bounds-rects (rest plot-bounds-rects))
(update-plot new-rect)
(set! unzoomed? #t)])]
[(motion) (cond [left-down? ; not event's left-down: only #t if clicked on snip
(when (not (and (= left-drag-x mouse-x)
(= left-drag-y mouse-y)))
(set! left-drag-x mouse-x)
(set! left-drag-y mouse-y)
(set! dragging? #t)
(set-zoom-timer))]
[(and (not (send evt get-left-down))
(<= 0 mouse-x (send (get-bitmap) get-width))
(<= 0 mouse-y (send (get-bitmap) get-height)))
(set-click-message)])]))
(define/override (draw dc dc-x-min dc-y-min left top right bottom dx dy draw-caret)
;(printf "~a: drawing~n" (current-milliseconds))
(super draw dc dc-x-min dc-y-min left top right bottom dx dy draw-caret)
(when dragging?
(define new-rect (get-area-bounds-rect))
(when (and (rect-rational? new-rect) (not (rect-zero-area? new-rect)))
(define width (send (get-bitmap) get-width))
(define height (send (get-bitmap) get-height))
(define pd (make-object plot-device% dc dc-x-min dc-y-min width height))
(send pd reset-drawing-params #f)
(define select-color (get-highlight-background-color))
(define draw-rect (rect-translate new-rect (vector dc-x-min dc-y-min)))
;; inside of selection box
(send pd set-pen select-color 1 'transparent)
(send pd set-brush select-color 'solid)
(send pd set-alpha 1/8)
(send pd draw-rect draw-rect)
;; border of selection box
(send pd set-minor-pen)
(send pd set-brush select-color 'transparent)
(send pd set-alpha 3/4)
(send pd draw-rect draw-rect)
;; side labels
(parameterize/group ([plot-parameters (get-saved-plot-parameters)])
(match-define (vector (ivl x-min x-max) (ivl y-min y-max)) plot-bounds-rect)
(match-define (vector (ivl new-area-x-min new-area-x-max)
(ivl new-area-y-min new-area-y-max))
new-rect)
(match-define (vector (ivl new-x-min new-x-max) (ivl new-y-min new-y-max))
(area-bounds->plot-bounds new-rect))
(define new-area-x-mid (* 1/2 (+ new-area-x-min new-area-x-max)))
(define new-area-y-mid (* 1/2 (+ new-area-y-min new-area-y-max)))
;; format new-x-min and new-x-max
(match-define (list new-x-min-str new-x-max-str)
((ticks-format (plot-x-ticks))
x-min x-max (list (pre-tick new-x-min #t) (pre-tick new-x-max #t))))
;; draw new-x-min
(send pd draw-text new-x-min-str
(vector (+ dc-x-min new-area-x-min) (+ dc-y-min new-area-y-mid))
'center (* 1/2 pi) #:outline? #t)
;; draw new-x-max
(send pd draw-text new-x-max-str
(vector (+ dc-x-min new-area-x-max) (+ dc-y-min new-area-y-mid))
'center (* 1/2 pi) #:outline? #t)
;; format new-y-min and new-y-max
(match-define (list new-y-min-str new-y-max-str)
((ticks-format (plot-y-ticks))
y-min y-max (list (pre-tick new-y-min #t) (pre-tick new-y-max #t))))
;; draw new-y-min
(send pd draw-text new-y-min-str
(vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-max))
'center #:outline? #t)
;; draw new-y-max
(send pd draw-text new-y-max-str
(vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-min))
'center #:outline? #t))
(send pd restore-drawing-params))))
(define cross-cursor (make-object cursor% 'cross))
(define/override (adjust-cursor dc x y editorx editory evt) cross-cursor)
(send this set-flags (list* 'handles-events 'handles-all-mouse-events (send this get-flags)))))
(define (make-2d-plot-snip bm saved-plot-parameters
make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds)
(make-object 2d-plot-snip%
bm saved-plot-parameters
make-plot plot-bounds-rect area-bounds-rect area-bounds->plot-bounds))

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

@ -247,23 +247,29 @@
(vector x y (pre-tick-value t2)))) (vector x y (pre-tick-value t2))))
(define x-ticks (define x-ticks
(collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks) (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max))
(map tick-inexact->exact rx-ticks))
(x-ticks-near? x-axis-y))) (x-ticks-near? x-axis-y)))
(define y-ticks (define y-ticks
(collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks) (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max))
(map tick-inexact->exact ry-ticks))
(y-ticks-near? y-axis-x))) (y-ticks-near? y-axis-x)))
(define z-ticks (define z-ticks
(collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-ticks) (collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max))
(map tick-inexact->exact rz-ticks))
(z-ticks-near? z-axis-x z-axis-y))) (z-ticks-near? z-axis-x z-axis-y)))
(define x-far-ticks (define x-far-ticks
(collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks) (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max))
(map tick-inexact->exact rx-far-ticks))
(x-ticks-near? x-far-axis-y))) (x-ticks-near? x-far-axis-y)))
(define y-far-ticks (define y-far-ticks
(collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks) (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max))
(map tick-inexact->exact ry-far-ticks))
(y-ticks-near? y-far-axis-x))) (y-ticks-near? y-far-axis-x)))
(define z-far-ticks (define z-far-ticks
(collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-far-ticks) (collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max))
(map tick-inexact->exact rz-far-ticks))
(z-ticks-near? z-far-axis-x z-far-axis-y))) (z-ticks-near? z-far-axis-x z-far-axis-y)))
;; =============================================================================================== ;; ===============================================================================================

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

@ -190,9 +190,9 @@
(define render-list-hash (make-hash)) (define render-list-hash (make-hash))
(define legend-entries-hash (make-hash)) (define legend-entries-hash (make-hash))
(make-3d-plot-snip (define (make-bm anim? angle altitude)
(λ (anim? angle altitude) (parameterize/group ([plot-parameters saved-plot-parameters]
(parameterize ([plot-animating? (if anim? #t (plot-animating?))] [plot-animating? (if anim? #t (plot-animating?))]
[plot3d-angle angle] [plot3d-angle angle]
[plot3d-altitude altitude]) [plot3d-altitude altitude])
((if (plot-animating?) draw-bitmap draw-bitmap/supersampling) ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling)
@ -223,7 +223,10 @@
(send area end-plot)) (send area end-plot))
width height))) width height)))
angle altitude saved-plot-parameters)))
(make-3d-plot-snip
(make-bm #f angle altitude) saved-plot-parameters
make-bm angle altitude)))
;; Plot to a frame ;; Plot to a frame
(defproc (plot3d-frame [renderer-tree (treeof (or/c renderer3d? nonrenderer?))] (defproc (plot3d-frame [renderer-tree (treeof (or/c renderer3d? nonrenderer?))]

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

@ -1,17 +1,14 @@
#lang racket/base #lang racket/base
(require racket/gui/base racket/class racket/match racket/list unstable/parameter-group (require racket/gui/base racket/class racket/match unstable/parameter-group
"../common/gui.rkt" "../common/snip.rkt"
"../common/math.rkt" "../common/math.rkt"
"../common/worker-thread.rkt" "../common/worker-thread.rkt"
"../common/plot-device.rkt" "../common/parameters.rkt")
"../common/parameters.rkt"
"plot-area.rkt")
(provide 3d-plot-snip% make-3d-plot-snip) (provide 3d-plot-snip% make-3d-plot-snip)
(define update-delay 16) ; about 60 fps (just over) (define update-delay 16) ; about 60 fps (just over)
(define message-timeout 2000)
(struct draw-command (animating? angle altitude) #:transparent) (struct draw-command (animating? angle altitude) #:transparent)
@ -19,38 +16,41 @@
(make-worker-thread (make-worker-thread
(match-lambda (match-lambda
[(draw-command animating? angle altitude) [(draw-command animating? angle altitude)
(parameterize/group ([plot-parameters saved-plot-parameters]) (make-bm animating? angle altitude)])))
(make-bm animating? angle altitude))])))
(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 plot-snip%
(init-field make-bm angle altitude saved-plot-parameters (init bm saved-plot-parameters)
[bm (make-bm #f angle altitude)]) (init-field make-bm angle altitude)
(inherit set-bitmap)
(super-make-object bm) (inherit set-bitmap get-bitmap get-saved-plot-parameters set-message reset-message-timeout)
(super-make-object bm saved-plot-parameters)
(define/override (copy) (define/override (copy)
(make-object this% make-bm angle altitude saved-plot-parameters bm)) (make-object this%
(get-bitmap) (get-saved-plot-parameters)
(define width (send bm get-width)) make-bm angle altitude))
(define height (send bm get-height))
(define left-click-x 0) (define left-click-x 0)
(define left-click-y 0) (define left-click-y 0)
(define left-drag-x 0) (define left-drag-x 0)
(define left-drag-y 0) (define left-drag-y 0)
(define (new-angle) (real-modulo (+ angle (* (- left-drag-x left-click-x) (/ 180 width))) 360)) (define (new-angle)
(define (new-altitude) (clamp (+ altitude (* (- left-drag-y left-click-y) (/ 180 height))) 0 90)) (define degrees-per-pixel (/ 180 (send (get-bitmap) get-width)))
(define dx (- left-drag-x left-click-x))
(real-modulo (+ angle (* dx degrees-per-pixel)) 360))
(define (refresh) (define (new-altitude)
;(printf "refreshing ~a~n" (current-milliseconds)) (define degrees-per-pixel (/ 180 (send (get-bitmap) get-height)))
(send this set-bitmap bm)) (define dy (- left-drag-y left-click-y))
(clamp (+ altitude (* dy degrees-per-pixel)) 0 90))
(define draw? #t) (define draw? #t)
(define left-down? #f) ; only #t if left-down happened on this snip
(define update-timer #f) (define update-timer #f)
(define rth (make-render-thread make-bm saved-plot-parameters)) (define rth (make-render-thread make-bm saved-plot-parameters))
@ -77,130 +77,64 @@
(when (and draw? can-draw?) (when (and draw? can-draw?)
(set! draw? #f) (set! draw? #f)
(worker-thread-put rth (draw-command #t (new-angle) (new-altitude)))) (worker-thread-put rth (draw-command #t (new-angle) (new-altitude))))
(refresh-message-timer)) (reset-message-timeout))
(define message #f)
(define message-timer #f)
(define (stop-message)
;(printf "stop-message ~a~n" (current-milliseconds))
(when message-timer
(send message-timer stop)
(set! message-timer #f)
(set! message #f)
(refresh)))
(define (refresh-message-timer)
(when message-timer
(send message-timer stop))
(set! message-timer (make-object timer% stop-message message-timeout)))
(define (set-message msg)
(refresh-message-timer)
(set! message msg))
(define (set-angles-message angle altitude) (define (set-angles-message angle altitude)
(set-message (format "angle = ~a\naltitude = ~a" (set-message (format "angle = ~a\naltitude = ~a"
(number->string (round angle)) (number->string (inexact->exact (round angle)))
(number->string (round altitude))))) (number->string (inexact->exact (round altitude))))
#:refresh? #f))
(define (start-message msg) (define rotated? #f)
(define refresh? (not (equal? msg message))) (define (set-click-message)
(set-message msg) (unless rotated?
(when refresh? (refresh))) (set-message "Click and drag to rotate")))
(define dragged? #f)
(define (start-click-message)
(unless dragged?
(start-message "Click and drag to rotate")))
(define/override (on-event dc x y editorx editory evt) (define/override (on-event dc x y editorx editory evt)
(define evt-type (send evt get-event-type)) (define evt-type (send evt get-event-type))
#;(when (not (eq? evt-type 'motion)) (define mouse-x (- (send evt get-x) x))
(printf "evt-type = ~v~n" evt-type)) (define mouse-y (- (send evt get-y) y))
#;(when (eq? evt-type 'motion)
(printf "motion for ~a; x,y = ~a,~a~n" (eq-hash-code this) (send evt get-x) (send evt get-y)))
(case evt-type (case evt-type
[(left-down) (worker-thread-wait rth) [(left-down) (worker-thread-wait rth)
(set! left-click-x mouse-x)
(set! left-click-y mouse-y)
(set! left-drag-x mouse-x)
(set! left-drag-y mouse-y)
(set! angle (new-angle)) (set! angle (new-angle))
(set! altitude (new-altitude)) (set! altitude (new-altitude))
(set-angles-message angle altitude) (set-angles-message angle altitude)
(set! left-click-x (send evt get-x)) (set! left-down? #t)
(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) (set! draw? #t)
(start-update-timer)] (start-update-timer)]
[(left-up) (when update-timer [(left-up) (when left-down?
(stop-update-timer) (stop-update-timer)
(set! draw? #f) (set! draw? #f)
(set! left-down? #f)
(worker-thread-wait rth) (worker-thread-wait rth)
(set! left-drag-x (send evt get-x)) (set! left-drag-x mouse-x)
(set! left-drag-y (send evt get-y)) (set! left-drag-y mouse-y)
(set! angle (new-angle)) (set! angle (new-angle))
(set! altitude (new-altitude)) (set! altitude (new-altitude))
(set-angles-message angle altitude) (set-angles-message angle altitude)
(set! left-click-x 0) (define new-bm (worker-thread-send rth (draw-command #f angle altitude)))
(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%) (when (is-a? new-bm bitmap%)
(set! bm new-bm) (set-bitmap new-bm)))]
(set-bitmap bm)))] [(motion) (cond [left-down?
[(motion) (when (and update-timer (send evt get-left-down)) (when (not (and (= left-drag-x mouse-x)
(when (not (and (= left-drag-x (send evt get-x)) (= left-drag-y mouse-y)))
(= left-drag-y (send evt get-y)))) (set! left-drag-x mouse-x)
(set! left-drag-x (send evt get-x)) (set! left-drag-y mouse-y)
(set! left-drag-y (send evt get-y))
(set! draw? #t) (set! draw? #t)
(set! dragged? #t))) (set! rotated? #t))]
(when (and (not (send evt get-left-down)) [else (and (not (send evt get-left-down))
(<= x (send evt get-x) (+ x width)) (<= 0 mouse-x (send (get-bitmap) get-width))
(<= y (send evt get-y) (+ y height))) (<= 0 mouse-y (send (get-bitmap) get-height)))
(start-click-message))])) (set-click-message)])]))
(define (draw-message dc dc-x-min dc-y-min)
(define pd (make-object plot-device% dc dc-x-min dc-y-min width height))
(send pd reset-drawing-params #f)
(define lines (map (λ (line) (format " ~a " line)) (regexp-split "\n" message)))
(define-values (_1 char-height baseline _2) (send pd get-text-extent (first lines)))
(define line-widths (map (λ (line) (send pd get-text-width line)) lines))
(define box-x-size (apply max line-widths))
(define box-y-size (+ baseline (* (length lines) (+ char-height baseline))))
(define box-x-min (+ dc-x-min (* 1/2 (- width box-x-size))))
(define box-y-min (+ dc-y-min (* 1/2 (- height box-y-size))))
(define box-x-max (+ box-x-min box-x-size))
(define box-y-max (+ box-y-min box-y-size))
(send pd set-alpha 2/3)
(send pd set-minor-pen)
(send pd draw-rect (vector (ivl box-x-min box-x-max) (ivl box-y-min box-y-max)))
(send pd set-alpha 1)
(for ([line (in-list lines)] [i (in-naturals)])
(send pd draw-text
line (vector box-x-min (+ box-y-min baseline (* i (+ char-height baseline))))
'top-left #:outline? #t))
(send pd restore-drawing-params))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
;(printf "drawing ~a~n" (current-milliseconds))
(super draw dc x y left top right bottom dx dy draw-caret)
;(send dc draw-bitmap-section bm x y 0 0 width height)
(when message
(parameterize/group ([plot-parameters saved-plot-parameters])
(draw-message dc x y))))
(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)
(send this set-flags (list* 'handles-events 'handles-all-mouse-events (send this get-flags))))) (send this set-flags (list* 'handles-events 'handles-all-mouse-events (send this get-flags)))))
;; make-3d-plot-snip : (real real real -> bitmap) real real -> 3d-plot-snip% (define (make-3d-plot-snip bm saved-plot-parameters make-bm angle altitude)
(define (make-3d-plot-snip make-bm angle altitude saved-plot-parameters) (make-object 3d-plot-snip% bm saved-plot-parameters make-bm angle altitude))
(make-object 3d-plot-snip% make-bm angle altitude saved-plot-parameters))