88 lines
2.7 KiB
Racket
88 lines
2.7 KiB
Racket
#lang scheme
|
|
|
|
(require 2htdp/universe htdp/testing)
|
|
|
|
;; rotate through a bunch of players with the ball until nobody is left
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Universe = [Listof IWorld]
|
|
;; BallMail = (make-mail IWorld 'go)
|
|
;; Result = (make-bundle [Listof IWorld] [Listof BallMail] '())
|
|
|
|
(define Result0 (make-bundle '() '() '()))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; [Listof IWorld] -> Result
|
|
;; create bundle with a singleton list of mails to the first world on the list
|
|
(define (mail2 lw)
|
|
(make-bundle lw (list (make-mail (first lw) 'go)) '()))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Universe IWorld -> Result
|
|
;; add w to the list of worlds; get the first one to play
|
|
|
|
(check-expect (add-world '() iworld1) (mail2 (list iworld1)))
|
|
|
|
(define (add-world univ wrld)
|
|
(mail2 (append univ (list wrld))))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Universe IWorld Sexp -> Result
|
|
;; w sent message m in universe u
|
|
|
|
(check-expect
|
|
(switch (list iworld1 iworld2) iworld1 'go) (mail2 (list iworld2 iworld1)))
|
|
|
|
(check-error
|
|
(switch (list iworld1 iworld2) iworld2 'go) "switch: wrong world sent message")
|
|
|
|
(check-error
|
|
(switch (list iworld2 iworld1) iworld2 'stop) "switch: bad message: stop")
|
|
|
|
(define (switch u w m)
|
|
(local ((define fst (first u))
|
|
(define nxt (append (rest u) (list fst))))
|
|
(cond
|
|
[(and (iworld=? fst w) (symbol=? m 'go)) (mail2 nxt)]
|
|
[(iworld=? fst w) (error 'switch "bad message: ~s" m)]
|
|
[else (error 'switch "wrong world sent message")])))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; [Listof IWorld] Universe IWorld -> Result
|
|
;; w disconnected from the universe
|
|
|
|
(check-expect (disconnect (list iworld1 iworld2 iworld3) iworld2)
|
|
(mail2 (list iworld1 iworld3)))
|
|
(check-expect (disconnect '() iworld2) Result0)
|
|
|
|
(define (disconnect u w)
|
|
(local ((define nxt (remq w u)))
|
|
(if (empty? nxt) Result0 (mail2 nxt))))
|
|
|
|
;; IWorld [Listof IWorld] -> [Listof IWorld]
|
|
;; remove w from low
|
|
|
|
(check-expect (remq 'a '(a b c)) '(b c))
|
|
(check-expect (remq 'a '(a b a c)) '(b c))
|
|
(check-expect (remq 'b '(a b a c)) '(a a c))
|
|
|
|
(define (remq w low)
|
|
(cond
|
|
[(empty? low) '()]
|
|
[else (local ((define fst (first low))
|
|
(define rst (remq w (rest low))))
|
|
(if (eq? fst w) rst (cons fst rst)))]))
|
|
|
|
;; -- run program run
|
|
|
|
(test)
|
|
|
|
(define (run _)
|
|
(universe '()
|
|
(on-new add-world)
|
|
(check-with list?)
|
|
(on-msg switch)
|
|
(on-disconnect disconnect)))
|
|
|
|
(run 'go)
|