Added docs and exported basic pinhole manipulation primitives

collects/2htdp/image.rkt

@@ -125,6 +125,12 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          image-height
          image-baseline
 
+         put-pinhole
+         clear-pinhole
+         center-pinhole
+         pinhole-x
+         pinhole-y
+         
          make-color
          make-pen pen
          pen?

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

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)))
+               (term image))))
-      (display #\.) (flush-output)
-      )
     #:attempts 1000)))
 
 ;;This expression was found by the above. Its problematic because it has a negative width.

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
+         image-snip->image)
-         
-         put-pinhole
-         clear-pinhole
-         pinhole-x
-         pinhole-y)
 
 ;; method names
 (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape)

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-height (text "Hello" 24 "black")) 'val '41)
-   (list '(image-baseline (text "Hello" 24 "black")) 'val '18)
+   (list '(image-baseline (text "Hello" 24 "black")) 'val '31)
    (list '(image-height (rectangle 10 0 "solid" "purple")) 'val '0)
    (list
     '(image-height

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