world draw bitmaps instead of getting them

svn: r6060

collects/htdp/Test/world.ss

@@ -0,0 +1,30 @@
+;; testing world 
+
+;; World = Nat 
+
+(define world0 10)
+
+(define (world->image w)
+  (place-image (circle 3 'solid 'red)
+               50 w
+               (empty-scene 100 100)))
+
+(define (world->next w) 
+  (if (>= (+ w 3) 100)
+      100
+      (+ w 1)))
+
+(define (world->steer w ke)
+  (cond
+    [(char? ke) w]
+    [(symbol=? ke 'left) 10]
+    [(symbol=? ke 'right) 90]
+    [else w]))
+
+;; run world run 
+
+(big-bang 100 100 .1 world0)
+
+(on-redraw world->image)
+(on-tick-event world->next)
+(on-key-event world->steer)

collects/htdp/hangman-world-play.ss

@@ -0,0 +1,59 @@
+(module hangman-world-play mzscheme 
+  (require "hangman-world.ss"
+           (lib "world.ss" "htdp")
+           (lib "etc.ss"))
+  
+  #| ------------------------------------------------------------------------
+  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))
+)

collects/htdp/hangman-world.ss

@@ -0,0 +1,150 @@
+#| TODO
+   1. use chars for letters; admit letters only 
+   2. write new exercises 
+   3. compare error messages for word to beginner language 
+   4. change messages at end to just display the word 
+|#
+
+#cs
+(module hangman-world mzscheme  
+  (require (lib "world.ss" "htdp")
+           (lib "error.ss" "htdp")
+           (lib "prim.ss" "lang")
+           (lib "contract.ss")
+           (lib "etc.ss") 
+           (lib "list.ss"))       
+  
+  (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
+   [letter? (any/c . -> . boolean?)]
+   [word? (any/c . -> . boolean?)]
+   [make-word (letter? letter? letter? . -> . word?)]
+   [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)
+   ;;  ->
+   ;;  true
+   ;; given a function that makes letters from words, and 
+   ;; a function that compares the chosen word to the status word with current guess,
+   ;; and a function that adds a body part to a Scene, start the world and set up 
+   ;; an event handler to play hangman 
+   hangman (reveal draw-body))
+  
+  (define (hangman rv dr)
+    (check-proc 'hangman rv 3 'first "3 arguments")
+    (check-proc 'hangman dr 2 'second "2 arguments")
+    (local ((define (reveal-list ch st gu)
+              (local ((define w ; status @ t+1
+                        (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]
+   
+   ;; (Word Word Symbol -> Symbol) (Symbol Scene -> Scene) -> true
+   ;; given a function that compares the chosen word, the status word, and 
+   ;; the current guess, start the world and install a event handler for 
+   ;; characters that plays hangman
+   hangman-list (reveal add-body-part))
+  
+  (provide
+   ;; [Listof Symbols]
+   body-parts)
+
+  (define body-parts
+    {list 'noose 'head 'right-arm 'left-arm 'body 'right-leg 'left-leg})
+  
+  (define (hangman-list reveal-list add-next-part)
+    (check-proc 'hangman-list reveal-list 3 'first "3 arguments")
+    (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))
+            ;; World KeyEvent -> World 
+            (define (click world ke)
+              (define pcs (third world))
+              (define wrd (first world))
+              (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 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))))
+            ;; [Listof Symbol] [Listof Symbol] Scene -> Scene 
+            (define (add-up-to parts pcs s)
+              (cond 
+                [(empty? parts) s]
+                [(and (cons? pcs) (eq? (first parts) (first pcs))) s]
+                [else (add-up-to (rest parts) pcs (add-next-part (first parts) s))])))
+      ;; --- go world go ---
+      (and 
+       (big-bang 200 200 .1 world0)
+       (on-redraw image)
+       (on-key-event click))))
+  
+    ;; Char -> Symbol 
+  (define (char->symbol c) (string->symbol (format "~a" c)))
+  
+  ;; Symbol -> Char 
+  (define (symbol->char c) (string-ref (symbol->string c) 0))
+  
+  ;; Symbol -> Word
+  (define (word->list s) (map char->symbol (string->list (symbol->string s))))
+  
+  ;; Word -> String 
+  (define (list-word->string w) (list->string (map symbol->char w)))
+  
+  ;; a list of symbolic words 
+  (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))))
+
+

collects/htdp/world.ss

@@ -591,7 +591,13 @@
     (define image-count 0)
     (define (save-image img)
       (define total (length event-history))
-      (define bm (send img get-bitmap))
+      ;; --- in lieu of (define bm (send img get-bitmap))
+      (define-values (w h) (send img get-size))
+      (define bm (make-object bitmap% w h))
+      (define dc (make-object bitmap-dc% bm))
+      (send dc clear)
+      (send img draw dc 0 0 0 0 w h 0 0 #f)
+      ;; ---
       (set! image-count (+ image-count 1))
       (send bm save-file (format "i~a.png" image-count) 'png)
       (update-frame (text (format "~a/~a created" image-count total) 18 'red)))
@@ -600,12 +606,14 @@
     (define target:dir
       (let* ([cd (current-directory)]
              [dd (get-directory "Select directory for images" #f cd)])
-        
         (if dd dd cd)))
     (parameterize ([current-directory target:dir])
       (let pb ([ev event-history][world the-world0][img (circle 1 'solid 'red)])
+        #;
+	(printf "event history: ~s\n" ev)
         (cond
           [(null? ev) 
+	   "THIS DESERVES A SECOND LOOK"
            (when (regexp-match "/Users/matthias/" (path->string target:dir))
              (create-animated-gif-on-my-mac))
            (update-frame img)]