added cropping to 2htdp/image

svn: r17474

collects/2htdp/image.ss

@@ -63,6 +63,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          above
          above/align
          
+	 crop
          rotate
          frame
    

collects/2htdp/private/image-more.ss

@@ -258,6 +258,18 @@
 ;                                                                                   
 ;       
 
+;; crop : number number number number image -> image
+;; crops an image to be w x h from (x,y)
+(define/chk (crop x1 y1 width height image)
+  (let ([iw (min width (image-width image))]
+        [ih (min height (image-height image))])
+    (make-image (make-crop (rectangle-points iw ih)
+                           (make-translate (- x1) (- y1) (image-shape image)))
+                (make-bb iw
+                         ih
+                         (min ih (image-baseline image)))
+                #f)))
+
 ;; frame : image -> image
 ;; draws a black frame around a image where the bounding box is
 ;; (useful for debugging images)
@@ -282,24 +294,79 @@
 ;; (in degrees)
 ;; LINEAR TIME OPERATION (sigh)
 (define/chk (rotate angle image)
-  (define left +inf.0)
-  (define top +inf.0)
-  (define right -inf.0)
-  (define bottom -inf.0)
-  (define (add-to-bounding-box/rotate simple-shape)
-    (let ([rotated-shape (rotate-simple angle simple-shape)])
-      (let-values ([(this-left this-top this-right this-bottom) (simple-bb rotated-shape)])
-        (set! left (min this-left left))
-        (set! top (min this-top top))
-        (set! right (max this-right right))
-        (set! bottom (max this-bottom bottom)))
-      rotated-shape))
-  (let* ([rotated (normalize-shape (image-shape image) add-to-bounding-box/rotate)])
-    (make-image (make-translate (- left) (- top) rotated)
-                (make-bb (- right left) (- bottom top) (- bottom top))
+  (let-values ([(rotated-shape ltrb)
+                (rotate-normalized-shape/bb angle 
+                                            (normalize-shape (image-shape image)))])
+    
+    (make-image (make-translate (- (ltrb-left ltrb)) (- (ltrb-top ltrb)) rotated-shape)
+                (make-bb (- (ltrb-right ltrb) (ltrb-left ltrb))
+                         (- (ltrb-bottom ltrb) (ltrb-top ltrb))
+                         (- (ltrb-bottom ltrb) (ltrb-top ltrb)))
                 #f)))
 
-;; simple-bb : simple-shape -> (values number number number number)
+;; rotate-normalized-shape/bb : angle normalized-shape -> (values normalized-shape ltrb)
+(define (rotate-normalized-shape/bb angle shape)
+  (cond
+    [(overlay? shape)
+     (let-values ([(top-shape top-ltrb) (rotate-normalized-shape/bb angle (overlay-top shape))]
+                  [(bottom-shape bottom-ltrb) (rotate-simple/bb angle (overlay-bottom shape))])
+       (values (make-overlay top-shape bottom-shape)
+               (union-ltrb top-ltrb bottom-ltrb)))]
+    [else 
+     (rotate-cropped-simple/bb angle shape)]))
+
+;; rotate-cropped-shape/bb : angle cropped-simple-shape -> (values cropped-simple-shape ltrb)
+(define (rotate-cropped-simple/bb angle shape)
+  (cond
+    [(crop? shape)
+     (let-values ([(rotated-shape ltrb) (rotate-cropped-simple/bb angle (crop-shape shape))])
+       (let* ([rotated-points (rotate-points angle (crop-points shape))]
+              [crop-ltrb (points->ltrb rotated-points)])
+         (values (make-crop rotated-points rotated-shape)
+                 (intersect-ltrb crop-ltrb ltrb))))]
+    [else 
+     (rotate-simple/bb angle shape)]))
+
+;; rotate-simple/bb : angle simple-shape -> (values simple-shape ltrb)
+(define (rotate-simple/bb angle shape)
+  (let ([rotated-shape (rotate-simple angle shape)])
+    (values rotated-shape (simple-bb rotated-shape))))
+
+;; rotate-simple : angle simple-shape -> simple-shape
+(define (rotate-simple θ simple-shape)
+  (cond
+    [(line-segment? simple-shape)
+     (make-line-segment (rotate-point (line-segment-start simple-shape)
+                                      θ)
+                        (rotate-point (line-segment-end simple-shape)
+                                      θ)
+                        (line-segment-color simple-shape))]
+    [(polygon? simple-shape)
+     (make-polygon (rotate-points θ (polygon-points simple-shape))
+                   (polygon-mode simple-shape)
+                   (polygon-color simple-shape))]
+    [else
+     (let* ([unrotated (translate-shape simple-shape)]
+            [rotated (rotate-atomic θ unrotated)])
+       (let-values ([(dx dy) 
+                     (c->xy (* (make-polar 1 (degrees->radians θ))
+                               (xy->c (translate-dx simple-shape)
+                                      (translate-dy simple-shape))))])
+         (make-translate dx dy rotated)))]))
+
+(define-struct ltrb (left top right bottom))
+(define (union-ltrb ltrb1 ltrb2)
+  (make-ltrb (min (ltrb-left ltrb1) (ltrb-left ltrb2))
+             (min (ltrb-top ltrb1) (ltrb-top ltrb2))
+             (max (ltrb-right ltrb1) (ltrb-right ltrb2))
+             (max (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))
+(define (intersect-ltrb ltrb1 ltrb2)
+  (make-ltrb (max (ltrb-left ltrb1) (ltrb-left ltrb2))
+             (max (ltrb-top ltrb1) (ltrb-top ltrb2))
+             (min (ltrb-right ltrb1) (ltrb-right ltrb2))
+             (min (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))
+
+;; simple-bb : simple-shape -> ltrb
 ;; returns the bounding box of 'shape' 
 ;; (only called for rotated shapes, so bottom=baseline)
 (define (simple-bb simple-shape)
@@ -309,36 +376,38 @@
            [y1 (point-y (line-segment-start simple-shape))]
            [x2 (point-x (line-segment-end simple-shape))]
            [y2 (point-y (line-segment-end simple-shape))])
-       (values (min x1 x2)
-               (min y1 y2)
-               (+ (max x1 x2) 1)
-               (+ (max y1 y2) 1)))]
+       (make-ltrb (min x1 x2)
+                  (min y1 y2)
+                  (+ (max x1 x2) 1)
+                  (+ (max y1 y2) 1)))]
     [(polygon? simple-shape)
-     (let ([points (polygon-points simple-shape)])
-       (let* ([fx (point-x (car points))]
-              [fy (point-y (car points))]
-              [left fx]
-              [top fy]
-              [right fx]
-              [bottom fy])
-         (for-each (λ (point)
-                     (let ([new-x (point-x point)]
-                           [new-y (point-y point)])
-                       (set! left (min new-x left))
-                       (set! top (min new-y top))
-                       (set! right (max new-x right))
-                       (set! bottom (max new-y bottom))))
-                   (cdr points))
-         (values left top right bottom)))]
+     (points->ltrb (polygon-points simple-shape))]
     [else
      (let ([dx (translate-dx simple-shape)]
            [dy (translate-dy simple-shape)])
        (let-values ([(l t r b) (np-atomic-bb (translate-shape simple-shape))])
-         (values (+ l dx)
-                 (+ t dy)
-                 (+ r dx)
-                 (+ b dy))))]))
+         (make-ltrb (+ l dx)
+                    (+ t dy)
+                    (+ r dx)
+                    (+ b dy))))]))
 
