hack for 2:image added to make sure it displays completely

svn: r17650

collects/2htdp/private/universe-image.ss

@@ -3,7 +3,7 @@
          (prefix-in 1: htdp/image)
          htdp/error)
 
-(provide image? scene? image-width image-height text
+(provide image? scene? image-width image-height text 2:image?
          check-image check-scene check-scene-result)
 
 (define (scene? x)
@@ -20,21 +20,13 @@
 (define (text a b c) (2:text a b c))
 
 (define (image-width x)
-  (check-arg 'image-width 
-             (image? x)
-             'image
-             1 
-             x)
+  (check-arg 'image-width (image? x) 'image 1 x)
   (if (2:image? x)
       (2:image-width x)
       (1:image-width x)))
 
 (define (image-height x)
-  (check-arg 'image-height 
-             (image? x)
-             'image
-             1 
-             x)
+  (check-arg 'image-height (image? x) 'image 1 x)
   (if (2:image? x)
       (2:image-height x)
       (1:image-height x)))

collects/2htdp/private/world.ss

@@ -147,8 +147,13 @@
       (define (show-canvas)
         (send visible set-cursor (make-object cursor% 'arrow))
         (let ([fst-scene (ppdraw)])
-          (set! width  (if width width (image-width fst-scene)))
-          (set! height (if height height (image-height fst-scene)))
+          (if (2:image? fst-scene)
+              (begin
+                (set! width  (if width width (+ (image-width fst-scene) 1)))
+                (set! height (if height height (+ (image-height fst-scene) 1))))
+              (begin
+                (set! width  (if width width (image-width fst-scene)))
+                (set! height (if height height (image-height fst-scene)))))              
           (create-frame)
           (show fst-scene)))
       

collects/2htdp/tests/bad-draw.ss

@@ -0,0 +1,12 @@
+#lang scheme
+
+(require 2htdp/universe)
+
+(define s "")
+(define x 0)
+
+(with-handlers ((exn? void))
+  (big-bang 0
+            (on-tick (lambda (w) (begin (set! x (+ x 1)) w)))
+            (on-draw (lambda (w) (set! s (number->string w))))))
+          

collects/2htdp/tests/full-scene-visible.ss

@@ -0,0 +1,15 @@
+#lang scheme/base
+
+(require 2htdp/universe
+         (prefix-in 2: 2htdp/image)
+         (prefix-in 1: htdp/image))
+
+(define (see-full-rectangle x f)
+  (big-bang x
+            (on-tick sub1)
+            (stop-when zero?)
+            (on-draw (λ (x) (f 100 100 'outline 'black)))))
+
+(see-full-rectangle 3 2:rectangle)
+
+(see-full-rectangle 3 1:rectangle)

collects/2htdp/tests/robby-optimization-gone.ss

@@ -0,0 +1,20 @@
+#lang scheme
+
+(require 2htdp/universe)
+(require 2htdp/image)
+
+(define s "")
+(define x 1)
+
+(big-bang 1
+          (on-tick (lambda (w)
+                     (begin 
+                       (set! x (+ x 1))
+                       (if (= x 3) 0 1))))
+          (stop-when zero?)
+          (on-draw (lambda (w)
+                     (begin
+                       (set! s (string-append "-" s))
+                       (rectangle 1 1 'solid 'green)))))
+
+(unless (string=? s "---") (error 'world-update-test "failed! ~s" s))