Core structure variation of chat-paper.rkt
This commit is contained in:
parent
0531d932b7
commit
d2ba5c65a9
|
@ -0,0 +1,88 @@
|
|||
#lang marketplace
|
||||
;; Equivalent to chat-paper.rkt, but using the raw unsugared
|
||||
;; structures rather than the friendly DSL overlay.
|
||||
|
||||
(require racket/match)
|
||||
(require marketplace)
|
||||
|
||||
(make-nested-vm
|
||||
(lambda (vm-pid)
|
||||
(process-spec (lambda (boot-pid)
|
||||
(lambda (k)
|
||||
(k (transition stateless
|
||||
(at-meta-level
|
||||
(add-endpoint 'listener
|
||||
(role 'subscriber
|
||||
(tcp-channel ? (tcp-listener 5999) ?)
|
||||
'observer)
|
||||
listener-event-handler))))))))
|
||||
#f)
|
||||
|
||||
(define listener-event-handler
|
||||
(match-lambda
|
||||
[(presence-event (role _ (tcp-channel them us _) _))
|
||||
(lambda (state)
|
||||
(transition state
|
||||
(spawn (process-spec (lambda (pid) (lambda (k) (k (chat-session them us)))))
|
||||
#f
|
||||
#f)))]
|
||||
[_
|
||||
(lambda (state) (transition state '()))]))
|
||||
|
||||
(define (chat-session them us)
|
||||
(define user (gensym 'user))
|
||||
(transition stateless
|
||||
(list (listen-to-user user them us)
|
||||
(speak-to-user user them us))))
|
||||
|
||||
(define (listen-to-user user them us)
|
||||
(list
|
||||
(add-endpoint 'speech-publisher
|
||||
(role 'publisher
|
||||
`(,user says ,?)
|
||||
'participant)
|
||||
(lambda (event)
|
||||
(lambda (state) (transition state '()))))
|
||||
(at-meta-level
|
||||
(add-endpoint 'tcp-receiver
|
||||
(role 'subscriber
|
||||
(tcp-channel them us ?)
|
||||
'participant)
|
||||
(match-lambda
|
||||
[(absence-event _ _)
|
||||
(lambda (state)
|
||||
(transition state (quit #f #f)))]
|
||||
[(message-event _ (tcp-channel _ _ (? bytes? text)))
|
||||
(lambda (state)
|
||||
(transition state (send-message `(,user says ,text) 'publisher)))]
|
||||
[_
|
||||
(lambda (state) (transition state '()))])))))
|
||||
|
||||
(define (speak-to-user user them us)
|
||||
(define (say fmt . args)
|
||||
(at-meta-level
|
||||
(send-message (tcp-channel us them (apply format fmt args))
|
||||
'publisher)))
|
||||
(define (announce who did-what)
|
||||
(unless (equal? who user)
|
||||
(say "~s ~s.~n" who did-what)))
|
||||
(list
|
||||
(say "You are ~s.~n" user)
|
||||
(at-meta-level
|
||||
(add-endpoint 'tcp-sender
|
||||
(role 'publisher
|
||||
(tcp-channel us them ?)
|
||||
'participant)
|
||||
(lambda (event)
|
||||
(lambda (state) (transition state '())))))
|
||||
(add-endpoint 'speech-subscriber
|
||||
(role 'subscriber
|
||||
`(,? says ,?)
|
||||
'participant)
|
||||
(match-lambda
|
||||
[(presence-event (role _ `(,who says ,_) _))
|
||||
(lambda (state) (transition state (announce who 'arrived)))]
|
||||
[(absence-event (role _ `(,who says ,_) _) _)
|
||||
(lambda (state) (transition state (announce who 'departed)))]
|
||||
[(message-event _ `(,who says ,what))
|
||||
(lambda (state) (transition state (say "~a: ~a" who what)))]))))
|
Loading…
Reference in New Issue