preserve pinholes in overlaying and related functions

(also started to add "pinhole" as a place, but not done with that yet)

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

@@ -134,9 +134,25 @@
 ;; images up at their centers.
 
 (define/chk (overlay/align x-place y-place image image2 . image3)
+  (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole))
+    (check-dependencies 'overlay/align
+                        (and (send image get-pinhole)
+                             (send image2 get-pinhole)
+                             (andmap (λ (x) (send x get-pinhole))
+                                     image3))
+                        "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes"
+                        'pinhole "pinhole"))
   (overlay/internal x-place y-place image (cons image2 image3)))
 
 (define/chk (underlay/align x-place y-place image image2 . image3)
+  (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole))
+    (check-dependencies 'underlay/align
+                        (and (send image get-pinhole)
+                             (send image2 get-pinhole)
+                             (andmap (λ (x) (send x get-pinhole))
+                                     image3))
+                        "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes"
+                        'pinhole "pinhole"))
   (let ([imgs (reverse (list* image image2 image3))])
     (overlay/internal x-place y-place (car imgs) (cdr imgs))))
 
@@ -157,7 +173,8 @@
                           (if (< dy 0) (- dy) 0)
                           (car rst)
                           (if (< dx 0) 0 dx)
-                          (if (< dy 0) 0 dy))
+                          (if (< dy 0) 0 dy)
+                          #t)
                (cdr rst)))])))
 
 (define (find-x-spot x-place image)
@@ -165,6 +182,7 @@
     [(left) 0]
     [(middle) (/ (get-right image) 2)]
     [(right) (get-right image)]
+    [(pinhole) (point-x (send image get-pinhole))]
     [else (error 'find-x-spot "~s" x-place)]))
 
 (define (find-y-spot y-place image)
@@ -173,6 +191,7 @@
     [(middle) (/ (get-bottom image) 2)]
     [(bottom) (get-bottom image)]
     [(baseline) (get-baseline image)]
+    [(pinhole) (point-y (send image get-pinhole))]
     [else (error 'find-y-spot "~s" y-place)]))
 
 ;; overlay/xy : image number number image -> image
@@ -184,7 +203,8 @@
              (if (< dy 0) (- dy) 0)
              image2
              (if (< dx 0) 0 dx)
-             (if (< dy 0) 0 dy)))
+             (if (< dy 0) 0 dy)
+             #t))
 
 (define/chk (underlay/xy image dx dy image2)
   (overlay/δ image2
@@ -192,18 +212,28 @@
              (if (< dy 0) 0 dy)
              image
              (if (< dx 0) (- dx) 0)
-             (if (< dy 0) (- dy) 0)))
+             (if (< dy 0) (- dy) 0)
+             #f))
 
-(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2)
+(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2 first-pinhole?)
-  (make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
+    (make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
-                            (make-translate dx2 dy2 (image-shape image2)))
+                              (make-translate dx2 dy2 (image-shape image2)))
-              (make-bb (max (+ (get-right image1) dx1)
+                (make-bb (max (+ (get-right image1) dx1)
-                            (+ (get-right image2) dx2))
+                              (+ (get-right image2) dx2))
-                       (max (+ (get-bottom image1) dy1)
+                         (max (+ (get-bottom image1) dy1)
-                            (+ (get-bottom image2) dy2))
+                              (+ (get-bottom image2) dy2))
-                       (max (+ (get-baseline image1) dy1)
+                         (max (+ (get-baseline image1) dy1)
-                            (+ (get-baseline image2) dy2)))
+                              (+ (get-baseline image2) dy2)))
-              #f))
+                #f
+                (if first-pinhole?
+                    (let ([ph (send image1 get-pinhole)])
+                      (and ph
+                           (make-point (+ (point-x ph) dx1)
+                                       (+ (point-y ph) dy1))))
+                    (let ([ph (send image2 get-pinhole)])
+                      (and ph
+                           (make-point (+ (point-x ph) dx2)
+                                       (+ (point-y ph) dy2)))))))
 
 ;; beside : image image image ... -> image
 ;; places images in a single horizontal row, top aligned
@@ -231,7 +261,8 @@
                           (if (< dy 0) (- dy) 0)
                           (car rst)
                           (get-right fst)
-                          (if (< dy 0) 0 dy))
+                          (if (< dy 0) 0 dy)
+                          #t)
                (cdr rst)))])))
 
 ;; above : image image image ... -> image
@@ -260,7 +291,8 @@
                           0
                           (car rst)
                           (if (< dx 0) 0 dx)
