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

made the bottom line of the drscheme window be half as tall

Browse Source 
svn: r7762
This commit is contained in:
Robby Findler 2007-11-19 04:01:13 +00:00
parent 976b976c4a
commit 753cd127a6
24 changed files with 291 additions and 373 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/drscheme/private/auto-language.ss
View File

@ -25,7 +25,12 @@
(when (equal? lang-spec spec-in-file) (when (equal? lang-spec spec-in-file)
(set! found-language? lang) (set! found-language? lang)
(set! settings (send lang metadata->settings str)) (set! settings (send lang metadata->settings str))
(send text delete 0 (send text paragraph-start-position lines))))))))) (let ([locked? (send text is-locked?)])
(when locked? (send text lock #f))
(printf "before ~s\n" (send text get-text 0 (send text last-position)))
(send text delete 0 (send text paragraph-start-position lines))
(printf "after ~s\n" (send text get-text 0 (send text last-position)))
(when locked? (send text lock #t))))))))))
all-languages) all-languages)
;; check to see if it looks like the module language. ;; check to see if it looks like the module language.

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

@ -3,15 +3,48 @@
(lib "pretty.ss") (lib "pretty.ss")
(lib "mred.ss" "mred")) (lib "mred.ss" "mred"))
(provide running-canvas%
get-running-bitmap)
(define head-size 40) (define head-size 40)
(define running-factor 1/2) (define small-bitmap-factor 1/2)
(define small-factor 1/5) (define small-factor 1/5)
(define line-size 2) (define line-size 2)
(define waiting-points (define waiting-points
'((head 47 2)
(neck 46 15)
(shoulders 38 42)
(left-shoulder 18 39)
(right-shoulder 65 42)
(left-elbow 8 74)
(right-elbow 68 76)
(left-hand 24 79)
(right-hand 56 83)
(waist 37 87)
(left-knee 23 117)
(right-knee 57 117)
(left-ankle 21 149)
(right-ankle 59 148)
(left-toe 3 148)
(right-toe 79 145)))
(define waiting-points/2
'((head 47 2)
(neck 46 15)
(shoulders 38 42)
(left-shoulder 18 39)
(right-shoulder 65 42)
(left-elbow 8 74)
(right-elbow 68 76)
(left-hand 24 79)
(right-hand 56 83)
(waist 37 87)
(left-knee 23 117)
(right-knee 57 117)
(left-ankle 21 149)
(right-ankle 59 148)
(left-toe 3 148)
(right-toe 79 132)))
(define waiting-points/old
'((head 55 0) '((head 55 0)
(neck 43 18) (neck 43 18)
(shoulders 37 33) (shoulders 37 33)
@ -29,7 +62,7 @@
(left-toe 0 154) (left-toe 0 154)
(right-toe 83 146))) (right-toe 83 146)))
(define waiting-points/2 (define waiting-points/2/old
'((head 55 0) '((head 55 0)
(neck 43 18) (neck 43 18)
(shoulders 37 33) (shoulders 37 33)
@ -65,58 +98,6 @@
(left-toe 14 146) (left-toe 14 146)
(right-toe 109 132))) (right-toe 109 132)))
(define running-canvas%
(class canvas%
(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)
(let-values ([(w h) (get-client-size)])
(let ([new-inside?
(and (<= 0 (send evt get-x) w)
(<= 0 (send evt get-y) h))]
[old-inside? inside?])
(set! inside? new-inside?)
(cond
[(and new-inside? (not old-inside?))
(unless is-running?
(set! timer
(new timer%
[notify-callback
(λ ()
(set! toggle? (not toggle?))
(refresh))]
[interval 200])))]
[(and (not new-inside?) old-inside? timer)
(send timer stop)
(set! timer #f)]))))
(define-values (w h running-dx running-dy waiting-dx waiting-dy)
(get-size-parameters))
(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)])
(inherit min-width min-height)
(min-width w)
(min-height h)))
(define (get-size-parameters) (define (get-size-parameters)
(let-values ([(min-rx min-ry) (get-max/min-x/y min running-points)] (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)] [(max-rx max-ry) (get-max/min-x/y max running-points)]
@ -134,59 +115,44 @@
[waiting-dy (+ 1 (- (/ h 2) (/ waiting-h 2)))]) [waiting-dy (+ 1 (- (/ h 2) (/ waiting-h 2)))])
(values w h running-dx running-dy waiting-dx waiting-dy)))) (values w h running-dx running-dy waiting-dx waiting-dy))))
(define running-bitmap #f) (define (get-bitmap points green)
(define (get-running-bitmap) (let-values ([(min-rx min-ry) (get-max/min-x/y min points)]
(unless running-bitmap [(max-rx max-ry) (get-max/min-x/y max points)])
(let-values ([(min-rx min-ry) (get-max/min-x/y min running-points)] (let* ([margin 2]
[(max-rx max-ry) (get-max/min-x/y max running-points)]) [bw (+ margin margin (ceiling (* small-factor (- max-rx min-rx))))]
(let* ([margin 2] [bh (+ margin margin (ceiling (* small-factor (- max-ry min-ry))))]
[bw (+ margin margin (ceiling (* small-factor (- max-rx min-rx))))] [w (ceiling (* bw small-bitmap-factor))]
[bh (+ margin margin (ceiling (* small-factor (- max-ry min-ry))))] [h (ceiling (* bh small-bitmap-factor))]
[w (ceiling (* bw running-factor))] [bm-big (make-object bitmap% bw bh)]
[h (ceiling (* bh running-factor))] [bm-solid (make-object bitmap% w h)]
[bm-big (make-object bitmap% bw bh)] [bm-small (make-object bitmap% w h)]
[bm-solid (make-object bitmap% w h)] [bdc-big (make-object bitmap-dc% bm-big)]
[bm-small (make-object bitmap% w h)] [bdc-solid (make-object bitmap-dc% bm-solid)]
[bdc-big (make-object bitmap-dc% bm-big)] [bdc-small (make-object bitmap-dc% bm-small)])
[bdc-solid (make-object bitmap-dc% bm-solid)] (send bdc-big clear)
[bdc-small (make-object bitmap-dc% bm-small)] (draw-callback bdc-big small-factor #f points
[green (make-object color% 30 100 30)]) (+ margin (- (* small-factor min-rx)))
(send bdc-big clear) (+ margin #;(- (* small-factor min-ry)))
(draw-callback bdc-big small-factor #f running-points 3)
(+ margin (- (* small-factor min-rx)))
(+ margin (- (* small-factor min-ry)))
3)
(send bdc-small clear) (send bdc-small clear)
(send bdc-small set-scale running-factor running-factor) (send bdc-small set-scale small-bitmap-factor small-bitmap-factor)
(send bdc-small draw-bitmap bm-big 0 0) (send bdc-small draw-bitmap bm-big 0 0)
(send bdc-small set-scale 1 1) (send bdc-small set-scale 1 1)
(send bdc-solid set-brush green 'solid) (send bdc-solid set-brush green 'solid)
(send bdc-solid set-pen green 1 'solid) (send bdc-solid set-pen green 1 'solid)
(send bdc-solid draw-rectangle 0 0 w h) (send bdc-solid draw-rectangle 0 0 w h)
(send bdc-solid set-bitmap #f) (send bdc-solid set-bitmap #f)
(send bdc-small set-bitmap #f) (send bdc-small set-bitmap #f)
(send bdc-big set-bitmap #f) (send bdc-big set-bitmap #f)
(send bm-solid set-loaded-mask bm-small) (send bm-solid set-loaded-mask bm-small)
(set! running-bitmap bm-solid)))) bm-solid)))
running-bitmap)
(define (test-running-canvas)
(let* ([f (new frame% [label ""])]
[c (new running-canvas% [parent f])])
(new button% [parent f]
[label "on"]
[callback
(λ (x y) (send c set-running #t))])
(new button% [parent f]
[label "off"]
[callback
(λ (x y) (send c set-running #f))])
(send f show #t)))
(define (get-running-bitmap) (get-bitmap running-points (make-object color% 30 100 30)))
(define (get-waiting-bitmap) (get-bitmap waiting-points (make-object color% 30 100 30)))
(define (normalize points) (define (normalize points)
(let-values ([(min-x min-y) (get-max/min-x/y min points)]) (let-values ([(min-x min-y) (get-max/min-x/y min points)])
@ -258,7 +224,7 @@
(+ dy (* factor (list-ref to-p 2))))))) (+ dy (* factor (list-ref to-p 2)))))))
;; Use this thunk to edit the points. ;; Use this thunk to edit the points.
;; Click the 'show' button to print out the pionts and then ;; Click the 'show' button to print out the points and then
;; copy and paste them back into this file. ;; copy and paste them back into this file.
(define (edit-points points) (define (edit-points points)
(define c% (define c%
@ -325,6 +291,7 @@
(draw-callback dc small-factor #f waiting-points 30 0 line-size) (draw-callback dc small-factor #f waiting-points 30 0 line-size)
(draw-callback dc small-factor #f points 30 50 line-size) (draw-callback dc small-factor #f points 30 50 line-size)
(draw-callback dc small-factor #f points 0 50 line-size))])) (draw-callback dc small-factor #f points 0 50 line-size))]))
(define cbitmap (new message% [label (get-bitmap points (send the-color-database find-color "black"))] [parent cp]))
(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]
@ -339,30 +306,36 @@
(λ (x y) (λ (x y)
(set! show-dots? (not show-dots?)) (set! show-dots? (not show-dots?))
(send cbig refresh))]) (send cbig refresh))])
(new button%
[parent bp]
[label "Bitmap"]
[callback
(λ (x y)
(send cbitmap set-label (get-bitmap points (send the-color-database find-color "black"))))])
(send f show #t)) (send f show #t))
#;
(let () (let ()
(define f (new frame% [label ""])) (define f (new frame% [label ""]))
(define m (new message% [label (get-running-bitmap)] [parent f])) (define hp (new horizontal-panel% [parent f]))
(define left-column (new vertical-panel% [parent hp]))
(define right-column (new vertical-panel% [parent hp]))
(define green-rb (get-running-bitmap))
(define black (send the-color-database find-color "black"))
(define rb (get-bitmap running-points black))
(define wb (get-bitmap waiting-points black))
(define wb2 (get-bitmap waiting-points/2 black))
(define rm (new message% [label rb] [parent left-column]))
(define grm (new message% [label green-rb] [parent right-column]))
(new message% [label wb] [parent left-column])
(new message% [label wb2] [parent left-column])
(new message% [label wb2] [parent right-column])
(new message% [label wb] [parent right-column])
(new grow-box-spacer-pane% [parent f]) (new grow-box-spacer-pane% [parent f])
(send (get-running-bitmap) save-file (build-path (collection-path "icons") "run.png") 'png) (send green-rb save-file (build-path (collection-path "icons") "run.png") 'png)
(send rb save-file (build-path (collection-path "icons") "b-run.png") 'png)
(send wb save-file (build-path (collection-path "icons") "b-wait.png") 'png)
(send wb2 save-file (build-path (collection-path "icons") "b-wait2.png") 'png)
(send f show #t)) (send f show #t))
#; #;(edit-points waiting-points/2)
(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 c set-running #t)
(send f show #t))
#;(edit-points waiting-points)
#;(edit-points running-points)) #;(edit-points running-points))

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

@ -23,8 +23,7 @@ module browser threading seems wrong.
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
(lib "name-message.ss" "mrlib") (lib "name-message.ss" "mrlib")
(lib "bitmap-label.ss" "mrlib") (lib "bitmap-label.ss" "mrlib")
(lib "include-bitmap.ss" "mrlib")
"stick-figures.ss"
"drsig.ss" "drsig.ss"
"auto-language.ss" "auto-language.ss"
@ -395,7 +394,7 @@ module browser threading seems wrong.
(λ (x) x) (λ (x) x)
text:info%)))))))))]) text:info%)))))))))])
(class* definitions-super% (definitions-text<%>) (class* definitions-super% (definitions-text<%>)
(inherit get-top-level-window) (inherit get-top-level-window is-locked? lock)
(define interactions-text #f) (define interactions-text #f)
(define/public (set-interactions-text it) (define/public (set-interactions-text it)
@ -471,8 +470,11 @@ module browser threading seems wrong.
(let ([metadata (send lang get-metadata (filename->modname filename) settings)]) (let ([metadata (send lang get-metadata (filename->modname filename) settings)])
(begin-edit-sequence) (begin-edit-sequence)
(begin-metadata-changes) (begin-metadata-changes)
(set! save-file-metadata metadata) (let ([locked? (is-locked?)])
(insert metadata 0 0))))) (when locked? (lock #f))
(set! save-file-metadata metadata)
(insert metadata 0 0)
(when locked? (lock #t)))))))
(define/private (filename->modname filename) (define/private (filename->modname filename)
(let-values ([(base name dir) (split-path filename)]) (let-values ([(base name dir) (split-path filename)])
(string->symbol (regexp-replace #rx"\\.[^.]*$" (string->symbol (regexp-replace #rx"\\.[^.]*$"
@ -489,8 +491,11 @@ module browser threading seems wrong.
(let-values ([(creator type) (file-creator-and-type filename)]) (let-values ([(creator type) (file-creator-and-type filename)])
(file-creator-and-type filename #"DrSc" type)))))) (file-creator-and-type filename #"DrSc" type))))))
(when save-file-metadata (when save-file-metadata
(let ([modified? (is-modified?)]) (let ([modified? (is-modified?)]
[locked? (is-locked?)])
(when locked? (lock #f))
(delete 0 (string-length save-file-metadata)) (delete 0 (string-length save-file-metadata))
(when locked? (lock #t))
(set! save-file-metadata #f) (set! save-file-metadata #f)
;; restore modification status to where it was before the metadata is removed ;; restore modification status to where it was before the metadata is removed
(set-modified modified?) (set-modified modified?)
@ -3364,17 +3369,15 @@ module browser threading seems wrong.
(define language-message (define language-message
(let* ([info-panel (get-info-panel)] (let* ([info-panel (get-info-panel)]
[vp (new vertical-panel% [p (new vertical-panel%
[parent info-panel] [parent info-panel]
[alignment '(left center)] [alignment '(left center)])]
[stretchable-width #t] [language-message (new language-label-message% [parent p] [frame this])])
[stretchable-height #f])]
[l-m-label (new language-label-message% [parent vp] [frame this])]
[language-message (new language-message% [parent vp])])
(send info-panel change-children (send info-panel change-children
(λ (l) (λ (l)
(list* vp (list* p
(remq* (list vp) l)))) (remq* (list p)
l))))
language-message)) language-message))
(update-save-message) (update-save-message)
@ -3401,6 +3404,66 @@ module browser threading seems wrong.
(set! newest-frame this) (set! newest-frame this)
(send definitions-canvas focus))) (send definitions-canvas focus)))
(define running-bitmap (include-bitmap (lib "b-run.png" "icons")))
(define waiting-bitmap (include-bitmap (lib "b-wait.png" "icons")))
(define waiting2-bitmap (include-bitmap (lib "b-wait2.png" "icons")))
(define running/waiting-bitmaps (list running-bitmap waiting-bitmap waiting2-bitmap))
(define running-canvas%
(class canvas%
(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)
(let-values ([(w h) (get-client-size)])
(let ([new-inside?
(and (<= 0 (send evt get-x) w)
(<= 0 (send evt get-y) h))]
[old-inside? inside?])
(set! inside? new-inside?)
(cond
[(and new-inside? (not old-inside?))
(unless is-running?
(set! timer
(new timer%
[notify-callback
(λ ()
(set! toggle? (not toggle?))
(refresh))]
[interval 200])))]
[(and (not new-inside?) old-inside? timer)
(send timer stop)
(set! timer #f)]))))
(define/override (on-paint)
(let ([dc (get-dc)]
[bm
(if is-running?
running-bitmap
(if toggle?
waiting-bitmap
waiting2-bitmap))])
(let-values ([(cw ch) (get-client-size)])
(send dc draw-bitmap bm
(- (/ 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]
[stretchable-height #f]
[style '(transparent)])
(inherit min-width min-height)
(min-width (apply max (map (λ (x) (send x get-width)) running/waiting-bitmaps)))
(min-height (apply max (map (λ (x) (send x get-height)) running/waiting-bitmaps)))))
;; get-mbytes : top-level-window -> (union #f ;; cancel ;; get-mbytes : top-level-window -> (union #f ;; cancel
;; integer[>=100] ;; a limit ;; integer[>=100] ;; a limit
;; #t) ;; no limit ;; #t) ;; no limit
@ -3530,86 +3593,21 @@ module browser threading seems wrong.
(loop (cdr l)) (loop (cdr l))
(cons (car l) (loop (cdr l))))])))) (cons (car l) (loop (cdr l))))]))))
(define programming-language-label (string-constant programming-language-label))
(define second-line-indent 6)
(define language-message%
(class canvas%
(inherit get-dc get-client-size refresh)
(define message "")
(define to-draw-message #f)
(define/public (set-lang l)
(unless (equal? l message)
(set! message l)
(compute-new-string)
(refresh)))
(define yellow? #f)
(define/public (set-yellow/lang y? l)
(unless (and (equal? y? yellow?)
(equal? l message))
(set! yellow? y?)
(set! message l)
(compute-new-string)
(refresh)))
(define/override (on-size w h)
(compute-new-string)
(refresh))
(define/private (compute-new-string)
(let-values ([(cw ch) (get-client-size)])
(let ([width-to-use (- cw (get-left-side-padding))])
(let loop ([c (string-length message)])
(cond
[(= c 0) (set! to-draw-message "")]
[else
(let ([candidate (if (= c (string-length message))
message
(string-append (substring message 0 c) "..."))])
(let-values ([(tw th _1 _2) (send (get-dc) get-text-extent candidate small-control-font)])
(cond
[(tw . <= . width-to-use) (set! to-draw-message candidate)]
[else
(loop (- c 1))])))])))))
(define/public (set-yellow y?)
(unless (equal? y? yellow?)
(set! yellow? y?)
(refresh)))
(define last-time-width 0)
(define last-time-string "")
(define/override (on-paint)
(unless to-draw-message
(compute-new-string))
(let ([dc (get-dc)])
(send dc set-font small-control-font)
(let*-values ([(tw th _1 _2) (send dc get-text-extent to-draw-message)]
[(w h) (values (+ tw (get-left-side-padding)) th)])
(send dc set-pen (get-panel-background) 1 'transparent)
(send dc set-brush (get-panel-background) 'transparent)
(send dc draw-rectangle 0 0 w h)
(when yellow?
(send dc set-pen "black" 1 'transparent)
(send dc set-brush "yellow" 'solid)
(send dc draw-rectangle (get-left-side-padding) 0 tw th))
(send dc draw-text to-draw-message (get-left-side-padding) 0))))
(super-new [style '(transparent)])
(inherit stretchable-width stretchable-height)
(stretchable-width #t)
(stretchable-height #f)
(inherit min-height)
(let ([dc (get-dc)])
(let-values ([(w2 h2 _3 _4) (send dc get-text-extent "x" small-control-font)])
(min-height (inexact->exact (floor h2)))))))
(define language-label-message% (define language-label-message%
(class name-message% (class name-message%
(init-field frame) (init-field frame)
(inherit refresh)
(inherit set-message)
(define yellow? #f)
(define/override (get-background-color) (and yellow? "yellow"))
(define/public (set-yellow y?)
(set! yellow? y?)
(refresh))
(define/public (set-yellow/lang y? lang)
(set-message #f lang)
(set-yellow y?))
(define/override (fill-popup menu reset) (define/override (fill-popup menu reset)
(let ([added-one? #f]) (let ([added-one? #f])
(send (new menu-item% (send (new menu-item%
@ -3658,8 +3656,11 @@ module browser threading seems wrong.
(λ (x y) (λ (x y)
(send frame choose-language-callback))])) (send frame choose-language-callback))]))
(super-new [label programming-language-label] (super-new [label ""]
[font tiny-control-font]))) [font small-control-font])
(inherit set-allow-shrinking)
(set-allow-shrinking 100)))
(define -frame% (frame-mixin super-frame%)) (define -frame% (frame-mixin super-frame%))

111
collects/framework/private/frame.ss
View File

@ -254,10 +254,7 @@
(super-new) (super-new)
(send (group:get-the-frame-group) insert-frame this))) (send (group:get-the-frame-group) insert-frame this)))
(define locked-message-line1 (string-constant read-only-line1)) (define locked-message (string-constant read-only))
(define locked-message-line2 (string-constant read-only-line2))
(define unlocked-message-line1 (string-constant read/write-line1))
(define unlocked-message-line2 (string-constant read/write-line2))
(define lock-canvas% (define lock-canvas%
(class canvas% (class canvas%
@ -272,38 +269,26 @@
(define/override (on-paint) (define/override (on-paint)
(let* ([dc (get-dc)] (let* ([dc (get-dc)]
[draw [draw
(λ (str1 str2 bg-color bg-style line-color line-style) (λ (str bg-color bg-style line-color line-style)
(send dc set-font small-control-font) (send dc set-font small-control-font)
(let-values ([(w h) (get-client-size)] (let-values ([(w h) (get-client-size)]
[(tw1 th1 _1 _2) (send dc get-text-extent str1)] [(tw th _1 _2) (send dc get-text-extent str)])
[(tw2 th2 _3 _4) (send dc get-text-extent str2)])
(send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style)) (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style))
(send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style)) (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style))
(send dc draw-rectangle 0 0 w h) (send dc draw-rectangle 0 0 w h)
(cond (send dc draw-text str
[(string=? str2 "") (- (/ w 2) (/ tw 2))
(send dc draw-text str1 (- (/ h 2) (/ th 2)))))])
(- (/ w 2) (/ tw1 2))
(- (* h 1/2) (/ th1 2)))]
[else
(send dc draw-text str1
(- (/ w 2) (/ tw1 2))
(- (* h 1/2) th1))
(send dc draw-text str2
(- (/ w 2) (/ tw2 2))
(* h 1/2))])))])
(when locked? (when locked?
(draw locked-message-line1 locked-message-line2 (draw locked-message "yellow" 'solid "black" 'solid))))
"yellow" 'solid "black" 'solid))))
(inherit get-parent min-width min-height stretchable-width stretchable-height) (inherit get-parent min-width min-height stretchable-width stretchable-height)
(define/private (setup-sizes) (define/private (setup-sizes)
(let ([dc (get-dc)]) (let ([dc (get-dc)])
(if locked? (if locked?
(let-values ([(wl1 hl1 _1 _2) (send dc get-text-extent locked-message-line1)] (let-values ([(w h _1 _2) (send dc get-text-extent locked-message)])
[(wl2 hl2 _3 _4) (send dc get-text-extent locked-message-line2)]) (min-width (inexact->exact (floor (+ w 4))))
(min-width (inexact->exact (floor (+ 2 (max (+ wl1 2) (+ wl2 2)))))) (min-height (inexact->exact (floor (+ h 2)))))
(min-height (inexact->exact (floor (+ 2 hl1 hl2)))))
(begin (begin
(min-width 0) (min-width 0)
(min-height 0))))) (min-height 0)))))
@ -315,58 +300,6 @@
(stretchable-width #f) (stretchable-width #f)
(stretchable-height #t))) (stretchable-height #t)))
#;
(define lock-canvas%
(class canvas%
(field [locked? #f])
(inherit refresh)
(define/public (set-locked l)
(set! locked? l)
(refresh))
(inherit get-client-size get-dc)
(define/override (on-paint)
(let* ([dc (get-dc)]
[draw
(λ (str1 str2 bg-color bg-style line-color line-style)
(send dc set-font small-control-font)
(let-values ([(w h) (get-client-size)]
[(tw1 th1 _1 _2) (send dc get-text-extent str1)]
[(tw2 th2 _3 _4) (send dc get-text-extent str2)])
(send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style))
(send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style))
(send dc draw-rectangle 0 0 w h)
(cond
[(string=? str2 "")
(send dc draw-text str1
(- (/ w 2) (/ tw1 2))
(- (* h 1/2) (/ th1 2)))]
[else
(send dc draw-text str1
(- (/ w 2) (/ tw1 2))
(- (* h 1/2) th1))
(send dc draw-text str2
(- (/ w 2) (/ tw2 2))
(* h 1/2))])))])
(if locked?
(draw locked-message-line1 locked-message-line2
"yellow" 'solid "black" 'solid)
(draw unlocked-message-line1 unlocked-message-line2
(get-panel-background) 'transparent (get-panel-background) 'transparent))))
(inherit get-parent min-width min-height stretchable-width stretchable-height)
(super-new [style '(transparent)])
(let ([dc (get-dc)])
(send dc set-font small-control-font)
(let-values ([(wl1 hl1 _1 _2) (send dc get-text-extent locked-message-line1)]
[(wl2 hl2 _3 _4) (send dc get-text-extent locked-message-line2)]
[(wu1 hu1 _5 _6) (send dc get-text-extent unlocked-message-line1)]
[(wu2 hu2 _7 _8) (send dc get-text-extent unlocked-message-line2)])
(stretchable-width #f)
(stretchable-height #t)
(min-width (inexact->exact (floor (+ 2 (max (+ wl1 2) (+ wl2 2) wu1 wu2)))))
(min-height (inexact->exact (floor (+ 2 hu1 hu2))))))))
(define status-line<%> (define status-line<%>
(interface (basic<%>) (interface (basic<%>)
open-status-line open-status-line
@ -987,34 +920,26 @@
(define-values (anchor-message (define-values (anchor-message
overwrite-message overwrite-message
macro-recording-message) macro-recording-message)
(let* ([text-info-messages-parent (let* ([anchor-message
(new vertical-panel%
[parent (get-info-panel)]
[stretchable-width #f])]
[anchor-message
(new message% (new message%
[font small-control-font] [font small-control-font]
[label (string-constant auto-extend-selection)] [label (string-constant auto-extend-selection)]
[parent text-info-messages-parent])] [parent (get-info-panel)])]
[hp (new horizontal-panel%
[alignment '(left center)]
[parent text-info-messages-parent]
[stretchable-height #f])]
[overwrite-message [overwrite-message
(new message% (new message%
[font small-control-font] [font small-control-font]
[label (string-constant overwrite)] [label (string-constant overwrite)]
[parent hp])] [parent (get-info-panel)])]
[macro-recording-message [macro-recording-message
(new message% (new message%
[label "c-x;("] [label "c-x;("]
[font small-control-font] [font small-control-font]
[parent hp])]) [parent (get-info-panel)])]
[msgs (list anchor-message
overwrite-message
macro-recording-message)])
(send (get-info-panel) change-children (send (get-info-panel) change-children
(λ (l) (λ (l) (append msgs (remq* msgs l))))
(cons
text-info-messages-parent
(remq text-info-messages-parent l))))
(values anchor-message (values anchor-message
overwrite-message overwrite-message
macro-recording-message))) macro-recording-message)))

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

@ -44,8 +44,8 @@
(define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s)) (define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s))
(define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w)) (define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w))
(define mrf-on-bitmap (delay (include-bitmap (lib "mrf.jpg" "icons")))) (define mrf-on-bitmap (delay (include-bitmap (lib "mrf.png" "icons"))))
(define gc-on-bitmap (delay (include-bitmap (lib "recycle.gif" "icons")))) (define gc-on-bitmap (delay (include-bitmap (lib "recycle.png" "icons"))))
(define (make-off-bitmap onb) (define (make-off-bitmap onb)
(let* ([bitmap (make-object bitmap% (let* ([bitmap (make-object bitmap%

BIN
collects/icons/b-run.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 338 B

BIN
collects/icons/b-wait.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 304 B

BIN
collects/icons/b-wait2.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 315 B

BIN
collects/icons/mrf.jpg
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 981 B

BIN
collects/icons/mrf.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.4 KiB

BIN
collects/icons/recycle.gif
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 482 B

BIN
collects/icons/recycle.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
collects/icons/run.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 399 B

After

Width:  |  Height:  |  Size: 402 B

6
collects/lang/htdp-langs.ss
View File

@ -524,8 +524,7 @@
`(,#'module #%htdp ,language-module `(,#'module #%htdp ,language-module
,@(map (λ (x) ,@(map (λ (x)
`(require ,x)) `(require ,x))
(htdp-lang-settings-teachpacks settings)) (htdp-lang-settings-teachpacks settings))))))])
1))))])
(let ([body-exps (let ([body-exps
(let loop () (let loop ()
(let ([result (reader (object-name port) port)]) (let ([result (reader (object-name port) port)])
@ -555,8 +554,7 @@
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
(dynamic-require ''#%htdp #f) (dynamic-require ''#%htdp #f)) ;; work around a bug in dynamic-require
#;(eval #'(dynamic-require '#%htdp))) ;; work around a bug in dynamic-require
(lambda () (lambda ()
(unless done-already? (unless done-already?
(set! done-already? #t) (set! done-already? #t)

60
collects/mrlib/name-message.ss
View File

@ -24,7 +24,8 @@
[h (and/c number? (min-h w))] [h (and/c number? (min-h w))]
[mouse-over? boolean?] [mouse-over? boolean?]
[grabbed? boolean?] [grabbed? boolean?]
[button-label-font (is-a?/c font%)]) [button-label-font (is-a?/c font%)]
[bkg-color (or/c false/c (is-a?/c color%) string?)])
void?)) void?))
(calc-button-min-sizes (calc-button-min-sizes
@ -45,6 +46,13 @@
(set! hidden? d?) (set! hidden? d?)
(refresh))) (refresh)))
(define allow-to-shrink #f)
(define/public (set-allow-shrinking w)
(unless (eq? w allow-to-shrink)
(set! allow-to-shrink w)
(set! to-draw-message #f)
(update-min-sizes)))
(define paths #f) (define paths #f)
;; label : string ;; label : string
@ -75,6 +83,7 @@
[else (string-constant untitled)])]) [else (string-constant untitled)])])
(unless (equal? label new-label) (unless (equal? label new-label)
(set! label new-label) (set! label new-label)
(set! to-draw-message #f)
(update-min-sizes) (update-min-sizes)
(refresh)))) (refresh))))
@ -134,13 +143,25 @@
(inherit get-parent) (inherit get-parent)
(define/private (update-min-sizes) (define/private (update-min-sizes)
(let-values ([(w h) (calc-button-min-sizes (get-dc) label font)]) (let-values ([(w h) (calc-button-min-sizes (get-dc) label font)])
(min-width w) (cond
[allow-to-shrink
(cond
[(< w allow-to-shrink)
(stretchable-width #f)
(min-width w)]
[else
(stretchable-width #t)
(min-width allow-to-shrink)])]
[else
(min-width w)])
(min-height h) (min-height h)
(send (get-parent) reflow-container))) (send (get-parent) reflow-container)))
(define/override (on-paint) (define/override (on-paint)
(when paint-sema (when paint-sema
(semaphore-post paint-sema)) (semaphore-post paint-sema))
(unless to-draw-message
(compute-new-string))
(let ([dc (get-dc)]) (let ([dc (get-dc)])
(let-values ([(w h) (get-client-size)]) (let-values ([(w h) (get-client-size)])
(cond (cond
@ -154,7 +175,30 @@
(send dc set-brush brush))] (send dc set-brush brush))]
[else [else
(when (and (> w 5) (> h 5)) (when (and (> w 5) (> h 5))
(draw-button-label dc label 0 0 w h mouse-over? mouse-grabbed? font))])))) (draw-button-label dc to-draw-message 0 0 w h mouse-over? mouse-grabbed? font (get-background-color)))]))))
(define/public (get-background-color) #f)
(define to-draw-message #f)
(define/private (compute-new-string)
(let-values ([(cw ch) (get-client-size)])
(let ([width-to-use (- cw (get-left-side-padding) triangle-width circle-spacer)])
(let loop ([c (string-length label)])
(cond
[(= c 0) (set! to-draw-message "")]
[else
(let ([candidate (if (= c (string-length label))
label
(string-append (substring label 0 c) "..."))])
(let-values ([(tw th _1 _2) (send (get-dc) get-text-extent candidate small-control-font)])
(cond
[(tw . <= . width-to-use) (set! to-draw-message candidate)]
[else
(loop (- c 1))])))])))))
(define/override (on-size w h)
(compute-new-string)
(refresh))
(super-new [style '(transparent no-focus)]) (super-new [style '(transparent no-focus)])
(update-min-sizes) (update-min-sizes)
@ -215,7 +259,13 @@
ans-w ans-w
ans-h))) ans-h)))
(define (draw-button-label dc label dx dy w h mouse-over? grabbed? button-label-font) (define (draw-button-label dc label dx dy w h mouse-over? grabbed? button-label-font bkg-color)
(when bkg-color
(send dc set-pen bkg-color 1 'solid)
(send dc set-brush bkg-color 'solid)
(send dc draw-rectangle dx dy w h))
(when (or mouse-over? grabbed?) (when (or mouse-over? grabbed?)
(let ([color (if grabbed? (let ([color (if grabbed?
mouse-grabbed-color mouse-grabbed-color

5
collects/string-constants/danish-string-constants.ss
View File

@ -196,10 +196,7 @@ please adhere to these guidelines:
;;; info bar at botttom of drscheme frame ;;; info bar at botttom of drscheme frame
(collect-button-label "GC") (collect-button-label "GC")
(read-only-line1 "Skrivebeskyttet") (read-only "Skrivebeskyttet")
(read-only-line2 "")
(read/write-line1 "Læs/")
(read/write-line2 "Skriv")
(auto-extend-selection "Auto-udvid") (auto-extend-selection "Auto-udvid")
(overwrite "Overskriv") (overwrite "Overskriv")
(running "kører") (running "kører")

5
collects/string-constants/dutch-string-constants.ss
View File

@ -81,10 +81,7 @@
;;; info bar at botttom of drscheme frame ;;; info bar at botttom of drscheme frame
(collect-button-label "GC") (collect-button-label "GC")
(read-only-line1 "Alleen") (read-only "Alleen lezen")
(read-only-line2 "lezen")
(read/write-line1 "Lezen/")
(read/write-line2 "Schrijven")
(auto-extend-selection "Auto-extend") ; <**> -- when does this appear? (auto-extend-selection "Auto-extend") ; <**> -- when does this appear?
(overwrite "Vervang") (overwrite "Vervang")
(running "Bezig") (running "Bezig")

9
collects/string-constants/english-string-constants.ss
View File

@ -196,10 +196,7 @@ please adhere to these guidelines:
;;; info bar at botttom of drscheme frame ;;; info bar at botttom of drscheme frame
(collect-button-label "GC") (collect-button-label "GC")
(read-only-line1 "Read") (read-only "Read only")
(read-only-line2 "only")
(read/write-line1 "Read/")
(read/write-line2 "Write")
(auto-extend-selection "Auto-extend") (auto-extend-selection "Auto-extend")
(overwrite "Overwrite") (overwrite "Overwrite")
(running "running") (running "running")
@ -958,9 +955,7 @@ please adhere to these guidelines:
(use-repeating-decimals "Repeating decimals") (use-repeating-decimals "Repeating decimals")
(decimal-notation-for-rationals "Use decimal notation for rationals") (decimal-notation-for-rationals "Use decimal notation for rationals")
; used in the bottom left of the drscheme frame as the label ; used in the bottom left of the drscheme frame
; above the programming language's name
(programming-language-label "Programming language:")
; used the popup menu from the just above; greyed out and only ; used the popup menu from the just above; greyed out and only
; visible when some languages are in the history ; visible when some languages are in the history
(recent-languages "Recent languages:") (recent-languages "Recent languages:")

7
collects/string-constants/french-string-constants.ss
View File

@ -196,10 +196,7 @@
;;; info bar at botttom of drscheme frame ;;; info bar at botttom of drscheme frame
(collect-button-label "Ramassage") ; de miettes (collect-button-label "Ramassage") ; de miettes
(read-only-line1 "Lecture") (read-only "Lecture seulement")
(read-only-line2 "seulement")
(read/write-line1 "Lecture/")
(read/write-line2 "écriture")
(auto-extend-selection "Autosélection") ; "Sélection auto-étendable" ? (auto-extend-selection "Autosélection") ; "Sélection auto-étendable" ?
(overwrite "Correction") ; vs Insertion ? surimpression ? (overwrite "Correction") ; vs Insertion ? surimpression ?
(running "en cours") (running "en cours")
@ -959,8 +956,6 @@
(decimal-notation-for-rationals "Utiliser la notation décimale pour les nombres rationnels") (decimal-notation-for-rationals "Utiliser la notation décimale pour les nombres rationnels")
; used in the bottom left of the drscheme frame as the label ; used in the bottom left of the drscheme frame as the label
; above the programming language's name
(programming-language-label "Langage de programmation :")
; used the popup menu from the just above; greyed out and only ; used the popup menu from the just above; greyed out and only
; visible when some languages are in the history ; visible when some languages are in the history
(recent-languages "Langages récents :") (recent-languages "Langages récents :")

6
collects/string-constants/german-string-constants.ss
View File

@ -98,10 +98,7 @@
;;; info bar at botttom of drscheme frame ;;; info bar at botttom of drscheme frame
(collect-button-label "GC") (collect-button-label "GC")
(read-only-line1 "Lese-") (read-only "Lese Modus")
(read-only-line2 "Modus")
(read/write-line1 "Schreib-")
(read/write-line2 "Modus")
(auto-extend-selection "Automatisch erweitern") (auto-extend-selection "Automatisch erweitern")
(overwrite "Überschreiben") (overwrite "Überschreiben")
(running "Programm läuft") (running "Programm läuft")
@ -854,7 +851,6 @@
;; used in the bottom left of the drscheme frame as the label ;; used in the bottom left of the drscheme frame as the label
;; above the programming language's name ;; above the programming language's name
(programming-language-label "Programmiersprache:")
;; used the popup menu from the just above; greyed out and only ;; used the popup menu from the just above; greyed out and only
;; visible when some languages are in the history ;; visible when some languages are in the history
(recent-languages "Kürzlich verwendete Sprachen:") (recent-languages "Kürzlich verwendete Sprachen:")

5
collects/string-constants/portuguese-string-constants.ss
View File

@ -196,10 +196,7 @@ please adhere to these guidelines:
;;; info bar at botttom of drscheme frame ;;; info bar at botttom of drscheme frame
(collect-button-label "GC") (collect-button-label "GC")
(read-only-line1 "Apenas") (read-only "Apenas Leitura")
(read-only-line2 "Leitura")
(read/write-line1 "Leitura/")
(read/write-line2 "Escrita")
(auto-extend-selection "Auto-Extensível") (auto-extend-selection "Auto-Extensível")
(overwrite "Reescrever") (overwrite "Reescrever")
(running "a executar") (running "a executar")

6
collects/string-constants/simplified-chinese-string-constants.ss
View File

@ -123,10 +123,7 @@
;;; info bar at botttom of drscheme frame ;;; info bar at botttom of drscheme frame
(collect-button-label "垃圾回收") (collect-button-label "垃圾回收")
(read-only-line1 "只") (read-only "只读")
(read-only-line2 "读")
(read/write-line1 "读/")
(read/write-line2 "写")
(auto-extend-selection "自动扩展") (auto-extend-selection "自动扩展")
(overwrite "覆盖") (overwrite "覆盖")
(running "运行中") (running "运行中")
@ -886,7 +883,6 @@
; used in the bottom left of the drscheme frame as the label ; used in the bottom left of the drscheme frame as the label
; above the programming language's name ; above the programming language's name
(programming-language-label "编程语言：")
; used the popup menu from the just above; greyed out and only ; used the popup menu from the just above; greyed out and only
; visible when some languages are in the history ; visible when some languages are in the history
(recent-languages "最近使用的语言：") (recent-languages "最近使用的语言：")

5
collects/string-constants/spanish-string-constants.ss
View File

@ -104,10 +104,7 @@
;;; info bar at botttom of drscheme frame ;;; info bar at botttom of drscheme frame
(collect-button-label "Recolectar") (collect-button-label "Recolectar")
(read-only-line1 "Sólo") (read-only "Sólo lectura")
(read-only-line2 "lectura")
(read/write-line1 "Lectura/")
(read/write-line2 "Escritura")
(auto-extend-selection "Selección Auto-Extendida") (auto-extend-selection "Selección Auto-Extendida")
(overwrite "Sobreescribir") (overwrite "Sobreescribir")
(running "ejecutando") (running "ejecutando")

6
collects/string-constants/traditional-chinese-string-constants.ss
View File

@ -122,10 +122,7 @@
;;; info bar at botttom of drscheme frame ;;; info bar at botttom of drscheme frame
(collect-button-label "垃圾回收") (collect-button-label "垃圾回收")
(read-only-line1 "只") (read-only "只讀")
(read-only-line2 "讀")
(read/write-line1 "讀/")
(read/write-line2 "寫")
(auto-extend-selection "自動擴展") (auto-extend-selection "自動擴展")
(overwrite "覆蓋") (overwrite "覆蓋")
(running "運行中") (running "運行中")
@ -885,7 +882,6 @@
; used in the bottom left of the drscheme frame as the label ; used in the bottom left of the drscheme frame as the label
; above the programming language's name ; above the programming language's name
(programming-language-label "程式語言：")
; used the popup menu from the just above; greyed out and only ; used the popup menu from the just above; greyed out and only
; visible when some languages are in the history ; visible when some languages are in the history
(recent-languages "最近使用的語言：") (recent-languages "最近使用的語言：")