added underlay

svn: r17072

collects/2htdp/image.ss

@@ -52,6 +52,9 @@ and they all have good sample contracts. (It is amazing what we can do with kids
 (provide overlay
          overlay/align
          overlay/xy
+         underlay
+         underlay/align
+         underlay/xy
          
          beside
          beside/align

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

@@ -307,10 +307,14 @@
 
 ;; overlay : image image image ... -> image
 ;; places images on top of each other with their upper left corners aligned. last one goes on the bottom
-
 (define/chk (overlay image image2 . image3)
   (overlay/internal 'left 'top image (cons image2 image3)))
 
+;; underlay : image image image ... -> image
+(define (underlay image image2 . image3)
+  (let ([imgs (reverse (list* image image2 image3))])
+    (overlay/internal 'left 'top (car imgs) (cdr imgs))))
+
 ;; overlay/align : string string image image image ... -> image
 ;; the first string has to be one of "center" "middle" "left" or "right" (or symbols)
 ;; the second string has to be one of "center" "middle" "top" "bottom" or "baseline" (or symbols)
@@ -322,6 +326,10 @@
 (define/chk (overlay/align x-place y-place image image2 . image3)
   (overlay/internal x-place y-place image (cons image2 image3)))
 
+(define/chk (underlay/align x-place y-place image image2 . image3)
+  (let ([imgs (reverse (list* image image2 image3))])
+    (overlay/internal x-place y-place (car imgs) (cdr imgs))))
+
 (define (overlay/internal x-place y-place fst rst)
   (let loop ([fst fst]
              [rst rst])
@@ -346,14 +354,16 @@
   (case x-place
     [(left) 0]
     [(middle) (/ (image-right image) 2)]
-    [(right) (image-right image)]))
+    [(right) (image-right image)]
+    [else (error 'find-x-spot "~s" x-place)]))
 
 (define (find-y-spot y-place image)
   (case y-place
     [(top) 0]
     [(middle) (/ (image-bottom image) 2)]
     [(bottom) (image-bottom image)]
-    [(baseline) (image-baseline image)]))
+    [(baseline) (image-baseline image)]
+    [else (error 'find-y-spot "~s" y-place)]))
 
 ;; overlay/xy : image number number image -> image
 ;; places images on top of each other with their upper-left corners offset by the two numbers
@@ -366,6 +376,14 @@
              (if (< dx 0) 0 dx)
              (if (< dy 0) 0 dy)))
 
+(define/chk (underlay/xy image dx dy image2)
+  (overlay/δ image2
+             (if (< dx 0) 0 dx)
+             (if (< dy 0) 0 dy)
+             image
+             (if (< dx 0) (- dx) 0)
+             (if (< dy 0) (- dy) 0)))
+
 (define (overlay/δ image1 dx1 dy1 image2 dx2 dy2)
   (make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
                             (make-translate dx2 dy2 (image-shape image2)))
@@ -943,6 +961,10 @@
 (provide overlay
          overlay/align
          overlay/xy
+         underlay
+         underlay/align
+         underlay/xy
+         
          beside
          beside/align
          above

collects/2htdp/tests/test-image.ss

@@ -285,9 +285,9 @@
        #f))
 
 (test (overlay/align 'middle
-                      'middle
-                      (ellipse 100 50 'solid 'green)
-                      (ellipse 50 100 'solid 'red))
+                     'middle
+                     (ellipse 100 50 'solid 'green)
+                     (ellipse 50 100 'solid 'red))
       =>
       (make-image
        (make-overlay
@@ -297,9 +297,9 @@
        #f))
 
 (test (overlay/align 'middle
-                      'middle
-                      (ellipse 50 100 'solid 'red)
-                      (ellipse 100 50 'solid 'green))
+                     'middle
+                     (ellipse 50 100 'solid 'red)
+                     (ellipse 100 50 'solid 'green))
       =>
       (make-image
        (make-overlay
@@ -310,9 +310,9 @@
 
 
 (test (overlay/align 'right
-                      'bottom
-                      (ellipse 50 100 'solid 'red)
-                      (ellipse 100 50 'solid 'green))
+                     'bottom
+                     (ellipse 50 100 'solid 'red)
+                     (ellipse 100 50 'solid 'green))
       =>
       (make-image
        (make-overlay
@@ -322,9 +322,9 @@
        #f))
 
 (test (overlay/align 'right
-                      'baseline
-                      (ellipse 50 100 'solid 'red)
-                      (ellipse 100 50 'solid 'green))
+                     'baseline
+                     (ellipse 50 100 'solid 'red)
+                     (ellipse 100 50 'solid 'green))
       =>
       (make-image
        (make-overlay
@@ -413,13 +413,136 @@
        #f))
 
 (test (above (ellipse 50 100 'solid 'red)
-              (ellipse 100 50 'solid 'blue))
+             (ellipse 100 50 'solid 'blue))
       =>
       (above/align 'left
                     (ellipse 50 100 'solid 'red)
                     (ellipse 100 50 'solid 'blue)))
 
 
+
+(test (underlay (ellipse 100 100 'solid 'blue)
+                (ellipse 120 120 'solid 'red))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red)))
+        (make-translate 0 0 (image-shape (ellipse 100 100 'solid 'blue))))
+       (make-bb 120
+                120
+                120)
+       #f))
+
+(test (underlay/xy (ellipse 100 100 'solid 'blue)
+                   0 0
+                   (ellipse 120 120 'solid 'red))
+      =>
+      (underlay (ellipse 100 100 'solid 'blue)
+                (ellipse 120 120 'solid 'red)))
+
+
+(test (underlay/xy (ellipse 50 100 'solid 'red)
+                   -25 25
+                   (ellipse 100 50 'solid 'green))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green)))
+        (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))))
+       (make-bb 100
+                100
+                100)
+       #f))
+
+(test (underlay/xy (ellipse 100 50 'solid 'green)
+                   10 10
+                   (ellipse 50 100 'solid 'red))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 10 10 (image-shape (ellipse 50 100 'solid 'red)))
+        (make-translate 0 0 (image-shape (ellipse 100 50 'solid 'green))))
+       (make-bb 100
+                110
+                110)
+       #f))
+
+(test (underlay (ellipse 100 50 'solid 'green)
+                (ellipse 50 100 'solid 'red))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 0 (image-shape (ellipse 50 100 'solid 'red)))
+        (make-translate 0 0 (image-shape (ellipse 100 50 'solid 'green))))
+       (make-bb 100
+                100
+                100)
+       #f))
+
+(test (underlay (ellipse 100 100 'solid 'blue)
+                (ellipse 120 120 'solid 'red)
+                (ellipse 140 140 'solid 'green))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 
+         0 0
+         (make-overlay
+          (make-translate 0 0 (image-shape (ellipse 140 140 'solid 'green)))
+          (make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red)))))
+        (make-translate 0 0 (image-shape (ellipse 100 100 'solid 'blue))))
+       (make-bb 140 140 140)
+       #f))
+
+(test (underlay/align 'middle
+                      'middle
+                      (ellipse 100 50 'solid 'green)
+                      (ellipse 50 100 'solid 'red))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red)))
+        (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green))))
+       (make-bb 100 100 100)
+       #f))
+
+(test (underlay/align 'middle
+                      'middle
+                      (ellipse 50 100 'solid 'red)
+                      (ellipse 100 50 'solid 'green))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green)))
+        (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))))
+       (make-bb 100 100 100)
+       #f))
+
+(test (underlay/align 'right
+                      'bottom
+                      (ellipse 50 100 'solid 'red)
+                      (ellipse 100 50 'solid 'green))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green)))
+        (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red))))
+       (make-bb 100 100 100)
+       #f))
+
+(test (underlay/align "right"
+                      "baseline"
+                      (ellipse 50 100 'solid 'red)
+                      (ellipse 100 50 'solid 'green))
+      =>
+      (make-image
+       (make-overlay
+        (make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green)))
+        (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red))))
+       (make-bb 100 100 100)
+       #f))
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  testing normalization

