record images during world program, not events; Closes PR11351

collects/2htdp/private/world.rkt

@@ -303,7 +303,7 @@
       
       ;; -> Scene
       ;; produce the scene for the this state
-      (define/private (ppdraw)
+      (define/public (ppdraw)
         (check-scene-result (name-of draw 'your-draw) (draw (send world get))))
       
       ;; -----------------------------------------------------------------------
@@ -357,6 +357,102 @@
 (define image-button:label ((bitmap-label-maker "Images" image-button:path) '_))
 
 (define aworld%
+  (class world% (super-new)
+    (inherit-field world0 draw rate width height record?)
+    (inherit show callback-stop!)
+    
+     ;; -> String or false 
+    (define/private (recordable-directory)
+      (and (string? record?) (directory-exists? record?) record?))
+
+    ;; Frame Custodian ->* (-> Void) (-> Void)
+    ;; adds the stop animation and image creation button, 
+    ;; whose callbacks runs as a thread in the custodian
+    (define/augment (create-frame frm play-back-custodian)
+      (define p (new horizontal-pane% [parent frm][alignment '(center center)]))
+      (define (pb)
+        (parameterize ([current-custodian play-back-custodian])
+          (thread (lambda () (play-back)))
+          (stop)))
+      (define (switch)
+        (send stop-button enable #f)
+        (if (recordable-directory) (pb) (send image-button enable #t)))
+      (define (stop) 
+        (send image-button enable #f)
+        (send stop-button enable #f))
+      (define-syntax-rule (btn l a y ...)
+        (new button% [parent p] [label l] [style '(border)] 
+             [callback (lambda a y ...)]))
+      (define stop-button 
+        (btn break-button:label (b e) (callback-stop! 'stop-images) (switch)))
+      (define image-button 
+        (btn image-button:label (b e) (pb)))
+      (send image-button enable #f)
+      (values switch stop))
+   
+    ;; an argument-recording ppdraw
+    (field [image-history '()]) ;; [Listof Evt]
+    (define/override (ppdraw)
+      (define image (super ppdraw))
+      (set! image-history (cons image image-history))
+      image)
+    
+    ;; --> Void
+    ;; re-play the history of events; create a png per step; create animated gif
+    ;; effect: write to user-chosen directory
+    (define/private (play-back)
+      ;; World EventRecord -> World 
+      (define (world-transition world fst) (apply (car fst) world (cdr fst)))
+      ;; --- creating images 
+      (define total (+ (length image-history) 1))
+      (define digt# (string-length (number->string total)))
+      (define imag# 0)
+      (define bmps '())
+      ;; Image -> Void
+      (define (save-image img)
+        (define bm (make-object bitmap% width height))
+        (define dc (make-object bitmap-dc% bm))
+        (send dc clear)
+        (send img draw dc 0 0 0 0 width height 0 0 #f)
+        (set! imag# (+ imag# 1))
+        (send bm save-file (format "i~a.png" (zero-fill imag# digt#)) 'png)
+        (set! bmps (cons bm bmps))
+        img)
+      ;; --- choose place 
+      (define img:dir
+        (or (recordable-directory)
+            (get-directory "image directory:" #f (current-directory))))
+      (when img:dir
+        (parameterize ([current-directory img:dir])
+          (define imageN 
+            (if (empty? image-history)
+                (save-image (draw world0))
+                (first (map save-image image-history))))
+          (show (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red))
+          (create-animated-gif rate bmps)
+          (show imageN))))))
+
+;; Number [Listof (-> bitmap)] -> Void
+;; turn the list of thunks into animated gifs 
+;; effect: overwrite the ANIMATED-GIF-FILE (in current directory)
+;; [Listof (-> bitmap)] -> Void
+;; turn the list of thunks into animated gifs 
+;; effect: overwrite the ANIMATED-GIF-FILE (in current directory)
+(define (create-animated-gif R bitmap-list)
+  (when (file-exists? ANIMATED-GIF-FILE) (delete-file ANIMATED-GIF-FILE))
+  (write-animated-gif bitmap-list (if (> +inf.0 R 0) (number->integer R) 5)
+                      ANIMATED-GIF-FILE
+                      #:one-at-a-time? #t
+                      #:loop? #f))
+
+(define ANIMATED-GIF-FILE "i-animated.gif")
+
+;; the version of aworld below records all events (pointers to functions)
+;; and replays them starting from the initial world. In terms of space, this 
+;; is quite efficient because there are only six differente actions (pointers)
+;; BUT, it doesn't work with random or other effectful stuff
+;; EXPLORE: put random into the library and make it an event 
+(define aworld-old%
   (class world% (super-new)
     (inherit-field world0 tick key release mouse rec draw rate width height record?)
     (inherit show callback-stop!)
@@ -397,7 +493,7 @@
     (define-syntax-rule
       (def/cb ovr (pname name arg ...))
       (define/override (pname arg ...) 
-	(when (super pname arg ...) (add-event name arg ...))))
+        (when (super pname arg ...) (add-event name arg ...))))
     
     (def/cb augment (ptock tick))
     (def/cb augment (pkey key e))
@@ -439,19 +535,4 @@
                   (L (rest history) (world-transition world (first history))))))
           (show (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red))
           (create-animated-gif rate (reverse bmps))
-          (show (draw worldN)))))))
-
-;; Number [Listof (-> bitmap)] -> Void
-;; turn the list of thunks into animated gifs 
-;; effect: overwrite the ANIMATED-GIF-FILE (in current directory)
-;; [Listof (-> bitmap)] -> Void
-;; turn the list of thunks into animated gifs 
-;; effect: overwrite the ANIMATED-GIF-FILE (in current directory)
-(define (create-animated-gif R bitmap-list)
-  (when (file-exists? ANIMATED-GIF-FILE) (delete-file ANIMATED-GIF-FILE))
-  (write-animated-gif bitmap-list (if (> +inf.0 R 0) (number->integer R) 5)
-                      ANIMATED-GIF-FILE
-                      #:one-at-a-time? #t
-                      #:loop? #f))
-
-(define ANIMATED-GIF-FILE "i-animated.gif")
+          (show (draw worldN)))))))

collects/2htdp/tests/perform-record.txt

@@ -0,0 +1,56 @@
+==================================================================
+WITH ROTATING JUST THE ENTIRE 1000 X 1000 IMAGE
+
+$$ record events and replay events from world0
+----------------------------------------------
+
+cpu time: 565085 real time: 646655 gc time: 38387
+cpu time: 563740 real time: 755095 gc time: 44929
+cpu time: 571815 real time: 904814 gc time: 43534
+
+$$ record all images during the run 
+----------------------------------------------
+
+cpu time: 561001 real time: 601603 gc time: 38273
+cpu time: 573939 real time: 643410 gc time: 44268
+cpu time: 576818 real time: 590559 gc time: 43788
+
+==================================================================
+WITH ROTATING JUST THE MOLE TILE (REALISTIC)
+
+$$ record events and replay events from world0
+----------------------------------------------
+
+cpu time: 41269 real time: 60555 gc time: 946
+cpu time: 40808 real time: 60496 gc time: 769
+cpu time: 41094 real time: 60226 gc time: 772
+
+$$ record all images during the run 
+----------------------------------------------
+
+cpu time: 41168 real time: 60843 gc time: 960
+cpu time: 41100 real time: 60323 gc time: 779
+cpu time: 41227 real time: 60373 gc time: 766
+
+==================================================================
+WITHOUT ROTATING: 
+
+$$ record events and replay events from world0
+----------------------------------------------
+
+cpu time: 64417 real time: 86047 gc time: 520
+cpu time: 63700 real time: 85693 gc time: 303
+cpu time: 64332 real time: 85991 gc time: 446
+
+$$ record all images during the run 
+----------------------------------------------
+
+cpu time: 64386 real time: 86030 gc time: 525
+cpu time: 64308 real time: 85871 gc time: 300
+cpu time: 64532 real time: 86174 gc time: 446
+
+just to make sure it's sane, I ran it again: 
+
+cpu time: 64169 real time: 86067 gc time: 556
+cpu time: 64356 real time: 86016 gc time: 377
+cpu time: 64262 real time: 85955 gc time: 375