+;; points->ltrb : (cons point (listof points)) -> (values number number number number)
+(define (points->ltrb points)
+  (let* ([fx (point-x (car points))]
+         [fy (point-y (car points))]
+         [left fx]
+         [top fy]
+         [right fx]
+         [bottom fy])
+    (for-each (λ (point)
+                (let ([new-x (point-x point)]
+                      [new-y (point-y point)])
+                  (set! left (min new-x left))
+                  (set! top (min new-y top))
+                  (set! right (max new-x right))
+                  (set! bottom (max new-y bottom))))
+              (cdr points))
+    (make-ltrb left top right bottom)))
 
 (define (np-atomic-bb atomic-shape)
   (cond
@@ -376,28 +445,7 @@
             (max ax bx cx dx)
             (max ay by cy dy))))
 
-;; rotate-simple : angle simple-shape -> simple-shape
-(define (rotate-simple θ simple-shape)
-  (cond
-    [(line-segment? simple-shape)
-     (make-line-segment (rotate-point (line-segment-start simple-shape)
-                                      θ)
-                        (rotate-point (line-segment-end simple-shape)
-                                      θ)
-                        (line-segment-color simple-shape))]
-    [(polygon? simple-shape)
-     (make-polygon (map (λ (p) (rotate-point p θ))
-                        (polygon-points simple-shape))
-                   (polygon-mode simple-shape)
-                   (polygon-color simple-shape))]
-    [else
-     (let* ([unrotated (translate-shape simple-shape)]
-            [rotated (rotate-atomic θ unrotated)])
-       (let-values ([(dx dy) 
-                     (c->xy (* (make-polar 1 (degrees->radians θ))
-                               (xy->c (translate-dx simple-shape)
-                                      (translate-dy simple-shape))))])
-         (make-translate dx dy rotated)))]))
+(define (rotate-points θ points) (map (λ (p) (rotate-point p θ)) points))
 
 (define (center-point np-atomic-shape)
   (let-values ([(l t r b) (np-atomic-bb np-atomic-shape)])
@@ -515,11 +563,11 @@
                     mode
                     color)))
 
