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

added pinhole support to cropping primitives and to frame

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

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

@ -299,13 +299,17 @@
(crop/internal x1 y1 w h image)))
(define (crop/internal x1 y1 width height image)
(let* ([points (rectangle-points width height)])
(let ([points (rectangle-points width height)]
[ph (send image get-pinhole)])
(make-image (make-crop points
(make-translate (- x1) (- y1) (image-shape image)))
(make-bb width
height
(min height (get-baseline image)))
#f)))
#f
(and ph
(make-point (- (point-x ph) x1)
(- (point-y ph) y1))))))
;; place-image : image x y scene -> scene
(define/chk (place-image image1 x1 y1 image2)
@ -366,7 +370,8 @@
(make-bb (get-right image)
(get-bottom image)
(get-baseline image))
#f))
#f
(send image get-pinhole)))
;; scale : I number -> I
;; scales the I by the given factor

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

@ -1664,8 +1664,22 @@
=>
60)
;; crop
;; frame
(test (pinhole-x (crop 2 2 8 10
(center-pinhole (rectangle 10 12 'solid 'red))))
=>
3)
(test (pinhole-y (crop 2 2 8 10
(center-pinhole (rectangle 10 12 'solid 'red))))
=>
4)
(test (pinhole-x (frame (center-pinhole (rectangle 10 12 'solid 'red))))
=>
5)
(test (pinhole-y (frame (center-pinhole (rectangle 10 12 'solid 'red))))
=>
6)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;