From 25cf0ea6102725375a503691fd763ac7a09d043f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 22 Jun 2014 23:39:41 -0500 Subject: [PATCH] add crop/align --- .../teachpack/2htdp/scribblings/image.scrbl | 27 +++++++++++++++++++ pkgs/htdp-pkgs/htdp-lib/2htdp/image.rkt | 1 + .../htdp-lib/2htdp/private/image-more.rkt | 11 ++++++++ pkgs/htdp-pkgs/htdp-lib/info.rkt | 2 ++ .../htdp-test/2htdp/tests/test-image.rkt | 19 +++++++++++++ 5 files changed, 60 insertions(+) diff --git a/pkgs/htdp-pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl b/pkgs/htdp-pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl index 281c25dc80..f5a3c571c2 100644 --- a/pkgs/htdp-pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl +++ b/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"] } diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/image.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/image.rkt index caec79155e..ecce6deeaa 100644 --- a/pkgs/htdp-pkgs/htdp-lib/2htdp/image.rkt +++ b/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 diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt index 82eb2b612b..086a677c6e 100644 --- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt +++ b/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 diff --git a/pkgs/htdp-pkgs/htdp-lib/info.rkt b/pkgs/htdp-pkgs/htdp-lib/info.rkt index d6b0fb9961..e0515c230c 100644 --- a/pkgs/htdp-pkgs/htdp-lib/info.rkt +++ b/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") diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt index b3cab01a23..9fbc7daff2 100644 --- a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt +++ b/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))