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

fixed PR 8770, made stick man a little bit shorter

Browse Source 
svn: r6793
This commit is contained in:
Robby Findler 2007-07-02 03:50:04 +00:00
parent c0999f05ee
commit 541752ca35
3 changed files with 32 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -12,6 +12,22 @@
(define line-size 2) (define line-size 2)
(define waiting-points (define waiting-points
'((head 47 -4)
(neck 40 14)
(shoulders 38 29)
(left-elbow 6 65)
(right-elbow 63 66)
(left-hand 59 73)
(right-hand 58 18)
(waist 35 77)
(left-knee 16 116)
(right-knee 55 113)
(left-ankle 16 155)
(right-ankle 61 154)
(left-toe -3 152)
(right-toe 80 145))
#;
'((head 47 -4) '((head 47 -4)
(neck 40 14) (neck 40 14)
(shoulders 38 29) (shoulders 38 29)
@ -205,7 +221,7 @@
(define orig-x 0) (define orig-x 0)
(define orig-y 0) (define orig-y 0)
(define/override (on-paint) (define/override (on-paint)
(draw-callback (get-dc) 1 #t points 0 0)) (draw-callback (get-dc) 1 #t points 0 0 line-size))
(define/override (on-event evt) (define/override (on-event evt)
(cond (cond
[(send evt button-down? 'left) [(send evt button-down? 'left)
@ -256,10 +272,10 @@
(new canvas% (new canvas%
[parent cp] [parent cp]
[paint-callback (λ (c dc) [paint-callback (λ (c dc)
(draw-callback dc small-factor #f running-points 0 0) (draw-callback dc small-factor #f running-points 0 0 line-size)
(draw-callback dc small-factor #f waiting-points 30 0) (draw-callback dc small-factor #f waiting-points 30 0 line-size)
(draw-callback dc small-factor #f points 30 50) (draw-callback dc small-factor #f points 30 50 line-size)
(draw-callback dc small-factor #f points 0 50))])) (draw-callback dc small-factor #f points 0 50 line-size))]))
(define bp (new horizontal-panel% [parent f] [stretchable-height #f])) (define bp (new horizontal-panel% [parent f] [stretchable-height #f]))
(new button% (new button%
[parent bp] [parent bp]

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

@ -282,6 +282,7 @@ module browser threading seems wrong.
(define make-execute-bitmap (define make-execute-bitmap
(bitmap-label-maker (string-constant execute-button-label) (bitmap-label-maker (string-constant execute-button-label)
#;(get-running-bitmap)
(build-path (collection-path "icons") "run.png"))) (build-path (collection-path "icons") "run.png")))
(define make-save-bitmap (define make-save-bitmap
(bitmap-label-maker (string-constant save-button-label) (bitmap-label-maker (string-constant save-button-label)
@ -1464,7 +1465,7 @@ module browser threading seems wrong.
(if (equal? f1 f2) (if (equal? f1 f2)
(loop (cdr p1) (cdr p2) (+ i 1)) (loop (cdr p1) (cdr p2) (+ i 1))
i))])))] i))])))]
[exp (reverse (explode-path (normalize-path fn)))] [exp (reverse (explode-path (normalize-path/exists fn)))]
[other-exps [other-exps
(filter (filter
(λ (x) (and x (λ (x) (and x
@ -1472,7 +1473,7 @@ module browser threading seems wrong.
(map (λ (other-tab) (map (λ (other-tab)
(let ([fn (send (send other-tab get-defs) get-filename)]) (let ([fn (send (send other-tab get-defs) get-filename)])
(and fn (and fn
(reverse (explode-path (normalize-path fn)))))) (reverse (explode-path (normalize-path/exists fn))))))
tabs))] tabs))]
[size [size
(let loop ([other-exps other-exps] (let loop ([other-exps other-exps]
@ -1484,6 +1485,11 @@ module browser threading seems wrong.
(max new-size size)))]))]) (max new-size size)))]))])
(path->string (apply build-path (reverse (take-n size exp)))))) (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) (define/private (add-modified-flag text string)
(if (send text is-modified?) (if (send text is-modified?)
(let ([prefix (get-save-diamond-prefix)]) (let ([prefix (get-save-diamond-prefix)])

4
collects/framework/private/editor.ss
View File

@ -426,7 +426,9 @@
(define/public (update-frame-filename) (define/public (update-frame-filename)
(let* ([filename (get-filename)] (let* ([filename (get-filename)]
[name (if filename [name (if filename
(path->string (file-name-from-path (normalize-path filename))) (path->string
(file-name-from-path
filename))
(get-filename/untitled-name))]) (get-filename/untitled-name))])
(for-each (λ (canvas) (for-each (λ (canvas)
(let ([tlw (send canvas get-top-level-window)]) (let ([tlw (send canvas get-top-level-window)])