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

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

@ -1,7 +1,8 @@
(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 :
@ -12,24 +13,24 @@
|#
(define (add-next-part body-part s)
(cond ((eq? body-part 'body)
(add-line s 100 60 100 130 'black))
(scene+line s 100 60 100 130 'black))
((eq? body-part 'right-leg)
(add-line s 100 130 30 170 'black))
(scene+line s 100 130 30 170 'black))
((eq? body-part 'left-leg)
(add-line s 100 130 170 170 'black))
(scene+line s 100 130 170 170 'black))
((eq? body-part 'right-arm)
(add-line s 100 75 40 65 'black))
(scene+line s 100 75 40 65 'black))
((eq? body-part 'left-arm)
(add-line s 100 75 160 65 'black))
(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 (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)))
(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))))
@ -56,4 +57,3 @@
[else x2]))
(define (go x) (hangman reveal add-next-part))
)

33
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
@ -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))
(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,7 +112,8 @@
(and
(big-bang 200 200 .1 world0)
(on-redraw image)
(on-key-event click))))
(on-key-event click)
(stop-when stop?))))
;; Char -> Symbol
(define (char->symbol c) (string->symbol (format "~a" c)))
@ -145,6 +154,6 @@
usa
vip
was
zoo))))
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