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

preserve pinholes in overlaying and related functions

Browse Source 
(also started to add "pinhole" as a place, but not done with that yet)
This commit is contained in:
Robby Findler 2010-09-06 19:56:42 -05:00
parent 5363396f94
commit d10cd2e6fa
4 changed files with 108 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -134,9 +134,25 @@
;; images up at their centers.
(define/chk (overlay/align x-place y-place image image2 . image3)
(when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole))
(check-dependencies 'overlay/align
(and (send image get-pinhole)
(send image2 get-pinhole)
(andmap (λ (x) (send x get-pinhole))
image3))
"when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes"
'pinhole "pinhole"))
(overlay/internal x-place y-place image (cons image2 image3)))
(define/chk (underlay/align x-place y-place image image2 . image3)
(when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole))
(check-dependencies 'underlay/align
(and (send image get-pinhole)
(send image2 get-pinhole)
(andmap (λ (x) (send x get-pinhole))
image3))
"when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes"
'pinhole "pinhole"))
(let ([imgs (reverse (list* image image2 image3))])
(overlay/internal x-place y-place (car imgs) (cdr imgs))))
@ -157,7 +173,8 @@
(if (< dy 0) (- dy) 0)
(car rst)
(if (< dx 0) 0 dx)
(if (< dy 0) 0 dy))
(if (< dy 0) 0 dy)
#t)
(cdr rst)))])))
(define (find-x-spot x-place image)
@ -165,6 +182,7 @@
[(left) 0]
[(middle) (/ (get-right image) 2)]
[(right) (get-right image)]
[(pinhole) (point-x (send image get-pinhole))]
[else (error 'find-x-spot "~s" x-place)]))
(define (find-y-spot y-place image)
@ -173,6 +191,7 @@
[(middle) (/ (get-bottom image) 2)]
[(bottom) (get-bottom image)]
[(baseline) (get-baseline image)]
[(pinhole) (point-y (send image get-pinhole))]
[else (error 'find-y-spot "~s" y-place)]))
;; overlay/xy : image number number image -> image
@ -184,7 +203,8 @@
(if (< dy 0) (- dy) 0)
image2
(if (< dx 0) 0 dx)
(if (< dy 0) 0 dy)))
(if (< dy 0) 0 dy)
#t))
(define/chk (underlay/xy image dx dy image2)
(overlay/δ image2
@ -192,18 +212,28 @@
(if (< dy 0) 0 dy)
image
(if (< dx 0) (- dx) 0)
(if (< dy 0) (- dy) 0)))
(if (< dy 0) (- dy) 0)
#f))
(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2)
(make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
(make-translate dx2 dy2 (image-shape image2)))
(make-bb (max (+ (get-right image1) dx1)
(+ (get-right image2) dx2))
(max (+ (get-bottom image1) dy1)
(+ (get-bottom image2) dy2))
(max (+ (get-baseline image1) dy1)
(+ (get-baseline image2) dy2)))
#f))
(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2 first-pinhole?)
(make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
(make-translate dx2 dy2 (image-shape image2)))
(make-bb (max (+ (get-right image1) dx1)
(+ (get-right image2) dx2))
(max (+ (get-bottom image1) dy1)
(+ (get-bottom image2) dy2))
(max (+ (get-baseline image1) dy1)
(+ (get-baseline image2) dy2)))
#f
(if first-pinhole?
(let ([ph (send image1 get-pinhole)])
(and ph
(make-point (+ (point-x ph) dx1)
(+ (point-y ph) dy1))))
(let ([ph (send image2 get-pinhole)])
(and ph
(make-point (+ (point-x ph) dx2)
(+ (point-y ph) dy2)))))))
;; beside : image image image ... -> image
;; places images in a single horizontal row, top aligned
@ -231,7 +261,8 @@
(if (< dy 0) (- dy) 0)
(car rst)
(get-right fst)
(if (< dy 0) 0 dy))
(if (< dy 0) 0 dy)
#t)
(cdr rst)))])))
;; above : image image image ... -> image
@ -260,7 +291,8 @@
0
(car rst)
(if (< dx 0) 0 dx)
(get-bottom fst))
(get-bottom fst)
#t)
(cdr rst)))])))
@ -330,7 +362,8 @@
(if (< dy 0) 0 dy)
scene
(if (< dx 0) (- dx) 0)
(if (< dy 0) (- dy) 0)))))
(if (< dy 0) (- dy) 0)
#f))))
(define/chk (scene+line image x1 y1 x2 y2 color)
(let* ([dx (abs (min 0 x1 x2))]

4
collects/2htdp/private/img-err.rkt
View File

@ -251,9 +251,9 @@
argname)]))
(define (y-place? arg)
(member arg '("top" top "bottom" bottom "middle" middle "center" center "baseline" baseline)))
(member arg '("top" top "bottom" bottom "middle" middle "center" center "baseline" baseline "pinhole" pinhole)))
(define (x-place? arg)
(member arg '("left" left "right" right "middle" middle "center" center)))
(member arg '("left" left "right" right "middle" middle "center" center "pinhole" pinhole)))
(define (mode? arg)
(member arg '(solid outline "solid" "outline")))
(define (angle? arg)

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

@ -1680,6 +1680,57 @@
=>
6)
(test (pinhole-x (overlay (put-pinhole 1 2 (rectangle 10 100 'solid 'red))
(put-pinhole 75 9 (rectangle 100 10 'solid 'blue))))
=>
46)
(test (pinhole-y (overlay (put-pinhole 1 2 (rectangle 10 100 'solid 'red))
(put-pinhole 75 9 (rectangle 100 10 'solid 'blue))))
=>
2)
(test (pinhole-x (overlay (put-pinhole 75 9 (rectangle 100 10 'solid 'blue))
(put-pinhole 1 2 (rectangle 10 100 'solid 'red))))
=>
75)
(test (pinhole-y (overlay (put-pinhole 75 9 (rectangle 100 10 'solid 'blue))
(put-pinhole 1 2 (rectangle 10 100 'solid 'red))))
=>
54)
(test (pinhole-x (overlay (rectangle 100 10 'solid 'blue)
(put-pinhole 1 2 (rectangle 10 100 'solid 'red))))
=>
#f)
(test (pinhole-y (overlay (rectangle 100 10 'solid 'blue)
(put-pinhole 1 2 (rectangle 10 100 'solid 'red))))
=>
#f)
(test (pinhole-x (beside (center-pinhole (rectangle 10 100 'solid 'red))
(center-pinhole (rectangle 100 10 'solid 'blue))))
=>
5)
(test (pinhole-y (beside (center-pinhole (rectangle 10 100 'solid 'red))
(center-pinhole (rectangle 100 10 'solid 'blue))))
=>
50)
(test (pinhole-x (above (center-pinhole (rectangle 10 100 'solid 'red))
(center-pinhole (rectangle 100 10 'solid 'blue))))
=>
50)
(test (pinhole-y (above (center-pinhole (rectangle 10 100 'solid 'red))
(center-pinhole (rectangle 100 10 'solid 'blue))))
=>
50)
(test (pinhole-x (place-image (center-pinhole (rectangle 10 100 'solid 'red))
0 0
(center-pinhole (rectangle 100 10 'solid 'blue))))
=>
50)
(test (pinhole-y (place-image (center-pinhole (rectangle 10 100 'solid 'red))
0 0
(center-pinhole (rectangle 100 10 'solid 'blue))))
=>
5)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;

6
collects/teachpack/2htdp/scribblings/image.scrbl
View File

@ -1290,6 +1290,12 @@ Accordingly, when the pixel is on an integral coordinate, then black and white l
take up a single pixel and in the center of their intersections is the actual pinholes.
See @secref["nitty-gritty"] for more details about pixels.
When images are @racket[overlay]'d, @racket[underlay]'d (or the variants of those functions),
placed @racket[beside], or @racket[above] each other,
the pinhole of the resulting image is the pinhole of the first image argument passed to the combining
operation. When images are combined with @racket[place-image] (or the variants of @racket[place-image]),
then the scene argument's pinhole is preserved.
@defproc[(center-pinhole [image image?]) image?]{
Creates a pinhole in @racket[image] at its center.
@image-examples[(center-pinhole (rectangle 40 20 "solid" "red"))