summaryrefslogtreecommitdiffstats
path: root/net/ricketyspace
diff options
context:
space:
mode:
Diffstat (limited to 'net/ricketyspace')
-rw-r--r--net/ricketyspace/ror/thirteen/client.rkt189
-rw-r--r--net/ricketyspace/ror/thirteen/run.rkt13
-rw-r--r--net/ricketyspace/ror/thirteen/server.rkt147
-rw-r--r--net/ricketyspace/ror/thirteen/shared.rkt28
4 files changed, 377 insertions, 0 deletions
diff --git a/net/ricketyspace/ror/thirteen/client.rkt b/net/ricketyspace/ror/thirteen/client.rkt
new file mode 100644
index 0000000..dc3b184
--- /dev/null
+++ b/net/ricketyspace/ror/thirteen/client.rkt
@@ -0,0 +1,189 @@
+#lang racket
+
+(require 2htdp/image 2htdp/universe "shared.rkt")
+
+(provide launch-guess-client)
+
+(struct client-state (type clue guess action done))
+
+(define ClientState0 (client-state -1 "" #f "" #f))
+
+(define SCENE-WIDTH 300)
+(define SCENE-HEIGHT 200)
+
+(define (launch-guess-client n host)
+ (big-bang ClientState0
+ (on-draw draw-guess)
+ (on-key handle-keys)
+ (name n)
+ (register host)
+ (on-receive handle-msg)))
+
+(define (handle-keys w key)
+ (cond [(= (client-state-type w) PLAYER) (handle-keys-player w key)]
+ [(= (client-state-type w) GUESSER) (handle-keys-guesser w key)]
+ [else w]))
+
+(define (handle-keys-player w key)
+ (define (action)
+ (client-state-action w))
+ (define (guess)
+ (client-state-guess w))
+ (define (set-clue clue)
+ (client-state PLAYER clue (guess) (action) #f))
+ (cond [(and (string=? (action) "c") (key=? key "c"))
+ (make-package w (server-msg PLAYER "c" ""))]
+ [(and (string=? (action) "a") (key=? key "up"))
+ (make-package (set-clue "up") (server-msg PLAYER "a" "up"))]
+ [(and (string=? (action) "a") (key=? key "down"))
+ (make-package (set-clue "down") (server-msg PLAYER "a" "down"))]
+ [(and (string=? (action) "a") (key=? key "="))
+ (make-package (set-clue "=") (server-msg PLAYER "a" "="))]
+ [else w]))
+
+(define (handle-keys-guesser w key)
+ (define (action)
+ (client-state-action w))
+ (cond [(and (string=? (action) "c") (key=? key "c")
+ (make-package w (server-msg GUESSER "c" "")))]
+ [(and (string=? (action) "g") (key=? key "g")
+ (make-package w (server-msg GUESSER "g" "")))]
+ [else w]))
+
+(define (handle-msg c c-msg)
+ (cond [(not (client-msg? c-msg)) c]
+ [(= (client-msg-type c-msg) PLAYER)
+ (handle-msg-player c c-msg)]
+ [(= (client-msg-type c-msg) GUESSER)
+ (handle-msg-guesser c c-msg)]
+ [else c]))
+
+(define (handle-msg-player c c-msg)
+ (define (is-done)
+ (client-msg-done c-msg))
+ (define (action)
+ (client-msg-action c-msg))
+ (define (set-done)
+ (let ([guess (client-msg-guess c-msg)])
+ (client-state PLAYER "" guess "" #t)))
+ (define (set-check)
+ (let ([clue (client-state-clue c)])
+ (client-state PLAYER clue #f "c" #f)))
+ (define (set-act)
+ (let ([guess (client-msg-guess c-msg)])
+ (client-state PLAYER "" guess "a" #f)))
+ (cond [(is-done) (set-done)]
+ [(string=? (action) "c") (set-check)]
+ [(string=? (action) "a") (set-act)]
+ [else c]))
+
+(define (handle-msg-guesser c c-msg)
+ (define (is-done)
+ (client-msg-done c-msg))
+ (define (action)
+ (client-msg-action c-msg))
+ (define (set-done)
+ (let ([guess (client-msg-guess c-msg)])
+ (client-state GUESSER "" guess "" #t)))
+ (define (set-check)
+ (let ([clue (client-msg-clue c-msg)]
+ [guess (client-msg-guess c-msg)])
+ (client-state GUESSER clue guess "c" #f)))
+ (define (set-guess)
+ (let ([clue (client-msg-clue c-msg)]
+ [guess (client-msg-guess c-msg)])
+ (client-state GUESSER clue guess "g" #f)))
+ (cond [(is-done) (set-done)]
+ [(string=? (action) "c") (set-check)]
+ [(string=? (action) "g") (set-guess)]
+ [else c]))
+
+(define (draw-guess c)
+ (define (render type result desc help)
+ (place-image/align
+ type 5 5 "left" "top"
+ (overlay (above result desc help)
+ (empty-scene SCENE-WIDTH SCENE-HEIGHT))))
+ (let ([type (draw-type c)]
+ [result (draw-result c)]
+ [desc (draw-desc c)]
+ [help (draw-help c)])
+ (render type result desc help)))
+
+(define (draw-type c)
+ (text (cond [(= (client-state-type c) PLAYER) "Player"]
+ [(= (client-state-type c) GUESSER) "Guesser"]
+ [else "..."])
+ 14 "black"))
+
+(define (draw-result c)
+ (text (cond [(= (client-state-type c) PLAYER)
+ (draw-result-player c)]
+ [else (draw-result-guesser c)])
+ 14 "black"))
+
+(define (draw-result-player c)
+ (define (done)
+ (client-state-done c))
+ (define (action)
+ (client-state-action c))
+ (define (guess)
+ (number->string (client-state-guess c)))
+ (cond [(and (not (done)) (string=? (action) "")) "..."]
+ [(done) (string-append (guess) " it is!")]
+ [(string=? (action) "a") (string-append "Guess: " (guess))]
+ [else ""]))
+
+(define (draw-result-guesser c)
+ (define (done)
+ (client-state-done c))
+ (define (action)
+ (client-state-action c))
+ (define (guess)
+ (let ([g (client-state-guess c)])
+ (cond [(number? g) (number->string g)]
+ [else ""])))
+ (define (clue)
+ (cond [(string=? (client-state-clue c) "up") ">"]
+ [else "<"]))
+ (cond [(and (not (done)) (string=? (action) "") "...")]
+ [(done) (string-append (guess) " it is!")]
+ [(and (string=? (action) "g") (> (string-length (guess)) 0))
+ (string-append "Number " (clue) " " (guess))]
+ [(string=? (action) "c") (string-append "Guess: " (guess))]
+ [else ""]))
+
+(define (draw-desc c)
+ (text (cond [(= (client-state-type c) PLAYER) ""]
+ [else (draw-desc-guesser c)])
+ 10 "black"))
+
+(define (draw-desc-guesser c)
+ (define (action)
+ (client-state-action c))
+ (cond [(string=? (action) "c") "Waiting for player to act on guess"]
+ [else ""]))
+
+(define (draw-help c)
+ (define (type)
+ (client-state-type c))
+ (text (cond [(= (type) PLAYER) (draw-help-player c)]
+ [else (draw-help-guesser c)])
+ 10 "black"))
+
+(define (draw-help-player c)
+ (define (action)
+ (client-state-action c))
+ (cond [(string=? (action) "c") "Press 'c' to check"]
+ [(string=? (action) "a") "Press ↑, ↓, or = "]
+ [else ""]))
+
+(define (draw-help-guesser c)
+ (define (action)
+ (client-state-action c))
+ (define (done)
+ (client-state-done c))
+ (cond [(string=? (action) "g") "Press 'g' to guess"]
+ [(string=? (action) "c") "Press 'c' to check"]
+ [(done) "Good Job!"]
+ [else ""]))
diff --git a/net/ricketyspace/ror/thirteen/run.rkt b/net/ricketyspace/ror/thirteen/run.rkt
new file mode 100644
index 0000000..b8726ac
--- /dev/null
+++ b/net/ricketyspace/ror/thirteen/run.rkt
@@ -0,0 +1,13 @@
+#lang racket
+
+(require 2htdp/universe "client.rkt" "server.rkt")
+
+(define (run)
+ (launch-many-worlds (launch-guess-client "Adam" LOCALHOST)
+ (launch-guess-server)
+ (launch-guess-client "Eve" LOCALHOST)))
+
+(define (bad)
+ (launch-many-worlds (launch-guess-client "Adam" LOCALHOST)
+ (launch-guess-server)
+ (launch-guess-client "Beatrice" LOCALHOST)))
diff --git a/net/ricketyspace/ror/thirteen/server.rkt b/net/ricketyspace/ror/thirteen/server.rkt
new file mode 100644
index 0000000..2e57867
--- /dev/null
+++ b/net/ricketyspace/ror/thirteen/server.rkt
@@ -0,0 +1,147 @@
+#lang racket
+
+(provide launch-guess-server)
+
+(require 2htdp/image 2htdp/universe "shared.rkt")
+
+(struct interval (small big) #:transparent)
+
+;; paction -> 'c' or 'a'
+;; gaction -> 'c' or 'g'
+(struct server-state (interval clue guess paction gaction clients done))
+
+(define u0 (server-state (interval LOWER UPPER) "" #f "c" "" 1 #f))
+
+(define (launch-guess-server)
+ (universe #f
+ (state #t)
+ (on-new connect)
+ (on-msg handle-msg)))
+
+(define (connect u client)
+ (cond [(false? u)
+ (make-bundle
+ u0
+ (list (make-mail client (client-msg PLAYER "" #f "c" #f)))
+ '())]
+ [(= (server-state-clients u) 1)
+ (make-bundle
+ (server-state
+ (server-state-interval u) (server-state-clue u)
+ (server-state-guess u) (server-state-paction u)
+ "g" 2 #f)
+ (list (make-mail client (client-msg GUESSER "" #f "g" #f)))
+ '())]
+ [else (make-bundle u empty (list client))]))
+
+(define (handle-msg u client s-msg)
+ (cond [(not (server-msg? s-msg)) (make-bundle u empty (list client))]
+ [(= (server-msg-type s-msg) PLAYER)
+ (handle-msg-player u client s-msg)]
+ [(= (server-msg-type s-msg) GUESSER)
+ (handle-msg-guesser u client s-msg)]
+ [else (make-bundle u empty (list client))]))
+
+(define (handle-msg-player u client s-msg)
+ (define (set-paction paction)
+ (let ([interval (server-state-interval u)]
+ [clue (server-state-clue u)]
+ [guess (server-state-guess u)]
+ [gaction (server-state-gaction u)]
+ [clients (server-state-clients u)])
+ (server-state interval clue guess paction gaction clients #f)))
+ (define (set-clue clue)
+ (let ([interval (server-state-interval u)]
+ [guess (server-state-guess u)]
+ [gaction (server-state-gaction u)]
+ [clients (server-state-clients u)]
+ [done (server-state-done u)])
+ (server-state interval clue guess "c" gaction clients done)))
+ (define (set-done)
+ (let ([interval (server-state-interval u)]
+ [guess (server-state-guess u)]
+ [gaction (server-state-gaction u)]
+ [clients (server-state-clients u)])
+ (server-state interval "" guess "" gaction clients #t)))
+ (define (mail clue guess action done)
+ (list (make-mail client (client-msg PLAYER clue guess action done))))
+ (let* ([clue (server-state-clue u)]
+ [guess (server-state-guess u)]
+ [action (server-msg-action s-msg)]
+ [done (server-state-done u)]
+ [action-ok (string=? (server-state-paction u) action)]
+ [has-guess (number? guess)]
+ [data (server-msg-data s-msg)])
+ (cond [(not action-ok)
+ (make-bundle u empty (list client))]
+ [(and (string=? action "c") (not has-guess))
+ (make-bundle u (mail clue guess action done) empty)]
+ [(and (string=? action "c") has-guess)
+ (make-bundle (set-paction "a") (mail clue guess "a" done) empty)]
+ [(and (string=? action "a") (member data '("up" "down")))
+ (make-bundle (set-clue data) (mail data #f "c" done) empty)]
+ [(and (string=? action "a") (string=? data "="))
+ (make-bundle (set-done) (mail "" guess "" #t) empty)]
+ [else (make-bundle u empty (list client))])))
+
+(define (handle-msg-guesser u client s-msg)
+ (define (set-guess interval clue guess)
+ (let ([paction (server-state-paction u)]
+ [clients (server-state-clients u)]
+ [done (server-state-done u)])
+ (server-state interval clue guess paction "c" clients done)))
+ (define (set-gaction-guess)
+ (let ([interval (server-state-interval u)]
+ [clue (server-state-clue u)]
+ [guess (server-state-guess u)]
+ [paction (server-state-paction u)]
+ [clients (server-state-clients u)]
+ [done (server-state-done u)])
+ (server-state interval clue guess paction "g" clients done)))
+ (define (has-clue)
+ (> (string-length (server-state-clue u)) 0))
+ (define (is-done)
+ (server-state-done u))
+ (define (mail clue guess action done)
+ (list (make-mail client
+ (client-msg GUESSER clue guess action done))))
+ (let* ([action (server-msg-action s-msg)]
+ [interval (server-state-interval u)]
+ [clue (server-state-clue u)]
+ [current-guess (server-state-guess u)]
+ [done (server-state-done u)]
+ [action-ok (string=? (server-state-gaction u) action)])
+ (cond [(not action-ok) (make-bundle u empty (list client))]
+ [(is-done) (make-bundle u (mail "" current-guess "" #t) empty)]
+ [(and (string=? action "g") (not (has-clue)))
+ (let ([guess (guess interval)])
+ (make-bundle (set-guess interval "" guess)
+ (mail "" guess "c" done) empty))]
+ [(and (string=? action "g") (has-clue))
+ (let* ([n-interval (next-interval interval clue)]
+ [guess (guess n-interval)])
+ (make-bundle (set-guess n-interval "" guess)
+ (mail "" guess "c" done) empty))]
+ [(and (string=? action "c") (has-clue))
+ (make-bundle (set-gaction-guess)
+ (mail clue current-guess "g" done) empty)]
+ [else (make-bundle u (mail clue current-guess action done)
+ empty)])))
+
+(define (next-interval interval clue)
+ (cond [(not (string? clue)) interval]
+ [(string=? "up" clue) (bigger interval)]
+ [(string=? "down" clue) (smaller interval)]
+ [else interval]))
+
+(define (single? w)
+ (= (interval-small w) (interval-big w)))
+
+(define (guess w)
+ (quotient (+ (interval-small w) (interval-big w)) 2))
+
+(define (smaller w)
+ (interval (interval-small w) (max (interval-small w) (sub1 (guess w)))))
+
+(define (bigger w)
+ (interval (min (interval-big w) (add1 (guess w))) (interval-big w)))
diff --git a/net/ricketyspace/ror/thirteen/shared.rkt b/net/ricketyspace/ror/thirteen/shared.rkt
new file mode 100644
index 0000000..176c429
--- /dev/null
+++ b/net/ricketyspace/ror/thirteen/shared.rkt
@@ -0,0 +1,28 @@
+#lang racket
+
+(provide
+ UPPER
+ LOWER
+ PLAYER
+ GUESSER
+ client-msg
+ client-msg?
+ client-msg-type
+ client-msg-clue
+ client-msg-guess
+ client-msg-action
+ client-msg-done
+ server-msg
+ server-msg?
+ server-msg-type
+ server-msg-action
+ server-msg-data)
+
+(define UPPER 100)
+(define LOWER 0)
+
+(define PLAYER 0)
+(define GUESSER 1)
+
+(struct client-msg (type clue guess action done) #:prefab)
+(struct server-msg (type action data) #:prefab)