Key debouncer
This commit is contained in:
parent
61b683fc94
commit
6b3f8d920a
|
@ -1,8 +1,10 @@
|
||||||
#lang syndicate/actor
|
#lang syndicate/actor
|
||||||
|
;; Demonstrates debouncer-like functionality.
|
||||||
|
|
||||||
(require syndicate/big-bang)
|
(require syndicate/big-bang)
|
||||||
(require/activate syndicate/big-bang/timestate)
|
(require/activate syndicate/big-bang/timestate)
|
||||||
|
|
||||||
|
(struct key-down (key) #:prefab)
|
||||||
(struct click-event (description) #:prefab)
|
(struct click-event (description) #:prefab)
|
||||||
|
|
||||||
(spawn #:name 'button
|
(spawn #:name 'button
|
||||||
|
@ -21,7 +23,7 @@
|
||||||
(on-start (wait-for-initial-press))
|
(on-start (wait-for-initial-press))
|
||||||
|
|
||||||
(assert (outbound (window name 10 10 0
|
(assert (outbound (window name 10 10 0
|
||||||
(seal (overlay (text "Click me" 22 "white")
|
(seal (overlay (text "Click me" 20 "white")
|
||||||
(rectangle 140 50 "solid" "red")))))))
|
(rectangle 140 50 "solid" "red")))))))
|
||||||
|
|
||||||
(spawn #:name 'status
|
(spawn #:name 'status
|
||||||
|
@ -32,7 +34,25 @@
|
||||||
(on (asserted (later-than (clear-time)))
|
(on (asserted (later-than (clear-time)))
|
||||||
(status 'waiting))
|
(status 'waiting))
|
||||||
(assert (outbound (window 'status 10 60 0
|
(assert (outbound (window 'status 10 60 0
|
||||||
(seal (text (format "~a" (status)) 22 "black"))))))
|
(seal (text (format "~a" (status)) 20 "black"))))))
|
||||||
|
|
||||||
|
(spawn #:name 'key-down-listener
|
||||||
|
(on (message (inbound (key-event $k _)))
|
||||||
|
(react (assert (key-down k))
|
||||||
|
(stop-when (message (inbound (release-event k _)))))))
|
||||||
|
|
||||||
|
(spawn #:name 'key-debouncer
|
||||||
|
(field [status 'no-key])
|
||||||
|
|
||||||
|
(on (asserted (key-down $k))
|
||||||
|
(react (stop-when (retracted (key-down k)))
|
||||||
|
(stop-when-timeout 500 (status `(down ,k)))))
|
||||||
|
(on (retracted (key-down $k))
|
||||||
|
(react (stop-when (asserted (key-down k)))
|
||||||
|
(stop-when-timeout 500 (status `(up ,k)))))
|
||||||
|
|
||||||
|
(assert (outbound (window 'key-debouncer 10 90 0
|
||||||
|
(seal (text (format "~a" (status)) 20 "black"))))))
|
||||||
|
|
||||||
(module+ main
|
(module+ main
|
||||||
(current-ground-dataspace
|
(current-ground-dataspace
|
||||||
|
|
Loading…
Reference in New Issue