racket-matrix-2012/os-big-bang-example.rkt

82 lines
2.3 KiB
Racket

#lang racket/base
;; Trivial demonstration of an os-big-bang style virtual machine.
;; Engages in various I/O and timer operations.
(require racket/match)
(require racket/port)
(require "os-big-bang.rkt")
(define display-driver-handler
(message-handlers w
[`(display ,message)
(transition w (send-meta-message (lambda ()
(display message)
(flush-output))))]))
(define read-line-driver-handler
(message-handlers w
[`(request ,reply-addr read-line)
(transition w
(subscribe/fresh sid
(ground-message-handler w
[((list 'read-line reply-addr)
(read-line-evt (current-input-port) 'any)
=> l)
(transition w
(unsubscribe sid)
(send-message `(reply ,reply-addr ,l)))])))]))
;; This should be part of racket
(define (time-evt msecs)
(wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))
(define (tick-driver self-sid interval)
(let loop ((last-tick-time 0) (counter 0))
(define next-time (+ last-tick-time interval))
(subscribe self-sid
(ground-message-handler w
[((list 'timer-alarm next-time)
(time-evt next-time)
=> now)
(transition w
(unsubscribe self-sid)
(send-message `(tick ,counter ,now))
(loop now (+ counter 1)))]))))
(define main
(os-big-bang 'none
(subscribe 'display-driver display-driver-handler)
(subscribe 'read-line-driver read-line-driver-handler)
(tick-driver 'ticker 1000)
(send-message `(display "Hello! "))
(send-message 'greet-loop)
(subscribe 'greet-loop-handler
(message-handlers w
['greet-loop
(transition w
(send-message `(display "Enter your name:\n"))
(send-message `(request read-name read-line)))]))
(subscribe 'ticker-handler
(message-handlers w
[`(tick ,counter ,_)
(transition w
(send-message
`(display ,(string-append "TICK "
(number->string counter)
"\n"))))]))
(subscribe 'read-line-result-handler
(message-handlers w
[`(reply read-name ,(== eof))
(transition w
(send-message `(display "Goodbye!\n")))]
[`(reply read-name ,name)
(transition w
(send-message `(display "Hello, "))
(send-message `(display ,name))
(send-message `(display "!\n"))
(unsubscribe 'ticker)
(send-message 'greet-loop)
)]))))
(ground-vm main)