diff --git a/collects/drscheme/private/stick-figures.ss b/collects/drscheme/private/stick-figures.ss index ba3bd67dcc..0190a31af3 100644 --- a/collects/drscheme/private/stick-figures.ss +++ b/collects/drscheme/private/stick-figures.ss @@ -3,10 +3,14 @@ (lib "pretty.ss") (lib "mred.ss" "mred")) - (provide running-canvas%) + (provide running-canvas% + get-running-bitmap) (define head-size 40) + (define running-bitmap-factor 1/11) (define small-factor 1/5) + (define line-size 2) + (define waiting-points '((head 47 -4) (neck 40 14) @@ -49,27 +53,13 @@ (define is-running? #f) (define-values (w h running-dx running-dy waiting-dx waiting-dy) - (let-values ([(min-rx min-ry) (get-max/min-x/y min running-points)] - [(max-rx max-ry) (get-max/min-x/y max running-points)] - [(min-wx min-wy) (get-max/min-x/y min waiting-points)] - [(max-wx max-wy) (get-max/min-x/y max waiting-points)]) - (let* ([running-w (* small-factor (- max-rx min-rx))] - [waiting-w (* small-factor (- max-wx min-wx))] - [running-h (* small-factor (- max-ry min-ry))] - [waiting-h (* small-factor (- max-wy min-wy))] - [w (+ 3 (ceiling (max running-w waiting-w)))] - [h (+ 3 (ceiling (max running-h waiting-h)))] - [running-dx (- (/ w 2) (/ running-w 2))] - [running-dy (- (/ h 2) (/ running-h 2))] - [waiting-dx (- (/ w 2) (/ waiting-w 2))] - [waiting-dy (- (/ h 2) (/ waiting-h 2))]) - (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) - (draw-callback dc small-factor #f waiting-points waiting-dx waiting-dy)))) + (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)))) (super-new [stretchable-width #f] [stretchable-height #f] [style '(transparent)]) @@ -77,6 +67,52 @@ (min-width w) (min-height h))) + (define (get-size-parameters) + (let-values ([(min-rx min-ry) (get-max/min-x/y min running-points)] + [(max-rx max-ry) (get-max/min-x/y max running-points)] + [(min-wx min-wy) (get-max/min-x/y min waiting-points)] + [(max-wx max-wy) (get-max/min-x/y max waiting-points)]) + (let* ([running-w (* small-factor (- max-rx min-rx))] + [waiting-w (* small-factor (- max-wx min-wx))] + [running-h (* small-factor (- max-ry min-ry))] + [waiting-h (* small-factor (- max-wy min-wy))] + [w (+ 2 (ceiling (max running-w waiting-w)))] + [h (+ 2 (ceiling (max running-h waiting-h)))] + [running-dx (+ 1 (- (/ w 2) (/ running-w 2)))] + [running-dy (+ 1 (- (/ h 2) (/ running-h 2)))] + [waiting-dx (+ 1 (- (/ w 2) (/ waiting-w 2)))] + [waiting-dy (+ 1 (- (/ h 2) (/ waiting-h 2)))]) + (values w h running-dx running-dy waiting-dx waiting-dy)))) + + (define running-bitmap #f) + (define (get-running-bitmap) + (unless running-bitmap + (let-values ([(min-rx min-ry) (get-max/min-x/y min running-points)] + [(max-rx max-ry) (get-max/min-x/y max running-points)]) + (let* ([margin 1] + [w (+ margin margin (ceiling (* running-bitmap-factor (- max-rx min-rx))))] + [h (+ margin margin (ceiling (* running-bitmap-factor (- max-ry min-ry))))] + [bm-mask (make-object bitmap% w h)] + [bm (make-object bitmap% w h)] + [bdc (make-object bitmap-dc% bm-mask)] + [green (make-object color% 30 132 30)]) + (send bdc clear) + (draw-callback bdc running-bitmap-factor #f running-points + (+ margin (- (* running-bitmap-factor min-rx))) + (+ margin (- (* running-bitmap-factor min-ry))) + 2) + (send bdc set-bitmap bm) + (send bdc set-brush green 'solid) + (send bdc set-pen green 1 'solid) + (send bdc draw-rectangle + 0 0 + (+ margin margin w) + (+ margin margin h)) + (send bdc set-bitmap #f) + (send bm set-loaded-mask bm-mask) + (set! running-bitmap bm)))) + running-bitmap) + (define (test-running-canvas) (let* ([f (new frame% [label ""])] [c (new running-canvas% [parent f])]) @@ -107,7 +143,7 @@ (apply choose (map (λ (x) (list-ref x 2)) points))))) (define show-dots? #t) - (define (draw-callback dc factor dots? points dx dy) + (define (draw-callback dc factor dots? points dx dy line-size) (send dc set-smoothing 'aligned) (let ([points (normalize points)]) (send dc set-pen "orange" 1 'solid) @@ -119,7 +155,7 @@ (+ dy (- (list-ref x 2) 4)) 9 9)) points)) - (send dc set-pen "black" 2 'solid) + (send dc set-pen "black" line-size 'solid) (send dc set-brush "black" 'transparent) (draw-points points dc factor dx dy) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 052a02ee59..78d92d36f4 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -282,7 +282,7 @@ module browser threading seems wrong. (define make-execute-bitmap (bitmap-label-maker (string-constant execute-button-label) - (build-path (collection-path "icons") "run.png"))) + (get-running-bitmap))) (define make-save-bitmap (bitmap-label-maker (string-constant save-button-label) (build-path (collection-path "icons") "save.png"))) @@ -1464,7 +1464,7 @@ module browser threading seems wrong. (if (equal? f1 f2) (loop (cdr p1) (cdr p2) (+ i 1)) i))])))] - [exp (reverse (explode-path (normalize-path fn)))] + [exp (reverse (explode-path (normalize-path/exists fn)))] [other-exps (filter (λ (x) (and x @@ -1472,7 +1472,7 @@ module browser threading seems wrong. (map (λ (other-tab) (let ([fn (send (send other-tab get-defs) get-filename)]) (and fn - (reverse (explode-path (normalize-path fn)))))) + (reverse (explode-path (normalize-path/exists fn)))))) tabs))] [size (let loop ([other-exps other-exps] @@ -1484,6 +1484,11 @@ module browser threading seems wrong. (max new-size size)))]))]) (path->string (apply build-path (reverse (take-n size exp)))))) + (define/private (normalize-path/exists fn) + (if (file-exists? fn) + (normalize-path fn) + fn)) + (define/private (add-modified-flag text string) (if (send text is-modified?) (let ([prefix (get-save-diamond-prefix)])