-
Notifications
You must be signed in to change notification settings - Fork 0
/
tool-wheel.rkt
63 lines (51 loc) · 1.89 KB
/
tool-wheel.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
#lang racket
(require racket/gui drracket/tool framework)
(require "../methods.rkt" "gadget-sig.rkt" "../logger.rkt")
(provide tool@)
(define-unit tool@
(import drracket:tool^)
(export gadget^)
(define m
(mixin (c:surrogate<%>) ()
(define ts 0)
(define up 0)
(define left 0)
(define/override (on-char ths super event)
(log-useless-debug "on-char ~a" (send event get-key-code))
(define (finish)
(define es (current-milliseconds))
(when (> (- es ts) 120)
(define old-step (send ths wheel-step))
(cond
[(> up 0)
(send ths wheel-step (* up old-step))
(super (new key-event% [key-code 'wheel-up]))]
[(< up 0)
(send ths wheel-step (* (- up) old-step))
(super (new key-event% [key-code 'wheel-down]))])
(cond
[(> left 0)
(send ths wheel-step (* left old-step))
(super (new key-event% [key-code 'wheel-left]))]
[(< left 0)
(send ths wheel-step (* (- left) old-step))
(super (new key-event% [key-code 'wheel-right]))])
(send ths wheel-step old-step)
(set! ts es)
(set! up 0)
(set! left 0)))
(when (> (- (current-milliseconds) ts) 500)
(set! up 0)
(set! left 0))
(case (send event get-key-code)
[(wheel-up) (set! up (+ up 1)) (finish)]
[(wheel-down) (set! up (- up 1)) (finish)]
[(wheel-left) (set! left (+ left 1)) (finish)]
[(wheel-right) (set! left (- left 1)) (finish)]
[else
(set! up 0)
(set! left 0)
(super event)]))
(super-new)))
(define gadgets
(hasheq 'definition-canvas-mixin m 'interaction-canvas-mixin m)))