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

svn: r1441

Browse Source
This commit is contained in:
Eli Barzilay 2005-11-29 23:28:45 +00:00
parent 97c1d0e83d
commit 3e23ef92cb
1 changed files with 92 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

184
collects/tests/mred/blits.ss
View File

@ -1,92 +1,92 @@
(define ok-frame (make-object frame% "Ok"))
(define ok-panel #f)
(define (try path mode color bg-color sx sy)
(let ([bm (if (is-a? path bitmap%)
path
(make-object bitmap% path 'unknown/mask))])
(let ([w (inexact->exact (ceiling (* sx (send bm get-width))))]
[h (inexact->exact (ceiling (* sy (send bm get-height))))])
(let* ([dest1 (make-object bitmap% w h)]
[dest2 (make-object bitmap% w h)]
[dc1 (make-object bitmap-dc% dest1)]
[dc2 (make-object bitmap-dc% dest2)]
[s1 (make-bytes (* w h 4))]
[s2 (make-bytes (* w h 4))])
(send dc1 clear)
(send dc2 clear)
(send dc1 set-brush bg-color 'solid)
(send dc1 draw-rectangle 0 0 w h)
(send dc2 set-brush bg-color 'solid)
(send dc2 draw-rectangle 0 0 w h)
(send dc1 set-scale sx sy)
(send dc2 set-scale sx sy)
(send dc1 draw-bitmap bm 0 0
mode color (send bm get-loaded-mask))
(send dc2 draw-bitmap bm 0 0
mode color (send bm get-loaded-mask))
(send dc1 get-argb-pixels 0 0 w h s1)
(send dc2 get-argb-pixels 0 0 w h s2)
(send dc1 set-bitmap #f)
(send dc2 set-bitmap #f)
(if (bytes=? s1 s2)
(make-object message% dest1 ok-panel)
(let ([f (make-object frame% "Different!")])
(make-object message% dest1 f)
(make-object message% dest2 f)
(send f show #t)))))))
(define (self-mask path)
(let ([bm (make-object bitmap% path)])
(send bm set-loaded-mask bm)
bm))
(define (plus-mask path mpath)
(let ([bm (make-object bitmap% path)]
[xmbm (make-object bitmap% mpath)])
(let* ([w (send bm get-width)]
[h (send bm get-height)]
[mbm (make-object bitmap% w h (= 1 (send xmbm get-depth)))]
[dc (make-object bitmap-dc% mbm)])
(send dc clear)
(send dc draw-bitmap-section xmbm 0 0 0 0 w h)
(send dc set-bitmap #f)
(send bm set-loaded-mask mbm)
bm)))
(define targets
(list
(build-path (collection-path "frtime") "clock.png")
(self-mask (build-path (collection-path "frtime") "clock.png"))
(build-path (collection-path "icons") "foot-up.png")
(build-path (collection-path "icons") "mred.xbm")
(self-mask (build-path (collection-path "icons") "mred.xbm"))
(plus-mask (build-path (collection-path "icons") "mred.xbm")
(build-path (collection-path "icons") "PLT-206.png"))
(plus-mask (build-path (collection-path "frtime") "clock.png")
(build-path (collection-path "icons") "mred.xbm"))
(build-path (collection-path "icons") "htdp-icon.gif")
))
(for-each
(lambda (mode)
(for-each (lambda (sx sy)
(set! ok-panel (make-object horizontal-panel% ok-frame))
(for-each
(lambda (fg)
(for-each (lambda (target)
(try target
mode
fg
(make-object color% "green")
sx sy))
targets))
(list (make-object color% "black")
(make-object color% "red"))))
'(1 3/2 1/2)
'(1 1/2 3/2)))
'(solid opaque xor))
(send ok-frame show #t)
(define ok-frame (make-object frame% "Ok"))
(define ok-panel #f)
(define (try path mode color bg-color sx sy)
(let ([bm (if (is-a? path bitmap%)
path
(make-object bitmap% path 'unknown/mask))])
(let ([w (inexact->exact (ceiling (* sx (send bm get-width))))]
[h (inexact->exact (ceiling (* sy (send bm get-height))))])
(let* ([dest1 (make-object bitmap% w h)]
[dest2 (make-object bitmap% w h)]
[dc1 (make-object bitmap-dc% dest1)]
[dc2 (make-object bitmap-dc% dest2)]
[s1 (make-bytes (* w h 4))]
[s2 (make-bytes (* w h 4))])
(send dc1 clear)
(send dc2 clear)
(send dc1 set-brush bg-color 'solid)
(send dc1 draw-rectangle 0 0 w h)
(send dc2 set-brush bg-color 'solid)
(send dc2 draw-rectangle 0 0 w h)
(send dc1 set-scale sx sy)
(send dc2 set-scale sx sy)
(send dc1 draw-bitmap bm 0 0
mode color (send bm get-loaded-mask))
(send dc2 draw-bitmap bm 0 0
mode color (send bm get-loaded-mask))
(send dc1 get-argb-pixels 0 0 w h s1)
(send dc2 get-argb-pixels 0 0 w h s2)
(send dc1 set-bitmap #f)
(send dc2 set-bitmap #f)
(if (bytes=? s1 s2)
(make-object message% dest1 ok-panel)
(let ([f (make-object frame% "Different!")])
(make-object message% dest1 f)
(make-object message% dest2 f)
(send f show #t)))))))
(define (self-mask path)
(let ([bm (make-object bitmap% path)])
(send bm set-loaded-mask bm)
bm))
(define (plus-mask path mpath)
(let ([bm (make-object bitmap% path)]
[xmbm (make-object bitmap% mpath)])
(let* ([w (send bm get-width)]
[h (send bm get-height)]
[mbm (make-object bitmap% w h (= 1 (send xmbm get-depth)))]
[dc (make-object bitmap-dc% mbm)])
(send dc clear)
(send dc draw-bitmap-section xmbm 0 0 0 0 w h)
(send dc set-bitmap #f)
(send bm set-loaded-mask mbm)
bm)))
(define targets
(list
(build-path (collection-path "frtime") "clock.png")
(self-mask (build-path (collection-path "frtime") "clock.png"))
(build-path (collection-path "icons") "foot-up.png")
(build-path (collection-path "icons") "mred.xbm")
(self-mask (build-path (collection-path "icons") "mred.xbm"))
(plus-mask (build-path (collection-path "icons") "mred.xbm")
(build-path (collection-path "icons") "PLT-206.png"))
(plus-mask (build-path (collection-path "frtime") "clock.png")
(build-path (collection-path "icons") "mred.xbm"))
(build-path (collection-path "icons") "htdp-icon.gif")
))
(for-each
(lambda (mode)
(for-each (lambda (sx sy)
(set! ok-panel (make-object horizontal-panel% ok-frame))
(for-each
(lambda (fg)
(for-each (lambda (target)
(try target
mode
fg
(make-object color% "green")
sx sy))
targets))
(list (make-object color% "black")
(make-object color% "red"))))
'(1 3/2 1/2)
'(1 1/2 3/2)))
'(solid opaque xor))
(send ok-frame show #t)