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

fix underlay & pinhole combination

Browse Source 
closes PR 13993
This commit is contained in:
Robby Findler 2013-11-02 21:41:09 -05:00
parent b0c79bfcc5
commit 8a7d828cc5
2 changed files with 17 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -143,12 +143,12 @@
;; places images on top of each other with their upper left corners aligned. ;; places images on top of each other with their upper left corners aligned.
;; last one goes on the bottom ;; last one goes on the bottom
(define/chk (overlay image image2 . image3) (define/chk (overlay image image2 . image3)
(overlay/internal 'middle 'middle image (cons image2 image3))) (overlay/internal 'middle 'middle image (cons image2 image3) #t))
;; underlay : image image image ... -> image ;; underlay : image image image ... -> image
(define/chk (underlay image image2 . image3) (define/chk (underlay image image2 . image3)
(let ([imgs (reverse (list* image image2 image3))]) (let ([imgs (reverse (list* image image2 image3))])
(overlay/internal 'middle 'middle (car imgs) (cdr imgs)))) (overlay/internal 'middle 'middle (car imgs) (cdr imgs) #f)))
;; overlay/align : string string image image image ... -> image ;; overlay/align : string string image image image ... -> image
;; the first string has to be one of "center" "middle" "left" or "right" (or symbols) ;; the first string has to be one of "center" "middle" "left" or "right" (or symbols)
@ -167,7 +167,7 @@
image3)) image3))
"when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes" "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes"
'pinhole "pinhole")) 'pinhole "pinhole"))
(overlay/internal x-place y-place image (cons image2 image3))) (overlay/internal x-place y-place image (cons image2 image3) #t))
(define/chk (underlay/align x-place y-place image image2 . image3) (define/chk (underlay/align x-place y-place image image2 . image3)
(when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole)) (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole))
@ -179,25 +179,27 @@
"when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes" "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes"
'pinhole "pinhole")) 'pinhole "pinhole"))
(let ([imgs (reverse (list* image image2 image3))]) (let ([imgs (reverse (list* image image2 image3))])
(overlay/internal x-place y-place (car imgs) (cdr imgs)))) (overlay/internal x-place y-place (car imgs) (cdr imgs) #f)))
(define/chk (overlay/pinhole image1 image2 . image3) (define/chk (overlay/pinhole image1 image2 . image3)
(overlay/internal 'pinhole 'pinhole (overlay/internal 'pinhole 'pinhole
(maybe-center-pinhole image1) (maybe-center-pinhole image1)
(map maybe-center-pinhole (cons image2 image3)))) (map maybe-center-pinhole (cons image2 image3))
#t))
(define/chk (underlay/pinhole image1 image2 . image3) (define/chk (underlay/pinhole image1 image2 . image3)
(let ([imgs (map maybe-center-pinhole (reverse (list* image1 image2 image3)))]) (let ([imgs (map maybe-center-pinhole (reverse (list* image1 image2 image3)))])
(overlay/internal 'pinhole 'pinhole (overlay/internal 'pinhole 'pinhole
(car imgs) (car imgs)
(cdr imgs)))) (cdr imgs)
#f)))
(define (maybe-center-pinhole img) (define (maybe-center-pinhole img)
(if (send img get-pinhole) (if (send img get-pinhole)
img img
(center-pinhole img))) (center-pinhole img)))
(define (overlay/internal x-place y-place fst rst) (define (overlay/internal x-place y-place fst rst first-pinhole?)
(let loop ([fst fst] (let loop ([fst fst]
[rst rst]) [rst rst])
(cond (cond
@ -215,7 +217,7 @@
(car rst) (car rst)
(if (< dx 0) 0 dx) (if (< dx 0) 0 dx)
(if (< dy 0) 0 dy) (if (< dy 0) 0 dy)
#t) first-pinhole?)
(cdr rst)))]))) (cdr rst)))])))
(define (find-x-spot x-place image) (define (find-x-spot x-place image)

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

@ -716,6 +716,13 @@
(make-bb 100 100 100) (make-bb 100 100 100)
#f)) #f))
(test (pinhole-x
(underlay
(put-pinhole 50 50 (rectangle 100 100 "solid" "gray"))
(rectangle 10 10 "solid" "black")))
=>
50)
(test (overlay/offset (rectangle 10 100 'solid 'red) (test (overlay/offset (rectangle 10 100 'solid 'red)
0 0 0 0
(rectangle 100 10 'solid 'blue)) (rectangle 100 10 'solid 'blue))