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

check b&w dc pixel ops

Browse Source 
svn: r2528

original commit: a10c2acb138a812967c0854355329c0302b66073
This commit is contained in:
Matthew Flatt 2006-03-28 16:19:53 +00:00
parent dad3641dd3
commit e5a7ef139a
2 changed files with 71 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
collects/tests/mred/dc.ss
View File

@ -75,66 +75,80 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Get-pixel, set-pixel, get-argb-pixels, etc.
;; New DC to reset background, etc:
(define mdc (make-object bitmap-dc% bm))
(send mdc clear)
(require (lib "etc.ss"))
(define col (make-object color%))
(define bts (make-bytes 40))
(define (pixel-tests b&w?)
(begin-with-definitions
(st #f mdc get-pixel 30 4 col)
(st #t mdc get-pixel 3 4 col)
(st 255 col red)
(st 255 col green)
(st 255 col blue)
(stv mdc get-argb-pixels 0 0 2 5 bts)
(test #t 'same-str (equal? (make-bytes 40 255) bts))
(define bm3 (make-object bitmap% 10 10 b&w?))
(send col set 30 40 50)
(send mdc try-color col col)
(send mdc set-pixel 3 4 col)
(define mdc (make-object bitmap-dc% bm3))
(send mdc clear)
(stv mdc get-argb-pixels 2 1 2 5 bts)
(test #t 'same-str (equal? (bytes-append (make-bytes 28 255)
(bytes 255
(send col red)
(send col green)
(send col blue))
(make-bytes 8 255))
bts))
(define col (make-object color%))
(define bts (make-bytes 40))
(define col2 (make-object color% 130 140 150))
(send mdc try-color col2 col2)
(let loop ([i 0])
(unless (= i 10)
(bytes-set! bts (+ 0 (* i 4)) 255)
(bytes-set! bts (+ 1 (* i 4)) (send col2 red))
(bytes-set! bts (+ 2 (* i 4)) (send col2 green))
(bytes-set! bts (+ 3 (* i 4)) (send col2 blue))
(loop (add1 i))))
(stv mdc set-argb-pixels 5 5 5 2 bts)
(let ([col3 (make-object color%)]
[white (make-object color% 255 255 255)]
[check-col (lambda (what a b)
(test #t `(same red ,what) (= (send a red) (send b red)))
(test #t `(same green ,what) (= (send a green) (send b green)))
(test #t `(same blue ,what) (= (send a blue) (send b blue))))])
(let i-loop ([i 0])
(unless (= i 10)
(let j-loop ([j 0])
(if (= j 10)
(i-loop (add1 i))
(begin
(st #t mdc get-pixel i j col3)
(cond
[(and (= i 3) (= j 4))
(check-col '(3 4) col col3)]
[(and (<= 5 i 9)
(<= 5 j 6))
(check-col `(,i ,j) col2 col3)]
[else
(check-col `(,i ,j) white col3)])
(j-loop (add1 j))))))))
(st #f mdc get-pixel 30 4 col)
(st #t mdc get-pixel 3 4 col)
(st 255 col red)
(st 255 col green)
(st 255 col blue)
(stv mdc get-argb-pixels 0 0 2 5 bts)
(test #t 'same-str (equal? (make-bytes 40 255) bts))
(send col set 30 40 50)
(send mdc try-color col col)
(send mdc set-pixel 3 4 col)
(when b&w?
(st 0 col red)
(st 0 col green)
(st 0 col blue))
(stv mdc get-argb-pixels 2 1 2 5 bts)
(test #t 'same-str (equal? (bytes-append (make-bytes 28 255)
(bytes 255
(send col red)
(send col green)
(send col blue))
(make-bytes 8 255))
bts))
(define col2 (make-object color% 130 140 150))
(send mdc try-color col2 col2)
(let loop ([i 0])
(unless (= i 10)
(bytes-set! bts (+ 0 (* i 4)) 255)
(bytes-set! bts (+ 1 (* i 4)) (send col2 red))
(bytes-set! bts (+ 2 (* i 4)) (send col2 green))
(bytes-set! bts (+ 3 (* i 4)) (send col2 blue))
(loop (add1 i))))
(stv mdc set-argb-pixels 5 5 5 2 bts)
(let ([col3 (make-object color%)]
[white (make-object color% 255 255 255)]
[check-col (lambda (what a b)
(test #t `(same red ,what) (= (send a red) (send b red)))
(test #t `(same green ,what) (= (send a green) (send b green)))
(test #t `(same blue ,what) (= (send a blue) (send b blue))))])
(let i-loop ([i 0])
(unless (= i 10)
(let j-loop ([j 0])
(if (= j 10)
(i-loop (add1 i))
(begin
(st #t mdc get-pixel i j col3)
(cond
[(and (= i 3) (= j 4))
(check-col '(3 4) col col3)]
[(and (<= 5 i 9)
(<= 5 j 6))
(check-col `(,i ,j) col2 col3)]
[else
(check-col `(,i ,j) white col3)])
(j-loop (add1 j))))))))))
(pixel-tests #f)
(pixel-tests #t)
;; ----------------------------------------
(report-errs)

2
collects/tests/mred/testing.ss
View File

@ -3,6 +3,8 @@
(require (lib "class.ss"))
(define SECTION #t)
(define errs null)
(define test-count 0)