-(define (rectangle-points width height)
-  (list (make-point 0 0)
-        (make-point width 0)
-        (make-point width height)
-        (make-point 0 height)))
+(define (rectangle-points width height [dx 0] [dy 0])
+  (list (make-point dx dy)
+        (make-point (+ dx width) dy)
+        (make-point (+ dx width) (+ height dy))
+        (make-point dx (+ dy height))))
   
 
 (define/chk (line x1 y1 color)
@@ -631,11 +679,15 @@
                   mode color))
 
 (define (make-a-polygon points mode color)
-  (let ([poly (make-polygon points mode color)])
-    (let-values ([(l t r b) (simple-bb poly)])
-      (make-image (make-translate (- l) (- t) poly)
-                  (make-bb (- r l) (- b t) (- b t))
-                  #f))))
+  (let* ([poly (make-polygon points mode color)]
+         [ltrb (simple-bb poly)]
+         [l (ltrb-left ltrb)]
+         [t (ltrb-top ltrb)]
+         [r (ltrb-right ltrb)]
+         [b (ltrb-bottom ltrb)])
+    (make-image (make-translate (- l) (- t) poly)
+                (make-bb (- r l) (- b t) (- b t))
+                #f)))
 (define (gcd a b)
   (cond
     [(zero? b) a]
@@ -761,7 +813,8 @@
          above/align
          
          rotate
-         
+         crop
+
          frame
          
          show-image

collects/2htdp/tests/test-image.ss

@@ -1,4 +1,17 @@
 #lang scheme/base
+#|
+;; snippet of code for experimentation
+(define images
+  (list (round-numbers (rotate 180 (line 20 30 "red")))
+        (round-numbers (line 20 30 "red"))))
+
+(define t (new text%))
+(define f (new frame% [label ""] [width 600] [height 400]))
+(define ec (new editor-canvas% [parent f] [editor t]))
+(for ((i (in-list images))) (send t insert i))
+(send f show #t)
+|#
+
 (require "../../mrlib/image-core.ss"
          "../private/image-more.ss"
          "../private/img-err.ss"
@@ -599,6 +612,32 @@
       =>
       (make-translate 135 170 (make-ellipse 50 100 0 'solid "blue")))
 
+(test (normalize-shape (image-shape
+                        (beside (rectangle 10 10 'solid 'black)
+                                (crop 0 0 5 5 (rectangle 10 10 'solid 'green)))))
+      =>
+      (make-overlay
+       (make-polygon
+        (list (make-point 0 0)
+              (make-point 10 0)
+              (make-point 10 10)
+              (make-point 0 10))
+        'solid
+        "black")
+       (make-crop
+        (list (make-point 10 0)
+              (make-point 15 0)
+              (make-point 15 5)
+              (make-point 10 5))
+        (make-polygon
+         (list (make-point 10 0)
+               (make-point 20 0)
+               (make-point 20 10)
+               (make-point 10 10))
+         'solid
+         "green"))))
+
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -764,11 +803,13 @@
 ;;
 
 ;; note: the regular-polygon and the rectangle generate the points in reverse directions.
-(check-equal? (round-numbers (regular-polygon 100 4 'outline 'green))
-              (round-numbers (rectangle 100 100 'outline 'green)))
+(test (round-numbers (regular-polygon 100 4 'outline 'green))
+      =>
+      (round-numbers (rectangle 100 100 'outline 'green)))
 
-(check-equal? (swizzle (list 0 1 2 3 4) 2)
-              (list 0 2 4 1 3))
+(test (swizzle (list 0 1 2 3 4) 2)
+      =>
+      (list 0 2 4 1 3))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -776,42 +817,48 @@
 ;;  text
 ;;
 
-(check-equal? (beside/align "baseline"
-                             (text "a" 18 "black")
-                             (text "b" 18 "black"))
-              (text "ab" 18 "black"))
+(test (beside/align "baseline"
+                    (text "a" 18 "black")
+                    (text "b" 18 "black"))
+      =>
+      (text "ab" 18 "black"))
 
-(check-equal? (round-numbers
-               (image-width (rotate 45 (text "One" 18 'black))))
-              (round-numbers
-               (let ([t (text "One" 18 'black)])
-                 (image-width (rotate 45 (rectangle (image-width t) 
-                                                    (image-height t)
-                                                    'solid 'black))))))
+(test (round-numbers
+       (image-width (rotate 45 (text "One" 18 'black))))
+      =>
+      (round-numbers
+       (let ([t (text "One" 18 'black)])
+         (image-width (rotate 45 (rectangle (image-width t) 
+                                            (image-height t)
+                                            'solid 'black))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; triangle
 ;;
 
-(check-equal? (round-numbers (rotate 180 (isosceles-triangle 60 330 "solid" "lightseagreen")))
-              (round-numbers (isosceles-triangle 60 30 "solid" "lightseagreen")))
+(test (round-numbers (rotate 180 (isosceles-triangle 60 330 "solid" "lightseagreen")))
+      =>
+      (round-numbers (isosceles-triangle 60 30 "solid" "lightseagreen")))
 
-(check-equal? (triangle 40 'outline 'black)
-              (regular-polygon 40 3 'outline 'black))
+(test (triangle 40 'outline 'black)
+      =>
+      (regular-polygon 40 3 'outline 'black))
 
-(check-equal? (equal~? (rotate (+ 180 45) (right-triangle 50 50 'solid 'black))
-                       (isosceles-triangle 50 90 'solid 'black)
-                       0.001)
-              #t)
+(test (equal~? (rotate (+ 180 45) (right-triangle 50 50 'solid 'black))
+               (isosceles-triangle 50 90 'solid 'black)
+               0.001)
+      =>
+      #t)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; square
 ;;
 
-(check-equal? (square 10 'solid 'black)
-              (rectangle 10 10 'solid 'black))
+(test (square 10 'solid 'black)
+      =>
+      (rectangle 10 10 'solid 'black))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -819,28 +866,33 @@
 ;; rhombus
 ;;
 
-(check-equal? (equal~? (rhombus 10 90 'solid 'black)
-                       (rotate 45 (square 10 'solid 'black))
-                       0.01)
-              #t)
+(test (equal~? (rhombus 10 90 'solid 'black)
+               (rotate 45 (square 10 'solid 'black))
+               0.01)
+      =>
+      #t)
 
-(check-equal? (equal~? (rhombus 50 150 'solid 'black)
-                       (rotate 90 (rhombus 50 30 'solid 'black))
-                       0.01)
-              #t)
+(test (equal~? (rhombus 50 150 'solid 'black)
+               (rotate 90 (rhombus 50 30 'solid 'black))
+               0.01)
+      =>
+      #t)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; lines
 ;;
 
-(check-equal? (image-width (line 10 20 'black))
-              11)
-(check-equal? (image-height (line 10 20 'black))
-              21)
+(test (image-width (line 10 20 'black))
+      =>
+      11)
+(test (image-height (line 10 20 'black))
+      =>
+      21)
 
-(check-equal? (round-numbers (rotate 90 (line 10 20 'black)))
-              (round-numbers (line 20 -10 'black)))
+(test (round-numbers (rotate 90 (line 10 20 'black)))
+      =>
+      (round-numbers (line 20 -10 'black)))
 
 (check-equal? (round-numbers (line 20 30 "red"))
               (round-numbers (rotate 180 (line 20 30 "red"))))
@@ -984,3 +1036,25 @@
 (check-equal? (begin (scale 2 (make-object bitmap% 10 10))
                      (void))
               (void))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; cropping
+;;
+
+(test (crop 0 0 10 10 (rectangle 20 20 'solid 'black))
+      =>
+      (rectangle 10 10 'solid 'black))
+
+(test (equal~? (crop 0 0 40 40 (circle 40 'solid 'red))
+               (rotate 180 (crop 40 40 40 40 (circle 40 'solid 'red)))
+               0.1)
+      =>
+      #t)
+
+(test (beside (rectangle 10 10 'solid 'black)
+              (crop 0 0 10 10 (rectangle 10 10 'solid 'green)))
+      =>
+      (beside (rectangle 10 10 'solid 'black)
+              (rectangle 10 10 'solid 'green)))

collects/mrlib/image-core.ss

@@ -117,6 +117,9 @@ has been moved out).
 ;;  - (make-scale x-factor y-factor shape)
 (define-struct/reg-mk scale (x y shape) #:transparent #:omit-define-syntaxes)
 ;;
+;;  - (make-crop (listof vector) shape)
+(define-struct/reg-mk crop (points shape) #:transparent #:omit-define-syntaxes)
+;;
 ;;  - atomic-shape
 
 ;; an atomic-shape is either:
@@ -160,11 +163,15 @@ has been moved out).
         (λ (x y) 42) 
         (λ (x y) 3)))
 ;; a normalized-shape (subtype of shape) is either
-;;  - (make-overlay normalized-shape simple-shape)
+;;  - (make-overlay normalized-shape cropped-simple-shape)
+;;  - cropped-simple-shape
+
+;; a cropped-simple-shape is either
+;;  - (make-crop (listof points) cropped-simple-shape)
 ;;  - simple-shape
 
 ;; a simple-shape (subtype of shape) is
-;;  - (make-translate dx dy np-atomic-shape)
+;;  - (make-translate dx dy np-atomic-shape))
 ;;  - polygon
 ;;  - line-segment
 
@@ -275,7 +282,7 @@ has been moved out).
     
     (define/public (get-normalized-shape)
       (unless normalized?
-        (set! shape (normalize-shape shape values))
+        (set! shape (normalize-shape shape))
         (set! normalized? #t))
       shape)
     
@@ -395,10 +402,16 @@ has been moved out).
              [dy 0]
              [x-scale 1]
              [y-scale 1]
+             [crops '()]  ;; (listof (listof point))
              [bottom #f])
     (define (scale-point p)
       (make-point (+ dx (* x-scale (point-x p)))
                   (+ dy (* y-scale (point-y p)))))
+    (define (add-crops shape)
+      (let loop ([crops crops])
+        (cond
+          [(null? crops) shape]
+          [else (make-crop (car crops) (loop (cdr crops)))])))
     (cond
       [(translate? shape)
        (loop (translate-shape shape)
@@ -406,6 +419,7 @@ has been moved out).
              (+ dy (* y-scale (translate-dy shape)))
              x-scale
              y-scale
+             crops
              bottom)]
       [(scale? shape)
        (loop (scale-shape shape)
@@ -413,30 +427,41 @@ has been moved out).
              dy
              (* x-scale (scale-x shape))
              (* y-scale (scale-y shape))
+             crops
              bottom)]
       [(overlay? shape)
        (loop (overlay-bottom shape)
-             dx dy x-scale y-scale
+             dx dy x-scale y-scale crops
              (loop (overlay-top shape)
-                   dx dy x-scale y-scale bottom))]
+                   dx dy x-scale y-scale crops
+                   bottom))]
+      [(crop? shape)
+       (loop (crop-shape shape)
+             dx dy x-scale y-scale 
+             (cons (map scale-point (crop-points shape)) crops)
+             bottom)]
       [(polygon? shape)
        (let* ([this-one 
-               (make-polygon (map scale-point (polygon-points shape))
-                             (polygon-mode shape)
-                             (polygon-color shape))])
+               (add-crops 
+                (make-polygon (map scale-point (polygon-points shape))
+                              (polygon-mode shape)
+                              (polygon-color shape)))])
          (if bottom
              (make-overlay bottom (f this-one))
              (f this-one)))]
       [(line-segment? shape)
        (let ([this-one 
-              (make-line-segment (scale-point (line-segment-start shape))
-                                 (scale-point (line-segment-end shape))
-                                 (line-segment-color shape))])
+              (add-crops
+               (make-line-segment (scale-point (line-segment-start shape))
+                                  (scale-point (line-segment-end shape))
+                                  (line-segment-color shape)))])
          (if bottom
              (make-overlay bottom (f this-one))
              (f this-one)))]
       [(np-atomic-shape? shape)
-       (let ([this-one (make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
+       (let ([this-one 
+              (add-crops
+               (make-translate dx dy (scale-np-atomic x-scale y-scale shape)))])
          (if bottom
              (make-overlay bottom (f this-one))
              (f this-one)))]
@@ -510,7 +535,7 @@ has been moved out).
 ;                                                                
 ;                                                         
 
-;; render-image : normalized-shape dc dx dy -> void
+;; render-image : image dc dx dy -> void
 (define (render-image image dc dx dy)
   (let ([pen (send dc get-pen)]
         [brush (send dc get-brush)]
@@ -519,33 +544,33 @@ has been moved out).
     (let loop ([shape (send image get-normalized-shape)])
       (cond
         [(overlay? shape)
-         (render-simple-shape (overlay-bottom shape) dc dx dy)
+         (render-cropped-simple-shape (overlay-bottom shape) dc dx dy)
          (loop (overlay-top shape))]
         [else
-         (render-simple-shape shape dc dx dy)]))
+         (render-cropped-simple-shape shape dc dx dy)]))
     (send dc set-pen pen)
     (send dc set-brush brush)
     (send dc set-font font)
     (send dc set-text-foreground fg)))
 
+(define (render-cropped-simple-shape shape dc dx dy)
+  (cond
+    [(crop? shape)
+     (let ([old-region (send dc get-clipping-region)]
+           [new-region (new region% [dc dc])]
+           [path (polygon-points->path (crop-points shape))])
+       (send new-region set-path path dx dy)
+       (when old-region (send new-region intersect old-region))
+       (send dc set-clipping-region new-region)
+       (render-cropped-simple-shape (crop-shape shape) dc dx dy)
+       (send dc set-clipping-region old-region))]
+    [else
+     (render-simple-shape shape dc dx dy)]))
+
 (define (render-simple-shape simple-shape dc dx dy)
   (cond
     [(polygon? simple-shape)
-     (let ([path (new dc-path%)]
-           [points (polygon-points simple-shape)])
-       (send path move-to (point-x (car points)) (point-y (car points)))
-       (let loop ([point (make-rectangular (point-x (car points)) (point-y (car points)))]
-                  [last-point (car points)]
-                  [points (cdr points)])
-         (unless (null? points)
-           (let* ([vec (make-rectangular (- (point-x (car points))
-                                            (point-x last-point))
-                                         (- (point-y (car points))
-                                            (point-y last-point)))]
-                  [endpoint (+ point vec (make-polar -1 (angle vec)))])
-             (send path line-to (real-part endpoint) (imag-part endpoint))
-             (loop endpoint (car points) (cdr points)))))
-       (send path line-to (point-x (car points)) (point-y (car points)))
+     (let ([path (polygon-points->path (polygon-points simple-shape))])
        (send dc set-pen (mode-color->pen (polygon-mode simple-shape) (polygon-color simple-shape)))
        (send dc set-brush (mode-color->brush (polygon-mode simple-shape) (polygon-color simple-shape)))
        (send dc draw-path path dx dy 'winding))]
@@ -599,6 +624,23 @@ has been moved out).
                       (imag-part p) 
                       #f 0 θ))))]))]))
 
+(define (polygon-points->path points)
+  (let ([path (new dc-path%)])
+    (send path move-to (point-x (car points)) (point-y (car points)))
+    (let loop ([point (make-rectangular (point-x (car points)) (point-y (car points)))]
+               [last-point (car points)]
+               [points (cdr points)])
+      (unless (null? points)
+        (let* ([vec (make-rectangular (- (point-x (car points))
+                                         (point-x last-point))
+                                      (- (point-y (car points))
+                                         (point-y last-point)))]
+               [endpoint (+ point vec (make-polar -1 (angle vec)))])
+          (send path line-to (real-part endpoint) (imag-part endpoint))
+          (loop endpoint (car points) (cdr points)))))
+    (send path line-to (point-x (car points)) (point-y (car points)))
+    path))
+
 #|
 
 the mask bitmap and the original bitmap are all together in a single bytes!
@@ -742,7 +784,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          (struct-out point)
          make-overlay overlay? overlay-top overlay-bottom
          make-translate translate? translate-dx translate-dy translate-shape
-         make-scale scale-x scale-y scale-shape
+         make-scale scale? scale-x scale-y scale-shape
+	 make-crop crop? crop-points crop-shape
          make-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color
          make-text text? text-string text-angle text-y-scale text-color
          text-angle text-size text-face text-family text-style text-weight text-underline

collects/teachpack/2htdp/scribblings/image-gen.ss

@@ -1,5 +1,8 @@
 #lang scheme/gui
 
+;; Run this file is generate the images in the img/ directory, 
+;; picked up by image-examples from image.scrbl
+
 (require 2htdp/private/image-more
          lang/posn
          mrlib/image-core)

collects/teachpack/2htdp/scribblings/image-toc.ss

@@ -8,8 +8,8 @@
   (list
    (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 41.0)
-   (list '(image-baseline (text "Hello" 24 "black")) 'val 31.0)
+   (list '(image-height (text "Hello" 24 "black")) 'val 24.0)
+   (list '(image-baseline (text "Hello" 24 "black")) 'val 18.0)
    (list
     '(image-height
       (overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple")))
@@ -34,6 +34,24 @@
     'image
     "f7f1480d58.png")
    (list '(frame (ellipse 20 20 "outline" "black")) 'image "6a5a617f28.png")
+   (list
+    '(above
+      (beside
+       (crop 40 40 40 40 (circle 40 "solid" "palevioletred"))
+       (crop 0 40 40 40 (circle 40 "solid" "lightcoral")))
+      (beside
+       (crop 40 0 40 40 (circle 40 "solid" "lightcoral"))
+       (crop 0 0 40 40 (circle 40 "solid" "palevioletred"))))
+    'image
+    "164b8da7bf6.png")
+   (list
+    '(crop 40 60 40 60 (ellipse 80 120 "solid" "dodgerblue"))
+    'image
+    "6c262f1d24.png")
+   (list
+    '(crop 0 0 40 40 (circle 40 "solid" "chocolate"))
+    'image
+    "8e7c1870c7.png")
    (list '(ellipse 60 60 "solid" "blue") 'image "d92d6a49f1.png")
    (list
     '(scale/xy 3 2 (ellipse 20 30 "solid" "blue"))

collects/teachpack/2htdp/scribblings/image.scrbl

@@ -453,7 +453,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
   
   }
 
-@section{Rotating, Scaling, and Framing Images}
+@section{Rotating, Scaling, Cropping, and Framing Images}
 
 @defproc[(rotate [angle angle?] [image image?]) image?]{
   Rotates @scheme[image] by @scheme[angle] degrees in a counter-clockwise direction.
@@ -488,6 +488,24 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                   (ellipse 60 60 "solid" "blue")]
 }
 
+@defproc[(crop [x real?] [y real?] 
+               [width (and/c real? (not/c negative?))]
+               [height (and/c real? (not/c negative?))]
+               [image image?])
+         image?]{
+
+ Crops @scheme[image] to the rectangle with the upper left at the point (@scheme[x],@scheme[y])
+ and with @scheme[width] and @scheme[height]. 
+ 
+ @image-examples[(crop 0 0 40 40 (circle 40 "solid" "chocolate"))
+                 (crop 40 60 40 60 (ellipse 80 120 "solid" "dodgerblue"))
+                 (above
+                  (beside (crop 40 40 40 40 (circle 40 "solid" "palevioletred"))
+                          (crop 0 40 40 40 (circle 40 "solid" "lightcoral")))
+                  (beside (crop 40 0 40 40 (circle 40 "solid" "lightcoral"))
+                          (crop 0 0 40 40 (circle 40 "solid" "palevioletred"))))]
+                 
+}
 
 @defproc[(frame [image image?]) image?]{
   Returns an image just like @scheme[image], except