diff --git a/collects/drscheme/private/stick-figures.ss b/collects/drscheme/private/stick-figures.ss index 2495627291..fcef8b806c 100644 --- a/collects/drscheme/private/stick-figures.ss +++ b/collects/drscheme/private/stick-figures.ss @@ -29,6 +29,24 @@ (left-toe 0 154) (right-toe 83 146))) + (define waiting-points/2 + '((head 55 0) + (neck 43 18) + (shoulders 37 33) + (left-shoulder 23 34) + (right-shoulder 50 37) + (left-elbow 8 74) + (right-elbow 66 69) + (left-hand 60 78) + (right-hand 68 18) + (waist 37 87) + (left-knee 19 122) + (right-knee 57 117) + (left-ankle 19 154) + (left-toe 0 154) + (right-ankle 62 155) + (right-toe 83 154))) + (define running-points '((head 130 18) (neck 114 33) @@ -47,6 +65,8 @@ (left-toe 14 146) (right-toe 109 132))) + (define running-points/2 running-points) + (define running-canvas% (class canvas% (inherit get-dc refresh) @@ -55,15 +75,20 @@ (set! is-running? r?) (refresh))) (define is-running? #f) + (define toggle? #t) (define-values (w h running-dx running-dy waiting-dx waiting-dy) (get-size-parameters)) - (define/override (on-paint) - (let ([dc (get-dc)]) - (if is-running? - (draw-callback dc small-factor #f running-points running-dx running-dy line-size) - (draw-callback dc small-factor #f waiting-points waiting-dx waiting-dy line-size)))) + (define/override (on-paint) + (if is-running? + (draw-callback (get-dc) small-factor #f + running-points + running-dx running-dy line-size) + (draw-callback (get-dc) small-factor #f + (if toggle? waiting-points waiting-points/2) + waiting-dx waiting-dy line-size))) + (super-new [stretchable-width #f] [stretchable-height #f] [style '(transparent)]) @@ -303,5 +328,19 @@ (send (get-running-bitmap) save-file (build-path (collection-path "icons") "run.png") 'png) (send f show #t)) + #; + (let () + (define f (new frame% [label ""])) + (define c (new running-canvas% [parent f])) + (new button% + [label "Run"] + [parent f] + [callback (λ (x y) (send c set-running #t))]) + (new button% + [label "Wait"] + [parent f] + [callback (λ (x y) (send c set-running #f))]) + (send f show #t)) + #;(edit-points waiting-points) #;(edit-points running-points))