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

.

Browse Source 
original commit: cc8860c7c0c8ccf270266936b8bec5e082904b83
This commit is contained in:
Matthew Flatt 2003-05-20 13:07:03 +00:00
parent 2f10f9757f
commit 1b85042467
1 changed files with 9 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/tests/mred/item.ss
View File

@ -1718,23 +1718,28 @@
(send f show #t))
(define (no-clear-canvas-frame)
(define f (make-frame frame% "No-Clear Canvas Test" #f #f 250))
(define f (new frame%
[label "No-Clear Canvas Test"]
[height 250]
[width 300]))
(define p (make-object vertical-panel% f))
(define c% (class canvas%
(inherit get-dc refresh)
(define delta 0)
(define/override (on-paint)
(let ([red (send the-brush-list find-or-create-brush "RED" 'solid)]
[blue (send the-brush-list find-or-create-brush "BLUE" 'solid)]
[dc (get-dc)])
(let loop ([x 0])
(unless (= x 300)
(unless (= x 500)
(send dc set-brush red)
(send dc draw-rectangle x 0 25 400)
(send dc draw-rectangle (- x delta) 0 25 400)
(send dc set-brush blue)
(send dc draw-rectangle (+ x 25) 0 25 400)
(send dc draw-rectangle (- (+ x 25) delta) 0 25 400)
(loop (+ x 50))))))
(define/override (on-event evt)
(when (send evt dragging?)
(set! delta (modulo (add1 delta) 100))
(refresh)))
(super-new)))
(new c% [parent p][style '(border)])