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

added pinhole support to add-line, add-curve, scene+line, and scene+curve

Browse Source
This commit is contained in:
Robby Findler 2010-09-06 07:24:10 -05:00
parent d2e443ac97
commit 9b720b9c0d
2 changed files with 48 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/2htdp/private/image-more.rkt
View File

@ -336,7 +336,8 @@
(make-line-segment (make-point x1 y1) (make-point x2 y2) color))
(image-shape image))
(image-bb image)
#f)))
#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))]
@ -348,7 +349,8 @@
color))
(image-shape image))
(image-bb image)
#f)))
#f
(send image get-pinhole))))
;; frame : image -> image
;; draws a black frame around a image where the bounding box is
@ -845,7 +847,8 @@
(make-line-segment (make-point x1 y1) (make-point x2 y2) color)
(image-shape image)))
(make-bb right bottom baseline)
#f)))
#f
(send image get-pinhole))))
(define/chk (add-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color)
(let* ([dx (abs (min 0 x1 x2))]
@ -865,7 +868,8 @@
color)
(image-shape image)))
(make-bb right bottom baseline)
#f)))
#f
(send image get-pinhole))))
;; this is just so that 'text' objects can be sized.
(define text-sizing-bm (make-object bitmap-dc% (make-object bitmap% 1 1)))

40
collects/2htdp/tests/test-image.rkt
View File

@ -1626,6 +1626,46 @@
(put-pinhole 5 6 (rectangle 10 12 'solid 'blue)))
=>
#t)
(test (pinhole-x (add-line (center-pinhole (rectangle 100 120 'solid 'red)) 10 10 20 20 'blue))
=>
50)
(test (pinhole-y (add-line (center-pinhole (rectangle 100 120 'solid 'red)) 10 10 20 20 'blue))
=>
60)
(test (pinhole-x (add-curve (center-pinhole (rectangle 100 120 'solid 'red))
10 10 30 1/2
20 20 60 1/2
'white))
=>
50)
(test (pinhole-y (add-curve (center-pinhole (rectangle 100 120 'solid 'red))
10 10 30 1/2
20 20 60 1/2
'white))
=>
60)
(test (pinhole-x (scene+line (center-pinhole (rectangle 100 120 'solid 'red)) 10 10 20 20 'blue))
=>
50)
(test (pinhole-y (scene+line (center-pinhole (rectangle 100 120 'solid 'red)) 10 10 20 20 'blue))
=>
60)
(test (pinhole-x (scene+curve (center-pinhole (rectangle 100 120 'solid 'red))
10 10 30 1/2
20 20 60 1/2
'white))
=>
50)
(test (pinhole-y (scene+curve (center-pinhole (rectangle 100 120 'solid 'red))
10 10 30 1/2
20 20 60 1/2
'white))
=>
60)
;; crop
;; frame
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;