collects/teachpack/2htdp/scribblings/image-gen.ss

@@ -28,7 +28,13 @@
 
 (define (handle-image exp)
   (printf ".") (flush-output)
-  (let ([result (parameterize ([current-namespace image-ns]) (eval exp))])
+  (let ([result 
+         (with-handlers ([exn:fail?
+                          (λ (x)
+                            (printf "\nerror evaluating:\n")
+                            (pretty-print exp)
+                            (raise x))])
+           (parameterize ([current-namespace image-ns]) (eval exp)))])
     (cond
       [(image? result)
        (let ([fn (exp->filename exp)])

collects/teachpack/2htdp/scribblings/image-toc.ss

@@ -8,8 +8,8 @@
   (list
    (list '(image-height (rectangle 100 100 "solid" "black")) 'val 100)
    (list '(image-baseline (rectangle 100 100 "solid" "black")) 'val 100)
-   (list '(image-height (text "Hello" 24 "black")) 'val 24.0)
-   (list '(image-baseline (text "Hello" 24 "black")) 'val 18.0)
+   (list '(image-height (text "Hello" 24 "black")) 'val 41.0)
+   (list '(image-baseline (text "Hello" 24 "black")) 'val 31.0)
    (list
     '(image-height
       (overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple")))
@@ -114,6 +114,76 @@
       (ellipse 20 10 "solid" "black"))
     'image
     "28c73238138.png")
+   (list
+    '(underlay/xy
+      (underlay/xy
+       (ellipse 40 40 "solid" "gray")
+       10
+       15
+       (ellipse 10 10 "solid" "forestgreen"))
+      20
+      15
+      (ellipse 10 10 "solid" "forestgreen"))
+    'image
+    "201c231dce2.png")
+   (list
+    '(underlay/xy
+      (rectangle 20 20 "solid" "red")
+      -20
+      -20
+      (rectangle 20 20 "solid" "black"))
+    'image
+    "42f9f9e4cf.png")
+   (list
+    '(underlay/xy
+      (rectangle 20 20 "solid" "red")
+      20
+      20
+      (rectangle 20 20 "solid" "black"))
+    'image
+    "157ab5efca7.png")
+   (list
+    '(underlay/xy
+      (rectangle 20 20 "outline" "black")
+      20
+      0
+      (rectangle 20 20 "outline" "black"))
+    'image
+    "26bd803042c.png")
+   (list
+    '(underlay/align
+      "right"
+      "top"
+      (rectangle 50 50 "solid" "seagreen")
+      (rectangle 40 40 "solid" "silver")
+      (rectangle 30 30 "solid" "seagreen")
+      (rectangle 20 20 "solid" "silver"))
+    'image
+    "ff2fcb7b87.png")
+   (list
+    '(underlay/align
+      "middle"
+      "middle"
+      (rectangle 30 60 "solid" "orange")
+      (ellipse 60 30 "solid" "purple"))
+    'image
+    "2d1e52503d7.png")
+   (list
+    '(underlay
+      (ellipse 10 60 "solid" "red")
+      (ellipse 20 50 "solid" "black")
+      (ellipse 30 40 "solid" "red")
+      (ellipse 40 30 "solid" "black")
+      (ellipse 50 20 "solid" "red")
+      (ellipse 60 10 "solid" "black"))
+    'image
+    "28253f4c3c.png")
+   (list
+    '(underlay
+      (rectangle 30 60 "solid" "orange")
+      (ellipse 60 30 "solid" "purple"))
+    'image
+    "9858b8d5d.png")
    (list
     '(overlay/xy
       (overlay/xy

collects/teachpack/2htdp/scribblings/image.scrbl

@@ -318,6 +318,70 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                    (ellipse 10 10 "solid" "forestgreen"))]
 }
 
