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

saved one pixel in height of the stick figures

Browse Source 
svn: r6790
This commit is contained in:
Robby Findler 2007-07-02 03:32:08 +00:00
parent 2d9aa42ec9
commit 0ef2e50e96
2 changed files with 64 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)

11
collects/drscheme/private/unit.ss
View File

@ -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)])