utest contains ball game

svn: r15085

collects/2htdp/utest/README

@@ -0,0 +1,11 @@
+
+to test:         $ ./xrun  
+to add a player: $ ./player Foo
+
+shared.ss : player infrastructure 
+carl.ss   : one specific player derived from shared.ss
+sam.ss    : another one 
+  -- add more with player plus string 
+
+balls.ss  : the server 
+

collects/2htdp/utest/ball2.ss

@@ -0,0 +1,28 @@
+#lang scheme/gui
+
+(require "../2htdp/universe.ss")
+
+(define-struct unistate (active passive) #:transparent)
+
+;; Universe = (make-unistate Player Player)
+;; interpretation: (make-unistate p q) means p is the currently active player, 
+;;   and q is the one waiting for the ball 
+
+;; SMessage is 'stop or 'go 
+
+;; Player Player -> (cons Universe [list SMessage])
+;; create initial universe and tell p2 to start playing 
+(define (create-universe p1 p2)
+  (make-bundle (make-unistate p2 p1) 
+               (list (make-mail p2 'go)
+                     (make-mail p1 'stop))))
+  
+;; Universe Player Sexp -> (cons Universe [list SMessage])
+;; p sent message m in universe u 
+(define (switch-players u p m)
+  (make-bundle (make-unistate (unistate-passive u) (unistate-active u))
+               (list (make-mail (unistate-passive u) 'go))))
+
+;; --- 
+
+(universe2 create-universe switch-players)

collects/2htdp/utest/balls.ss

@@ -0,0 +1,86 @@
+#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 World '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 World -> 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 World 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 World] Universe World -> 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))))
+
+;; World [Listof World] -> [Listof World]
+;; 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)
+            (on-msg switch)
+            (on-disconnect disconnect)))
+
+(run 'go)

collects/2htdp/utest/carl.ss

@@ -0,0 +1,6 @@
+(module carl scheme
+
+(require "shared.ss")
+
+(make-player 100 'carl)
+)

collects/2htdp/utest/design.txt

@@ -0,0 +1,34 @@
+
+ Two collaboration worlds display a moving ball, one of them should rest. 
+
+Pass Through (Distributed) Version
+----------------------------------
+
+ Two screens pop up and a ball moves from the bottom to the top, on each of
+ them. When one reaches the top, it rests and sends a signal to the other
+ to 'go. This means only one of the worlds will have a moving ball, the
+ other one rests. 
+
+ use ../pass-through.ss 
+
+ World and Messages: 
+ ;; World   = Number | 'resting 
+ ;; Message = 'go
+
+Arbitrated Version
+----------------------------------
+
+ Two screen pop up. The server sends one of them a go signal and the other
+ one a rest signal. Until then both move so I can use the same shared
+ code. 
+
+ use ball-universe.ss 
+
+ World and Messages: 
+ ;; World    = Number | 'resting 
+ ;; ReceivedMessage = 'go
+ ;; SendMessages    = ... any token will do ... 
+
+ Server: 
+ ;; ReceivedMessages = ... any token will do ... 
+ ;; SendMessages     = 'go 

collects/2htdp/utest/player

@@ -0,0 +1,16 @@
+#! /bin/sh
+#|
+exec mred -qu "$0" ${1+"$@"}
+|#
+
+#lang scheme
+
+(require "shared.ss")
+
+(define argv (current-command-line-arguments))
+
+(unless (= (vector-length argv) 1)
+  (error 'player "name of one player expected: $ ./player name"))
+  
+(make-player 200 (string->symbol (vector-ref argv 0)))
+

collects/2htdp/utest/sam.ss

@@ -0,0 +1,6 @@
+;; The first three lines of this file were inserted by DrScheme. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname sam) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+(require "shared.ss")
+
+(make-player 200 'sam)

collects/2htdp/utest/shared.ss

@@ -0,0 +1,72 @@
+#lang scheme
+
+(require 2htdp/universe htdp/testing)
+;(require "../2htdp/universe.ss" htdp/testing)
+
+;; World   = Number | 'resting 
+(define WORLD0 'resting)
+
+;; constants 
+(define HEIGHT 100)
+(define DefWidth 50)
+
+;; visual constants 
+(define mt (nw:rectangle DefWidth HEIGHT 'solid 'gray))
+(define BALL (circle 3 'solid 'red))
+
+;; -----------------------------------------------------------------------------
+;; World Number -> Message 
+;; on receiving a message from server, place the ball at lower end or stop
+
+(check-expect (receive 'resting 'go) HEIGHT)
+(check-expect (receive HEIGHT 'go) HEIGHT)
+(check-expect (receive (- HEIGHT 1) 'go) (- HEIGHT 1))
+(check-expect (receive 0 'go) 0)
+
+(define (receive w n) 
+  (cond
+    [(number? w) w]
+    [else HEIGHT]))
+
+;; World -> Scene 
+;; render the world 
+
+(place-image BALL 50 100 mt)
+
+(check-expect (draw 100) (place-image BALL 50 100 mt))
+
+(define (draw w)
+  (cond
+    [(symbol? w) (place-image (text "resting" 11 'red) 10 10 mt)]
+    [(number? w) (place-image BALL 50 w mt)]))
+
+;; World -> World 
+(check-expect (move 'resting) 'resting)
+(check-expect (move HEIGHT) (- HEIGHT 1))
+(check-expect (move 0) (make-package 'resting 'go))
+(define (move x)
+  (cond
+    [(symbol? x) x]
+    [(number? x) (if (<= x 0) (make-package 'resting 'go) (sub1 x))]))
+
+;; -----------------------------------------------------------------------------
+;; Number (U String Symbol) -> true
+;; create and hook up a player with the localhost server 
+(define (make-player width t)
+  (set! mt (place-image (text (format "~a" t) 11 'black) 5 85 
+                        (empty-scene width HEIGHT)))
+  (big-bang WORLD0 
+            (on-draw draw)
+            (on-receive receive)
+            (on-tick move)
+	    (name t)
+            (register LOCALHOST)))
+
+(generate-report)
+
+;; --- 
+
+(require scheme/contract)
+
+(provide/contract
+ [make-player (-> (and/c number? (>=/c 100)) (or/c string? symbol?) any/c)])

collects/2htdp/utest/xrun

@@ -0,0 +1,3 @@
+mred balls.ss &
+./player carl & 
+./player sam &

collects/2htdp/utest/xrun2

@@ -0,0 +1,3 @@
+mred ball2.ss &
+mred carl.ss & 
+mred sam.ss &