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.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")))))
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 ;make-status-word : word -> word
61 12687dd9 2023-08-04 jrmu ;Given aword, creates an equally long word consisting only of the letter '_.
63 12687dd9 2023-08-04 jrmu (define (make-status-word aword)
64 12687dd9 2023-08-04 jrmu (build-list (length aword) (lambda (x) '_)))
66 12687dd9 2023-08-04 jrmu ;;hangman : -> void
67 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.
69 12687dd9 2023-08-04 jrmu (define (hangman)
70 12687dd9 2023-08-04 jrmu (begin (set! chosen-word (list-ref WORDS (random WORDS#)))
71 12687dd9 2023-08-04 jrmu (set! status-word (make-status-word chosen-word))
72 12687dd9 2023-08-04 jrmu (set! body-parts-left PARTS)))
74 12687dd9 2023-08-04 jrmu ;;Initializes the state variables
77 12687dd9 2023-08-04 jrmu ;A response is either
78 12687dd9 2023-08-04 jrmu ; 1. "You won"
79 12687dd9 2023-08-04 jrmu ; 2. (list "The End" body-part word)
80 12687dd9 2023-08-04 jrmu ; 3. (list "Good guess!" word)
81 12687dd9 2023-08-04 jrmu ; 4. (list "Sorry" body-part word)
83 12687dd9 2023-08-04 jrmu ;hangman-guess : letter -> response
84 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.
86 12687dd9 2023-08-04 jrmu (define (hangman-guess aletter)
87 12687dd9 2023-08-04 jrmu (local ((define old-status status-word)
88 12687dd9 2023-08-04 jrmu (define updated-status (begin (reveal-list! aletter)
89 12687dd9 2023-08-04 jrmu status-word)))
91 12687dd9 2023-08-04 jrmu [(contains previous-guesses aletter) "You have used this guess before."]
94 12687dd9 2023-08-04 jrmu (set! previous-guesses (cons aletter previous-guesses))
96 12687dd9 2023-08-04 jrmu [(equal? old-status updated-status)
97 12687dd9 2023-08-04 jrmu (local ((define lost-part (first body-parts-left)))
98 12687dd9 2023-08-04 jrmu (begin (set! body-parts-left (rest body-parts-left))
100 12687dd9 2023-08-04 jrmu [(empty? body-parts-left) (list "The End" lost-part chosen-word)]
101 12687dd9 2023-08-04 jrmu [else (list "Sorry" lost-part status-word)])))]
102 12687dd9 2023-08-04 jrmu [(equal? status-word chosen-word) "You won"]
103 12687dd9 2023-08-04 jrmu [else (list "Good guess!" status-word)]))])))
105 12687dd9 2023-08-04 jrmu ;reveal-word: word word letter -> word
106 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.
108 12687dd9 2023-08-04 jrmu (define (reveal-word chosen-word status-word aletter)
109 12687dd9 2023-08-04 jrmu (local ((define (reveal-letter chosen-letter status-letter)
111 12687dd9 2023-08-04 jrmu [(equal? chosen-letter aletter) chosen-letter]
112 12687dd9 2023-08-04 jrmu [else status-letter])))
113 12687dd9 2023-08-04 jrmu (map reveal-letter chosen-word status-word)))
115 12687dd9 2023-08-04 jrmu ;;reveal-list! : letter -> void
116 12687dd9 2023-08-04 jrmu ;;effect: modifies status-word based on a comparison with chosen-word, status-word, and guess
118 12687dd9 2023-08-04 jrmu (define (reveal-list! guess)
119 12687dd9 2023-08-04 jrmu (local ((define (reveal-one chosen-letter status-letter)
121 12687dd9 2023-08-04 jrmu [(symbol=? chosen-letter guess) guess]
122 12687dd9 2023-08-04 jrmu [else status-letter])))
123 12687dd9 2023-08-04 jrmu (set! status-word (map reveal-one chosen-word status-word))))
125 12687dd9 2023-08-04 jrmu ;contains : (listof X) X -> boolean
126 12687dd9 2023-08-04 jrmu ;Determine if alox contains anx
127 12687dd9 2023-08-04 jrmu (define (contains alox anx)
128 12687dd9 2023-08-04 jrmu (ormap (lambda (x) (equal? x anx)) alox))
129 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
133 12687dd9 2023-08-04 jrmu ;test-hangman : letter word X -> boolean
134 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).
135 12687dd9 2023-08-04 jrmu (define (test-hangman guess status partsleft response)
136 12687dd9 2023-08-04 jrmu (begin (set! chosen-word '(b a l l))
137 12687dd9 2023-08-04 jrmu (set! status-word status)
138 12687dd9 2023-08-04 jrmu (set! body-parts-left partsleft)
139 12687dd9 2023-08-04 jrmu (equal? (hangman-guess guess) response)))
143 12687dd9 2023-08-04 jrmu (and (test-hangman 'l '(b _ _ _) '(arm leg) '("Good guess!" (b _ l l)))
144 12687dd9 2023-08-04 jrmu (equal? status-word '(b _ l l)))
145 12687dd9 2023-08-04 jrmu (test-hangman 'a '(b _ l l) '(arm leg) "You won")
146 12687dd9 2023-08-04 jrmu (and (test-hangman 'l '(b _ l l) '(right-leg left-leg) '("Sorry" right-leg (b _ l l)))
147 12687dd9 2023-08-04 jrmu (equal? body-parts-left '(left-leg)))
148 12687dd9 2023-08-04 jrmu (and (test-hangman 'l '(b _ l l) '(left-leg) '("The End" (b a l l)))
149 12687dd9 2023-08-04 jrmu (equal? body-parts-left empty))
154 12687dd9 2023-08-04 jrmu ;word->string : word -> string
155 12687dd9 2023-08-04 jrmu ;Given a word, convert it to a string.
157 12687dd9 2023-08-04 jrmu (define (word->string aword)
158 12687dd9 2023-08-04 jrmu (foldr string-append "" (map (lambda (aletter) (symbol->string aletter)) aword)))
160 12687dd9 2023-08-04 jrmu ;;GUI-items
161 12687dd9 2023-08-04 jrmu (define guess-message (make-message "Guess: "))
162 12687dd9 2023-08-04 jrmu (define guess-choice (make-choice (map (lambda (aletter) (symbol->string aletter)) LETTERS)))
163 12687dd9 2023-08-04 jrmu (define status-message (make-message "Status: "))
164 12687dd9 2023-08-04 jrmu (define status-word-message (make-message (word->string status-word)))
165 12687dd9 2023-08-04 jrmu (define result-message (make-message "Let's play hangman!"))
166 12687dd9 2023-08-04 jrmu (define body-part-message (make-message ""))
168 12687dd9 2023-08-04 jrmu ;;Controller
170 12687dd9 2023-08-04 jrmu ; 1. "You won"
171 12687dd9 2023-08-04 jrmu ; 2. (list "The End" body-part word)
172 12687dd9 2023-08-04 jrmu ; 3. (list "Good guess!" word)
173 12687dd9 2023-08-04 jrmu ; 4. (list "Sorry" body-part word)
176 12687dd9 2023-08-04 jrmu (define (check-call-back event)
177 12687dd9 2023-08-04 jrmu (local ((define response (hangman-guess (list-ref LETTERS (choice-index guess-choice)))))
179 12687dd9 2023-08-04 jrmu [(string? response) (and (draw-message result-message response)
180 12687dd9 2023-08-04 jrmu (draw-message status-word-message (word->string status-word)))]
181 12687dd9 2023-08-04 jrmu [(= (length response) 2)
182 12687dd9 2023-08-04 jrmu (and (draw-message result-message (first response))
183 12687dd9 2023-08-04 jrmu (draw-message status-word-message (word->string (second response))))]
184 12687dd9 2023-08-04 jrmu [(and (draw-message result-message (first response))
185 12687dd9 2023-08-04 jrmu (draw-message body-part-message (symbol->string (second response)))
186 12687dd9 2023-08-04 jrmu (draw-message status-word-message (word->string (third response)))
187 12687dd9 2023-08-04 jrmu (draw-next-part (second response)))
189 12687dd9 2023-08-04 jrmu [(empty? body-parts-left)
190 12687dd9 2023-08-04 jrmu (begin (hangman)
191 12687dd9 2023-08-04 jrmu (draw-message status-message "Chosen Word:"))]
192 12687dd9 2023-08-04 jrmu [else true])])))
194 12687dd9 2023-08-04 jrmu (define check-button (make-button "Check" check-call-back))
196 12687dd9 2023-08-04 jrmu (create-window
197 12687dd9 2023-08-04 jrmu (list (list guess-message guess-choice check-button)
198 12687dd9 2023-08-04 jrmu (list status-message status-word-message)
199 12687dd9 2023-08-04 jrmu (list result-message body-part-message)))
201 12687dd9 2023-08-04 jrmu (define CWIDTH 300)
202 12687dd9 2023-08-04 jrmu (define CHEIGHT 300)
203 12687dd9 2023-08-04 jrmu (start CWIDTH CHEIGHT)
205 12687dd9 2023-08-04 jrmu ; draw-next-part : symbol -> boolean
206 12687dd9 2023-08-04 jrmu ; Draws the next part given the name of the part. Returns true if
207 12687dd9 2023-08-04 jrmu ; drawing is successful.
209 12687dd9 2023-08-04 jrmu (define (draw-next-part part)
210 12687dd9 2023-08-04 jrmu (local ((define XCENTER (/ CWIDTH 2))
211 12687dd9 2023-08-04 jrmu (define COLORHEAD 'brown)
212 12687dd9 2023-08-04 jrmu (define COLORBODY 'purple)
213 12687dd9 2023-08-04 jrmu (define COLORARMS 'brown)
214 12687dd9 2023-08-04 jrmu (define COLORLEGS 'red)
215 12687dd9 2023-08-04 jrmu (define (draw-noose)
216 12687dd9 2023-08-04 jrmu (and (draw-solid-line (make-posn 0 (/ CHEIGHT 10))
217 12687dd9 2023-08-04 jrmu (make-posn XCENTER (/ CHEIGHT 10)))
218 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (/ CHEIGHT 10))
219 12687dd9 2023-08-04 jrmu (make-posn XCENTER (/ CHEIGHT 5)))))
220 12687dd9 2023-08-04 jrmu (define (draw-head)
221 12687dd9 2023-08-04 jrmu (draw-circle (make-posn XCENTER (/ CHEIGHT 3)) (* CHEIGHT 2/15) COLORHEAD))
222 12687dd9 2023-08-04 jrmu (define (draw-body)
223 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (* 7/15 CHEIGHT))
224 12687dd9 2023-08-04 jrmu (make-posn XCENTER (* CHEIGHT 3/4))
225 12687dd9 2023-08-04 jrmu COLORBODY))
226 12687dd9 2023-08-04 jrmu (define (draw-right-arm)
227 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (* 3/5 CHEIGHT))
228 12687dd9 2023-08-04 jrmu (make-posn (* CWIDTH 3/4) (* CHEIGHT 7/15))
229 12687dd9 2023-08-04 jrmu COLORARMS))
230 12687dd9 2023-08-04 jrmu (define (draw-left-arm)
231 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (* 3/5 CHEIGHT))
232 12687dd9 2023-08-04 jrmu (make-posn (* CWIDTH 1/4) (* CHEIGHT 7/15))
233 12687dd9 2023-08-04 jrmu COLORARMS))
234 12687dd9 2023-08-04 jrmu (define (draw-right-leg)
235 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (* 3/4 CHEIGHT))
236 12687dd9 2023-08-04 jrmu (make-posn (* CWIDTH 7/8) (* CHEIGHT 15/16))
237 12687dd9 2023-08-04 jrmu COLORLEGS))
238 12687dd9 2023-08-04 jrmu (define (draw-left-leg)
239 12687dd9 2023-08-04 jrmu (draw-solid-line (make-posn XCENTER (* 3/4 CHEIGHT))
240 12687dd9 2023-08-04 jrmu (make-posn (* CWIDTH 1/8) (* CHEIGHT 15/16))
241 12687dd9 2023-08-04 jrmu COLORLEGS)))
243 12687dd9 2023-08-04 jrmu [(symbol=? part 'noose) (draw-noose)]
244 12687dd9 2023-08-04 jrmu [(symbol=? part 'head) (draw-head)]
245 12687dd9 2023-08-04 jrmu [(symbol=? part 'body) (draw-body)]
246 12687dd9 2023-08-04 jrmu [(symbol=? part 'right-arm) (draw-right-arm)]
247 12687dd9 2023-08-04 jrmu [(symbol=? part 'left-arm) (draw-left-arm)]
248 12687dd9 2023-08-04 jrmu [(symbol=? part 'right-leg) (draw-right-leg)]
249 12687dd9 2023-08-04 jrmu [(symbol=? part 'left-leg) (draw-left-leg)])))
252 12687dd9 2023-08-04 jrmu ;;Wish-list
253 12687dd9 2023-08-04 jrmu ;;Once game is over, create a new button, reset the board
254 12687dd9 2023-08-04 jrmu ;;Once game is over, you need to erase the body-part message or at least put the correct body part image (left-leg is never given)
255 12687dd9 2023-08-04 jrmu ;;Once game is over, replace status-word with chosen-word
