1040 lines
36 KiB
Scheme
1040 lines
36 KiB
Scheme
;; Load this one with MrEd
|
|
|
|
(load-relative "loadtest.ss")
|
|
(require (lib "image.ss" "htdp")
|
|
(lib "error.ss" "htdp")
|
|
(lib "posn.ss" "lang")
|
|
(lib "imageeq.ss" "lang"))
|
|
|
|
(define-values (image-snip1 image-snip2)
|
|
(let ()
|
|
(define size 2)
|
|
|
|
(define (do-draw c-bm m-bm)
|
|
(let ([bdc (make-object bitmap-dc% c-bm)])
|
|
(send bdc clear)
|
|
(send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
|
|
(send bdc set-brush (send the-brush-list find-or-create-brush "red" 'solid))
|
|
(send bdc draw-rectangle 0 0 size size)
|
|
(send bdc set-bitmap m-bm)
|
|
(send bdc clear)
|
|
(send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
|
|
(send bdc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
|
|
(send bdc draw-rectangle 0 0 (/ size 2) size)
|
|
(send bdc set-bitmap #f)))
|
|
|
|
(define image-snip1
|
|
(let* ([c-bm (make-object bitmap% size size)]
|
|
[m-bm (make-object bitmap% size size #t)])
|
|
(do-draw c-bm m-bm)
|
|
(make-object image-snip% c-bm m-bm)))
|
|
|
|
(define image-snip2
|
|
(let* ([c-bm (make-object bitmap% size size)]
|
|
[m-bm (make-object bitmap% size size)])
|
|
(do-draw c-bm m-bm)
|
|
(send c-bm set-loaded-mask m-bm)
|
|
(make-object image-snip% c-bm)))
|
|
|
|
(values image-snip1 image-snip2)))
|
|
|
|
(define image-snip3 (make-object image-snip%))
|
|
|
|
;; check-on-bitmap : symbol snip -> void
|
|
;; checks on various aspects of the bitmap snips to make
|
|
;; sure that they draw properly
|
|
(define (check-on-bitmap name snp)
|
|
(let-values ([(width height) (send snp get-size)])
|
|
(let ([bdc (make-object bitmap-dc%)]
|
|
[max-difference
|
|
(lambda (s1 s2)
|
|
(apply max
|
|
(map (lambda (x y) (abs (- x y)))
|
|
(bytes->list s1)
|
|
(bytes->list s1))))])
|
|
|
|
;; test that no drawing is outside the snip's drawing claimed drawing area
|
|
(let ([bm-clip (make-object bitmap% (+ width 100) (+ height 100))]
|
|
[bm-noclip (make-object bitmap% (+ width 100) (+ height 100))]
|
|
[s-clip (make-bytes (* (+ width 100) (+ height 100) 4))]
|
|
[s-noclip (make-bytes (* (+ width 100) (+ height 100) 4))])
|
|
(send bdc set-bitmap bm-clip)
|
|
(send bdc clear)
|
|
(send bdc set-clipping-rect 50 50 width height)
|
|
(send snp draw bdc 50 50 0 0 (+ width 100) (+ height 100) 0 0 #f)
|
|
(send bdc set-clipping-region #f)
|
|
(send bdc get-argb-pixels 0 0 (+ width 100) (+ height 100) s-clip)
|
|
|
|
(send bdc set-bitmap bm-noclip)
|
|
(send bdc clear)
|
|
(send snp draw bdc 50 50 0 0 (+ width 100) (+ height 100) 0 0 #f)
|
|
(send bdc get-argb-pixels 0 0 (+ width 100) (+ height 100) s-noclip)
|
|
(send bdc set-bitmap #f)
|
|
(test (list 'bmclip name #t) (lambda () (list 'bmclip name (equal? s-clip s-noclip)))))
|
|
|
|
(let ([bm-normal (make-object bitmap% width height)]
|
|
[bm-bitmap (make-object bitmap% width height)]
|
|
[s-normal (make-bytes (* width height 4))]
|
|
[s-bitmap (make-bytes (* width height 4))])
|
|
|
|
(send bdc set-bitmap bm-normal)
|
|
(send bdc clear)
|
|
(send snp draw bdc 0 0 0 0 width height 0 0 #f)
|
|
(send bdc get-argb-pixels 0 0 width height s-normal)
|
|
(send bdc set-bitmap bm-bitmap)
|
|
(send bdc clear)
|
|
|
|
;; force the snip to switch over to bitmap mode
|
|
(send snp get-argb)
|
|
|
|
(send snp draw bdc 0 0 0 0 width height 0 0 #f)
|
|
(send bdc get-argb-pixels 0 0 width height s-bitmap)
|
|
(send bdc set-bitmap #f)
|
|
(test (list 'bmsame name #t)
|
|
(lambda () (list 'bmsame name
|
|
(<= (max-difference s-normal s-bitmap) 2))))))))
|
|
|
|
(test #t 'image? (image? (rectangle 10 10 'solid 'blue)))
|
|
(test #t 'image? (image? (rectangle 10 10 "solid" 'blue)))
|
|
(test #t 'image? (image? (rectangle 10 10 'outline 'blue)))
|
|
(test #t 'image? (image? (rectangle 10 10 "outline" 'blue)))
|
|
(test #f 'image? (image? 5))
|
|
|
|
(define red (make-color 255 0 0))
|
|
(define blue (make-color 0 0 255))
|
|
(define black (make-color 0 0 0))
|
|
(define white (make-color 255 255 255))
|
|
|
|
(define awhite (make-alpha-color 0 255 255 255))
|
|
(define ablack (make-alpha-color 0 0 0 0))
|
|
(define ared (make-alpha-color 0 255 0 0))
|
|
(define aclr (make-alpha-color 255 0 0 0))
|
|
|
|
(define (p00 i) (move-pinhole i (- (pinhole-x i)) (- (pinhole-y i))))
|
|
(define (ignore x) 'ignore)
|
|
|
|
(test 3
|
|
'pinhole-x
|
|
(pinhole-x (rectangle 6 8 'solid 'black)))
|
|
(test 4
|
|
'pinhole-y
|
|
(pinhole-y (rectangle 6 8 'solid 'black)))
|
|
(test 1
|
|
'move-pinhole1
|
|
(pinhole-x (move-pinhole (rectangle 6 8 'solid 'black) -2 -2)))
|
|
(test 2
|
|
'move-pinhole2
|
|
(pinhole-y (move-pinhole (rectangle 6 8 'solid 'black) -2 -2)))
|
|
|
|
(test (list red)
|
|
'color-list
|
|
(image->color-list (rectangle 1 1 'solid 'red)))
|
|
|
|
(test (list (list red) (list blue) (list black) (list white))
|
|
'colors-set-up-properly
|
|
(list (image->color-list (rectangle 1 1 'solid 'red))
|
|
(image->color-list (rectangle 1 1 'solid 'blue))
|
|
(image->color-list (rectangle 1 1 'solid 'black))
|
|
(image->color-list (rectangle 1 1 'solid 'white))))
|
|
|
|
(test (list blue blue blue blue)
|
|
'color-list
|
|
(image->color-list (rectangle 2 2 'solid 'blue)))
|
|
|
|
(test (list blue blue blue
|
|
blue blue blue
|
|
blue blue blue)
|
|
'color-list2
|
|
(image->color-list (rectangle 3 3 'solid 'blue)))
|
|
(test (list blue blue blue
|
|
blue blue blue
|
|
blue blue blue)
|
|
'color-list2
|
|
(image->color-list (rectangle 3 3 "solid" 'blue)))
|
|
(test (list blue blue blue
|
|
blue white blue
|
|
blue blue blue)
|
|
'color-list2
|
|
(image->color-list (rectangle 3 3 'outline 'blue)))
|
|
(test (list blue blue blue
|
|
blue white blue
|
|
blue blue blue)
|
|
'color-list2
|
|
(image->color-list (rectangle 3 3 "outline" 'blue)))
|
|
|
|
(test #t
|
|
'color-list
|
|
(image=? (color-list->image (list blue blue blue blue) 2 2 0 0)
|
|
(rectangle 2 2 'solid 'blue)))
|
|
(test #f
|
|
'color-list
|
|
(image=? (color-list->image (list blue blue blue blue) 2 2 0 0)
|
|
(rectangle 1 4 'solid 'blue)))
|
|
(test #t
|
|
'color-list
|
|
(image=? (color-list->image (list blue blue blue blue) 1 4 0 0)
|
|
(rectangle 1 4 'solid 'blue)))
|
|
|
|
(test #t
|
|
'alpha-color-list1
|
|
(equal? (make-alpha-color 0 255 0 0)
|
|
(car (image->alpha-color-list (rectangle 1 1 'solid 'red)))))
|
|
(test #t
|
|
'alpha-color-list2
|
|
(equal? (make-alpha-color 0 255 0 0)
|
|
(car (image->alpha-color-list (rectangle 1 1 "solid" 'red)))))
|
|
|
|
(test #t
|
|
'alpha-color-list3
|
|
(andmap (lambda (x) (equal? x (make-alpha-color 0 255 0 0)))
|
|
(image->alpha-color-list (rectangle 1 1 "solid" 'red))))
|
|
(test #t
|
|
'alpha-color-list4
|
|
(andmap (lambda (x) (equal? x (make-alpha-color 0 255 0 0)))
|
|
(image->alpha-color-list (rectangle 1 1 'solid 'red))))
|
|
|
|
(test #t
|
|
'alpha-color-list5
|
|
(equal? (make-alpha-color 0 0 255 0)
|
|
(car (image->alpha-color-list (rectangle 1 1 'solid 'green)))))
|
|
(test #t
|
|
'alpha-color-list6
|
|
(equal? (make-alpha-color 0 0 0 255)
|
|
(car (image->alpha-color-list (rectangle 1 1 'solid 'blue)))))
|
|
|
|
(test #t
|
|
'alpha-color-list7
|
|
(= (image-width
|
|
(alpha-color-list->image
|
|
(list ared aclr ared
|
|
aclr aclr aclr)
|
|
3
|
|
2
|
|
0
|
|
0))
|
|
3))
|
|
|
|
(test #t
|
|
'alpha-color-list8
|
|
(= (image-height
|
|
(alpha-color-list->image
|
|
(list ared aclr ared
|
|
aclr aclr aclr)
|
|
3
|
|
2
|
|
0
|
|
0))
|
|
2))
|
|
|
|
(test #t
|
|
'alpha-color-list9
|
|
(equal? (image->color-list
|
|
(alpha-color-list->image
|
|
(list ared aclr ared
|
|
aclr aclr aclr)
|
|
3 2 0 0))
|
|
(list red white red
|
|
white white white)))
|
|
(test #t
|
|
'alpha-color-list10
|
|
(equal? (image->color-list
|
|
(overlay
|
|
(p00 (rectangle 3 3 'solid 'blue))
|
|
(p00 (alpha-color-list->image
|
|
(list ared aclr ared
|
|
aclr aclr aclr
|
|
ared aclr ared)
|
|
3
|
|
3
|
|
0
|
|
0))))
|
|
(list red blue red
|
|
blue blue blue
|
|
red blue red)))
|
|
|
|
(test #t
|
|
'image=?1
|
|
(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)))
|
|
|
|
(test #t
|
|
'image=?2
|
|
(image=? (alpha-color-list->image (list (make-alpha-color 255 100 100 100)) 1 1 0 0)
|
|
(alpha-color-list->image (list (make-alpha-color 255 200 200 200)) 1 1 0 0)))
|
|
|
|
(test #f
|
|
'image=?3
|
|
(image=? (alpha-color-list->image (list (make-alpha-color 200 100 100 100)) 1 1 0 0)
|
|
(alpha-color-list->image (list (make-alpha-color 200 200 200 200)) 1 1 0 0)))
|
|
|
|
(test #f
|
|
'image=?4
|
|
(image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)
|
|
(make-alpha-color 200 100 150 175))
|
|
1
|
|
2
|
|
0
|
|
0)
|
|
(alpha-color-list->image (list (make-alpha-color 200 100 150 175)
|
|
(make-alpha-color 200 100 150 175))
|
|
2
|
|
1
|
|
0
|
|
0)))
|
|
|
|
(test #f
|
|
'image=?5
|
|
(image=? (rectangle 4 4 'outline 'black)
|
|
(overlay/xy
|
|
(rectangle 4 4 'outline 'black)
|
|
-1
|
|
-1
|
|
(circle 1 'solid 'red))))
|
|
|
|
(test #t
|
|
'overlay
|
|
(image=? (color-list->image (list blue red blue red) 2 2 0 0)
|
|
(overlay (p00 (rectangle 2 2 'solid 'red))
|
|
(p00 (rectangle 1 2 'solid 'blue)))))
|
|
|
|
(test #t
|
|
'overlay/multiple
|
|
(image=? (overlay (rectangle 6 6 'solid 'red)
|
|
(overlay (rectangle 4 4 'solid 'white)
|
|
(rectangle 2 2 'solid 'blue)))
|
|
(overlay (rectangle 6 6 'solid 'red)
|
|
(rectangle 4 4 'solid 'white)
|
|
(rectangle 2 2 'solid 'blue))))
|
|
|
|
(test #t
|
|
'overlay/empty-spaces-are-unmasked
|
|
(image=? (color-list->image (list red red red blue) 2 2 0 0)
|
|
(overlay
|
|
(p00 (rectangle 2 2 'solid 'blue))
|
|
(overlay (p00 (rectangle 1 2 'solid 'red))
|
|
(p00 (rectangle 2 1 'solid 'red))))))
|
|
|
|
(test #t
|
|
'overlay/xy1
|
|
(image=? (color-list->image (list red blue red blue) 2 2 0 0)
|
|
(overlay/xy (p00 (rectangle 2 2 'solid 'red))
|
|
1 0
|
|
(p00 (rectangle 1 2 'solid 'blue)))))
|
|
|
|
(test #t
|
|
'overlay/xy2
|
|
(image=? (color-list->image (list red red red blue) 2 2 0 0)
|
|
(overlay/xy (p00 (rectangle 2 2 'solid 'red))
|
|
1 1
|
|
(p00 (rectangle 1 1 'solid 'blue)))))
|
|
|
|
(test #t
|
|
'overlay/xy3
|
|
(image=? (color-list->image (list red red blue blue) 2 2 0 0)
|
|
(overlay/xy (p00 (rectangle 2 1 'solid 'red))
|
|
0 1
|
|
(p00 (rectangle 2 1 'solid 'blue)))))
|
|
|
|
(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)))))
|
|
|
|
(test #t
|
|
'overlay/xy/white
|
|
(image=? (alpha-color-list->image (list ablack ablack ablack
|
|
ablack awhite ablack
|
|
ablack ablack ablack)
|
|
3 3 0 0)
|
|
(overlay/xy (p00 (rectangle 3 3 'solid 'black))
|
|
1 1
|
|
(p00 (rectangle 1 1 'solid 'white)))))
|
|
|
|
(test #t
|
|
'color-list->image/white-in-mask
|
|
(image=? (color-list->image (list black red black
|
|
red red red
|
|
black red black)
|
|
3 3 0 0)
|
|
(overlay (p00 (rectangle 3 3 'solid 'red))
|
|
(color-list->image (list black white black
|
|
white white white
|
|
black white black)
|
|
3 3 0 0))))
|
|
|
|
|
|
(test #t
|
|
'overlay
|
|
(image=? (color-list->image (list red blue red red blue red) 3 2 0 0)
|
|
(overlay/xy (p00 (rectangle 3 2 'solid 'red))
|
|
1 0
|
|
(p00 (rectangle 1 2 'solid 'blue)))))
|
|
|
|
(test #t
|
|
'image-inside?1
|
|
(image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red))
|
|
1 0
|
|
(p00 (rectangle 1 2 'solid 'blue)))
|
|
(rectangle 1 2 'solid 'blue)))
|
|
|
|
(test #f
|
|
'image-inside?2
|
|
(image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red))
|
|
1 0
|
|
(p00 (rectangle 1 2 'solid 'blue)))
|
|
(rectangle 1 2 'solid 'black)))
|
|
|
|
(test #t
|
|
'image-inside?3
|
|
(image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red))
|
|
1 0
|
|
(p00 (rectangle 1 2 'solid 'blue)))
|
|
(rectangle 1 2 'solid 'red)))
|
|
|
|
(test #f
|
|
'image-inside?4
|
|
(image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red))
|
|
1 0
|
|
(p00 (rectangle 1 2 'solid 'blue)))
|
|
(rectangle 2 1 'solid 'red)))
|
|
|
|
(test #t
|
|
'image-inside?5
|
|
(image-inside? (alpha-color-list->image (list (make-alpha-color 0 255 0 0)) 1 1 0 0)
|
|
(alpha-color-list->image (list (make-alpha-color 255 0 0 0)) 1 1 0 0)))
|
|
|
|
(test #f
|
|
'image-inside?6
|
|
(image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red))
|
|
1 0
|
|
(p00 (rectangle 1 2 'solid 'blue)))
|
|
(color-list->image (list blue white white)
|
|
3 1 0 0)))
|
|
|
|
(test #t
|
|
'image-inside?7
|
|
(image-inside? (overlay/xy (p00 (rectangle 16 16 'solid 'red))
|
|
2 5
|
|
(p00 (ellipse 6 6 'outline 'blue)))
|
|
(ellipse 6 6 'outline 'blue)))
|
|
|
|
(test #t
|
|
'image-inside?8
|
|
(image-inside?
|
|
(overlay (p00 (rectangle (image-width (text "x" 12 'red))
|
|
(image-height (text "x" 12 'red))
|
|
'solid
|
|
'white))
|
|
(text "x" 12 'red))
|
|
(text "x" 12 'red)))
|
|
|
|
(test #t
|
|
'image-inside?9
|
|
(image-inside?
|
|
(text "y x y" 12 'red)
|
|
(text "x" 12 'red)))
|
|
|
|
(test (make-posn 2 5)
|
|
'find-image1
|
|
(find-image (overlay/xy (p00 (rectangle 16 16 'solid 'red))
|
|
2 5
|
|
(p00 (ellipse 6 6 'outline 'blue)))
|
|
(p00 (ellipse 6 6 'outline 'blue))))
|
|
|
|
(test (make-posn 0 0)
|
|
'find-image2
|
|
(find-image (p00 (rectangle 16 16 'solid 'blue))
|
|
(p00 (ellipse 6 6 'outline 'blue))))
|
|
|
|
(test (make-posn 1 1)
|
|
'find-image3
|
|
(find-image (overlay/xy (rectangle 10 10 'solid 'blue)
|
|
1
|
|
1
|
|
(ellipse 5 5 'solid 'red))
|
|
(ellipse 5 5 'solid 'red)))
|
|
|
|
(test 5
|
|
'image-width
|
|
(image-width (rectangle 5 7 'solid 'red)))
|
|
|
|
(test 7
|
|
'image-height
|
|
(image-height (rectangle 5 7 'solid 'red)))
|
|
|
|
(test 1 'color-red (color-red (make-color 1 2 3)))
|
|
(test 2 'color-green (color-green (make-color 1 2 3)))
|
|
(test 3 'color-blue (color-blue (make-color 1 2 3)))
|
|
(test #t 'color?1 (color? (make-color 1 2 3)))
|
|
(test #f 'color?2 (color? 10))
|
|
(test #t 'image-color?1 (image-color? (make-color 1 2 3)))
|
|
(test #t 'image-color?2 (image-color? "blue"))
|
|
(test #t 'image-color?3 (image-color? 'blue))
|
|
(test #f 'image-color?4 (image-color? 10))
|
|
(test #f 'image-color?5 (image-color? "not-a-color"))
|
|
(test #f 'image-color?6 (image-color? 'not-a-color))
|
|
|
|
(test #t
|
|
'line
|
|
(image=? (line 4 0 'red)
|
|
(color-list->image (list red red red red red) 5 1 0 0)))
|
|
|
|
(test #t
|
|
'line
|
|
(image=? (line 0 4 'red)
|
|
(color-list->image (list red red red red red) 1 5 0 0)))
|
|
|
|
;; note: next two tests may be platform-specific... I'm not sure.
|
|
;; I developed them under macos x. -robby
|
|
(test #t
|
|
'triangle1
|
|
(image=? (triangle 3 'outline 'red)
|
|
(color-list->image
|
|
(list white red white
|
|
white red white
|
|
red white red
|
|
red red red)
|
|
3
|
|
4
|
|
0
|
|
0)))
|
|
|
|
(test #t
|
|
'triangle2
|
|
(image=? (triangle 3 'solid 'red)
|
|
(color-list->image
|
|
(list white red white
|
|
white red white
|
|
red red red
|
|
red red red)
|
|
3
|
|
4
|
|
0
|
|
0)))
|
|
|
|
(test #t
|
|
'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)))
|
|
|
|
(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)))
|
|
|
|
(test 7
|
|
'add-line3
|
|
(image-width (add-line (rectangle 7 7 'solid 'black)
|
|
-3 0
|
|
2 0
|
|
'red)))
|
|
|
|
(test #t
|
|
'add-line4
|
|
(image=? (overlay (rectangle 6 6 'solid 'blue)
|
|
(rectangle 6 1 'solid 'red))
|
|
(add-line (rectangle 6 6 'solid 'blue)
|
|
-3 0
|
|
2 0
|
|
'red)))
|
|
|
|
(test 26
|
|
'add-line-w1
|
|
(image-width
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
-20 -20
|
|
0 0
|
|
'red)))
|
|
(test 26
|
|
'add-line-w2
|
|
(image-width
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
-20 20
|
|
0 0
|
|
'red)))
|
|
(test 26
|
|
'add-line-w3
|
|
(image-width
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
20 -20
|
|
0 0
|
|
'red)))
|
|
(test 26
|
|
'add-line-w4
|
|
(image-width
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
20 20
|
|
0 0
|
|
'red)))
|
|
|
|
(test 26
|
|
'add-line-w5
|
|
(image-width
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
-20 -20
|
|
'red)))
|
|
(test 26
|
|
'add-line-w6
|
|
(image-width
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
-20 20
|
|
'red)))
|
|
(test 26
|
|
'add-line-w7
|
|
(image-width
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
20 -20
|
|
'red)))
|
|
(test 26
|
|
'add-line-w8
|
|
(image-width
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
20 20
|
|
'red)))
|
|
|
|
(test 26
|
|
'add-line-h1
|
|
(image-height
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
-20 -20
|
|
0 0
|
|
'red)))
|
|
(test 26
|
|
'add-line-h2
|
|
(image-height
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
-20 20
|
|
0 0
|
|
'red)))
|
|
(test 26
|
|
'add-line-h3
|
|
(image-height
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
20 -20
|
|
0 0
|
|
'red)))
|
|
(test 26
|
|
'add-line-h4
|
|
(image-height
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
20 20
|
|
0 0
|
|
'red)))
|
|
|
|
(test 26
|
|
'add-line-h5
|
|
(image-height
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
-20 -20
|
|
'red)))
|
|
(test 26
|
|
'add-line-h6
|
|
(image-height
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
-20 20
|
|
'red)))
|
|
(test 26
|
|
'add-line-h7
|
|
(image-height
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
20 -20
|
|
'red)))
|
|
(test 26
|
|
'add-line-h8
|
|
(image-height
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
20 20
|
|
'red)))
|
|
|
|
(test 5
|
|
image-width
|
|
(add-line (line 0 0 'red) 3.141597 3 0 0 'black))
|
|
|
|
(test 'ignore
|
|
(lambda (x) 'ignore)
|
|
;; Make sure that inexact coordinate doesn't create inexact
|
|
;; width:
|
|
(send (add-line (line 0 0 'red) 3.141597 3 0 0 'black) get-argb))
|
|
|
|
(test (list 3 4)
|
|
'ph-ellipse
|
|
(list (pinhole-x (ellipse 6 8 'solid 'red))
|
|
(pinhole-y (ellipse 6 8 'solid 'red))))
|
|
(test (list 3 3)
|
|
'ph-circle
|
|
(list (pinhole-x (circle 3 'solid 'red))
|
|
(pinhole-y (circle 3 'solid 'red))))
|
|
(test (list 0 0)
|
|
'ph-line
|
|
(list (pinhole-x (line 10 10 'red))
|
|
(pinhole-y (line 10 10 'red))))
|
|
(test (list 0 0)
|
|
'ph-text
|
|
(list (pinhole-x (text "10" 10 'red))
|
|
(pinhole-y (text "10" 10 'red))))
|
|
|
|
(test (list 3 3)
|
|
'ph-add-line
|
|
(list (pinhole-x (add-line (rectangle 6 6 'solid 'red)
|
|
0 0
|
|
3 3
|
|
'black))
|
|
(pinhole-y (add-line (rectangle 6 6 'solid 'red)
|
|
0 0
|
|
3 3
|
|
'black))))
|
|
(test (list 3 4)
|
|
'ph-overlay1
|
|
(list (pinhole-x (overlay (rectangle 6 8 'solid 'red) (rectangle 2 4 'solid 'red)))
|
|
(pinhole-y (overlay (rectangle 6 8 'solid 'red) (rectangle 2 4 'solid 'red)))))
|
|
(test (list 0 0)
|
|
'ph-overlay2
|
|
(list (pinhole-x (overlay (move-pinhole (rectangle 6 8 'solid 'red) -3 -4)
|
|
(move-pinhole (rectangle 2 4 'solid 'red) -1 -2)))
|
|
(pinhole-y (overlay (move-pinhole (rectangle 6 8 'solid 'red) -3 -4)
|
|
(move-pinhole (rectangle 2 4 'solid 'red) -1 -2)))))
|
|
(test (list 5 5)
|
|
'ph-overlay/xy1
|
|
(list (pinhole-x (overlay/xy (move-pinhole (rectangle 6 8 'solid 'red) -3 -4)
|
|
-5 -5
|
|
(move-pinhole (rectangle 2 4 'solid 'red) -1 -2)))
|
|
(pinhole-y (overlay/xy (move-pinhole (rectangle 6 8 'solid 'red) -3 -4)
|
|
-5 -5
|
|
(move-pinhole (rectangle 2 4 'solid 'red) -1 -2)))))
|
|
|
|
|
|
(check-on-bitmap 'solid-rect (rectangle 2 2 'solid 'red))
|
|
(check-on-bitmap 'outline-rect (rectangle 2 2 'outline 'red))
|
|
(check-on-bitmap 'solid-ellipse (ellipse 2 4 'solid 'red))
|
|
(check-on-bitmap 'outline-ellipse (ellipse 2 4 'outline 'red))
|
|
(check-on-bitmap 'solid-ellipse (circle 4 'solid 'red))
|
|
(check-on-bitmap 'outline-ellipse (circle 4 'outline 'red))
|
|
(check-on-bitmap 'solid-triangle (triangle 10 'solid 'red))
|
|
(check-on-bitmap 'outline-triangle (triangle 10 'outline 'red))
|
|
(check-on-bitmap 'line (line 10 7 'red))
|
|
(check-on-bitmap 'text (text "XX" 12 'red))
|
|
(check-on-bitmap 'overlay1 (overlay (p00 (rectangle 1 4 'solid 'blue))
|
|
(p00 (rectangle 4 1 'solid 'green))))
|
|
(check-on-bitmap 'overlay2 (overlay/xy (p00 (rectangle 4 4 'solid 'blue))
|
|
2 2
|
|
(p00 (rectangle 4 4 'solid 'green))))
|
|
(check-on-bitmap 'overlay3 (overlay image-snip1
|
|
(rectangle (image-width image-snip1)
|
|
(image-height image-snip1)
|
|
'outline
|
|
'red)))
|
|
(check-on-bitmap 'alpha-color-list
|
|
(overlay
|
|
(p00 (rectangle 3 3 'solid 'blue))
|
|
(alpha-color-list->image
|
|
(list ared aclr ared
|
|
aclr aclr aclr
|
|
ared aclr ared)
|
|
3
|
|
3
|
|
0
|
|
0)))
|
|
(check-on-bitmap 'add-line
|
|
(add-line
|
|
(p00 (rectangle 100 100 'solid 'black))
|
|
-10 -10
|
|
110 110
|
|
'red))
|
|
|
|
(check-on-bitmap 'add-line1
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
-20 -20
|
|
0 0
|
|
'red))
|
|
(check-on-bitmap 'add-line2
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
-20 20
|
|
0 0
|
|
'red))
|
|
(check-on-bitmap 'add-line3
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
20 -20
|
|
0 0
|
|
'red))
|
|
(check-on-bitmap 'add-line4
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
20 20
|
|
0 0
|
|
'red))
|
|
(check-on-bitmap 'add-line5
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
-20 -20
|
|
'red))
|
|
(check-on-bitmap 'add-line6
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
-20 20
|
|
'red))
|
|
(check-on-bitmap 'add-line7
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
20 -20
|
|
'red))
|
|
(check-on-bitmap 'add-line8
|
|
(add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green))
|
|
0 0
|
|
20 20
|
|
'red))
|
|
|
|
#|
|
|
|
|
The tests beginning with "bs-" ensure
|
|
that the operations all can accept bitmap
|
|
snips as arguments
|
|
|
|
|#
|
|
|
|
(test #t
|
|
'bs-image?
|
|
(image? image-snip1))
|
|
(test #t
|
|
'bs-image?
|
|
(image? image-snip2))
|
|
(test #t
|
|
'bs-image=?
|
|
(image=? image-snip1 image-snip2))
|
|
(test 2
|
|
'bs-image-width
|
|
(image-width image-snip1))
|
|
(test 2
|
|
'bs-image-width
|
|
(image-width image-snip2))
|
|
(test 2
|
|
'bs-image-height
|
|
(image-height image-snip1))
|
|
(test 2
|
|
'bs-image-height
|
|
(image-height image-snip2))
|
|
(test #t
|
|
'bs-overlay
|
|
(image=? image-snip1 (overlay image-snip1 image-snip2)))
|
|
(test #t
|
|
'bs-overlay/xy
|
|
(image=? image-snip1 (overlay/xy image-snip1 0 0 image-snip2)))
|
|
(test #t
|
|
'bs-add-line
|
|
(image=?
|
|
(add-line image-snip1 0 0 10 10 'green)
|
|
(add-line image-snip2 0 0 10 10 'green)))
|
|
(test #t
|
|
'bs-image-inside?1
|
|
(image-inside? image-snip1 image-snip2))
|
|
(test #t
|
|
'bs-image-inside?2
|
|
(image-inside? image-snip1 image-snip2))
|
|
(test (make-posn 0 0)
|
|
'bs-find-image1
|
|
(find-image image-snip1 image-snip2))
|
|
(test (make-posn 0 0)
|
|
'bs-find-image2
|
|
(find-image image-snip2 image-snip1))
|
|
(test #t
|
|
'bs-image->color-list
|
|
(equal? (image->color-list image-snip1)
|
|
(image->color-list image-snip2)))
|
|
(test #t
|
|
'bs-image->alpha-color-list
|
|
(equal? (image->alpha-color-list image-snip1)
|
|
(image->alpha-color-list image-snip2)))
|
|
(test 1
|
|
'bs-pinhole-x
|
|
(pinhole-x image-snip1))
|
|
(test 1
|
|
'bs-pinhole-y
|
|
(pinhole-y image-snip2))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; test image-snip that doesnt' have a bitmap
|
|
;;
|
|
|
|
(test 20
|
|
'image-snip-no-bitmap1
|
|
(image-width image-snip3))
|
|
|
|
(test 'passed
|
|
'image-snip-no-bitmap2
|
|
(begin (overlay/xy image-snip3 10 10 image-snip3) 'passed))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; test color arguments
|
|
;;
|
|
|
|
(test 'ignore
|
|
'clr-rectangle-sym
|
|
(ignore (rectangle 10 10 'solid 'blue)))
|
|
(test 'ignore
|
|
'clr-rectangle-str
|
|
(ignore (rectangle 10 10 'solid "blue")))
|
|
(test 'ignore
|
|
'clr-rectangle-clr
|
|
(ignore (rectangle 10 10 'solid (make-color 0 0 255))))
|
|
|
|
(test 'ignore
|
|
'clr-ellipse-sym
|
|
(ignore (ellipse 10 10 'solid 'blue)))
|
|
(test 'ignore
|
|
'clr-ellipse-str
|
|
(ignore (ellipse 10 10 'solid "blue")))
|
|
(test 'ignore
|
|
'clr-ellipse-clr
|
|
(ignore (ellipse 10 10 'solid (make-color 0 0 255))))
|
|
|
|
(test 'ignore
|
|
'clr-circle-sym
|
|
(ignore (circle 10 'solid 'blue)))
|
|
(test 'ignore
|
|
'clr-circle-str
|
|
(ignore (circle 10 'solid "blue")))
|
|
(test 'ignore
|
|
'clr-circle-clr
|
|
(ignore (circle 10 'solid (make-color 0 0 255))))
|
|
|
|
(test 'ignore
|
|
'clr-triangle-sym
|
|
(ignore (triangle 10 'solid 'blue)))
|
|
(test 'ignore
|
|
'clr-triangle-str
|
|
(ignore (triangle 10 'solid "blue")))
|
|
(test 'ignore
|
|
'clr-triangle-clr
|
|
(ignore (triangle 10 'solid (make-color 0 0 255))))
|
|
|
|
(test 'ignore
|
|
'clr-line-sym
|
|
(ignore (line 10 10 'blue)))
|
|
(test 'ignore
|
|
'clr-line-str
|
|
(ignore (line 10 10 "blue")))
|
|
(test 'ignore
|
|
'clr-line-clr
|
|
(ignore (line 10 10 (make-color 0 0 255))))
|
|
|
|
(test 'ignore
|
|
'clr-add-line-sym
|
|
(ignore (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 'blue)))
|
|
(test 'ignore
|
|
'clr-add-line-str
|
|
(ignore (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 "blue")))
|
|
(test 'ignore
|
|
'clr-add-line-clr
|
|
(ignore (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 (make-color 0 0 255))))
|
|
|
|
(test 'ignore
|
|
'clr-text-sym
|
|
(ignore (text "abc" 12 'blue)))
|
|
(test 'ignore
|
|
'clr-text-str
|
|
(ignore (text "abc" 12 "blue")))
|
|
(test 'ignore
|
|
'clr-text-clr
|
|
(ignore (text "abc" 12 (make-color 0 0 255))))
|
|
|
|
(define (tp-exn/num re)
|
|
(lambda (exn)
|
|
(and (tp-exn? exn)
|
|
(regexp-match re (exn-message exn)))))
|
|
|
|
;; tests that the expression
|
|
;; a) raises a teachpack exception record,
|
|
;; b) has the right argument position, and
|
|
;; c) has the right name.
|
|
(define-syntax (err/rt-name-test stx)
|
|
(syntax-case stx ()
|
|
[(_ (name . args) position)
|
|
(identifier? (syntax name))
|
|
(syntax
|
|
(err/rt-test (name . args)
|
|
(lambda (exn)
|
|
(and (tp-exn? exn)
|
|
(let* ([msg (exn-message exn)]
|
|
[beg (format "~a:" 'name)]
|
|
[len (string-length beg)])
|
|
(and (regexp-match position msg)
|
|
((string-length msg) . > . len)
|
|
(string=? (substring msg 0 len) beg)))))))]))
|
|
|
|
(err/rt-name-test (image-width 1) "first")
|
|
(err/rt-name-test (image-height 1) "first")
|
|
(err/rt-name-test (overlay 1 2) "first")
|
|
(err/rt-name-test (overlay image-snip1 2) "second")
|
|
(err/rt-name-test (overlay image-snip1 image-snip2 3) "3")
|
|
(err/rt-name-test (overlay/xy #f #f #f #f) "first")
|
|
(err/rt-name-test (overlay/xy image-snip1 #f #f #f) "second")
|
|
(err/rt-name-test (overlay/xy image-snip1 1 #f #f) "third")
|
|
(err/rt-name-test (overlay/xy image-snip1 1 1 #f) "fourth")
|
|
(err/rt-name-test (pinhole-x 1) "first")
|
|
(err/rt-name-test (pinhole-y 1) "first")
|
|
(err/rt-name-test (move-pinhole #f #f #f) "first")
|
|
(err/rt-name-test (move-pinhole image-snip1 #f #f) "second")
|
|
(err/rt-name-test (move-pinhole image-snip1 0 #f) "third")
|
|
(err/rt-name-test (rectangle #f #f #f #f) "first")
|
|
(err/rt-name-test (rectangle 10 #f #f #f) "second")
|
|
(err/rt-name-test (rectangle 10 10 #f #f) "third")
|
|
(err/rt-name-test (rectangle 10 10 'solid #f) "fourth")
|
|
(err/rt-name-test (circle #f #f #f) "first")
|
|
(err/rt-name-test (circle 10 #f #f) "second")
|
|
(err/rt-name-test (circle 10 'solid #f) "third")
|
|
(err/rt-name-test (ellipse #f #f #f #f) "first")
|
|
(err/rt-name-test (ellipse 10 #f #f #f) "second")
|
|
(err/rt-name-test (ellipse 10 10 #f #f) "third")
|
|
(err/rt-name-test (ellipse 10 10 'solid #f) "fourth")
|
|
(err/rt-name-test (triangle #f #f #f) "first")
|
|
(err/rt-name-test (triangle 10 #f #f) "second")
|
|
(err/rt-name-test (triangle 10 'solid #f) "third")
|
|
(err/rt-name-test (line #f #f #f) "first")
|
|
(err/rt-name-test (line 10 #f #f) "second")
|
|
(err/rt-name-test (line 10 10 #f) "third")
|
|
(err/rt-name-test (add-line #f #f #f #f #f #f) "first")
|
|
(err/rt-name-test (add-line image-snip1 #f #f #f #f #f) "second")
|
|
(err/rt-name-test (add-line image-snip1 10 #f #f #f #f) "third")
|
|
(err/rt-name-test (add-line image-snip1 10 10 #f #f #f) "fourth")
|
|
(err/rt-name-test (add-line image-snip1 10 10 11 #f #f) "fifth")
|
|
(err/rt-name-test (add-line image-snip1 10 10 11 11 #f) "sixth")
|
|
(err/rt-name-test (text #f #f #f) "first")
|
|
(err/rt-name-test (text "abc" #f #f) "second")
|
|
(err/rt-name-test (text "abc" 10 #f) "third")
|
|
(err/rt-name-test (image-inside? #f #f) "first")
|
|
(err/rt-name-test (image-inside? image-snip1 #f) "second")
|
|
(err/rt-name-test (find-image #f #f) "first")
|
|
(err/rt-name-test (find-image image-snip1 #f) "second")
|
|
(err/rt-name-test (image->color-list 1) "first")
|
|
(err/rt-name-test (color-list->image #f #f #f #f #f) "first")
|
|
(err/rt-name-test (color-list->image (list (make-color 0 0 0)) #f #f #f #f) "second")
|
|
(err/rt-name-test (color-list->image (list (make-color 0 0 0)) 1 #f #f #f) "third")
|
|
(err/rt-name-test (color-list->image (list (make-color 0 0 0)) 1 1 #f #f) "fourth")
|
|
(err/rt-name-test (color-list->image (list (make-color 0 0 0)) 1 1 0 #f) "fifth")
|
|
(err/rt-name-test (image->alpha-color-list #f) "first")
|
|
(err/rt-name-test (alpha-color-list->image #f #f #f #f #f) "first")
|
|
(err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) #f #f #f #f) "second")
|
|
(err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 #f #f #f) "third")
|
|
(err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 1 #f #f) "fourth")
|
|
(err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 1 0 #f) "fifth")
|
|
|
|
(report-errs) |