From fd9ac82bd5e7eae8d8b66adcdb5ed4b52413d274 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 28 Aug 2008 19:56:38 +0000 Subject: [PATCH] world: big-bang & friends can be re-run svn: r11466 --- collects/htdp/hangman-world-play.ss | 106 ++++++++++++++-------------- collects/htdp/hangman-world.ss | 97 +++++++++++++------------ collects/htdp/world.ss | 16 +++-- 3 files changed, 117 insertions(+), 102 deletions(-) diff --git a/collects/htdp/hangman-world-play.ss b/collects/htdp/hangman-world-play.ss index 35921912dd..396b5c99d7 100644 --- a/collects/htdp/hangman-world-play.ss +++ b/collects/htdp/hangman-world-play.ss @@ -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)) diff --git a/collects/htdp/hangman-world.ss b/collects/htdp/hangman-world.ss index 95924142b0..03b8995188 100644 --- a/collects/htdp/hangman-world.ss +++ b/collects/htdp/hangman-world.ss @@ -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))) + ) diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss index cdb15d3441..daa3bea1c5 100644 --- a/collects/htdp/world.ss +++ b/collects/htdp/world.ss @@ -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 )\n" "-- (big-bang )\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