From 8a7d828cc5eca147fa55dd92711d78d0d7e458fe Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 2 Nov 2013 21:41:09 -0500 Subject: [PATCH] fix underlay & pinhole combination closes PR 13993 --- .../htdp-lib/2htdp/private/image-more.rkt | 18 ++++++++++-------- .../htdp-test/2htdp/tests/test-image.rkt | 7 +++++++ 2 files changed, 17 insertions(+), 8 deletions(-) diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt index 15e539e5a1..2d5b381f14 100644 --- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt @@ -143,12 +143,12 @@ ;; 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 'middle 'middle image (cons image2 image3))) + (overlay/internal 'middle 'middle image (cons image2 image3) #t)) ;; underlay : image image image ... -> image (define/chk (underlay image image2 . image3) (let ([imgs (reverse (list* image image2 image3))]) - (overlay/internal 'middle 'middle (car imgs) (cdr imgs)))) + (overlay/internal 'middle 'middle (car imgs) (cdr imgs) #f))) ;; overlay/align : string string image image image ... -> image ;; the first string has to be one of "center" "middle" "left" or "right" (or symbols) @@ -167,7 +167,7 @@ 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))) + (overlay/internal x-place y-place image (cons image2 image3) #t)) (define/chk (underlay/align x-place y-place image image2 . image3) (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole)) @@ -179,25 +179,27 @@ "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)))) + (overlay/internal x-place y-place (car imgs) (cdr imgs) #f))) (define/chk (overlay/pinhole image1 image2 . image3) (overlay/internal 'pinhole 'pinhole (maybe-center-pinhole image1) - (map maybe-center-pinhole (cons image2 image3)))) + (map maybe-center-pinhole (cons image2 image3)) + #t)) (define/chk (underlay/pinhole image1 image2 . image3) (let ([imgs (map maybe-center-pinhole (reverse (list* image1 image2 image3)))]) (overlay/internal 'pinhole 'pinhole (car imgs) - (cdr imgs)))) + (cdr imgs) + #f))) (define (maybe-center-pinhole img) (if (send img get-pinhole) img (center-pinhole img))) -(define (overlay/internal x-place y-place fst rst) +(define (overlay/internal x-place y-place fst rst first-pinhole?) (let loop ([fst fst] [rst rst]) (cond @@ -215,7 +217,7 @@ (car rst) (if (< dx 0) 0 dx) (if (< dy 0) 0 dy) - #t) + first-pinhole?) (cdr rst)))]))) (define (find-x-spot x-place image) diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt index 0c430d6257..1859eacb6e 100644 --- a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt +++ b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt @@ -716,6 +716,13 @@ (make-bb 100 100 100) #f)) +(test (pinhole-x + (underlay + (put-pinhole 50 50 (rectangle 100 100 "solid" "gray")) + (rectangle 10 10 "solid" "black"))) + => + 50) + (test (overlay/offset (rectangle 10 100 'solid 'red) 0 0 (rectangle 100 10 'solid 'blue))