double-click "debouncing" example

racket/syndicate/big-bang/timestate.rkt

@@ -0,0 +1,25 @@
+#lang syndicate/actor
+;; Big-bang specific timestate implementation with compatible protocol.
+
+(provide (struct-out later-than)
+         stop-when-timeout
+         sleep)
+
+(require syndicate/big-bang)
+(require (only-in syndicate/drivers/timestate
+                  later-than later-than? struct:later-than later-than-msecs))
+
+(define-syntax-rule (stop-when-timeout relative-msecs body ...)
+  (let ((deadline (+ (current-inexact-milliseconds) relative-msecs)))
+    (stop-when (asserted (later-than deadline)) body ...)))
+
+(define (sleep sec)
+  (let ((deadline (+ (current-inexact-milliseconds) (* sec 1000.0))))
+    (until (asserted (later-than deadline)))))
+
+(spawn #:name 'big-bang-timestate-driver
+       (during (observe (later-than $deadline))
+         (field [ready? #f])
+         (assert #:when (ready?) (later-than deadline))
+         (on (message (inbound (tick-event)))
+             (ready? (>= (current-inexact-milliseconds) deadline)))))

racket/syndicate/examples/actor/double-click.rkt

@@ -0,0 +1,40 @@
+#lang syndicate/actor
+
+(require syndicate/big-bang)
+(require/activate syndicate/big-bang/timestate)
+
+(struct click-event (description) #:prefab)
+
+(spawn #:name 'button
+       (define name 'clickable)
+
+       (define (wait-for-initial-press)
+         (react (stop-when (message (inbound (mouse-event _ _ name "button-down")))
+                  (send! (click-event 'first-click))
+                  (react (stop-when (message (inbound (mouse-event _ _ name "button-down")))
+                           (send! (click-event 'double-click))
+                           (wait-for-initial-press))
+                         (stop-when-timeout 500
+                           (send! (click-event 'single-click))
+                           (wait-for-initial-press))))))
+
+       (on-start (wait-for-initial-press))
+
+       (assert (outbound (window name 10 10 0
+                                 (seal (overlay (text "Click me" 22 "white")
+                                                (rectangle 140 50 "solid" "red")))))))
+
+(spawn #:name 'status
+       (field [status 'waiting] [clear-time (current-inexact-milliseconds)])
+       (on (message (click-event $description))
+           (status description)
+           (clear-time (+ (current-inexact-milliseconds) 1000)))
+       (on (asserted (later-than (clear-time)))
+           (status 'waiting))
+       (assert (outbound (window 'status 10 60 0
+                                 (seal (text (format "~a" (status)) 22 "black"))))))
+
+(module+ main
+  (current-ground-dataspace
+   (big-bang-dataspace #:width 160
+                       #:height 120)))