8b93de59c6
Endpoint-indifferent line styles (allows styles in finely chopped lines) Adjacent polygons now gapless (faces drawn w/o antialiasing; jaggies mitigated by supersampling)
114 lines
4.2 KiB
Racket
114 lines
4.2 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/gui/base racket/class racket/match racket/list
|
|
"../common/gui.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 draw-command (animating? angle altitude) #:transparent)
|
|
(struct copy-command () #:transparent)
|
|
|
|
(define (make-render-thread make-bm)
|
|
(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 #f angle altitude)]
|
|
[rth (make-render-thread make-bm)])
|
|
(inherit set-bitmap)
|
|
|
|
(super-make-object bm)
|
|
|
|
(define width (send bm get-width))
|
|
(define height (send bm get-height))
|
|
|
|
(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 (* (- 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?
|
|
(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)
|
|
(worker-thread-put rth (draw-command animating? (new-angle) (new-altitude)))))
|
|
|
|
(define (stop-timer)
|
|
(when timer
|
|
(send timer stop)
|
|
(set! timer #f)))
|
|
|
|
(define (start-timer)
|
|
(stop-timer)
|
|
(set! timer (make-object timer% (update #t) update-delay)))
|
|
|
|
(define/override (on-event dc x y editorx editory evt)
|
|
(case (send evt get-event-type)
|
|
[(left-down) (worker-thread-wait rth)
|
|
(set! angle (new-angle))
|
|
(set! altitude (new-altitude))
|
|
(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)
|
|
(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! 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 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 (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)
|
|
|
|
(send this set-flags (list* 'handles-events (send this get-flags)))))
|
|
|
|
;; make-3d-plot-snip : (real real real -> bitmap) real real -> 3d-plot-snip%
|
|
(define (make-3d-plot-snip make-bm angle altitude)
|
|
(make-object 3d-plot-snip% make-bm angle altitude))
|