diff --git a/collects/2htdp/image.rkt b/collects/2htdp/image.rkt index 47dce5b3b7..b25ed2fab7 100644 --- a/collects/2htdp/image.rkt +++ b/collects/2htdp/image.rkt @@ -124,6 +124,12 @@ and they all have good sample contracts. (It is amazing what we can do with kids image-width image-height image-baseline + + put-pinhole + clear-pinhole + center-pinhole + pinhole-x + pinhole-y make-color make-pen pen diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index 171ed666b6..03942aac0e 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -1198,6 +1198,18 @@ (orig-make-color int0-255-1 int0-255-2 int0-255-3)) make-color)) +(define/chk (pinhole-x image) (let ([ph (send image get-pinhole)]) (and ph (point-x ph)))) +(define/chk (pinhole-y image) (let ([ph (send image get-pinhole)]) (and ph (point-y ph)))) +(define/chk (put-pinhole x1 y1 image) (make-image (image-shape image) (image-bb image) (image-normalized? image) (make-point x1 y1))) +(define/chk (center-pinhole image) + (let ([bb (send image get-bb)]) + (make-image (image-shape image) + (image-bb image) + (image-normalized? image) + (make-point (/ (bb-right bb) 2) + (/ (bb-baseline bb) 2))))) +(define/chk (clear-pinhole image) (make-image (image-shape image) (image-bb image) (image-normalized? image) #f)) + (define build-color/color (let ([orig-make-color make-color]) (define/chk (color int0-255-1 int0-255-2 int0-255-3) @@ -1290,6 +1302,12 @@ rotate-xy + put-pinhole + pinhole-x + pinhole-y + clear-pinhole + center-pinhole + build-color/make-color build-color/color build-pen/make-pen diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index b2075488a2..fd7959c942 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -1786,9 +1786,7 @@ (unless (< cpu 4000) (error 'test-image.rkt "saving and loading this image takes too longer than 4 seconds:\n ~s" - (term image))) - (display #\.) (flush-output) - ) + (term image)))) #:attempts 1000))) ;;This expression was found by the above. Its problematic because it has a negative width. diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index ea070810f4..d1a6fac8bd 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -97,10 +97,6 @@ has been moved out). (define (image-normalized? p) (send p get-normalized?)) (define (set-image-shape! p s) (send p set-shape s)) (define (set-image-normalized?! p n?) (send p set-normalized? n?)) -(define (pinhole-x p) (let ([ph (send p get-pinhole)]) (and ph (pinhole-x ph)))) -(define (pinhole-y p) (let ([ph (send p get-pinhole)]) (and ph (pinhole-y ph)))) -(define (put-pinhole x y image) (make-image (image-shape image) (image-bb image) (image-normalized? image) (make-point x y))) -(define (clear-pinhole image) (make-image (image-shape image) (image-bb image) (image-normalized? image) #f)) (define (image? p) (or (is-a? p image%) (is-a? p image-snip%) @@ -372,6 +368,7 @@ has been moved out). #f #f)] [(= 2 (length lst)) + ;; backwards compatibility for saved images that didn't have a pinhole (make-image (list-ref lst 0) (list-ref lst 1) #f @@ -1095,12 +1092,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! to-img bitmap->image - image-snip->image - - put-pinhole - clear-pinhole - pinhole-x - pinhole-y) + image-snip->image) ;; method names (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) diff --git a/collects/teachpack/2htdp/scribblings/image-toc.rkt b/collects/teachpack/2htdp/scribblings/image-toc.rkt index 7f865eac14..d8f4fb2da5 100644 --- a/collects/teachpack/2htdp/scribblings/image-toc.rkt +++ b/collects/teachpack/2htdp/scribblings/image-toc.rkt @@ -36,10 +36,20 @@ (above r r r r r r)) 'image "245380940d6-1.png") + (list '(pinhole-y (center-pinhole (rectangle 10 10 "solid" "red"))) 'val '5) + (list '(pinhole-x (center-pinhole (rectangle 10 10 "solid" "red"))) 'val '5) + (list + '(put-pinhole 2 18 (rectangle 40 20 "solid" "forestgreen")) + 'image + "14fa9751041.png") + (list + '(center-pinhole (rectangle 40 20 "solid" "red")) + 'image + "b2c3ee438.png") (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) - (list '(image-baseline (text "Hello" 24 "black")) 'val '18) + (list '(image-height (text "Hello" 24 "black")) 'val '41) + (list '(image-baseline (text "Hello" 24 "black")) 'val '31) (list '(image-height (rectangle 10 0 "solid" "purple")) 'val '0) (list '(image-height diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index f0df082ca3..3f48d3bd87 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -1274,6 +1274,33 @@ The baseline of an image is the place where the bottoms any letters line up, not Two images are equal if they draw exactly the same way, at their current size (not neccessarily at all sizes). +@section{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 +lining them up on the their pinholes. When an image has a pinhole, the pinhole +is drawn with crosshairs drawn across the image. + +@defproc[(center-pinhole [image image?]) image?]{ + Creates a pinhole in @racket[image] at its center. + @image-examples[(center-pinhole (rectangle 40 20 "solid" "red"))] +} +@defproc[(put-pinhole [x integer?] [y integer?] [image image?]) image?]{ + Creates a pinhole in @racket[image] at the point (@racket[x],@racket[y]). + @image-examples[(put-pinhole 2 18 (rectangle 40 20 "solid" "forestgreen"))] +} +@defproc[(pinhole-x [image image?]) (or/c integer? #f)]{ + Returns the x coordinate of @racket[image]'s pinhole. + @image-examples[(pinhole-x (center-pinhole (rectangle 10 10 "solid" "red")))] +} +@defproc[(pinhole-y [image image?]) (or/c integer? #f)]{ + Returns the y coordinate of @racket[image]'s pinhole. + @image-examples[(pinhole-y (center-pinhole (rectangle 10 10 "solid" "red")))] +} +@defproc[(clear-pinhole [image image?]) image?]{ + Removes a pinhole from @racket[image] (if the image has a pinhole). +} + @section[#:tag "nitty-gritty"]{The nitty gritty of pixels, pens, and lines} The image library treats coordinates as if they are in the upper-left corner diff --git a/collects/teachpack/2htdp/scribblings/img/14fa9751041.png b/collects/teachpack/2htdp/scribblings/img/14fa9751041.png new file mode 100644 index 0000000000..26c353b7e7 Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/14fa9751041.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/b2c3ee438.png b/collects/teachpack/2htdp/scribblings/img/b2c3ee438.png new file mode 100644 index 0000000000..0652650e69 Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/b2c3ee438.png differ