From cc9686486836b71c7005f419242c66e780b87b18 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 6 Sep 2010 07:36:18 -0500
Subject: [PATCH] added pinhole support to cropping primitives and to frame

---
 collects/2htdp/private/image-more.rkt | 11 ++++++++---
 collects/2htdp/tests/test-image.rkt   | 18 ++++++++++++++++--
 2 files changed, 24 insertions(+), 5 deletions(-)

diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt
index 6aa9b7fe89..c9f30b6dd5 100644
--- a/collects/2htdp/private/image-more.rkt
+++ b/collects/2htdp/private/image-more.rkt
@@ -299,13 +299,17 @@
     (crop/internal x1 y1 w h image)))
 
 (define (crop/internal x1 y1 width height image)
-  (let* ([points (rectangle-points width height)])
+  (let ([points (rectangle-points width height)]
+        [ph (send image get-pinhole)])
     (make-image (make-crop points
                            (make-translate (- x1) (- y1) (image-shape image)))
                 (make-bb width
                          height
                          (min height (get-baseline image)))
-                #f)))
+                #f
+                (and ph 
+                     (make-point (- (point-x ph) x1)
+                                 (- (point-y ph) y1))))))
 
 ;; place-image : image x y scene -> scene
 (define/chk (place-image image1 x1 y1 image2) 
@@ -366,7 +370,8 @@
               (make-bb (get-right image)
                        (get-bottom image)
                        (get-baseline image))
-              #f))
+              #f
+              (send image get-pinhole)))
 
 ;; scale : I number -> I
 ;; scales the I by the given factor
diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt
index 7831f77903..da9565a816 100644
--- a/collects/2htdp/tests/test-image.rkt
+++ b/collects/2htdp/tests/test-image.rkt
@@ -1664,8 +1664,22 @@
       =>
       60)
 
-;; crop
-;; frame
+(test (pinhole-x (crop 2 2 8 10
+                       (center-pinhole (rectangle 10 12 'solid 'red))))
+      =>
+      3)
+(test (pinhole-y (crop 2 2 8 10
+                       (center-pinhole (rectangle 10 12 'solid 'red))))
+      =>
+      4)
+
+(test (pinhole-x (frame (center-pinhole (rectangle 10 12 'solid 'red))))
+      =>
+      5)
+(test (pinhole-y (frame (center-pinhole (rectangle 10 12 'solid 'red))))
+      =>
+      6)
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;