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

PR 9761

Browse Source 
svn: r11779
This commit is contained in:
Robby Findler 2008-09-16 20:26:15 +00:00
parent de0ebda750
commit ce217355f8
2 changed files with 37 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/lang/private/imageeq.ss
View File

@ -32,9 +32,13 @@
(let ([a (coerce-to-cache-image-snip a-raw)]
[b (coerce-to-cache-image-snip b-raw)])
(let-values ([(aw ah) (snip-size a)]
[(bw bh) (snip-size b)])
[(bw bh) (snip-size b)]
[(apx apy) (send a get-pinhole)]
[(bpx bpy) (send b get-pinhole)])
(and (= aw bw)
(= ah bh)
(= apx bpx)
(= apy bpy)
(same/alpha? (argb-vector (send a get-argb))
(argb-vector (send b get-argb)))))))

53
collects/tests/mzscheme/htdp-image.ss
View File

@ -181,25 +181,25 @@
(test (list blue blue blue
blue white blue
blue blue blue)
'color-list2
'color-list3
(image->color-list (rectangle 3 3 "outline" 'blue)))
(test #t
'color-list
'color-list4
(image=? (color-list->image (list blue blue blue blue) 2 2 0 0)
(rectangle 2 2 'solid 'blue)))
(p00 (rectangle 2 2 'solid 'blue))))
(test #f
'color-list
'color-list5
(image=? (color-list->image (list blue blue blue blue) 2 2 0 0)
(rectangle 1 4 'solid 'blue)))
(test #t
'color-list
'color-list6
(image=? (color-list->image (list blue blue blue blue) 1 4 0 0)
(rectangle 1 4 'solid 'blue)))
(p00 (rectangle 1 4 'solid 'blue))))
(test #t
'color-list
'color-list7
(image=? (color-list->image (list 'blue 'blue 'blue 'blue) 2 2 0 0)
(rectangle 2 2 'solid 'blue)))
(p00 (rectangle 2 2 'solid 'blue))))
(test #t
'alpha-color-list1
@ -283,6 +283,17 @@
(image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)
(alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)))
;; different pinholes => different images
(test #f
'image=?1b
(image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 1 0)
(alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)))
(test #f
'image=?1c
(image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)
(alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 1)))
(test #t
'image=?2
(image=? (alpha-color-list->image (list (make-alpha-color 255 100 100 100)) 1 1 0 0)
@ -364,9 +375,9 @@
(test #t
'overlay/xy4
(image=? (color-list->image (list blue blue red red) 2 2 0 0)
(overlay/xy (p00 (rectangle 2 1 'solid 'red))
0 -1
(p00 (rectangle 2 1 'solid 'blue)))))
(p00 (overlay/xy (p00 (rectangle 2 1 'solid 'red))
0 -1
(p00 (rectangle 2 1 'solid 'blue))))))
(test #t
'overlay/xy/white
@ -539,7 +550,7 @@
;; I developed them under macos x. -robby
(test #t
'triangle1
(image=? (triangle 3 'outline 'red)
(image=? (p00 (triangle 3 'outline 'red))
(color-list->image
(list white red white
white red white
@ -552,7 +563,7 @@
(test #t
'triangle2
(image=? (triangle 3 'solid 'red)
(image=? (p00 (triangle 3 'solid 'red))
(color-list->image
(list white red white
white red white
@ -595,19 +606,19 @@
'add-line1
(image=? (overlay (p00 (rectangle 5 4 'solid 'black))
(p00 (rectangle 1 4 'solid 'red)))
(add-line (p00 (rectangle 4 4 'solid 'black))
-1 0
-1 3
'red)))
(p00 (add-line (p00 (rectangle 4 4 'solid 'black))
-1 0
-1 3
'red))))
(test #t
'add-line2
(image=? (overlay (p00 (rectangle 4 5 'solid 'black))
(p00 (rectangle 4 1 'solid 'red)))
(add-line (p00 (rectangle 4 4 'solid 'black))
0 -1
3 -1
'red)))
(p00 (add-line (p00 (rectangle 4 4 'solid 'black))
0 -1
3 -1
'red))))
(test 7
'add-line3