373 lines
14 KiB
Scheme
373 lines
14 KiB
Scheme
#lang scheme/gui
|
|
|
|
(require (for-syntax "syn-aux.ss")
|
|
"check-aux.ss"
|
|
"timer.ss"
|
|
"last.ss"
|
|
scheme/match
|
|
htdp/error
|
|
(only-in mzlib/etc evcase)
|
|
string-constants)
|
|
|
|
(provide universe%)
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ;
|
|
; ; ; ;
|
|
; ; ;
|
|
; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;;
|
|
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ; ; ; ; ;;; ; ;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
(define universe%
|
|
(last-mixin
|
|
(clock-mixin
|
|
(class* object% (start-stop<%>) (inspect #f) (super-new)
|
|
(init-field ;; type Result
|
|
; = (make-bundle [Listof World] Universe [Listof Mail])
|
|
universe0 ;; the initial state of the universe
|
|
on-new ;; Universe World -> Result
|
|
on-msg ;; Universe World Message -> Result
|
|
tick ;; Universe -> Result
|
|
(on-disconnect ;; Universe World -> Result
|
|
(lambda (u w) (list u)))
|
|
(to-string #f) ;; Universe -> String
|
|
)
|
|
|
|
(field [universe universe0])
|
|
|
|
;; -----------------------------------------------------------------------
|
|
;; dealing with events
|
|
(define-syntax-rule
|
|
;; A B ... -> Void
|
|
(def/cback pub (pname a ...)
|
|
;; Universe A B ... -> (cons Universe Mail)
|
|
;; effect: change server state, broadcast mails
|
|
name)
|
|
(begin
|
|
(pub pname)
|
|
(define (pname a ...)
|
|
(define (handler e) (stop! e))
|
|
(with-handlers ([exn? handler])
|
|
(define r (check-state-x-mail 'name (name iworlds universe a ...)))
|
|
(define u (bundle-state r))
|
|
(set! iworlds (bundle-low r))
|
|
(set! universe u)
|
|
(unless (boolean? to-string) (send gui add (to-string iworlds u)))
|
|
(broadcast (bundle-mails r))))))
|
|
|
|
(def/cback private (pmsg iworld received) on-msg)
|
|
|
|
(def/cback private (pdisconnect iworld) on-disconnect)
|
|
|
|
(def/cback private (pnew iworld) ppnew)
|
|
|
|
(define/private (ppnew low uni p)
|
|
(iworld-send p 'okay)
|
|
(on-new low uni p))
|
|
|
|
(def/cback public (ptock) tick)
|
|
|
|
;; Symbol Any -> Result
|
|
;; check that r is Result
|
|
;; effect: stop the server if the callbacks perform badly
|
|
(define/private (check-state-x-mail tag r)
|
|
(with-handlers ((exn? (lambda (x) (stop! x))))
|
|
(define s (format "expected from ~a, given: " tag))
|
|
(define f "(make-bundle [Listof World] Universe [Listof Mail]) ~a~e")
|
|
(unless (bundle? r)
|
|
(error tag (format f s r)))
|
|
r))
|
|
|
|
;; -----------------------------------------------------------------------
|
|
;; start and stop server, start and stop the universe
|
|
|
|
(field [iworlds '()] ;; [Listof World]
|
|
[gui (new gui%
|
|
[stop-server (lambda () (stop! universe))]
|
|
[stop-and-restart (lambda () (restart))])]
|
|
[dr:custodian (current-custodian)]
|
|
[the-custodian (make-custodian)])
|
|
|
|
;; start the universe, enable registrations and message exchanges
|
|
(define/public (start!)
|
|
(set! the-custodian (make-custodian))
|
|
(parameterize ([current-custodian the-custodian])
|
|
(define (loop)
|
|
(apply sync
|
|
(handle-evt (tcp-accept-evt tcp-listener) add-iworld)
|
|
(map iworld-wait-for-msg iworlds)))
|
|
(define (add-iworld in-out)
|
|
(with-handlers ((tcp-eof? (lambda _ (loop))))
|
|
(define in (first in-out))
|
|
(define next (tcp-receive in))
|
|
(match next
|
|
[(cons 'REGISTER info)
|
|
(let* ([w (create-iworld in (second in-out) info)])
|
|
; (set! iworlds (cons w iworlds))
|
|
(pnew w)
|
|
(send gui add (format "~a signed up" info))
|
|
(loop))]
|
|
[else (loop)])))
|
|
(define (iworld-wait-for-msg p)
|
|
(handle-evt (iworld-in p)
|
|
(lambda (in)
|
|
(with-handlers
|
|
((tcp-eof?
|
|
(lambda (e)
|
|
(handler p e
|
|
(lambda ()
|
|
(if (null? iworlds)
|
|
(restart)
|
|
(loop)))))))
|
|
(define r (tcp-receive in))
|
|
(send gui add (format "~a ->: ~a" (iworld-name p) r))
|
|
(pmsg p r)
|
|
(loop)))))
|
|
(define tcp-listener
|
|
(with-handlers ((exn:fail:network? (lambda (x) (stop! x))))
|
|
(tcp-listen SQPORT 4 #t)))
|
|
;; --- go universe go ---
|
|
(set! iworlds '())
|
|
(set! universe universe0)
|
|
(send gui add "a new universe is up and running")
|
|
(thread loop)))
|
|
|
|
;; World Exn (-> X) -> X
|
|
(define/private (handler p e cont)
|
|
(close-output-port (iworld-out p))
|
|
(close-input-port (iworld-in p))
|
|
(send gui add (format "~a !! closed port" (iworld-name p)))
|
|
(pdisconnect p)
|
|
(cont))
|
|
|
|
;; [Listof Mail] -> Void
|
|
;; send payload of messages to designated worlds
|
|
(define/private (broadcast lm)
|
|
;;; --- why the heck is there no exception handler -------------
|
|
(for-each (lambda (p+m)
|
|
;; what exception should I catch
|
|
;; remove the world from the list
|
|
;; factor out from elsewhere
|
|
;; can this mean I perform a callback during a callback?
|
|
;; collect 'bad' worlds instead and disconnect them later?
|
|
;; (handler
|
|
(with-handlers ((exn? (lambda (e) (printf "\n\n*** to be done ***\n\n"))))
|
|
(define w (mail-to p+m))
|
|
(define n (iworld-name w))
|
|
(define p (mail-content p+m))
|
|
(unless (memq w iworlds)
|
|
(send gui add (format "~s not on list" n)))
|
|
(when (memq w iworlds)
|
|
(iworld-send w p)
|
|
(send gui add (format "-> ~a: ~a" n p)))))
|
|
lm))
|
|
|
|
(define/private (restart)
|
|
;; I am running in a custodian that is about to be killed,
|
|
;; so let's switch to one up in the hierarchy
|
|
(let ([old-t (current-thread)]
|
|
[go (make-semaphore)])
|
|
(parameterize ([current-custodian dr:custodian])
|
|
(thread (lambda ()
|
|
(sync old-t go)
|
|
(start!))))
|
|
(send gui add "stopping the universe")
|
|
(send gui add "----------------------------------")
|
|
(for-each (lambda (w)
|
|
(close-input-port (iworld-in w))
|
|
(close-output-port (iworld-out w)))
|
|
iworlds)
|
|
(custodian-shutdown-all the-custodian)
|
|
(semaphore-post go)))
|
|
|
|
(define/public (stop! msg)
|
|
(send gui show #f)
|
|
(custodian-shutdown-all the-custodian))
|
|
|
|
;; -----------------------------------------------------------------------
|
|
;; initialize the universe and run
|
|
(send gui show #t)
|
|
(start!)))))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ;;; ; ;; ; ;;;; ;;;
|
|
; ; ; ; ; ;; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;;;
|
|
; ;; ;; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;; ; ;; ;;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
(provide
|
|
iworld? ;; Any -> Boolean
|
|
iworld=? ;; World World -> Boolean
|
|
iworld-name ;; World -> Symbol
|
|
iworld1 ;; sample worlds
|
|
iworld2
|
|
iworld3)
|
|
|
|
;; --- the server representation of a world ---
|
|
(define-struct iworld (in out name info) #:transparent)
|
|
;; World = (make-iworld IPort OPort Symbol [Listof Sexp])
|
|
|
|
(define iworld1 (make-iworld (current-input-port) (current-output-port) 'iworld1 '()))
|
|
(define iworld2 (make-iworld (current-input-port) (current-output-port) 'iworld2 '()))
|
|
(define iworld3 (make-iworld (current-input-port) (current-output-port) 'iworld3 '()))
|
|
|
|
(define (iworld=? u v)
|
|
(check-arg 'iworld=? (iworld? u) 'iworld "first" u)
|
|
(check-arg 'iworld=? (iworld? v) 'iworld "second" v)
|
|
(eq? u v))
|
|
|
|
;; IPort OPort Sexp -> Player
|
|
(define (create-iworld i o info)
|
|
(if (and (pair? info) (symbol? (car info)))
|
|
(make-iworld i o (car info) (cdr info))
|
|
(make-iworld i o (gensym 'iworld) info)))
|
|
|
|
;; Player S-exp -> Void
|
|
(define (iworld-send p sexp)
|
|
(tcp-send (iworld-out p) sexp))
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;;; ; ; ;
|
|
; ; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ;; ; ; ;
|
|
; ; ; ; ; ;
|
|
; ; ; ; ; ;
|
|
; ; ; ; ; ;
|
|
; ;;; ;;; ;
|
|
;
|
|
;
|
|
;
|
|
|
|
;; effect: create and show a gui with two buttons and an editor for logging
|
|
(define gui%
|
|
(class frame%
|
|
(init stop-server stop-and-restart)
|
|
(inherit show)
|
|
(define/augment (on-close) (end))
|
|
(super-new [label "Universe"][width 500][height 300][style '(metal)])
|
|
(field
|
|
[end (lambda _ (show #f) (stop-server))]
|
|
[panel (new horizontal-panel% [parent this] [stretchable-height #f]
|
|
[alignment '(center center)])]
|
|
[stop (new button% [parent panel] [label "stop"] [callback end])]
|
|
[s&re (new button% [parent panel] [label "stop and restart"]
|
|
[callback (lambda (but evt) (stop-and-restart))])]
|
|
[text (new text%)]
|
|
[edit (new editor-canvas% [parent this] [editor text]
|
|
[style '(no-border no-hscroll auto-vscroll)])])
|
|
|
|
;; add lines to the end of the text
|
|
(define/public (add str)
|
|
(queue-callback
|
|
(lambda ()
|
|
(send text lock #f)
|
|
(send text insert (format "~a\n" str) (send text last-position))
|
|
(send text lock #t))))
|
|
|
|
;; -------------------------------------------------------------------------
|
|
;; add menu, lock, and show
|
|
(copy-and-paste this)
|
|
(send text lock #t)))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Frame Text -> Void
|
|
;; add menu bar to frame for copying all of the text
|
|
(require string-constants)
|
|
|
|
(define (copy-and-paste frame)
|
|
(define mb (new menu-bar% [parent frame]))
|
|
(define edit (new menu%
|
|
[label (string-constant edit-menu-label)]
|
|
[parent mb]))
|
|
(new menu-item%
|
|
[label (string-constant copy-menu-item)]
|
|
[parent edit]
|
|
[shortcut #\c]
|
|
[callback (lambda (m e)
|
|
(define t (send frame get-focus-object))
|
|
(when (is-a? t editor<%>)
|
|
(send t copy)))])
|
|
(new menu-item%
|
|
[label (string-constant select-all-menu-item)]
|
|
[parent edit]
|
|
[shortcut #\a]
|
|
[callback (lambda (m e)
|
|
(define t (send frame get-focus-object))
|
|
(when (is-a? t text%)
|
|
(send t set-position 0 (send t last-position))))])
|
|
(void))
|
|
|
|
;
|
|
;
|
|
; ;;; ;;; ; ;;
|
|
; ;; ;; ;
|
|
; ;; ;; ;;; ;;; ;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ; ; ;;;; ; ;
|
|
; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ;
|
|
; ;;; ;;; ;;;;; ;;;;; ;;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
(provide
|
|
;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
|
|
;; type Mail = (make-mail World S-expression)
|
|
make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle
|
|
bundle? ;; is this a bundle?
|
|
make-mail ;; World S-expression -> Mail
|
|
mail? ;; is this a real mail?
|
|
)
|
|
|
|
(define-struct bundle (low state mails) #:transparent)
|
|
|
|
(set! make-bundle
|
|
(let ([make-bundle make-bundle])
|
|
(lambda (low state mails)
|
|
(check-arg-list 'make-bundle low iworld? "iworld" "first")
|
|
(check-arg-list 'make-bundle mails mail? "mail" "third")
|
|
(make-bundle low state mails))))
|
|
|
|
;; Symbol Any (Any -> Boolean) String String -> Void
|
|
;; raise a TP exception if low is not a list of world? elements
|
|
(define (check-arg-list tag low iworld? msg rank)
|
|
(check-arg tag (list? low) (format "list [of ~as]" msg) rank low)
|
|
(for-each (lambda (c)
|
|
(check-arg tag (iworld? c) msg (format "(elements of) ~a" rank) c))
|
|
low))
|
|
|
|
(define-struct mail (to content) #:transparent)
|
|
|
|
(set! make-mail
|
|
(let ([make-mail make-mail])
|
|
(lambda (to content)
|
|
(check-arg 'make-mail (iworld? to) 'iworld "first" to)
|
|
(check-arg 'make-mail (sexp? content) 'S-expression "second" content)
|
|
(make-mail to content))))
|