1 ;; The first three lines of this file were inserted by DrScheme. They record metadata
2 ;; about the language level of this file in a form that our tools can easily process.
3 #reader(lib "htdp-advanced-reader.ss" "lang")((modname |39.2|) (read-case-sensitive #t) (teachpacks ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp") (lib "gui.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp") (lib "gui.ss" "teachpack" "htdp")))))
4 ;;Model
5 
6 ;A word is a (listof letters) where letters is a symbol from 'a ... 'z and '_.
7 
8 ;;Constants
9 
10 (define WORDS '((o c t o p u s)
11                 (s q u i d)
12                 (s a l m o n)
13                 (t i l a p i a)
14                 (b a s s)
15                 (s h r i m p)
16                 (c l a m s)
17                 (m u s s e l)
18                 (o y s t e r)
19                 (c r a b)
20                 (s t a r f i s h)
21                 (j e l l y f i s h)
22                 (s e a l i o n)
23                 (t u n a)
24                 (d o l p h i n)
25                 (w h a l e)
26                 (k e l p)
27                 (m a n a t e e)))
28 
29 ;;The alphabet
30 (define LETTERS '(a b c d e f g h i j k l m n o p q r s t u v w x y z))
31 
32 ;;The number of words
33 (define WORDS# (length WORDS))
34 
35 ;;A body-part is one of the following symbols:
36 (define PARTS '(noose head body right-arm left-arm right-leg left-leg))
37 
38 ;;State Variables
39 
40 ;;chosen-word : word
41 ;;This word is the target word that the player needs to guess
42 
43 (define chosen-word (first WORDS))
44 
45 ;;status-word : word
46 ;;This word represents the current status of the player's guesses
47 
48 (define status-word (first WORDS))
49 
50 ;;body-parts-left : (listof body-parts)
51 ;;Indicates how many body-parts are left before the hangman is dead.
52 
53 (define body-parts-left PARTS)
54 
55 ;;previous-guesses : word
56 ;;Keeps track of all previous guesses.
57 
58 (define previous-guesses empty)
59 
60 ;;new-knowledge : boolean
61 ;;Keeps track of whether or not the guessed letter adds new-knowledge.
62 
63 (define new-knowledge false)
64 
65 ;;letters-remaining : number
66 ;;Keeps track of the letters that still need to be uncovered.
67 
68 (define letters-remaining (length chosen-word))
69 
70 ;make-status-word : word -> word
71 ;Given aword, creates an equally long word consisting only of the letter '_.
72 
73 (define (make-status-word aword)
74   (build-list (length aword) (lambda (x) '_)))
75 
76 ;;hangman : -> void
77 ;;Initiates the hangman program by selecting the chosen word and resetting the status word and the number of body-parts left.
78 
79 (define (hangman)
80   (begin (set! chosen-word (list-ref WORDS (random WORDS#)))
81          (set! status-word (make-status-word chosen-word))
82          (set! body-parts-left PARTS)
83          (set! previous-guesses empty)
84          (set! new-knowledge false)
85          (set! letters-remaining (length chosen-word))))
86 
87 ;;Initializes the state variables
88 (hangman)
89 
90 ;A response is either
91 ;   1. "You won"
92 ;   2. (list "The End" body-part word)
93 ;   3. (list "Good guess!" word)
94 ;   4. (list "Sorry" body-part word)
95 
96 ;hangman-guess : letter -> response
97 ;If aletter is present in chosen-word but not in status-word, (effect) update status-word.  Otherwise, shorten body-part-list.  In all cases, output one of the four possible responses.  Also effect the update of previous-guesses.
98 
99 (define (hangman-guess aletter)
100   (local ((define updated-status (reveal-word chosen-word status-word aletter)))
101     (cond
102       [(contains previous-guesses aletter) "You have used this guess before."]
103       [else
104        (begin
105          (set! previous-guesses (cons aletter previous-guesses))
106          (cond
107            [new-knowledge (begin (set! status-word updated-status)
108                                  (set! letters-remaining (sub1 letters-remaining))
109                                  (cond
110                                    [(zero? letters-remaining) "You won"]
111                                    [else (list "Good guess!" status-word)]))]
112            [else
113             (local ((define lost-part (first body-parts-left)))
114               (begin (set! body-parts-left (rest body-parts-left))
115                      (cond  
116                        [(empty? body-parts-left) (list "The End" lost-part chosen-word)]
117                        [else (list "Sorry" lost-part status-word)])))]))])))
118 
119 ;reveal-word: word word letter -> word
120 ;Given chosen-word, status-word, and aletter, return an updated status-word where '_ is replaced by aletter for all letters in chosen-word that are aletter.
121 
122 (define (reveal-word chosen-word status-word aletter)
123   (local ((define (reveal-letter chosen-letter status-letter)
124             (cond
125               [(and (symbol=? chosen-letter aletter)
126                     (symbol=? status-letter '_))
127                (begin (set! new-knowledge true)
128                       aletter)]
129               [else status-letter])))
130     (begin (set! new-knowledge false)
131            (map reveal-letter chosen-word status-word)))) 
132 
133 ;contains : (listof X) X -> boolean
134 ;Determine if alox contains anx
135 (define (contains alox anx)
136   (ormap (lambda (x) (equal? x anx)) alox))
137 ;Exercise 37.2.4.   Formulate the four examples for hangman-guess as boolean-valued expressions that produce true if hangman-guess is correct. Develop an additional example for each case; turn these new examples into additional tests.    Solution
138 
139 #|
140 ;Tests
141 ;test-hangman : letter word X -> boolean
142 ;Tests hangman-guess and returns true if the test is successful.  Consumes guess (a letter), status (a word), partsleft (listof body-parts), and response (one of the four responses).
143 (define (test-hangman guess status partsleft response)
144   (begin (set! chosen-word '(b a l l))
145          (set! status-word status)
146          (set! body-parts-left partsleft)
147          (equal? (hangman-guess guess) response)))
148 
149 
150 
151 (and (test-hangman 'l '(b _ _ _) '(arm leg) '("Good guess!" (b _ l l)))
152      (equal? status-word '(b _ l l)))
153 (test-hangman 'a '(b _ l l) '(arm leg) "You won")
154 (and (test-hangman 'l '(b _ l l) '(right-leg left-leg) '("Sorry" right-leg (b _ l l)))
155      (equal? body-parts-left '(left-leg)))
156 (and (test-hangman 'l '(b _ l l) '(left-leg) '("The End" (b a l l)))
157      (equal? body-parts-left empty))
158 |#
159 
160 ;;View
161 
162 ;word->string : word -> string
163 ;Given a word, convert it to a string.
164 
165 (define (word->string aword)
166   (foldr string-append "" (map (lambda (aletter) (symbol->string aletter)) aword)))
167 
168 ;;GUI-items
169 (define guess-message (make-message "Guess: "))
170 (define guess-choice (make-choice (map (lambda (aletter) (symbol->string aletter)) LETTERS)))
171 (define status-message (make-message "Status: "))
172 (define status-word-message (make-message (word->string status-word)))
173 (define result-message (make-message "Let's play hangman!"))
174 (define body-part-message (make-message ""))
175 
176 ;;Controller
177 
178 ;   1. "You won"
179 ;   2. (list "The End" body-part word)
180 ;   3. (list "Good guess!" word)
181 ;   4. (list "Sorry" body-part word)
182 
183 
184 (define (check-call-back event)
185   (local ((define response (hangman-guess (list-ref LETTERS (choice-index guess-choice)))))
186     (cond
187       [(string? response) (and (draw-message result-message response)
188                                (draw-message status-word-message (word->string status-word)))]
189       [(= (length response) 2)
190        (and (draw-message result-message (first response))
191             (draw-message status-word-message (word->string (second response))))]
192       [(and (draw-message result-message (first response))
193             (draw-message body-part-message (symbol->string (second response)))
194             (draw-message status-word-message (word->string (third response)))
195             (draw-next-part (second response)))
196        (cond
197          [(empty? body-parts-left)
198           (begin (hangman)
199                  (draw-message status-message "Chosen Word:"))]
200          [else true])])))
201 
202 (define check-button (make-button "Check" check-call-back))
203 
204 (create-window
205  (list (list guess-message guess-choice check-button)
206        (list status-message status-word-message)
207        (list result-message body-part-message)))
208 
209 (define CWIDTH 300)
210 (define CHEIGHT 300)
211 (start CWIDTH CHEIGHT)
212 
213 ; draw-next-part : symbol -> boolean
214 ; Draws the next part given the name of the part.  Returns true if
215 ; drawing is successful.
216 
217 (define (draw-next-part part)
218   (local ((define XCENTER (/ CWIDTH 2))
219           (define COLORHEAD 'brown)
220           (define COLORBODY 'purple)
221           (define COLORARMS 'brown)
222           (define COLORLEGS 'red)
223           (define (draw-noose)
224             (and (draw-solid-line (make-posn 0 (/ CHEIGHT 10))
225                                   (make-posn XCENTER (/ CHEIGHT 10)))
226                  (draw-solid-line (make-posn XCENTER (/ CHEIGHT 10))
227                                   (make-posn XCENTER (/ CHEIGHT 5)))))
228           (define (draw-head)
229             (draw-circle (make-posn XCENTER (/ CHEIGHT 3)) (* CHEIGHT 2/15) COLORHEAD))
230           (define (draw-body)
231             (draw-solid-line (make-posn XCENTER (* 7/15 CHEIGHT))
232                              (make-posn XCENTER (* CHEIGHT 3/4))
233                              COLORBODY))
234           (define (draw-right-arm)
235             (draw-solid-line (make-posn XCENTER (* 3/5 CHEIGHT))
236                              (make-posn (* CWIDTH 3/4) (* CHEIGHT 7/15))
237                              COLORARMS))
238           (define (draw-left-arm)
239             (draw-solid-line (make-posn XCENTER (* 3/5 CHEIGHT))
240                              (make-posn (* CWIDTH 1/4) (* CHEIGHT 7/15))
241                              COLORARMS))
242           (define (draw-right-leg)
243             (draw-solid-line (make-posn XCENTER (* 3/4 CHEIGHT))
244                              (make-posn (* CWIDTH 7/8) (* CHEIGHT 15/16))
245                              COLORLEGS))
246           (define (draw-left-leg)
247             (draw-solid-line (make-posn XCENTER (* 3/4 CHEIGHT))
248                              (make-posn (* CWIDTH 1/8) (* CHEIGHT 15/16))
249                              COLORLEGS)))
250     (cond
251       [(symbol=? part 'noose) (draw-noose)]
252       [(symbol=? part 'head) (draw-head)]
253       [(symbol=? part 'body) (draw-body)]
254       [(symbol=? part 'right-arm) (draw-right-arm)]
255       [(symbol=? part 'left-arm) (draw-left-arm)]    
256       [(symbol=? part 'right-leg) (draw-right-leg)]    
257       [(symbol=? part 'left-leg) (draw-left-leg)])))
258 
259 #|
260 ;Tests reveal-word given cw, sw, aletter, expected, and new?.
261 
262 (define (test-reveal-word cw sw aletter expected new?)
263   (begin (set! chosen-word cw)
264          (set! status-word sw)
265          (and (equal? (reveal-word cw sw aletter) expected)
266               (equal? new? new-knowledge))))
267 
268 ;If status-word is (list 'b '_ 'l 'l) and chosen-word is (list 'b 'a 'l 'l), then evaluating
269 ;(reveal-one chosen-word status-word 'a)
270 ;produces (list 'b 'a 'l 'l) and new-knowledge is true.
271 
272 (test-reveal-word '(b a l l) '(b _ l l) 'a '(b a l l) true)
273 
274 ;If status-word is (list 'b '_ '_ '_) and chosen-word is (list 'b 'a 'l 'l), then evaluating
275 ;(reveal-one chosen-word status-word 'x)
276 ;produces (list 'b '_ '_ '_) and new-knowledge is false.
277 
278 (test-reveal-word '(b a l l) '(b _ _ _) 'x '(b _ _ _) false)
279 
280 ;If status-word is (list 'b '_ '_ '_) and chosen-word is (list 'b 'a 'l 'l), then evaluating
281 ;(reveal-one chosen-word status-word 'l)
282 ;produces (list 'b '_ 'l 'l) and new-knowledge is true.
283 
284 (test-reveal-word '(b a l l) '(b _ _ _) 'l '(b _ l l) true)
285 
286 ;Finally, if status-word is (list 'b '_ 'l 'l) and chosen-word is (list 'b 'a 'l 'l), then evaluating
287 ;(reveal-one chosen-word status-word 'l)
288 ;produces (list 'b '_ 'l 'l) and new-knowledge is false. 
289 
290 (test-reveal-word '(b a l l) '(b _ l l) 'l '(b _ l l) false)
291 
292 |#