diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index c9f30b6dd5..aa6de046c9 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/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) - (make-image (make-overlay (make-translate dx1 dy1 (image-shape image1)) - (make-translate dx2 dy2 (image-shape image2))) - (make-bb (max (+ (get-right image1) dx1) - (+ (get-right image2) dx2)) - (max (+ (get-bottom image1) dy1) - (+ (get-bottom image2) dy2)) - (max (+ (get-baseline image1) dy1) - (+ (get-baseline image2) dy2))) - #f)) +(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2 first-pinhole?) + (make-image (make-overlay (make-translate dx1 dy1 (image-shape image1)) + (make-translate dx2 dy2 (image-shape image2))) + (make-bb (max (+ (get-right image1) dx1) + (+ (get-right image2) dx2)) + (max (+ (get-bottom image1) dy1) + (+ (get-bottom image2) dy2)) + (max (+ (get-baseline image1) dy1) + (+ (get-baseline image2) dy2))) + #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))] diff --git a/collects/2htdp/private/img-err.rkt b/collects/2htdp/private/img-err.rkt index cfb2f9a680..b7d8be9bea 100644 --- a/collects/2htdp/private/img-err.rkt +++ b/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) diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index da9565a816..f56597b351 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index 639c53a8ec..6d8c3adbab 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/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"))