suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

small refactoring of hangman checks

Browse Source 
svn: r10793
This commit is contained in:
Matthias Felleisen 2008-07-16 16:14:21 +00:00
parent 43e815713c
commit 469c1a0c89
3 changed files with 297 additions and 279 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/htdp/Test/hangman-error.ss Normal file
View File

@ -0,0 +1,14 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-advanced-reader.ss" "lang")((modname hangman-error) (read-case-sensitive #t) (teachpacks ((lib "hangman.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ((lib "hangman.ss" "teachpack" "htdp")))))
(define (reveal-list chosen status guess)
'(a))
(define (draw-next-part body-part)
(begin
"this revealed an omission in the teachpack"
(printf "body-part ~s\n" body-part)))
(start 200 200)
(check-error (hangman-list reveal-list draw-next-part)
"draw-next-part: result of type <boolean> expected, given: #<void>")

9
collects/htdp/error.ss
View File

@ -5,6 +5,7 @@
;; --------------------------------------------------------------------------
(provide check-arg check-arity check-proc check-result check-list-list
check-fun-res
natural?
find-non tp-exn? number->ord)
@ -16,6 +17,14 @@
(let ([r (filter (compose not pred?) l)])
(if (null? r) #f (car r))))
;(: check-fun-res (∀ (γ) (∀ (β α ...) (α ...α -> β)) (_ -γ-> boolean) _ -> γ))
(define (check-fun-res f pred? type)
(lambda x
(define r (apply f x))
(check-result (object-name f) pred? type r)
r))
#| Tests ------------------------------------------------------------------
(not (find-non list? '((1 2 3) (a b c))))
(symbol? (find-non number? '(1 2 3 a)))

553
collects/htdp/hangman.ss
View File

@ -1,123 +1,123 @@
#cs(module hangman mzscheme
(require "error.ss"
"draw-sig.ss"
"big-draw.ss"
mzlib/class
mzlib/unit
mzlib/etc
lang/prim
mred)
(provide
hangman
hangman-list
)
(define-higher-order-primitive hangman hangman/proc (make-word reveal draw-next))
(define-higher-order-primitive hangman-list hangman-list/proc (reveal-list draw-next))
#lang mzscheme
(require "error.ss"
"draw-sig.ss"
"big-draw.ss"
mzlib/class
mzlib/unit
mzlib/etc
lang/prim
mred)
(provide-signature-elements draw^)
#| ------------------------------------------------------------------------
(provide
hangman
hangman-list
)
(define-higher-order-primitive hangman hangman/proc (make-word reveal draw-next))
(define-higher-order-primitive hangman-list hangman-list/proc (reveal-list draw-next))
(provide-signature-elements draw^)
#| ------------------------------------------------------------------------
The Basic Constants |#
(define TITLE "Hangman")
(define WELCOME "Welcome to Hangman")
(define WINNER "We have a winner!")
(define LOSER "This is the end, my friend. The word was ~a.")
(define SMALL_A (char->integer #\a))
(define LETTERS
(build-list 26 (lambda (i) (format "~a" (integer->char (+ SMALL_A i))))))
(define TRUMPET
(make-object bitmap%
(build-path (collection-path "icons") "trumpet.xbm")
'xbm))
(define PARTS (vector 'right-leg 'left-leg 'left-arm 'right-arm 'body 'head 'noose))
(define NUMBER-OF-GUESSES (vector-length PARTS))
;; char->symbol : char -> symbol
(define (char->symbol c)
(string->symbol (format "~a" c)))
;; word->list : symbol -> (listof letter)
(define (word->list sym)
(map char->symbol (string->list (symbol->string sym))))
;; WORDS : (listof (list letter letter letter))
(define WORDS
(map word->list
'(and
are
but
cat
cow
dog
eat
fee
gal
hat
inn
jam
kit
lit
met
now
owl
pet
rat
sea
the
usa
vip
was
zoo)))
;; WORDS2 : (listof (listof letter))
(define WORDS2
(append (map word->list
'(apple
bottle
cattle
drscheme
elephant
folder
gift
hangman
idle
jet
knowledge
length
macintosh
north
ottoman
public
queue
rattlesnake
snow
toddler
under
virus
xylaphon
yellow
zombie))
WORDS))
;; ------------------------------------------------------------------------
;; The GUI
;; two communication channels to GUI; init with setup-gui
(define status-message #f)
(define message-panel #f)
;; setup-gui : str ->* message% panel%
;; to produce a status message and a panel where winning/losing can be announced
;; effect: set up a new frame, arrange the GUI, and display (blank) status word
(define (setup-gui status)
(local (#| --------------------------------------------------------------
(define TITLE "Hangman")
(define WELCOME "Welcome to Hangman")
(define WINNER "We have a winner!")
(define LOSER "This is the end, my friend. The word was ~a.")
(define SMALL_A (char->integer #\a))
(define LETTERS
(build-list 26 (lambda (i) (format "~a" (integer->char (+ SMALL_A i))))))
(define TRUMPET
(make-object bitmap%
(build-path (collection-path "icons") "trumpet.xbm")
'xbm))
(define PARTS (vector 'right-leg 'left-leg 'left-arm 'right-arm 'body 'head 'noose))
(define NUMBER-OF-GUESSES (vector-length PARTS))
;; char->symbol : char -> symbol
(define (char->symbol c)
(string->symbol (format "~a" c)))
;; word->list : symbol -> (listof letter)
(define (word->list sym)
(map char->symbol (string->list (symbol->string sym))))
;; WORDS : (listof (list letter letter letter))
(define WORDS
(map word->list
'(and
are
but
cat
cow
dog
eat
fee
gal
hat
inn
jam
kit
lit
met
now
owl
pet
rat
sea
the
usa
vip
was
zoo)))
;; WORDS2 : (listof (listof letter))
(define WORDS2
(append (map word->list
'(apple
bottle
cattle
drscheme
elephant
folder
gift
hangman
idle
jet
knowledge
length
macintosh
north
ottoman
public
queue
rattlesnake
snow
toddler
under
virus
xylaphon
yellow
zombie))
WORDS))
;; ------------------------------------------------------------------------
;; The GUI
;; two communication channels to GUI; init with setup-gui
(define status-message #f)
(define message-panel #f)
;; setup-gui : str ->* message% panel%
;; to produce a status message and a panel where winning/losing can be announced
;; effect: set up a new frame, arrange the GUI, and display (blank) status word
(define (setup-gui status)
(local (#| --------------------------------------------------------------
The GUI Layout: (computed as a function of constants)
------------------------------------------------
@ -129,164 +129,159 @@
| message% |
------------------------------------------------
|#
(define frame (make-object frame% TITLE #f 100 50))
(define verti (make-object vertical-panel% frame))
(define panel (make-object horizontal-panel% verti))
(define _1 (send panel set-alignment 'center 'center))
(define choice (make-object choice% "Guess:" LETTERS panel void))
; (make-object message% " " panel);; added for looks
(define check (make-object button% "Check" panel
(lambda (x y)
(check-guess
(char->symbol
(list-ref LETTERS
(send choice get-selection)))))))
(define _2 (make-object message% " Status: " panel))
(define m (make-object message% (uncover status) panel))
(define p (make-object horizontal-panel% verti))
(define _3 (send p set-alignment 'center 'center))
(define _4 (make-object message% WELCOME p)))
(set! status-message m)
(set! message-panel p)
(send frame show #t)))
;; ------------------------------------------------------------------------
;; The functions for communicating with the GUI
;; a-winner! : -> void
;; effect: signal win and disable game
(define (a-winner!)
(send message-panel change-children (lambda (x) null))
(make-object message% WINNER message-panel)
(make-object message% TRUMPET message-panel))
;; a-loser! : -> void
;; effect: signal loss and disable game
(define (a-loser!)
(send message-panel change-children (lambda (x) null))
(make-object message% (format LOSER (uncover chosen)) message-panel))
;; ------------------------------------------------------------------------
;; The functions for playing the game
;; check-guess : symbol -> word
;; to check whether guess occurs in the chosen word, using reveal
;; effect: update the status word
(define (check-guess guess)
(let ((result (reveal chosen status guess)))
(cond
[(equal? result chosen)
(send status-message set-label (uncover chosen))
(a-winner!)]
[(equal? result status)
(draw-next-part (select-piece!))
(when (the-end?) (a-loser!))]
[else
(set! status result)
(send status-message set-label (uncover status))])))
;; uncover : word -> string
;; to translate the current word into a string,
;; using abstraction breaking struct-ref
(define (uncover a-word)
(error 'hangman "impossible"))
;; pieces-left : index into PARTS
(define pieces-left NUMBER-OF-GUESSES)
(define (init-guesses)
(set! pieces-left NUMBER-OF-GUESSES))
;; select-piece! : -> void
;; effect: to decrease pieces-left and to pick the next thing to be drawn
(define (select-piece!)
(if (> pieces-left 0)
(begin
(set! pieces-left (sub1 pieces-left))
(vector-ref PARTS pieces-left))
;; (<= pieces-left 0)
(vector-ref PARTS 1)))
;; the-end? : -> boolean
;; to check whether the hangman is complet
(define (the-end?) (zero? pieces-left))
;; USER INTERFACE to student
;; chosen : word
(define chosen 10)
;; status : word
(define status 10)
;; reveal : (word word letter -> word)
(define (reveal chosen status guess)
(error 'hangman "appply hangman first!"))
;; draw-next-part : (symbol -> #t)
(define (draw-next-part s)
(error 'hangman "appply hangman first!"))
;; hangman :
;; (letter letter letter -> word)
;; (word word letter -> word)
;; (symbol -> true)
;; ->
;; true
;; effects: set up game status, draw noose, show frame
;; depends on: words are structures
(define (hangman/proc mw rv dr)
(check-proc 'hangman mw 3 '1st "3 arguments")
(check-proc 'hangman rv 3 '2nd "3 arguments")
(check-proc 'hangman dr 1 '3rd "1 argument")
(set! chosen (apply mw (list-ref WORDS (random (length WORDS)))))
(set! status (mw '_ '_ '_))
;; make uncover work for structs
(set! uncover
(lambda (a-word)
;; abstraction breaking hack.
(parameterize ([current-inspector (dynamic-require ''drscheme-secrets 'drscheme-inspector)])
(unless (struct? a-word)
(error 'hangman "expected a struct, got: ~e" a-word))
(let ([word-vec (struct->vector a-word)])
(unless (= (vector-length word-vec) 4)
(error 'hangman "expected words to be structures with three fields, found ~a fields"
(- (vector-length word-vec) 1)))
(format "~a~a~a"
(vector-ref word-vec 1)
(vector-ref word-vec 2)
(vector-ref word-vec 3))))))
(initialize rv dr status))
;; word2 = (listof letter)
;; hangman-list : (word2 word2 letter -> word2) (symbol -> #t) -> void
;; effects: set up game status, draw noose, show frame
(define (hangman-list/proc rv dr)
(check-proc 'hangman-list rv 3 '1st "3 arguments")
(check-proc 'hangman-list dr 1 '2nd "1 argument")
(set! chosen (list-ref WORDS2 (random (length WORDS2))))
(set! status (build-list (length chosen) (lambda (x) '_)))
;; make uncover work for lists
(set! uncover
(lambda (word)
(apply string-append (map (lambda (x) (format "~a" x)) word))))
(initialize (lambda (x y z)
(define r (rv x y z))
(check-result (object-name rv) list? "list of symbols" r)
r)
(lambda (x)
(define r (dr x))
(check-result (object-name dr) boolean? "boolean" r)
r)
status))
;; initialize : as it says ...
;; the gui, the guess, the picture, the reveal function the draw-next function
(define (initialize rv dr status)
(init-guesses)
(set! reveal rv)
(set! draw-next-part dr)
(setup-gui status)
(draw-next-part (select-piece!)))
)
(define frame (make-object frame% TITLE #f 100 50))
(define verti (make-object vertical-panel% frame))
(define panel (make-object horizontal-panel% verti))
(define _1 (send panel set-alignment 'center 'center))
(define choice (make-object choice% "Guess:" LETTERS panel void))
; (make-object message% " " panel);; added for looks
(define check (make-object button% "Check" panel
(lambda (x y)
(check-guess
(char->symbol
(list-ref LETTERS
(send choice get-selection)))))))
(define _2 (make-object message% " Status: " panel))
(define m (make-object message% (uncover status) panel))
(define p (make-object horizontal-panel% verti))
(define _3 (send p set-alignment 'center 'center))
(define _4 (make-object message% WELCOME p)))
(set! status-message m)
(set! message-panel p)
(send frame show #t)))
;; ------------------------------------------------------------------------
;; The functions for communicating with the GUI
;; a-winner! : -> void
;; effect: signal win and disable game
(define (a-winner!)
(send message-panel change-children (lambda (x) null))
(make-object message% WINNER message-panel)
(make-object message% TRUMPET message-panel))
;; a-loser! : -> void
;; effect: signal loss and disable game
(define (a-loser!)
(send message-panel change-children (lambda (x) null))
(make-object message% (format LOSER (uncover chosen)) message-panel))
;; ------------------------------------------------------------------------
;; The functions for playing the game
;; check-guess : symbol -> word
;; to check whether guess occurs in the chosen word, using reveal
;; effect: update the status word
(define (check-guess guess)
(let ((result (reveal chosen status guess)))
(cond
[(equal? result chosen)
(send status-message set-label (uncover chosen))
(a-winner!)]
[(equal? result status)
(draw-next-part (select-piece!))
(when (the-end?) (a-loser!))]
[else
(set! status result)
(send status-message set-label (uncover status))])))
;; uncover : word -> string
;; to translate the current word into a string,
;; using abstraction breaking struct-ref
(define (uncover a-word)
(error 'hangman "impossible"))
;; pieces-left : index into PARTS
(define pieces-left NUMBER-OF-GUESSES)
(define (init-guesses)
(set! pieces-left NUMBER-OF-GUESSES))
;; select-piece! : -> void
;; effect: to decrease pieces-left and to pick the next thing to be drawn
(define (select-piece!)
(if (> pieces-left 0)
(begin
(set! pieces-left (sub1 pieces-left))
(vector-ref PARTS pieces-left))
;; (<= pieces-left 0)
(vector-ref PARTS 1)))
;; the-end? : -> boolean
;; to check whether the hangman is complet
(define (the-end?) (zero? pieces-left))
;; USER INTERFACE to student
;; chosen : word
(define chosen 10)
;; status : word
(define status 10)
;; reveal : (word word letter -> word)
(define (reveal chosen status guess)
(error 'hangman "appply hangman first!"))
;; draw-next-part : (symbol -> #t)
(define (draw-next-part s)
(error 'hangman "appply hangman first!"))
;; hangman :
;; (letter letter letter -> word)
;; (word word letter -> word)
;; (symbol -> true)
;; ->
;; true
;; effects: set up game status, draw noose, show frame
;; depends on: words are structures
(define (hangman/proc mw rv dr)
(check-proc 'hangman mw 3 '1st "3 arguments")
(check-proc 'hangman rv 3 '2nd "3 arguments")
(check-proc 'hangman dr 1 '3rd "1 argument")
(set! chosen (apply mw (list-ref WORDS (random (length WORDS)))))
(set! status (mw '_ '_ '_))
;; make uncover work for structs
(set! uncover
(lambda (a-word)
;; abstraction breaking hack.
(parameterize ([current-inspector (dynamic-require ''drscheme-secrets 'drscheme-inspector)])
(unless (struct? a-word)
(error 'hangman "expected a struct, got: ~e" a-word))
(let ([word-vec (struct->vector a-word)])
(unless (= (vector-length word-vec) 4)
(error 'hangman "expected words to be structures with three fields, found ~a fields"
(- (vector-length word-vec) 1)))
(format "~a~a~a"
(vector-ref word-vec 1)
(vector-ref word-vec 2)
(vector-ref word-vec 3))))))
(initialize rv dr status))
;; word2 = (listof letter)
;; hangman-list : (word2 word2 letter -> word2) (symbol -> #t) -> void
;; effects: set up game status, draw noose, show frame
(define (hangman-list/proc rv dr)
(check-proc 'hangman-list rv 3 '1st "3 arguments")
(check-proc 'hangman-list dr 1 '2nd "1 argument")
(set! chosen (list-ref WORDS2 (random (length WORDS2))))
(set! status (build-list (length chosen) (lambda (x) '_)))
;; make uncover work for lists
(set! uncover
(lambda (word)
(apply string-append (map (lambda (x) (format "~a" x)) word))))
(initialize (check-fun-res rv list? "list of symbols")
(check-fun-res dr boolean? "boolean")
status))
;; initialize : as it says ...
;; the gui, the guess, the picture, the reveal function the draw-next function
(define (initialize rv dr status)
(init-guesses)
(set! reveal rv)
(set! draw-next-part dr)
(setup-gui status)
(draw-next-part (select-piece!)))