1 12687dd9 2023-08-04 jrmu ;; The first three lines of this file were inserted by DrScheme. They record metadata
2 12687dd9 2023-08-04 jrmu ;; about the language level of this file in a form that our tools can easily process.
3 12687dd9 2023-08-04 jrmu #reader(lib "htdp-advanced-reader.ss" "lang")((modname |37.3|) (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")))))
6 12687dd9 2023-08-04 jrmu ;A word is a (listof letters) where letters is a symbol from 'a ... 'z and '_.
10 12687dd9 2023-08-04 jrmu (define WORDS '((o c t o p u s)
12 12687dd9 2023-08-04 jrmu (s a l m o n)
13 12687dd9 2023-08-04 jrmu (t i l a p i a)
15 12687dd9 2023-08-04 jrmu (s h r i m p)
17 12687dd9 2023-08-04 jrmu (m u s s e l)
18 12687dd9 2023-08-04 jrmu (o y s t e r)
20 12687dd9 2023-08-04 jrmu (s t a r f i s h)
21 12687dd9 2023-08-04 jrmu (j e l l y f i s h)
22 12687dd9 2023-08-04 jrmu (s e a l i o n)
24 12687dd9 2023-08-04 jrmu (d o l p h i n)
27 12687dd9 2023-08-04 jrmu (m a n a t e e)))
29 12687dd9 2023-08-04 jrmu ;;The alphabet
30 12687dd9 2023-08-04 jrmu (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))
32 12687dd9 2023-08-04 jrmu ;;The number of words
33 12687dd9 2023-08-04 jrmu (define WORDS# (length WORDS))
35 12687dd9 2023-08-04 jrmu ;;A body-part is one of the following symbols:
36 12687dd9 2023-08-04 jrmu (define PARTS '(noose head body right-arm left-arm right-leg left-leg))
38 12687dd9 2023-08-04 jrmu ;;State Variables
40 12687dd9 2023-08-04 jrmu ;;chosen-word : word
41 12687dd9 2023-08-04 jrmu ;;This word is the target word that the player needs to guess
43 12687dd9 2023-08-04 jrmu (define chosen-word (first WORDS))
45 12687dd9 2023-08-04 jrmu ;;status-word : word
46 12687dd9 2023-08-04 jrmu ;;This word represents the current status of the player's guesses
48 12687dd9 2023-08-04 jrmu (define status-word (first WORDS))
50 12687dd9 2023-08-04 jrmu ;;body-parts-left : (listof body-parts)
51 12687dd9 2023-08-04 jrmu ;;Indicates how many body-parts are left before the hangman is dead.
53 12687dd9 2023-08-04 jrmu (define body-parts-left PARTS)
55 12687dd9 2023-08-04 jrmu ;;previous-guesses : word
56 12687dd9 2023-08-04 jrmu ;;Keeps track of all previous guesses.
58 12687dd9 2023-08-04 jrmu (define previous-guesses empty)
60 12687dd9 2023-08-04 jrmu ;;new-knowledge : boolean
61 12687dd9 2023-08-04 jrmu ;;Keeps track of whether or not the guessed letter adds new-knowledge.
63 12687dd9 2023-08-04 jrmu (define new-knowledge false)
65 12687dd9 2023-08-04 jrmu ;;letters-remaining : number
66 12687dd9 2023-08-04 jrmu ;;Keeps track of the letters that still need to be uncovered.
68 12687dd9 2023-08-04 jrmu (define letters-remaining (length chosen-word))
70 12687dd9 2023-08-04 jrmu ;make-status-word : word -> word
71 12687dd9 2023-08-04 jrmu ;Given aword, creates an equally long word consisting only of the letter '_.
73 12687dd9 2023-08-04 jrmu (define (make-status-word aword)
74 12687dd9 2023-08-04 jrmu (build-list (length aword) (lambda (x) '_)))
76 12687dd9 2023-08-04 jrmu ;;hangman : -> void
77 12687dd9 2023-08-04 jrmu ;;Initiates the hangman program by selecting the chosen word and resetting the status word and the number of body-parts left.
79 12687dd9 2023-08-04 jrmu (define (hangman)
80 12687dd9 2023-08-04 jrmu (begin (set! chosen-word (list-ref WORDS (random WORDS#)))
81 12687dd9 2023-08-04 jrmu (set! status-word (make-status-word chosen-word))
82 12687dd9 2023-08-04 jrmu (set! body-parts-left PARTS)
83 12687dd9 2023-08-04 jrmu (set! previous-guesses empty)
84 12687dd9 2023-08-04 jrmu (set! new-knowledge false)
85 12687dd9 2023-08-04 jrmu (set! letters-remaining (length chosen-word))))
87 12687dd9 2023-08-04 jrmu ;;Initializes the state variables
90 12687dd9 2023-08-04 jrmu ;A response is either
91 12687dd9 2023-08-04 jrmu ; 1. "You won"
92 12687dd9 2023-08-04 jrmu ; 2. (list "The End" body-part word)
93 12687dd9 2023-08-04 jrmu ; 3. (list "Good guess!" word)
94 12687dd9 2023-08-04 jrmu ; 4. (list "Sorry" body-part word)
96 12687dd9 2023-08-04 jrmu ;hangman-guess : letter -> response
97 12687dd9 2023-08-04 jrmu ;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.
99 12687dd9 2023-08-04 jrmu (define (hangman-guess aletter)
100 12687dd9 2023-08-04 jrmu (local ((define updated-status (reveal-word chosen-word status-word aletter)))
102 12687dd9 2023-08-04 jrmu [(contains previous-guesses aletter) "You have used this guess before."]
105 12687dd9 2023-08-04 jrmu (set! previous-guesses (cons aletter previous-guesses))
107 12687dd9 2023-08-04 jrmu [new-knowledge (begin (set! status-word updated-status)
108 12687dd9 2023-08-04 jrmu (set! letters-remaining (sub1 letters-remaining))
110 12687dd9 2023-08-04 jrmu [(zero? letters-remaining) "You won"]
111 12687dd9 2023-08-04 jrmu [else (list "Good guess!" status-word)]))]
113 12687dd9 2023-08-04 jrmu (local ((define lost-part (first body-parts-left)))
114 12687dd9 2023-08-04 jrmu (begin (set! body-parts-left (rest body-parts-left))
116 12687dd9 2023-08-04 jrmu [(empty? body-parts-left) (list "The End" lost-part chosen-word)]
117 12687dd9 2023-08-04 jrmu [else (list "Sorry" lost-part status-word)])))]))])))
119 12687dd9 2023-08-04 jrmu ;reveal-word: word word letter -> word
120 12687dd9 2023-08-04 jrmu ;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.
122 12687dd9 2023-08-04 jrmu (define (reveal-word chosen-word status-word aletter)
123 12687dd9 2023-08-04 jrmu (local ((define (reveal-letter chosen-letter status-letter)
125 12687dd9 2023-08-04 jrmu [(and (symbol=? chosen-letter aletter)
126 12687dd9 2023-08-04 jrmu (symbol=? status-letter '_))
127 12687dd9 2023-08-04 jrmu (begin (set! new-knowledge true)
129 12687dd9 2023-08-04 jrmu [else status-letter])))
130 12687dd9 2023-08-04 jrmu (begin (set! new-knowledge false)
131 12687dd9 2023-08-04 jrmu (map reveal-letter chosen-word status-word))))
133 12687dd9 2023-08-04 jrmu ;contains : (listof X) X -> boolean
134 12687dd9 2023-08-04 jrmu ;Determine if alox contains anx
135 12687dd9 2023-08-04 jrmu (define (contains alox anx)
136 12687dd9 2023-08-04 jrmu (ormap (lambda (x) (equal? x anx)) alox))
137 12687dd9 2023-08-04 jrmu ;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
141 12687dd9 2023-08-04 jrmu ;test-hangman : letter word X -> boolean
142 12687dd9 2023-08-04 jrmu ;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 12687dd9 2023-08-04 jrmu (define (test-hangman guess status partsleft response)
144 12687dd9 2023-08-04 jrmu (begin (set! chosen-word '(b a l l))
145 12687dd9 2023-08-04 jrmu (set! status-word status)
146 12687dd9 2023-08-04 jrmu (set! body-parts-left partsleft)
147 12687dd9 2023-08-04 jrmu (equal? (hangman-guess guess) response)))
151 12687dd9 2023-08-04 jrmu (and (test-hangman 'l '(b _ _ _) '(arm leg) '("Good guess!" (b _ l l)))
152 12687dd9 2023-08-04 jrmu (equal? status-word '(b _ l l)))
153 12687dd9 2023-08-04 jrmu (test-hangman 'a '(b _ l l) '(arm leg) "You won")
154 12687dd9 2023-08-04 jrmu (and (test-hangman 'l '(b _ l l) '(right-leg left-leg) '("Sorry" right-leg (b _ l l)))
155 12687dd9 2023-08-04 jrmu (equal? body-parts-left '(left-leg)))
156 12687dd9 2023-08-04 jrmu (and (test-hangman 'l '(b _ l l) '(left-leg) '("The End" (b a l l)))
157 12687dd9 2023-08-04 jrmu (equal? body-parts-left empty))
162 12687dd9 2023-08-04 jrmu ;word->string : word -> string
163 12687dd9 2023-08-04 jrmu ;Given a word, convert it to a string.
165 12687dd9 2023-08-04 jrmu (define (word->string aword)
166 12687dd9 2023-08-04 jrmu (foldr string-append "" (map (lambda (aletter) (symbol->string aletter)) aword)))
168 12687dd9 2023-08-04 jrmu ;;GUI-items
169 12687dd9 2023-08-04 jrmu (define guess-message (make-message "Guess: "))
170 12687dd9 2023-08-04 jrmu (define guess-choice (make-choice (map (lambda (aletter) (symbol->string aletter)) LETTERS)))
171 12687dd9 2023-08-04 jrmu (define status-message (make-message "Status: "))
172 12687dd9 2023-08-04 jrmu (define status-word-message (make-message (word->string status-word)))
173 12687dd9 2023-08-04 jrmu (define result-message (make-message "Let's play hangman!"))
174 12687dd9 2023-08-04 jrmu (define body-part-message (make-message ""))
176 12687dd9 2023-08-04 jrmu ;;Controller
178 12687dd9 2023-08-04 jrmu ; 1. "You won"
179 12687dd9 2023-08-04 jrmu ; 2. (list "The End" body-part word)
180 12687dd9 2023-08-04 jrmu ; 3. (list "Good guess!" word)
181 12687dd9 2023-08-04 jrmu ; 4. (list "Sorry" body-part word)
184 12687dd9 2023-08-04 jrmu (define (check-call-back event)
185 12687dd9 2023-08-04 jrmu (local ((define response (hangman-guess (list-ref LETTERS (choice-index guess-choice)))))
187 12687dd9 2023-08-04 jrmu [(string? response) (and (draw-message result-message response)
188 12687dd9 2023-08-04 jrmu (draw-message status-word-message (word->string status-word)))]
189 12687dd9 2023-08-04 jrmu [(= (length response) 2)
190 12687dd9 2023-08-04 jrmu (and (draw-message result-message (first response))
191 12687dd9 2023-08-04 jrmu (draw-message status-word-message (word->string (second response))))]
192 12687dd9 2023-08-04 jrmu [(and (draw-message result-message (first response))
193 12687dd9 2023-08-04 jrmu (draw-message body-part-message (symbol->string (second response)))
194 12687dd9 2023-08-04 jrmu (draw-message status-word-message (word->string (third response)))
195 12687dd9 2023-08-04 jrmu (draw-next-part (second response)))
197 12687dd9 2023-08-04 jrmu [(empty? body-parts-left)
198 12687dd9 2023-08-04 jrmu (begin (hangman)
199 12687dd9 2023-08-04 jrmu (draw-message status-message "Chosen Word:"))]
200 12687dd9 2023-08-04 jrmu [else true])])))
202 12687dd9 2023-08-04 jrmu (define check-button (make-button "Check" check-call-back))
204 12687dd9 2023-08-04 jrmu (create-window
205 12687dd9 2023-08-04 jrmu (list (list guess-message guess-choice check-button)
206 12687dd9 2023-08-04 jrmu (list status-message status-word-message)
207 12687dd9 2023-08-04 jrmu (list result-message body-part-message)))
209 12687dd9 2023-08-04 jrmu (define CWIDTH 300)
210 12687dd9 2023-08-04 jrmu (define CHEIGHT 300)
211 12687dd9 2023-08-04 jrmu (start CWIDTH CHEIGHT)
213 12687dd9 2023-08-04 jrmu ; draw-next-part : symbol -> boolean
214 12687dd9 2023-08-04 jrmu ; Draws the next part given the name of the part. Returns true if
215 12687dd9 2023-08-04 jrmu ; drawing is successful.
217 12687dd9 2023-08-04 jrmu (define (draw-next-part part)
218 12687dd9 2023-08-04 jrmu (local ((define XCENTER (/ CWIDTH 2))
219 12687dd9 2023-08-04 jrmu (define COLORHEAD 'brown)
220 12687dd9 2023-08-04 jrmu (define COLORBODY 'purple)
221 12687dd9 2023-08-04 jrmu (define COLORARMS 'brown)
222 12687dd9 2023-08-04 jrmu (define COLORLEGS 'red)
223 12687dd9 2023-08-04 jrmu (define (draw-noose)
224 12687dd9 2023-08-04 jrmu (and (draw-solid-line (make-posn 0 (/ CHEIGHT 10))
225 12687dd9 2023-08-04 jrmu (make-posn XCENTER (/ CHEIGHT 10)))
226 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (/ CHEIGHT 10))
227 12687dd9 2023-08-04 jrmu (make-posn XCENTER (/ CHEIGHT 5)))))
228 12687dd9 2023-08-04 jrmu (define (draw-head)
229 12687dd9 2023-08-04 jrmu (draw-circle (make-posn XCENTER (/ CHEIGHT 3)) (* CHEIGHT 2/15) COLORHEAD))
230 12687dd9 2023-08-04 jrmu (define (draw-body)
231 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (* 7/15 CHEIGHT))
232 12687dd9 2023-08-04 jrmu (make-posn XCENTER (* CHEIGHT 3/4))
233 12687dd9 2023-08-04 jrmu COLORBODY))
234 12687dd9 2023-08-04 jrmu (define (draw-right-arm)
235 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (* 3/5 CHEIGHT))
236 12687dd9 2023-08-04 jrmu (make-posn (* CWIDTH 3/4) (* CHEIGHT 7/15))
237 12687dd9 2023-08-04 jrmu COLORARMS))
238 12687dd9 2023-08-04 jrmu (define (draw-left-arm)
239 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (* 3/5 CHEIGHT))
240 12687dd9 2023-08-04 jrmu (make-posn (* CWIDTH 1/4) (* CHEIGHT 7/15))
241 12687dd9 2023-08-04 jrmu COLORARMS))
242 12687dd9 2023-08-04 jrmu (define (draw-right-leg)
243 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (* 3/4 CHEIGHT))
244 12687dd9 2023-08-04 jrmu (make-posn (* CWIDTH 7/8) (* CHEIGHT 15/16))
245 12687dd9 2023-08-04 jrmu COLORLEGS))
246 12687dd9 2023-08-04 jrmu (define (draw-left-leg)
247 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (* 3/4 CHEIGHT))
248 12687dd9 2023-08-04 jrmu (make-posn (* CWIDTH 1/8) (* CHEIGHT 15/16))
249 12687dd9 2023-08-04 jrmu COLORLEGS)))
251 12687dd9 2023-08-04 jrmu [(symbol=? part 'noose) (draw-noose)]
252 12687dd9 2023-08-04 jrmu [(symbol=? part 'head) (draw-head)]
253 12687dd9 2023-08-04 jrmu [(symbol=? part 'body) (draw-body)]
254 12687dd9 2023-08-04 jrmu [(symbol=? part 'right-arm) (draw-right-arm)]
255 12687dd9 2023-08-04 jrmu [(symbol=? part 'left-arm) (draw-left-arm)]
256 12687dd9 2023-08-04 jrmu [(symbol=? part 'right-leg) (draw-right-leg)]
257 12687dd9 2023-08-04 jrmu [(symbol=? part 'left-leg) (draw-left-leg)])))
260 12687dd9 2023-08-04 jrmu ;Tests reveal-word given cw, sw, aletter, expected, and new?.
262 12687dd9 2023-08-04 jrmu (define (test-reveal-word cw sw aletter expected new?)
263 12687dd9 2023-08-04 jrmu (begin (set! chosen-word cw)
264 12687dd9 2023-08-04 jrmu (set! status-word sw)
265 12687dd9 2023-08-04 jrmu (and (equal? (reveal-word cw sw aletter) expected)
266 12687dd9 2023-08-04 jrmu (equal? new? new-knowledge))))
268 12687dd9 2023-08-04 jrmu ;If status-word is (list 'b '_ 'l 'l) and chosen-word is (list 'b 'a 'l 'l), then evaluating
269 12687dd9 2023-08-04 jrmu ;(reveal-one chosen-word status-word 'a)
270 12687dd9 2023-08-04 jrmu ;produces (list 'b 'a 'l 'l) and new-knowledge is true.
272 12687dd9 2023-08-04 jrmu (test-reveal-word '(b a l l) '(b _ l l) 'a '(b a l l) true)
274 12687dd9 2023-08-04 jrmu ;If status-word is (list 'b '_ '_ '_) and chosen-word is (list 'b 'a 'l 'l), then evaluating
275 12687dd9 2023-08-04 jrmu ;(reveal-one chosen-word status-word 'x)
276 12687dd9 2023-08-04 jrmu ;produces (list 'b '_ '_ '_) and new-knowledge is false.
278 12687dd9 2023-08-04 jrmu (test-reveal-word '(b a l l) '(b _ _ _) 'x '(b _ _ _) false)
280 12687dd9 2023-08-04 jrmu ;If status-word is (list 'b '_ '_ '_) and chosen-word is (list 'b 'a 'l 'l), then evaluating
281 12687dd9 2023-08-04 jrmu ;(reveal-one chosen-word status-word 'l)
282 12687dd9 2023-08-04 jrmu ;produces (list 'b '_ 'l 'l) and new-knowledge is true.
284 12687dd9 2023-08-04 jrmu (test-reveal-word '(b a l l) '(b _ _ _) 'l '(b _ l l) true)
286 12687dd9 2023-08-04 jrmu ;Finally, if status-word is (list 'b '_ 'l 'l) and chosen-word is (list 'b 'a 'l 'l), then evaluating
287 12687dd9 2023-08-04 jrmu ;(reveal-one chosen-word status-word 'l)
288 12687dd9 2023-08-04 jrmu ;produces (list 'b '_ 'l 'l) and new-knowledge is false.
290 12687dd9 2023-08-04 jrmu (test-reveal-word '(b a l l) '(b _ l l) 'l '(b _ l l) false)
