diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index aa6de046c9..37a515c495 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -244,6 +244,14 @@ ;; places images in a horizontal row where the vertical alignment is ;; covered by the string argument (define/chk (beside/align y-place image1 image2 . image3) + (when (eq? y-place 'pinhole) + (check-dependencies 'beside/align + (and (send image1 get-pinhole) + (send image2 get-pinhole) + (andmap (λ (x) (send x get-pinhole)) + image3)) + "when y-place is ~e or ~e, then all of the arguments must have pinholes" + 'pinhole "pinhole")) (beside/internal y-place image1 (cons image2 image3))) (define (beside/internal y-place fst rst) @@ -274,6 +282,14 @@ ;; places images in a horizontal row where the vertical alignment is ;; covered by the string argument (define/chk (above/align x-place image1 image2 . image3) + (when (eq? x-place 'pinhole) + (check-dependencies 'above/align + (and (send image1 get-pinhole) + (send image2 get-pinhole) + (andmap (λ (x) (send x get-pinhole)) + image3)) + "when x-place is ~e or ~e, then all of the arguments must have pinholes" + 'pinhole "pinhole")) (above/internal x-place image1 (cons image2 image3))) (define (above/internal x-place fst rst) @@ -347,6 +363,12 @@ (define/chk (place-image image1 x1 y1 image2) (place-image/internal image1 x1 y1 image2 'middle 'middle)) (define/chk (place-image/align image1 x1 y1 x-place y-place image2) + (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole)) + (check-dependencies 'place-image/align + (and (send image1 get-pinhole) + (send image2 get-pinhole)) + "when x-place or y-place is ~e or ~e, then both of the image arguments must have pinholes" + 'pinhole "pinhole")) (place-image/internal image1 x1 y1 image2 x-place y-place)) (define (place-image/internal image orig-dx orig-dy scene x-place y-place) diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index f56597b351..04d07cbcda 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -1732,6 +1732,52 @@ => 5) +(test (clear-pinhole + (overlay/align "pinhole" 'pinhole + (center-pinhole (rectangle 40 100 'solid 'red)) + (put-pinhole 0 0 (rectangle 100 40 'solid 'blue)))) + => + (overlay/xy (rectangle 40 100 'solid 'red) + 20 50 + (rectangle 100 40 'solid 'blue))) + +(test (clear-pinhole + (underlay/align "pinhole" 'pinhole + (center-pinhole (rectangle 40 100 'solid 'red)) + (put-pinhole 100 40 (rectangle 100 40 'solid 'blue)))) + => + (underlay/xy (rectangle 40 100 'solid 'red) + -80 10 + (rectangle 100 40 'solid 'blue))) + +(test (clear-pinhole + (beside/align "pinhole" + (center-pinhole (rectangle 100 40 'solid 'purple)) + (center-pinhole (rectangle 40 100 'solid 'purple)))) + => + (beside (rectangle 100 40 'solid 'purple) + (rectangle 40 100 'solid 'purple))) + + +(test (clear-pinhole + (above/align "pinhole" + (center-pinhole (rectangle 100 40 'solid 'purple)) + (center-pinhole (rectangle 40 100 'solid 'purple)))) + => + (above (rectangle 100 40 'solid 'purple) + (rectangle 40 100 'solid 'purple))) + +(test (clear-pinhole + (place-image/align + (center-pinhole (rectangle 100 10 'solid 'red)) + 0 0 "pinhole" "pinhole" + (center-pinhole (rectangle 10 100 'solid 'blue)))) + => + (place-image/align + (rectangle 100 10 'solid 'red) + 0 0 "center" "center" + (rectangle 10 100 'solid 'blue))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; test errors. @@ -1816,6 +1862,98 @@ => #rx"^color-list->bitmap") +(test/exn (overlay/align + "pinhole" "center" + (center-pinhole (rectangle 10 100 'solid 'blue)) + (rectangle 100 10 'solid 'red)) + => + #rx"^overlay/align") +(test/exn (overlay/align + "center" "pinhole" + (center-pinhole (rectangle 10 100 'solid 'blue)) + (rectangle 100 10 'solid 'red)) + => + #rx"^overlay/align") +(test/exn (overlay/align + "pinhole" "center" + (rectangle 100 10 'solid 'red) + (center-pinhole (rectangle 10 100 'solid 'blue))) + => + #rx"^overlay/align") +(test/exn (overlay/align + "center" "pinhole" + (rectangle 100 10 'solid 'red) + (center-pinhole (rectangle 10 100 'solid 'blue))) + => + #rx"^overlay/align") + +(test/exn (underlay/align + "pinhole" "center" + (center-pinhole (rectangle 10 100 'solid 'blue)) + (rectangle 100 10 'solid 'red)) + => + #rx"^underlay/align") +(test/exn (underlay/align + "center" "pinhole" + (center-pinhole (rectangle 10 100 'solid 'blue)) + (rectangle 100 10 'solid 'red)) + => + #rx"^underlay/align") +(test/exn (underlay/align + "pinhole" "center" + (rectangle 100 10 'solid 'red) + (center-pinhole (rectangle 10 100 'solid 'blue))) + => + #rx"^underlay/align") +(test/exn (underlay/align + "center" "pinhole" + (rectangle 100 10 'solid 'red) + (center-pinhole (rectangle 10 100 'solid 'blue))) + => + #rx"^underlay/align") + +(test/exn (place-image/align + (center-pinhole (rectangle 10 100 'solid 'blue)) + 0 0 "pinhole" "center" + (rectangle 100 10 'solid 'red)) + => + #rx"^place-image/align") +(test/exn (place-image/align + (center-pinhole (rectangle 10 100 'solid 'blue)) + 0 0 "center" "pinhole" + (rectangle 100 10 'solid 'red)) + => + #rx"^place-image/align") +(test/exn (place-image/align + (rectangle 100 10 'solid 'red) + 0 0 "pinhole" "center" + (center-pinhole (rectangle 10 100 'solid 'blue))) + => + #rx"^place-image/align") +(test/exn (place-image/align + (rectangle 100 10 'solid 'red) + 0 0 "center" "pinhole" + (center-pinhole (rectangle 10 100 'solid 'blue))) + => + #rx"^place-image/align") + + + +(test/exn (above/align + "pinhole" + (rectangle 100 10 'solid 'red) + (center-pinhole (rectangle 10 100 'solid 'blue))) + => + #rx"^above/align") +(test/exn (beside/align + "pinhole" + (center-pinhole (rectangle 10 100 'solid 'blue)) + (rectangle 100 10 'solid 'red)) + => + #rx"^beside/align") + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; random testing of normalization diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index 6d8c3adbab..2db75ff2ab 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -1190,11 +1190,14 @@ This section lists predicates for the basic structures provided by the image lib @racket['middle], @racket["center"], @racket['center], -@racket["baseline"], or -@racket['baseline]. +@racket["baseline"], +@racket['baseline], +@racket["pinhole"], or +@racket['pinhole]. The baseline of an image is the place where the bottoms any letters line up, not counting descenders, e.g. the tail on ``y'' or ``g'' or ``j''. +Using @racket["pinhole"] or @racket['pinhole] is only allowed when all of the image arguments have @seclink["pinholes"]{pinholes}. } @@ -1207,8 +1210,13 @@ The baseline of an image is the place where the bottoms any letters line up, not @racket['right], @racket["middle"], @racket['middle], - @racket["center"], or - @racket['center]. + @racket["center"], + @racket['center], + @racket["pinhole"], or + @racket['pinhole]. + + Using @racket["pinhole"] or @racket['pinhole] is only allowed when all of the image arguments have @seclink["pinholes"]{pinholes}. + } @defproc[(angle? [x any/c]) boolean?]{ @@ -1275,7 +1283,7 @@ Two images are equal if they draw exactly the same way at their current size (not neccessarily at all sizes) and, if there are pinholes, the pinholes are in the same place. -@section{Pinholes} +@section[#:tag "pinholes"]{Pinholes} A pinhole is an optional property of an image that identifies a point somewhere in the image. The pinhole can then be used to facilitate overlaying images by