add crop/align

pkgs/htdp-pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl

@@ -1390,6 +1390,31 @@ the parts that fit onto @racket[scene].
                  
 }
 
+@defproc[(crop/align [x-place x-place?]
+                     [y-place y-place?]
+                     [width (and/c real? (not/c negative?))]
+                     [height (and/c real? (not/c negative?))]
+                     [image image?])
+         image?]{
+
+ Crops @racket[image] to a rectangle whose size is @racket[width] and @racket[height]
+       and is positioned based on @racket[x-place] and @racket[y-place].
+
+ @crop-warning
+
+ @image-examples[(crop/align "left" "top" 40 40 (circle 40 "solid" "chocolate"))
+                 (crop/align "right" "bottom" 40 60 (ellipse 80 120 "solid" "dodgerblue"))
+                 (crop/align "center" "center" 50 30 (circle 25 "solid" "mediumslateblue"))
+                 (above
+                  (beside (crop/align "right" "bottom" 40 40 (circle 40 "solid" "palevioletred"))
+                          (crop/align "left" "bottom" 40 40 (circle 40 "solid" "lightcoral")))
+                  (beside (crop/align "right" "top" 40 40 (circle 40 "solid" "lightcoral"))
+                          (crop/align "left" "top" 40 40 (circle 40 "solid" "palevioletred"))))]
+
+ @history[#:added "1.1"]
+}
+
+
 @defproc[(frame [image image?]) image?]{
   Returns an image just like @racket[image], except
   with a black, single pixel frame drawn around the 
@@ -1410,6 +1435,8 @@ the parts that fit onto @racket[scene].
 
 @defproc[(color-frame [image image?] [color (or/c pen? image-color?)]) image?]{
   Like @racket[frame], except with the given @racket[color].
+       
+  @history[#:added "1.1"]
 }
 
 

pkgs/htdp-pkgs/htdp-lib/2htdp/image.rkt

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

pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt

@@ -407,6 +407,16 @@
 (define/chk (crop x1 y1 width height image)
   (crop/internal x1 y1 width height image))
 
+(define/chk (crop/align x-place y-place width height image)
+  (define x-spot (find-x-spot x-place image))
+  (define y-spot (find-y-spot y-place image))
+  (define crop-rec (rectangle width height "solid" "black"))
+  (define w-off (find-x-spot x-place crop-rec))
+  (define h-off (find-y-spot y-place crop-rec))
+  (crop/internal (- x-spot w-off)
+                 (- y-spot h-off)
+                 width height image))
+
 (define (crop/internal x1 y1 width height image)
   (let ([points (rectangle-points width height)]
         [ph (send image get-pinhole)])
@@ -1525,6 +1535,7 @@
          
          rotate
          crop
+         crop/align
          flip-vertical
          flip-horizontal
          frame

pkgs/htdp-pkgs/htdp-lib/info.rkt

@@ -34,3 +34,5 @@
 (define pkg-desc "implementation (no documentation) part of \"htdp\"")
 
 (define pkg-authors '(matthias mflatt robby))
+
+(define version "1.1")

pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt

@@ -1691,6 +1691,13 @@
       =>
       (rectangle 10 10 'solid 'black))
 
+(test (crop/align 'left 'top 10 10 (rectangle 20 20 'solid 'black))
+      =>
+      (rectangle 10 10 'solid 'black))
+(test (crop/align 'center 'center 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)
@@ -1765,6 +1772,18 @@
                    2 7
                    (circle 4 'solid 'black)))
 
+(test (above
+       (beside (crop/align "right" "bottom" 40 40 (circle 40 "solid" "palevioletred"))
+               (crop/align "left" "bottom" 40 40 (circle 40 "solid" "lightcoral")))
+       (beside (crop/align "right" "top" 40 40 (circle 40 "solid" "lightcoral"))
+               (crop/align "left" "top" 40 40 (circle 40 "solid" "palevioletred"))))
+      =>
+      (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")))))
+
 (let ()
   (define image1 (circle 8 'solid 'red))
   (define image2 (rectangle 40 4 'solid 'blue))