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

world: big-bang & friends can be re-run

Browse Source 
svn: r11466
This commit is contained in:
Matthias Felleisen 2008-08-28 19:56:38 +00:00
parent 538b6e5e90
commit fd9ac82bd5
3 changed files with 117 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
collects/htdp/hangman-world-play.ss
View File

@ -1,59 +1,59 @@
(module hangman-world-play mzscheme
(require "hangman-world.ss"
htdp/world
mzlib/etc)
#| ------------------------------------------------------------------------
;; 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-intermediate-lambda-reader.ss" "lang")((modname hangman-world-play) (read-case-sensitive #t) (teachpacks ((lib "world.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "world.ss" "teachpack" "htdp")))))
(require (lib "hangman-world.ss" "htdp"))
(require (lib "world.ss" "htdp"))
#| ------------------------------------------------------------------------
add-next-part :
{ 'noose 'head 'right-arm 'left-arm 'body 'right-leg 'left-leg } scene -> scene
result: #t if things went okay
effect: to add the specified body part in a canvas of size W x H
credit: John Clements
|#
(define (add-next-part body-part s)
(cond ((eq? body-part 'body)
(add-line s 100 60 100 130 'black))
((eq? body-part 'right-leg)
(add-line s 100 130 30 170 'black))
((eq? body-part 'left-leg)
(add-line s 100 130 170 170 'black))
((eq? body-part 'right-arm)
(add-line s 100 75 40 65 'black))
((eq? body-part 'left-arm)
(add-line s 100 75 160 65 'black))
((eq? body-part 'head)
(place-image (circle 10 'outline 'black) 100 50 s))
((eq? body-part 'noose)
(local ((define s1 (add-line s 100 30 100 10 'black))
(define s2 (add-line s1 100 10 0 10 'black))
(define s3 (add-line s2 115 35 123 43 'black))
(define s4 (add-line s3 123 35 115 43 'black))
(define s5 (add-line s4 131 40 139 48 'black))
(define s6 (add-line s5 139 40 131 48 'black)))
(place-image (circle 30 'outline 'red) 120 50 s6)))
(else (error 'ouch))))
;; reveal-list : list-of-letters list-of-letters letter -> list-of-letters
(define (reveal-list l1 l2 gu)
(map (lambda (x1 x2)
(cond
[(symbol=? x1 gu) gu]
[else x2]))
l1 l2))
(define (go-list x) (hangman-list reveal-list add-next-part))
;; reveal : Word Words Letter -> Word
(define (reveal l1 l2 gu)
(make-word
(reveal1 (word-one l1) (word-one l2) gu)
(reveal1 (word-two l1) (word-two l2) gu)
(reveal1 (word-three l1) (word-three l2) gu)))
(define (reveal1 x1 x2 gu)
(cond
[(symbol=? x1 gu) gu]
[else x2]))
(define (go x) (hangman reveal add-next-part))
)
(define (add-next-part body-part s)
(cond ((eq? body-part 'body)
(scene+line s 100 60 100 130 'black))
((eq? body-part 'right-leg)
(scene+line s 100 130 30 170 'black))
((eq? body-part 'left-leg)
(scene+line s 100 130 170 170 'black))
((eq? body-part 'right-arm)
(scene+line s 100 75 40 65 'black))
((eq? body-part 'left-arm)
(scene+line s 100 75 160 65 'black))
((eq? body-part 'head)
(place-image (circle 10 'outline 'black) 100 50 s))
((eq? body-part 'noose)
(local ((define s1 (scene+line s 100 30 100 10 'black))
(define s2 (scene+line s1 100 10 0 10 'black))
(define s3 (scene+line s2 115 35 123 43 'black))
(define s4 (scene+line s3 123 35 115 43 'black))
(define s5 (scene+line s4 131 40 139 48 'black))
(define s6 (scene+line s5 139 40 131 48 'black)))
(place-image (circle 30 'outline 'red) 120 50 s6)))
(else (error 'ouch))))
;; reveal-list : list-of-letters list-of-letters letter -> list-of-letters
(define (reveal-list l1 l2 gu)
(map (lambda (x1 x2)
(cond
[(symbol=? x1 gu) gu]
[else x2]))
l1 l2))
(define (go-list x) (hangman-list reveal-list add-next-part))
;; reveal : Word Words Letter -> Word
(define (reveal l1 l2 gu)
(make-word
(reveal1 (word-one l1) (word-one l2) gu)
(reveal1 (word-two l1) (word-two l2) gu)
(reveal1 (word-three l1) (word-three l2) gu)))
(define (reveal1 x1 x2 gu)
(cond
[(symbol=? x1 gu) gu]
[else x2]))
(define (go x) (hangman reveal add-next-part))

97
collects/htdp/hangman-world.ss
View File

@ -4,9 +4,7 @@
3. compare error messages for word to beginner language
4. change messages at end to just display the word
|#
#cs
(module hangman-world mzscheme
(module hangman-world scheme
(require htdp/world
htdp/error
lang/prim
@ -16,7 +14,7 @@
(define (letter? s) (and (symbol? s) (pair? (member s LETTERS))))
(define LETTERS '(a b c d e f g h i j k l m o p q r s t u v w x y z _))
(define-struct word (one two three))
(provide/contract
@ -26,11 +24,11 @@
[word-one (word? . -> . letter?)]
[word-two (word? . -> . letter?)]
[word-three (word? . -> . letter?)])
(provide-higher-order-primitive
;; Letter = Symbol
;; type Word
;; (Letter Letter Letter -> Word)
;; (Word Word Letter -> Word)
;; (Symbol Scene -> Scene)
@ -50,7 +48,7 @@
(rv (apply make-word ch) (apply make-word st) gu)))
(list (word-one w) (word-two w) (word-three w)))))
(hangman-list reveal-list dr)))
(provide-higher-order-primitive
;; Word = [Listof Symbol]
@ -63,7 +61,7 @@
(provide
;; [Listof Symbols]
body-parts)
(define body-parts
{list 'noose 'head 'right-arm 'left-arm 'body 'right-leg 'left-leg})
@ -72,7 +70,7 @@
(check-proc 'hangman-list add-next-part 2 'second "2 arguments")
(local ((define chosen (list-ref WORDS (random (length WORDS))))
(define status (build-list (length chosen) (lambda (x) '_)))
(define world0 (list chosen status body-parts))
(define world0 (list chosen status body-parts))
;; World KeyEvent -> World
(define (click world ke)
(define pcs (third world))
@ -80,20 +78,30 @@
(define sta (second world))
(define cmp (reveal-list wrd sta (char->symbol ke)))
(cond
[(empty? pcs)
(end-of-time
(format "This is the end my friend. The word is ~a." (list-word->string chosen)))]
[(symbol? ke) world]
[(equal? sta cmp) (list wrd sta (rest pcs))]
[(equal? wrd cmp)
(end-of-time
(format "Congratulations, the word was ~a." (list-word->string chosen)))]
[else (list wrd cmp pcs)]))
;; World -> Scene
(define (image world)
(define wrd (first world))
(define cmp (second world))
(define pcs (third world))
(place-image (text (list-word->string (second world)) 18 'red) 20 100
(add-up-to body-parts pcs (empty-scene 200 200))))
(define scn
(place-image (text (list-word->string (second world)) 18 'red) 20 100
(add-up-to body-parts pcs (empty-scene 200 200))))
(cond
[(equal? wrd cmp)
(place-image (text "Congratulations!" 11 'red) 10 10 scn)]
[(empty? pcs)
(place-image
(text (string-append "This is the end, my friend: "
(list-word->string chosen))
11 'red)
10 10 scn)]
[else scn]))
;; World -> Boolean
(define (stop? world)
(or (empty? (third world)) (equal? (first world) (second world))))
;; [Listof Symbol] [Listof Symbol] Scene -> Scene
(define (add-up-to parts pcs s)
(cond
@ -104,9 +112,10 @@
(and
(big-bang 200 200 .1 world0)
(on-redraw image)
(on-key-event click))))
(on-key-event click)
(stop-when stop?))))
;; Char -> Symbol
;; Char -> Symbol
(define (char->symbol c) (string->symbol (format "~a" c)))
;; Symbol -> Char
@ -122,29 +131,29 @@
(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))))
are
but
cat
cow
dog
eat
fee
gal
hat
inn
jam
kit
lit
met
now
owl
pet
rat
sea
the
usa
vip
was
zoo)))
)

16
collects/htdp/world.ss
View File

@ -12,6 +12,9 @@
(set! current-world new-world)
(when (C current-world) (render (F current-world))))
|#
;; Thu Aug 28 15:54:23 EDT 2008: big-bang can now be re-run after the world
;; has stopped
;; Tue Aug 12 08:54:45 EDT 2008: ke=? changed to key=?
;; Fri Jul 4 10:25:47 EDT 2008: added ke=? and key-event?
;; Mon Jun 16 15:38:14 EDT 2008: removed end-of-time and provided stop-when
@ -245,7 +248,7 @@ Matthew
"-- (big-bang <width> <height> <rate> <world0>)\n"
"-- (big-bang <width> <height> <rate> <world0> <animated-gif>)\n"
"see Help Desk."))
(define *running?* #f)
(define big-bang0
(case-lambda
[(w h delta world) (big-bang w h delta world #f)]
@ -267,7 +270,10 @@ Matthew
animated-gif)
(let ([w (coerce w)]
[h (coerce h)])
(when (vw-init?) (error 'big-bang "big-bang already called once"))
(when *running?* (error 'big-bang "the world is still running"))
(set! *running?* #t)
(callback-stop!)
;; (when (vw-init?) (error 'big-bang "big-bang already called once"))
(install-world delta world) ;; call first to establish a visible world
(set-and-show-frame w h animated-gif) ;; now show it
(unless animated-gif (set! add-event void)) ;; no recording if image undesired
@ -846,8 +852,9 @@ Matthew
(set! timer-callback void)
(set! mouse-callback void)
(set! key-callback void)
(set! stop-when-callback (lambda (w) #f))
(set! redraw-callback void))
(set! stop-when-callback (lambda () #f))
(set! redraw-callback void)
(set! *running?* #f))
;; Any -> Boolean
;; is the callback set to the default value
@ -886,7 +893,6 @@ Matthew
(define tname (if fname fname 'your-redraw-function))
(check-result fname boolean? "boolean" result)
result)
(set-stop-when-callback (lambda (w) #f))
;; f : [World KeyEvent -> World]
;; esp : EventSpace