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

Use running stickman in lower-right "run" indicator

Browse Source 
Please merge into release
(cherry picked from commit 436a1dcb71)
This commit is contained in:
Neil Toronto 2012-01-11 21:24:44 -07:00 committed by Ryan Culpepper
parent 4603785afe
commit d637be4b71
1 changed files with 36 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
collects/drracket/private/unit.rkt
View File

@ -39,7 +39,7 @@ module browser threading seems wrong.
"eval-helpers.rkt" "eval-helpers.rkt"
(prefix-in drracket:arrow: "../arrow.rkt") (prefix-in drracket:arrow: "../arrow.rkt")
(prefix-in icons: (combine-in images/icons/file images/icons/control images/icons/style (prefix-in icons: (combine-in images/icons/file images/icons/control images/icons/style
images/logos)) images/icons/stickman images/logos))
mred mred
(prefix-in mred: mred) (prefix-in mred: mred)
@ -4395,66 +4395,52 @@ module browser threading seems wrong.
; ;
; ;
(define running-bitmap (include-bitmap (lib "icons/b-run.png")))
(define waiting-bitmap (include-bitmap (lib "icons/b-wait.png")))
(define waiting2-bitmap (include-bitmap (lib "icons/b-wait2.png")))
(define running/waiting-bitmaps (list running-bitmap waiting-bitmap waiting2-bitmap))
(define running-canvas% (define running-canvas%
(class canvas% (class canvas%
(inherit get-dc refresh get-client-size) (inherit get-dc refresh get-client-size)
(define/public (set-running r?)
(unless (eq? r? is-running?)
(set! is-running? r?)
(refresh)))
(define is-running? #f)
(define toggle? #t)
(define timer #f)
(define inside? #f)
(define/override (on-event evt) (define stickman-height 18)
(let-values ([(w h) (get-client-size)]) (define num-running-frames 12)
(let ([new-inside? (define frame-delay 200) ; 5 FPS at the most (when the user program is blocked or waiting)
(and (< 0 (send evt get-x) w) (define running-frames
(< 0 (send evt get-y) h))] (for/vector ([t (in-range 0 1 (/ 1 num-running-frames))])
[old-inside? inside?]) (icons:running-stickman-icon t icons:run-icon-color "white" icons:run-icon-color
(set! inside? new-inside?) stickman-height)))
(cond (define standing-frame
[(and new-inside? (not old-inside?)) (icons:standing-stickman-icon icons:run-icon-color "white" icons:run-icon-color
(unless is-running? stickman-height))
(set! timer
(new timer% (define all-running-frames
[notify-callback (cons standing-frame (vector->list running-frames)))
(λ ()
(set! toggle? (not toggle?)) (define is-running? #f)
(refresh))] (define frame 0)
[interval 200])))] (define timer (make-object timer% (λ () (refresh) (yield)) #f))
[(and (not new-inside?) old-inside? timer)
(send timer stop) (define/public (set-running r?)
(set! timer #f)])))) (cond [r? (unless is-running? (set! frame 4))
(send timer start frame-delay #f)]
[else (send timer stop)
(refresh)])
(set! is-running? r?))
(define/override (on-paint) (define/override (on-paint)
(let ([dc (get-dc)] (define dc (get-dc))
[bm (define bm (cond [is-running? (define bm (vector-ref running-frames frame))
(if is-running? (set! frame (modulo (+ frame 1) num-running-frames))
running-bitmap bm]
(if toggle? [else standing-frame]))
waiting-bitmap (define-values (w h) (get-client-size))
waiting2-bitmap))]) (send dc draw-bitmap bm
(let-values ([(cw ch) (get-client-size)]) (- (/ w 2) (/ (send bm get-width) 2))
(send dc draw-bitmap bm (- (/ h 2) (/ (send bm get-height) 2))))
(- (/ cw 2) (/ (send bm get-width) 2))
(- (/ ch 2) (/ (send bm get-height) 2))
'solid
(send the-color-database find-color "black")
(send bm get-loaded-mask)))))
(super-new [stretchable-width #f] (super-new [stretchable-width #f]
[stretchable-height #f] [stretchable-height #f]
[style '(transparent no-focus)]) [style '(transparent no-focus)])
(inherit min-width min-height) (inherit min-width min-height)
(min-width (apply max (map (λ (x) (send x get-width)) running/waiting-bitmaps))) (min-width (apply max (map (λ (x) (send x get-width)) all-running-frames)))
(min-height (apply max (map (λ (x) (send x get-height)) running/waiting-bitmaps))))) (min-height (apply max (map (λ (x) (send x get-height)) all-running-frames)))))
;; get-mbytes : top-level-window -> (union #f ;; cancel ;; get-mbytes : top-level-window -> (union #f ;; cancel
;; integer[>=100] ;; a limit ;; integer[>=100] ;; a limit