suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added add-polygon and scene+polygon functions.

Browse Source
This commit is contained in:
Stephen Bloch 2013-12-31 13:41:42 -05:00
parent b7f4e10fe1
commit 7b742e7c65
4 changed files with 225 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
pkgs/htdp-pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl
View File

@ -689,6 +689,83 @@ the @racket[point-count] argument determines how many points the star has.
(make-pen "darkslategray" 10 "solid" "projecting" "miter")))]
}
@defproc[(add-polygon [image image?]
[posns (listof posn?)]
[mode mode?]
[color image-color?])
image?]{
Adds a closed polygon to the image @racket[image], with vertices as specified in @racket[posns] (relative to the top-left corner of @racket[image]). Unlike @racket[scene+polygon], if the polygon goes outside the bounds of @racket[image], the result is enlarged to accommodate both.
@mode/color-and-nitty-text
@image-examples[(add-polygon (rectangle 55 34 "solid" "light blue")
(list (make-posn 50 10)
(make-posn 20 15)
(make-posn 50 20)
(make-posn 10 25)
(make-posn 35 30))
"outline" "red")
(add-polygon (square 65 "solid" "light blue")
(list (make-posn 30 -20)
(make-posn 50 50)
(make-posn -20 30))
"solid" "forest green")
(add-polygon (square 180 "solid" "yellow")
(list
(make-posn 109 160)
(make-posn 26 148)
(make-posn 46 36)
(make-posn 93 44)
(make-posn 89 68)
(make-posn 122 72))
"outline" "dark blue")
(add-polygon (square 50 "solid" "light blue")
(list (make-posn 25 -10)
(make-posn 60 25)
(make-posn 25 60)
(make-posn -10 25))
"solid" "pink")]
}
@defproc[(scene+polygon [image image?]
[posns (listof posn?)]
[mode mode?]
[color image-color?])
image?]{
Adds a closed polygon to the image @racket[image], with vertices as specified in @racket[posns] (relative to the top-left corner of @racket[image]). Unlike @racket[add-polygon], if the polygon goes outside the bounds of @racket[image], the result is clipped to @racket[image].
@crop-warning
@image-examples[(scene+polygon (rectangle 55 34 "solid" "light blue")
(list (make-posn 50 10)
(make-posn 20 15)
(make-posn 50 20)
(make-posn 10 25)
(make-posn 35 30))
"outline" "red")
(scene+polygon (square 65 "solid" "light blue")
(list (make-posn 30 -20)
(make-posn 50 50)
(make-posn -20 30))
"solid" "forest green")
(scene+polygon (square 180 "solid" "yellow")
(list
(make-posn 109 160)
(make-posn 26 148)
(make-posn 46 36)
(make-posn 93 44)
(make-posn 89 68)
(make-posn 122 72))
"outline" "dark blue")
(scene+polygon (square 50 "solid" "light blue")
(list (make-posn 25 -10)
(make-posn 60 25)
(make-posn 25 60)
(make-posn -10 25))
"solid" "pink")]
}
@section{Overlaying Images}
@defproc[(overlay [i1 image?] [i2 image?] [is image?] ...) image?]{
@ -1164,6 +1241,7 @@ a black outline.
(make-pen "goldenrod" 30 "solid" "round" "round"))]
}
@defproc[(scene+curve [scene image?]
[x1 real?] [y1 real?] [angle1 angle?] [pull1 real?]
[x2 real?] [y2 real?] [angle2 angle?] [pull2 real?]

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

@ -95,8 +95,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids
right-triangle
line
add-line
add-polygon
add-curve
scene+line
scene+polygon
scene+curve
text
text/font

24
pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt
View File

@ -472,6 +472,19 @@
#f
(send image get-pinhole))))
(define/chk (scene+polygon image posns mode color)
(check-mode/color-combination 'scene+polygon 4 mode color)
(when (null? posns) (error 'scene+polygon "must have at least one posn"))
(make-image (make-overlay
(make-crop (rectangle-points (get-right image) (get-bottom image))
(make-polygon (map (lambda (p) (make-point (posn-x p) (posn-y p))) posns)
mode color))
(image-shape image))
(image-bb image)
#f
(send image get-pinhole)))
(define/chk (scene+curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color)
(let* ([dx (abs (min 0 x1 x2))]
[dy (abs (min 0 y1 y2))])
@ -995,6 +1008,15 @@
#f
(send image get-pinhole))))
(define/chk (add-polygon image posns mode color)
(if (null? posns)
(error 'add-polygon "must have at least one posn")
(let ((left (apply min (map posn-x posns)))
(top (apply min (map posn-y posns)))
(poly (polygon posns mode color)))
(overlay/xy poly (- left) (- top) image)
)))
(define/chk (add-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color)
(define cs (make-curve-segment (make-point x1 y1) angle1 pull1
(make-point x2 y2) angle2 pull2
@ -1533,8 +1555,10 @@
line
add-line
add-polygon
add-curve
scene+line
scene+polygon
scene+curve
text
text/font

121
pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt
View File

@ -1220,6 +1220,127 @@
=>
100)
(test (add-polygon (rectangle 60 50 'solid 'black)
(list (make-posn -10 0)
(make-posn 60 -10)
(make-posn 70 50)
(make-posn 0 60))
'outline 'red)
=>
(overlay/xy
(polygon (list (make-posn 0 10)
(make-posn 70 0)
(make-posn 80 60)
(make-posn 10 70))
'outline 'red)
10 10
(rectangle 60 50 'solid 'black)))
(test (scene+polygon (rectangle 60 50 'solid 'black)
(list (make-posn -10 0)
(make-posn 60 -10)
(make-posn 70 50)
(make-posn 0 60))
'outline 'red)
=>
(rectangle 60 50 'solid 'black))
(test (add-polygon (rectangle 60 60 'solid 'black)
(list (make-posn -10 0)
(make-posn 60 -10)
(make-posn 70 60)
(make-posn 0 70))
'solid 'red)
=>
(polygon (list (make-posn 0 10)
(make-posn 70 0)
(make-posn 80 70)
(make-posn 10 80))
'solid 'red)
)
(test (add-polygon (rectangle 100 60 'solid 'green)
(list (make-posn 70 20)
(make-posn 40 40)
(make-posn 60 60)
(make-posn 5 70)
(make-posn 2 40))
'outline 'red)
=>
(overlay/xy (polygon (list (make-posn 100 50)
(make-posn 70 70)
(make-posn 90 90)
(make-posn 35 100)
(make-posn 32 70))
'outline 'red)
-2 -20
(rectangle 100 60 'solid 'green)))
(test (scene+polygon (rectangle 60 50 'solid 'black)
(list (make-posn -10 0)
(make-posn 60 -10)
(make-posn 70 60)
(make-posn 0 70))
'solid 'red)
=>
(rectangle 60 50 'solid 'red))
(test (scene+polygon (rectangle 120 100 'solid 'black)
(list (make-posn 50 40)
(make-posn 70 40)
(make-posn 70 60)
(make-posn 50 60))
'outline 'red)
=>
(overlay (square 20 'outline 'red) (rectangle 120 100 'solid 'black)))
(test (scene+polygon (rectangle 90 100 'solid 'black)
(list (make-posn 30 10)
(make-posn 100 20)
(make-posn 50 30)
(make-posn 100 40)
(make-posn 30 50))
'solid 'red)
=>
(place-image/align (polygon (list (make-posn 30 50)
(make-posn 100 40)
(make-posn 50 30)
(make-posn 100 20)
(make-posn 30 10))
'solid 'red)
30 10 'left 'top (rectangle 90 100 'solid 'black)))
(test (image-width (scene+polygon (rectangle 90 100 'solid 'black)
(list (make-posn 30 10)
(make-posn 100 20)
(make-posn 50 30)
(make-posn 100 40)
(make-posn 30 50))
'outline 'orange))
=> 90)
(test (image-height (scene+polygon (rectangle 90 100 'solid 'black)
(list (make-posn 30 10)
(make-posn 100 20)
(make-posn 50 30)
(make-posn 100 40)
(make-posn 30 50))
'outline 'orange))
=> 100)
(test (scene+polygon (rectangle 100 100 'solid 'blue)
(list (make-posn 20 10)
(make-posn -10 -20)
(make-posn -20 -10)
(make-posn 10 20))
'outline 'orange)
=>
(place-image/align (polygon (list (make-posn -20 -10)
(make-posn 10 20)
(make-posn 20 10)
(make-posn -10 -20))
'outline 'orange)
-20 -20 'left 'top
(rectangle 100 100 'solid 'blue)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; curves