Core structure variation of chat-paper.rkt

This commit is contained in:
Tony Garnock-Jones 2013-05-28 11:26:34 -04:00
parent 0531d932b7
commit d2ba5c65a9
1 changed files with 88 additions and 0 deletions

View File

@ -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)))]))))