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

svn: r11466

collects/htdp/hangman-world-play.ss

@@ -1,59 +1,59 @@
-(module hangman-world-play mzscheme 
+;; The first three lines of this file were inserted by DrScheme. They record metadata
-  (require "hangman-world.ss"
+;; about the language level of this file in a form that our tools can easily process.
-           htdp/world
+#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")))))
-           mzlib/etc)
+(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)
+(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))
+         (local ((define s1 (scene+line s  100 30 100 10 'black))
-                   (define s2 (add-line s1 100 10   0 10 'black))
+                 (define s2 (scene+line s1 100 10   0 10 'black))
-                   (define s3 (add-line s2 115 35 123 43 'black))
+                 (define s3 (scene+line s2 115 35 123 43 'black))
-                   (define s4 (add-line s3 123 35 115 43 'black))
+                 (define s4 (scene+line s3 123 35 115 43 'black))
-                   (define s5 (add-line s4 131 40 139 48 'black))
+                 (define s5 (scene+line s4 131 40 139 48 'black))
-                   (define s6 (add-line s5 139 40 131 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
+;; reveal-list : list-of-letters list-of-letters letter -> list-of-letters
-  (define (reveal-list l1 l2 gu)
+(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))
+(define (go-list x) (hangman-list reveal-list add-next-part))
 
-  ;; reveal : Word Words Letter -> Word 
+;; reveal : Word Words Letter -> Word 
-  (define (reveal l1 l2 gu)
+(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)
+(define (reveal1 x1 x2 gu)
   (cond
     [(symbol=? x1 gu) gu]
     [else x2]))
 
-  (define (go x) (hangman reveal add-next-part))
+(define (go x) (hangman reveal add-next-part))
-)

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 
 |#
-
+(module hangman-world scheme
-#cs
-(module hangman-world mzscheme
   (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)))
-
+  )
 

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 <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! stop-when-callback (lambda () #f))
-  (set! redraw-callback void))
+  (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