50 lines
1.4 KiB
Racket
50 lines
1.4 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/match)
|
|
(require "codec.rkt")
|
|
(require "os-big-bang.rkt")
|
|
(require "os-udp.rkt")
|
|
|
|
(provide (struct-out set-timer)
|
|
(struct-out timer-expired)
|
|
timer-driver
|
|
timer-relay)
|
|
|
|
(struct set-timer (label msecs relative?) #:prefab)
|
|
(struct timer-expired (label msecs) #:prefab)
|
|
|
|
;; Something like this should be part of racket
|
|
(define (timer-evt msecs relative?)
|
|
(wrap-evt (alarm-evt (if relative? (+ (current-inexact-milliseconds) msecs) msecs))
|
|
(lambda (_) (current-inexact-milliseconds))))
|
|
|
|
(define (timer-driver [self-id 'timer-driver])
|
|
(os-big-bang 'no-state
|
|
(subscribe 'timer-setter
|
|
(message-handlers w
|
|
[(set-timer reply-label msecs relative?)
|
|
(transition w
|
|
(subscribe/fresh label
|
|
(ground-message-handler w
|
|
[((list self-id label)
|
|
(timer-evt msecs relative?)
|
|
=> now)
|
|
(transition w
|
|
(unsubscribe label)
|
|
(send-message (timer-expired reply-label now)))])))]))))
|
|
|
|
(define (timer-relay [self-id 'timer-relay])
|
|
(os-big-bang 'no-state
|
|
(subscribe 'timer-relay
|
|
(message-handlers w
|
|
[(set-timer reply-label msecs relative?)
|
|
(define timer-id (list self-id reply-label))
|
|
(transition w
|
|
(send-meta-message (set-timer timer-id msecs relative?))
|
|
(subscribe/fresh label
|
|
(meta-message-handlers w
|
|
[(timer-expired (== timer-id) now)
|
|
(transition w
|
|
(unsubscribe label)
|
|
(send-message (timer-expired reply-label now)))])))]))))
|