-                          (get-bottom fst))
+                          (get-bottom fst)
+                          #t)
                (cdr rst)))])))
 
 
@@ -330,7 +362,8 @@
                 (if (< dy 0) 0 dy)
                 scene
                 (if (< dx 0) (- dx) 0)
-                (if (< dy 0) (- dy) 0)))))
+                (if (< dy 0) (- dy) 0)
+                #f))))
 
 (define/chk (scene+line image x1 y1 x2 y2 color)
   (let* ([dx (abs (min 0 x1 x2))]

collects/2htdp/private/img-err.rkt

@@ -251,9 +251,9 @@
             argname)]))
 
 (define (y-place? arg)
-  (member arg '("top" top "bottom" bottom "middle" middle "center" center "baseline" baseline)))
+  (member arg '("top" top "bottom" bottom "middle" middle "center" center "baseline" baseline "pinhole" pinhole)))
 (define (x-place? arg)
-  (member arg '("left" left "right" right "middle" middle "center" center)))
+  (member arg '("left" left "right" right "middle" middle "center" center "pinhole" pinhole)))
 (define (mode? arg)
   (member arg '(solid outline "solid" "outline")))
 (define (angle? arg)

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

@@ -1680,6 +1680,57 @@
       =>
       6)
 
+(test (pinhole-x (overlay (put-pinhole 1 2 (rectangle 10 100 'solid 'red))
+                          (put-pinhole 75 9 (rectangle 100 10 'solid 'blue))))
+      =>
+      46)
+(test (pinhole-y (overlay (put-pinhole 1 2 (rectangle 10 100 'solid 'red))
+                          (put-pinhole 75 9 (rectangle 100 10 'solid 'blue))))
+      =>
+      2)
+(test (pinhole-x (overlay (put-pinhole 75 9 (rectangle 100 10 'solid 'blue))
+                          (put-pinhole 1 2 (rectangle 10 100 'solid 'red))))
+      =>
+      75)
+(test (pinhole-y (overlay (put-pinhole 75 9 (rectangle 100 10 'solid 'blue))
+                          (put-pinhole 1 2 (rectangle 10 100 'solid 'red))))
+      =>
+      54)
+(test (pinhole-x (overlay (rectangle 100 10 'solid 'blue)
+                          (put-pinhole 1 2 (rectangle 10 100 'solid 'red))))
+      =>
+      #f)
+(test (pinhole-y (overlay (rectangle 100 10 'solid 'blue)
+                          (put-pinhole 1 2 (rectangle 10 100 'solid 'red))))
+      =>
+      #f)
+(test (pinhole-x (beside (center-pinhole (rectangle 10 100 'solid 'red))
+                         (center-pinhole (rectangle 100 10 'solid 'blue))))
+      =>
+      5)
+(test (pinhole-y (beside (center-pinhole (rectangle 10 100 'solid 'red))
+                         (center-pinhole (rectangle 100 10 'solid 'blue))))
+      =>
+      50)
+(test (pinhole-x (above (center-pinhole (rectangle 10 100 'solid 'red))
+                        (center-pinhole (rectangle 100 10 'solid 'blue))))
+      =>
+      50)
+(test (pinhole-y (above (center-pinhole (rectangle 10 100 'solid 'red))
+                        (center-pinhole (rectangle 100 10 'solid 'blue))))
+      =>
+      50)
+
+(test (pinhole-x (place-image (center-pinhole (rectangle 10 100 'solid 'red))
+                              0 0
+                              (center-pinhole (rectangle 100 10 'solid 'blue))))
+      =>
+      50)
+(test (pinhole-y (place-image (center-pinhole (rectangle 10 100 'solid 'red))
+                              0 0
+                              (center-pinhole (rectangle 100 10 'solid 'blue))))
+      =>
+      5)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;

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

@@ -1290,6 +1290,12 @@ Accordingly, when the pixel is on an integral coordinate, then black and white l
 take up a single pixel and in the center of their intersections is the actual pinholes.
 See @secref["nitty-gritty"] for more details about pixels.
 
+When images are @racket[overlay]'d, @racket[underlay]'d (or the variants of those functions),
+placed @racket[beside], or @racket[above] each other, 
+the pinhole of the resulting image is the pinhole of the first image argument passed to the combining
+operation. When images are combined with @racket[place-image] (or the variants of @racket[place-image]), 
+then the scene argument's pinhole is preserved.
+
 @defproc[(center-pinhole [image image?]) image?]{
   Creates a pinhole in @racket[image] at its center.
   @image-examples[(center-pinhole (rectangle 40 20 "solid" "red"))