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

now we tap our feet ...

Browse Source 
svn: r6825
This commit is contained in:
Robby Findler 2007-07-05 16:04:12 +00:00
parent 59cd498e8a
commit eb0a20f126
1 changed files with 27 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/drscheme/private/stick-figures.ss
View File

@ -65,17 +65,39 @@
(left-toe 14 146) (left-toe 14 146)
(right-toe 109 132))) (right-toe 109 132)))
(define running-points/2 running-points)
(define running-canvas% (define running-canvas%
(class canvas% (class canvas%
(inherit get-dc refresh) (inherit get-dc refresh get-client-size)
(define/public (set-running r?) (define/public (set-running r?)
(unless (eq? r? is-running?) (unless (eq? r? is-running?)
(set! is-running? r?) (set! is-running? r?)
(refresh))) (refresh)))
(define is-running? #f) (define is-running? #f)
(define toggle? #t) (define toggle? #t)
(define timer #f)
(define inside? #f)
(define/override (on-event evt)
(let-values ([(w h) (get-client-size)])
(let ([new-inside?
(and (<= 0 (send evt get-x) w)
(<= 0 (send evt get-y) h))]
[old-inside? inside?])
(set! inside? new-inside?)
(cond
[(and new-inside? (not old-inside?))
(unless is-running?
(set! timer
(new timer%
[notify-callback
(λ ()
(printf ".") (flush-output)
(set! toggle? (not toggle?))
(refresh))]
[interval 200])))]
[(and (not new-inside?) old-inside? timer)
(send timer stop)
(set! timer #f)]))))
(define-values (w h running-dx running-dy waiting-dx waiting-dy) (define-values (w h running-dx running-dy waiting-dx waiting-dy)
(get-size-parameters)) (get-size-parameters))
@ -328,7 +350,6 @@
(send (get-running-bitmap) save-file (build-path (collection-path "icons") "run.png") 'png) (send (get-running-bitmap) save-file (build-path (collection-path "icons") "run.png") 'png)
(send f show #t)) (send f show #t))
#;
(let () (let ()
(define f (new frame% [label ""])) (define f (new frame% [label ""]))
(define c (new running-canvas% [parent f])) (define c (new running-canvas% [parent f]))
@ -340,7 +361,8 @@
[label "Wait"] [label "Wait"]
[parent f] [parent f]
[callback (λ (x y) (send c set-running #f))]) [callback (λ (x y) (send c set-running #f))])
(send c set-running #t)
(send f show #t)) (send f show #t))
#;(edit-points waiting-points) #;(edit-points waiting-points)
#;(edit-points running-points)) #;(edit-points running-points/2))