blob: 2e578670c324ecc55e4f60355910cedfba7c969d (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
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)))
|