+@defproc[(underlay [i1 image?] [i2 image?] [is image?] ...) image?]{
+  Underlays all of its arguments building a single image.
+  
+  It behaves like @scheme[overlay], but with the arguments in the reverse order.
+  That is, the first argument goes
+  underneath of the second argument, which goes underneath the third argument, etc.
+  The images are all lined up on their upper-left corners.
+
+  @image-examples[(underlay (rectangle 30 60 "solid" "orange")
+                            (ellipse 60 30 "solid" "purple"))
+                  (underlay (ellipse 10 60 "solid" "red")
+                            (ellipse 20 50 "solid" "black")
+                            (ellipse 30 40 "solid" "red")
+                            (ellipse 40 30 "solid" "black")
+                            (ellipse 50 20 "solid" "red")
+                            (ellipse 60 10 "solid" "black"))]
+  
+  }
+
+@defproc[(underlay/align [x-place x-place?] [y-place y-place?] [i1 image?] [i2 image?] [is image?] ...) image?]{
+  Underlays all of its image arguments, much like the @scheme[underlay] function, but using
+  @scheme[x-place] and @scheme[y-place] to determine where the images are lined up. For example, if
+  @scheme[x-place] and @scheme[y-place] are both @scheme["middle"], then the images are lined up
+  on their centers.
+
+  @image-examples[(underlay/align "middle" "middle"
+                                  (rectangle 30 60 "solid" "orange")
+                                  (ellipse 60 30 "solid" "purple"))
+                  (underlay/align "right" "top"
+                                  (rectangle 50 50 "solid" "seagreen")
+                                  (rectangle 40 40 "solid" "silver")
+                                  (rectangle 30 30 "solid" "seagreen")
+                                  (rectangle 20 20 "solid" "silver"))]
+                                  
+  
+  }
+
+@defproc[(underlay/xy [i1 image?] [x real?] [y real?] [i2 image?]) image?]{
+  Constructs an image by underlaying @scheme[i1] underneath of @scheme[i2] after
+  shifting @scheme[i2] over by @scheme[x] pixels to the right and @scheme[y] 
+  pixels down.
+  
+  This is the same as @scheme[(overlay/xy i2 (- x) (- y) i1)].
+  
+  @image-examples[(underlay/xy (rectangle 20 20 "outline" "black")
+                               20 0
+                               (rectangle 20 20 "outline" "black"))
+                  (underlay/xy (rectangle 20 20 "solid" "red")
+                               20 20
+                               (rectangle 20 20 "solid" "black"))
+                  (underlay/xy (rectangle 20 20 "solid" "red")
+                               -20 -20
+                               (rectangle 20 20 "solid" "black"))
+                  (underlay/xy 
+                   (underlay/xy (ellipse 40 40 "solid" "gray")
+                                10
+                                15
+                                (ellipse 10 10 "solid" "forestgreen"))
+                   20
+                   15
+                   (ellipse 10 10 "solid" "forestgreen"))]
+}
+
+
 @defproc[(beside [i1 image?] [i2 image?] [is image?] ...) image?]{
   Constructs an image by placing all of the argument images in a
   horizontal row, aligned along their top edges.