207 lines
8.2 KiB
Racket
207 lines
8.2 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/gui/base racket/class racket/match racket/list unstable/parameter-group
|
|
"../common/gui.rkt"
|
|
"../common/math.rkt"
|
|
"../common/worker-thread.rkt"
|
|
"../common/plot-device.rkt"
|
|
"../common/parameters.rkt"
|
|
"plot-area.rkt")
|
|
|
|
(provide 3d-plot-snip% make-3d-plot-snip)
|
|
|
|
(define update-delay 16) ; about 60 fps (just over)
|
|
(define message-timeout 2000)
|
|
|
|
(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)
|
|
(parameterize/group ([plot-parameters saved-plot-parameters])
|
|
(make-bm animating? angle altitude))])))
|
|
|
|
(define (clamp x mn mx) (min* (max* x mn) mx))
|
|
|
|
(define 3d-plot-snip%
|
|
(class image-snip%
|
|
(init-field make-bm angle altitude saved-plot-parameters
|
|
[bm (make-bm #f angle altitude)])
|
|
(inherit set-bitmap)
|
|
|
|
(super-make-object bm)
|
|
|
|
(define/override (copy)
|
|
(make-object this% make-bm angle altitude saved-plot-parameters 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 (refresh)
|
|
;(printf "refreshing ~a~n" (current-milliseconds))
|
|
(send this set-bitmap bm))
|
|
|
|
(define draw? #t)
|
|
(define update-timer #f)
|
|
(define rth (make-render-thread make-bm saved-plot-parameters))
|
|
|
|
(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))))
|
|
(refresh-message-timer))
|
|
|
|
(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)
|
|
(set-message (format "angle = ~a\naltitude = ~a"
|
|
(number->string (round angle))
|
|
(number->string (round altitude)))))
|
|
|
|
(define (start-message msg)
|
|
(define refresh? (not (equal? msg message)))
|
|
(set-message msg)
|
|
(when refresh? (refresh)))
|
|
|
|
(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 evt-type (send evt get-event-type))
|
|
#;(when (not (eq? evt-type 'motion))
|
|
(printf "evt-type = ~v~n" evt-type))
|
|
#;(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
|
|
[(left-down) (worker-thread-wait rth)
|
|
(set! angle (new-angle))
|
|
(set! altitude (new-altitude))
|
|
(set-angles-message angle 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-update-timer)]
|
|
[(left-up) (when update-timer
|
|
(stop-update-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-angles-message angle 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 (and update-timer (send evt get-left-down))
|
|
(when (not (and (= left-drag-x (send evt get-x))
|
|
(= left-drag-y (send evt get-y))))
|
|
(set! left-drag-x (send evt get-x))
|
|
(set! left-drag-y (send evt get-y))
|
|
(set! draw? #t)
|
|
(set! dragged? #t)))
|
|
(when (and (not (send evt get-left-down))
|
|
(<= x (send evt get-x) (+ x width))
|
|
(<= y (send evt get-y) (+ y height)))
|
|
(start-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/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)))))
|
|
|
|
;; make-3d-plot-snip : (real real real -> bitmap) real real -> 3d-plot-snip%
|
|
(define (make-3d-plot-snip make-bm angle altitude saved-plot-parameters)
|
|
(make-object 3d-plot-snip% make-bm angle altitude saved-plot-parameters))
|