137 lines
5.3 KiB
Racket
137 lines
5.3 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/gui/base racket/class racket/match unstable/parameter-group
|
|
"../common/snip.rkt"
|
|
"../common/math.rkt"
|
|
"../common/worker-thread.rkt"
|
|
"../common/parameters.rkt")
|
|
|
|
(provide 3d-plot-snip% make-3d-plot-snip)
|
|
|
|
(define update-delay 16) ; about 60 fps (just over)
|
|
(define show-rotate-message? #t)
|
|
|
|
(struct draw-command (animating? angle altitude) #:transparent)
|
|
|
|
(define (make-render-thread make-bm saved-plot-parameters)
|
|
(make-worker-thread
|
|
(match-lambda
|
|
[(draw-command animating? angle altitude)
|
|
(make-bm animating? angle altitude)])))
|
|
|
|
(define (clamp x mn mx) (min* (max* x mn) mx))
|
|
|
|
(define 3d-plot-snip%
|
|
(class plot-snip%
|
|
(init bm saved-plot-parameters)
|
|
(init-field make-bm angle altitude)
|
|
|
|
(inherit set-bitmap get-bitmap
|
|
get-saved-plot-parameters set-message reset-message-timeout
|
|
get-left-down-here?)
|
|
|
|
(super-make-object bm saved-plot-parameters)
|
|
|
|
(define/override (copy)
|
|
(make-object this%
|
|
(get-bitmap) (get-saved-plot-parameters)
|
|
make-bm angle altitude))
|
|
|
|
(define left-click-x 0)
|
|
(define left-click-y 0)
|
|
(define left-drag-x 0)
|
|
(define left-drag-y 0)
|
|
|
|
(define (new-angle)
|
|
(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 (new-altitude)
|
|
(define degrees-per-pixel (/ 180 (send (get-bitmap) get-height)))
|
|
(define dy (- left-drag-y left-click-y))
|
|
(clamp (+ altitude (* dy degrees-per-pixel)) 0 90))
|
|
|
|
(define rth (make-render-thread make-bm saved-plot-parameters))
|
|
(define draw? #t)
|
|
(define update-timer #f)
|
|
|
|
(define (stop-update-timer)
|
|
(when update-timer
|
|
(send update-timer stop)
|
|
(set! update-timer #f)))
|
|
|
|
(define (start-update-timer)
|
|
(stop-update-timer)
|
|
(set! update-timer (make-object timer% update update-delay)))
|
|
|
|
(define (update)
|
|
;(printf "update ~a~n" (current-milliseconds))
|
|
(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-angles-message (new-angle) (new-altitude))
|
|
(set-bitmap bm)
|
|
#t]
|
|
[else #f])]
|
|
[else #t]))
|
|
(when (and draw? can-draw?)
|
|
(set! draw? #f)
|
|
(worker-thread-put rth (draw-command #t (new-angle) (new-altitude))))
|
|
(reset-message-timeout))
|
|
|
|
(define (set-angles-message angle altitude)
|
|
(set-message (format "angle = ~a\naltitude = ~a"
|
|
(number->string (inexact->exact (round angle)))
|
|
(number->string (inexact->exact (round altitude))))
|
|
#:refresh? #f))
|
|
|
|
(define (set-click-message)
|
|
(when show-rotate-message?
|
|
(set-message "Click and drag to rotate")))
|
|
|
|
(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) (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! altitude (new-altitude))
|
|
(set-angles-message angle altitude)
|
|
(set! draw? #t)
|
|
(start-update-timer)]
|
|
[(left-up) (when (get-left-down-here?)
|
|
(stop-update-timer)
|
|
(set! draw? #f)
|
|
(worker-thread-wait rth)
|
|
(set! left-drag-x mouse-x)
|
|
(set! left-drag-y mouse-y)
|
|
(set! angle (new-angle))
|
|
(set! altitude (new-altitude))
|
|
(set-angles-message angle altitude)
|
|
(define new-bm (worker-thread-send rth (draw-command #f angle altitude)))
|
|
(when (is-a? new-bm bitmap%)
|
|
(set-bitmap new-bm)))]
|
|
[(motion) (cond [(get-left-down-here?)
|
|
(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! draw? #t)
|
|
(set! show-rotate-message? #f))]
|
|
[else (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)])])
|
|
(super on-event dc x y editorx editory evt))
|
|
))
|
|
|
|
(define (make-3d-plot-snip bm saved-plot-parameters make-bm angle altitude)
|
|
(make-object 3d-plot-snip% bm saved-plot-parameters make-bm angle altitude))
|