made the bottom line of the drscheme window be half as tall
svn: r7762
This commit is contained in:
Robby Findler
parent
976b976c4a
commit
753cd127a6
|
|
@ -25,7 +25,12 @@
|
|||
(when (equal? lang-spec spec-in-file)
|
||||
(set! found-language? lang)
|
||||
(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)
|
||||
|
||||
;; check to see if it looks like the module language.
|
||||
|
|
|
|||
|
|
@ -3,15 +3,48 @@
|
|||
(lib "pretty.ss")
|
||||
(lib "mred.ss" "mred"))
|
||||
|
||||
(provide running-canvas%
|
||||
get-running-bitmap)
|
||||
|
||||
(define head-size 40)
|
||||
(define running-factor 1/2)
|
||||
(define small-bitmap-factor 1/2)
|
||||
(define small-factor 1/5)
|
||||
(define line-size 2)
|
||||
|
||||
(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)
|
||||
(neck 43 18)
|
||||
(shoulders 37 33)
|
||||
|
|
@ -29,7 +62,7 @@
|
|||
(left-toe 0 154)
|
||||
(right-toe 83 146)))
|
||||
|
||||
(define waiting-points/2
|
||||
(define waiting-points/2/old
|
||||
'((head 55 0)
|
||||
(neck 43 18)
|
||||
(shoulders 37 33)
|
||||
|
|
@ -65,58 +98,6 @@
|
|||
(left-toe 14 146)
|
||||
(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)
|
||||
(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)]
|
||||
|
|
@ -134,59 +115,44 @@
|
|||
[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 2]
|
||||
[bw (+ margin margin (ceiling (* small-factor (- max-rx min-rx))))]
|
||||
[bh (+ margin margin (ceiling (* small-factor (- max-ry min-ry))))]
|
||||
[w (ceiling (* bw running-factor))]
|
||||
[h (ceiling (* bh running-factor))]
|
||||
[bm-big (make-object bitmap% bw bh)]
|
||||
[bm-solid (make-object bitmap% w h)]
|
||||
[bm-small (make-object bitmap% w h)]
|
||||
[bdc-big (make-object bitmap-dc% bm-big)]
|
||||
[bdc-solid (make-object bitmap-dc% bm-solid)]
|
||||
[bdc-small (make-object bitmap-dc% bm-small)]
|
||||
[green (make-object color% 30 100 30)])
|
||||
(send bdc-big clear)
|
||||
(draw-callback bdc-big small-factor #f running-points
|
||||
(+ margin (- (* small-factor min-rx)))
|
||||
(+ margin (- (* small-factor min-ry)))
|
||||
3)
|
||||
(define (get-bitmap points green)
|
||||
(let-values ([(min-rx min-ry) (get-max/min-x/y min points)]
|
||||
[(max-rx max-ry) (get-max/min-x/y max points)])
|
||||
(let* ([margin 2]
|
||||
[bw (+ margin margin (ceiling (* small-factor (- max-rx min-rx))))]
|
||||
[bh (+ margin margin (ceiling (* small-factor (- max-ry min-ry))))]
|
||||
[w (ceiling (* bw small-bitmap-factor))]
|
||||
[h (ceiling (* bh small-bitmap-factor))]
|
||||
[bm-big (make-object bitmap% bw bh)]
|
||||
[bm-solid (make-object bitmap% w h)]
|
||||
[bm-small (make-object bitmap% w h)]
|
||||
[bdc-big (make-object bitmap-dc% bm-big)]
|
||||
[bdc-solid (make-object bitmap-dc% bm-solid)]
|
||||
[bdc-small (make-object bitmap-dc% bm-small)])
|
||||
(send bdc-big clear)
|
||||
(draw-callback bdc-big small-factor #f points
|
||||
(+ margin (- (* small-factor min-rx)))
|
||||
(+ margin #;(- (* small-factor min-ry)))
|
||||
3)
|
||||
|
||||
(send bdc-small clear)
|
||||
(send bdc-small set-scale running-factor running-factor)
|
||||
(send bdc-small draw-bitmap bm-big 0 0)
|
||||
(send bdc-small set-scale 1 1)
|
||||
(send bdc-small clear)
|
||||
(send bdc-small set-scale small-bitmap-factor small-bitmap-factor)
|
||||
(send bdc-small draw-bitmap bm-big 0 0)
|
||||
(send bdc-small set-scale 1 1)
|
||||
|
||||
(send bdc-solid set-brush green 'solid)
|
||||
(send bdc-solid set-pen green 1 'solid)
|
||||
(send bdc-solid draw-rectangle 0 0 w h)
|
||||
(send bdc-solid set-brush green 'solid)
|
||||
(send bdc-solid set-pen green 1 'solid)
|
||||
(send bdc-solid draw-rectangle 0 0 w h)
|
||||
|
||||
(send bdc-solid set-bitmap #f)
|
||||
(send bdc-small set-bitmap #f)
|
||||
(send bdc-big set-bitmap #f)
|
||||
(send bdc-solid set-bitmap #f)
|
||||
(send bdc-small set-bitmap #f)
|
||||
(send bdc-big set-bitmap #f)
|
||||
|
||||
(send bm-solid set-loaded-mask bm-small)
|
||||
(set! running-bitmap 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)))
|
||||
(send bm-solid set-loaded-mask bm-small)
|
||||
bm-solid)))
|
||||
|
||||
(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)
|
||||
(let-values ([(min-x min-y) (get-max/min-x/y min points)])
|
||||
|
|
@ -258,7 +224,7 @@
|
|||
(+ dy (* factor (list-ref to-p 2)))))))
|
||||
|
||||
;; 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.
|
||||
(define (edit-points points)
|
||||
(define c%
|
||||
|
|
@ -325,6 +291,7 @@
|
|||
(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 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]))
|
||||
(new button%
|
||||
[parent bp]
|
||||
|
|
@ -339,30 +306,36 @@
|
|||
(λ (x y)
|
||||
(set! show-dots? (not show-dots?))
|
||||
(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))
|
||||
|
||||
#;
|
||||
(let ()
|
||||
(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])
|
||||
(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))
|
||||
|
||||
#;
|
||||
(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 waiting-points/2)
|
||||
#;(edit-points running-points))
|
||||
|
|
|
|||
|
|
@ -23,8 +23,7 @@ module browser threading seems wrong.
|
|||
(lib "framework.ss" "framework")
|
||||
(lib "name-message.ss" "mrlib")
|
||||
(lib "bitmap-label.ss" "mrlib")
|
||||
|
||||
"stick-figures.ss"
|
||||
(lib "include-bitmap.ss" "mrlib")
|
||||
"drsig.ss"
|
||||
"auto-language.ss"
|
||||
|
||||
|
|
@ -395,7 +394,7 @@ module browser threading seems wrong.
|
|||
(λ (x) x)
|
||||
text:info%)))))))))])
|
||||
(class* definitions-super% (definitions-text<%>)
|
||||
(inherit get-top-level-window)
|
||||
(inherit get-top-level-window is-locked? lock)
|
||||
|
||||
(define interactions-text #f)
|
||||
(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)])
|
||||
(begin-edit-sequence)
|
||||
(begin-metadata-changes)
|
||||
(set! save-file-metadata metadata)
|
||||
(insert metadata 0 0)))))
|
||||
(let ([locked? (is-locked?)])
|
||||
(when locked? (lock #f))
|
||||
(set! save-file-metadata metadata)
|
||||
(insert metadata 0 0)
|
||||
(when locked? (lock #t)))))))
|
||||
(define/private (filename->modname filename)
|
||||
(let-values ([(base name dir) (split-path filename)])
|
||||
(string->symbol (regexp-replace #rx"\\.[^.]*$"
|
||||
|
|
@ -489,8 +491,11 @@ module browser threading seems wrong.
|
|||
(let-values ([(creator type) (file-creator-and-type filename)])
|
||||
(file-creator-and-type filename #"DrSc" type))))))
|
||||
(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))
|
||||
(when locked? (lock #t))
|
||||
(set! save-file-metadata #f)
|
||||
;; restore modification status to where it was before the metadata is removed
|
||||
(set-modified modified?)
|
||||
|
|
@ -3364,17 +3369,15 @@ module browser threading seems wrong.
|
|||
|
||||
(define language-message
|
||||
(let* ([info-panel (get-info-panel)]
|
||||
[vp (new vertical-panel%
|
||||
[parent info-panel]
|
||||
[alignment '(left center)]
|
||||
[stretchable-width #t]
|
||||
[stretchable-height #f])]
|
||||
[l-m-label (new language-label-message% [parent vp] [frame this])]
|
||||
[language-message (new language-message% [parent vp])])
|
||||
[p (new vertical-panel%
|
||||
[parent info-panel]
|
||||
[alignment '(left center)])]
|
||||
[language-message (new language-label-message% [parent p] [frame this])])
|
||||
(send info-panel change-children
|
||||
(λ (l)
|
||||
(list* vp
|
||||
(remq* (list vp) l))))
|
||||
(list* p
|
||||
(remq* (list p)
|
||||
l))))
|
||||
language-message))
|
||||
|
||||
(update-save-message)
|
||||
|
|
@ -3401,6 +3404,66 @@ module browser threading seems wrong.
|
|||
(set! newest-frame this)
|
||||
(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
|
||||
;; integer[>=100] ;; a limit
|
||||
;; #t) ;; no limit
|
||||
|
|
@ -3530,86 +3593,21 @@ module browser threading seems wrong.
|
|||
(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%
|
||||
(class name-message%
|
||||
(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)
|
||||
(let ([added-one? #f])
|
||||
(send (new menu-item%
|
||||
|
|
@ -3658,8 +3656,11 @@ module browser threading seems wrong.
|
|||
(λ (x y)
|
||||
(send frame choose-language-callback))]))
|
||||
|
||||
(super-new [label programming-language-label]
|
||||
[font tiny-control-font])))
|
||||
(super-new [label ""]
|
||||
[font small-control-font])
|
||||
|
||||
(inherit set-allow-shrinking)
|
||||
(set-allow-shrinking 100)))
|
||||
|
||||
(define -frame% (frame-mixin super-frame%))
|
||||
|
||||
|
|
|
|||
|
|
@ -254,10 +254,7 @@
|
|||
(super-new)
|
||||
(send (group:get-the-frame-group) insert-frame this)))
|
||||
|
||||
(define locked-message-line1 (string-constant read-only-line1))
|
||||
(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 locked-message (string-constant read-only))
|
||||
|
||||
(define lock-canvas%
|
||||
(class canvas%
|
||||
|
|
@ -272,38 +269,26 @@
|
|||
(define/override (on-paint)
|
||||
(let* ([dc (get-dc)]
|
||||
[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)
|
||||
(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)])
|
||||
[(tw th _1 _2) (send dc get-text-extent str)])
|
||||
(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))])))])
|
||||
(send dc draw-text str
|
||||
(- (/ w 2) (/ tw 2))
|
||||
(- (/ h 2) (/ th 2)))))])
|
||||
(when locked?
|
||||
(draw locked-message-line1 locked-message-line2
|
||||
"yellow" 'solid "black" 'solid))))
|
||||
(draw locked-message "yellow" 'solid "black" 'solid))))
|
||||
|
||||
(inherit get-parent min-width min-height stretchable-width stretchable-height)
|
||||
(define/private (setup-sizes)
|
||||
(let ([dc (get-dc)])
|
||||
(if locked?
|
||||
(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)])
|
||||
(min-width (inexact->exact (floor (+ 2 (max (+ wl1 2) (+ wl2 2))))))
|
||||
(min-height (inexact->exact (floor (+ 2 hl1 hl2)))))
|
||||
(let-values ([(w h _1 _2) (send dc get-text-extent locked-message)])
|
||||
(min-width (inexact->exact (floor (+ w 4))))
|
||||
(min-height (inexact->exact (floor (+ h 2)))))
|
||||
(begin
|
||||
(min-width 0)
|
||||
(min-height 0)))))
|
||||
|
|
@ -315,58 +300,6 @@
|
|||
(stretchable-width #f)
|
||||
(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<%>
|
||||
(interface (basic<%>)
|
||||
open-status-line
|
||||
|
|
@ -987,34 +920,26 @@
|
|||
(define-values (anchor-message
|
||||
overwrite-message
|
||||
macro-recording-message)
|
||||
(let* ([text-info-messages-parent
|
||||
(new vertical-panel%
|
||||
[parent (get-info-panel)]
|
||||
[stretchable-width #f])]
|
||||
[anchor-message
|
||||
(let* ([anchor-message
|
||||
(new message%
|
||||
[font small-control-font]
|
||||
[label (string-constant auto-extend-selection)]
|
||||
[parent text-info-messages-parent])]
|
||||
[hp (new horizontal-panel%
|
||||
[alignment '(left center)]
|
||||
[parent text-info-messages-parent]
|
||||
[stretchable-height #f])]
|
||||
[parent (get-info-panel)])]
|
||||
[overwrite-message
|
||||
(new message%
|
||||
[font small-control-font]
|
||||
[label (string-constant overwrite)]
|
||||
[parent hp])]
|
||||
[parent (get-info-panel)])]
|
||||
[macro-recording-message
|
||||
(new message%
|
||||
[label "c-x;("]
|
||||
[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
|
||||
(λ (l)
|
||||
(cons
|
||||
text-info-messages-parent
|
||||
(remq text-info-messages-parent l))))
|
||||
(λ (l) (append msgs (remq* msgs l))))
|
||||
(values anchor-message
|
||||
overwrite-message
|
||||
macro-recording-message)))
|
||||
|
|
|
|||
|
|
@ -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-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 gc-on-bitmap (delay (include-bitmap (lib "recycle.gif" "icons"))))
|
||||
(define mrf-on-bitmap (delay (include-bitmap (lib "mrf.png" "icons"))))
|
||||
(define gc-on-bitmap (delay (include-bitmap (lib "recycle.png" "icons"))))
|
||||
|
||||
(define (make-off-bitmap onb)
|
||||
(let* ([bitmap (make-object bitmap%
|
||||
|
|
|
|||
BIN
collects/icons/b-run.png
Normal file
BIN
collects/icons/b-run.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 338 B |
BIN
collects/icons/b-wait.png
Normal file
BIN
collects/icons/b-wait.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 304 B |
BIN
collects/icons/b-wait2.png
Normal file
BIN
collects/icons/b-wait2.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 315 B |
Binary file not shown.
|
Before Width: | Height: | Size: 981 B |
BIN
collects/icons/mrf.png
Normal file
BIN
collects/icons/mrf.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.4 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 482 B |
BIN
collects/icons/recycle.png
Normal file
BIN
collects/icons/recycle.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.6 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 399 B After Width: | Height: | Size: 402 B |
|
|
@ -524,8 +524,7 @@
|
|||
`(,#'module #%htdp ,language-module
|
||||
,@(map (λ (x)
|
||||
`(require ,x))
|
||||
(htdp-lang-settings-teachpacks settings))
|
||||
1))))])
|
||||
(htdp-lang-settings-teachpacks settings))))))])
|
||||
(let ([body-exps
|
||||
(let loop ()
|
||||
(let ([result (reader (object-name port) port)])
|
||||
|
|
@ -555,8 +554,7 @@
|
|||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(dynamic-require ''#%htdp #f)
|
||||
#;(eval #'(dynamic-require '#%htdp))) ;; work around a bug in dynamic-require
|
||||
(dynamic-require ''#%htdp #f)) ;; work around a bug in dynamic-require
|
||||
(lambda ()
|
||||
(unless done-already?
|
||||
(set! done-already? #t)
|
||||
|
|
|
|||
|
|
@ -24,7 +24,8 @@
|
|||
[h (and/c number? (min-h w))]
|
||||
[mouse-over? 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?))
|
||||
|
||||
(calc-button-min-sizes
|
||||
|
|
@ -45,6 +46,13 @@
|
|||
(set! hidden? d?)
|
||||
(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)
|
||||
|
||||
;; label : string
|
||||
|
|
@ -75,6 +83,7 @@
|
|||
[else (string-constant untitled)])])
|
||||
(unless (equal? label new-label)
|
||||
(set! label new-label)
|
||||
(set! to-draw-message #f)
|
||||
(update-min-sizes)
|
||||
(refresh))))
|
||||
|
||||
|
|
@ -134,13 +143,25 @@
|
|||
(inherit get-parent)
|
||||
(define/private (update-min-sizes)
|
||||
(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)
|
||||
(send (get-parent) reflow-container)))
|
||||
|
||||
(define/override (on-paint)
|
||||
(when paint-sema
|
||||
(semaphore-post paint-sema))
|
||||
(semaphore-post paint-sema))
|
||||
(unless to-draw-message
|
||||
(compute-new-string))
|
||||
(let ([dc (get-dc)])
|
||||
(let-values ([(w h) (get-client-size)])
|
||||
(cond
|
||||
|
|
@ -154,7 +175,30 @@
|
|||
(send dc set-brush brush))]
|
||||
[else
|
||||
(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)])
|
||||
(update-min-sizes)
|
||||
|
|
@ -215,7 +259,13 @@
|
|||
ans-w
|
||||
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?)
|
||||
(let ([color (if grabbed?
|
||||
mouse-grabbed-color
|
||||
|
|
|
|||
|
|
@ -196,10 +196,7 @@ please adhere to these guidelines:
|
|||
|
||||
;;; info bar at botttom of drscheme frame
|
||||
(collect-button-label "GC")
|
||||
(read-only-line1 "Skrivebeskyttet")
|
||||
(read-only-line2 "")
|
||||
(read/write-line1 "Læs/")
|
||||
(read/write-line2 "Skriv")
|
||||
(read-only "Skrivebeskyttet")
|
||||
(auto-extend-selection "Auto-udvid")
|
||||
(overwrite "Overskriv")
|
||||
(running "kører")
|
||||
|
|
|
|||
|
|
@ -81,10 +81,7 @@
|
|||
|
||||
;;; info bar at botttom of drscheme frame
|
||||
(collect-button-label "GC")
|
||||
(read-only-line1 "Alleen")
|
||||
(read-only-line2 "lezen")
|
||||
(read/write-line1 "Lezen/")
|
||||
(read/write-line2 "Schrijven")
|
||||
(read-only "Alleen lezen")
|
||||
(auto-extend-selection "Auto-extend") ; <**> -- when does this appear?
|
||||
(overwrite "Vervang")
|
||||
(running "Bezig")
|
||||
|
|
|
|||
|
|
@ -196,10 +196,7 @@ please adhere to these guidelines:
|
|||
|
||||
;;; info bar at botttom of drscheme frame
|
||||
(collect-button-label "GC")
|
||||
(read-only-line1 "Read")
|
||||
(read-only-line2 "only")
|
||||
(read/write-line1 "Read/")
|
||||
(read/write-line2 "Write")
|
||||
(read-only "Read only")
|
||||
(auto-extend-selection "Auto-extend")
|
||||
(overwrite "Overwrite")
|
||||
(running "running")
|
||||
|
|
@ -958,9 +955,7 @@ please adhere to these guidelines:
|
|||
(use-repeating-decimals "Repeating decimals")
|
||||
(decimal-notation-for-rationals "Use decimal notation for rationals")
|
||||
|
||||
; used in the bottom left of the drscheme frame as the label
|
||||
; above the programming language's name
|
||||
(programming-language-label "Programming language:")
|
||||
; used in the bottom left of the drscheme frame
|
||||
; used the popup menu from the just above; greyed out and only
|
||||
; visible when some languages are in the history
|
||||
(recent-languages "Recent languages:")
|
||||
|
|
|
|||
|
|
@ -196,10 +196,7 @@
|
|||
|
||||
;;; info bar at botttom of drscheme frame
|
||||
(collect-button-label "Ramassage") ; de miettes
|
||||
(read-only-line1 "Lecture")
|
||||
(read-only-line2 "seulement")
|
||||
(read/write-line1 "Lecture/")
|
||||
(read/write-line2 "écriture")
|
||||
(read-only "Lecture seulement")
|
||||
(auto-extend-selection "Autosélection") ; "Sélection auto-étendable" ?
|
||||
(overwrite "Correction") ; vs Insertion ? surimpression ?
|
||||
(running "en cours")
|
||||
|
|
@ -959,8 +956,6 @@
|
|||
(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
|
||||
; above the programming language's name
|
||||
(programming-language-label "Langage de programmation :")
|
||||
; used the popup menu from the just above; greyed out and only
|
||||
; visible when some languages are in the history
|
||||
(recent-languages "Langages récents :")
|
||||
|
|
|
|||
|
|
@ -98,10 +98,7 @@
|
|||
|
||||
;;; info bar at botttom of drscheme frame
|
||||
(collect-button-label "GC")
|
||||
(read-only-line1 "Lese-")
|
||||
(read-only-line2 "Modus")
|
||||
(read/write-line1 "Schreib-")
|
||||
(read/write-line2 "Modus")
|
||||
(read-only "Lese Modus")
|
||||
(auto-extend-selection "Automatisch erweitern")
|
||||
(overwrite "Überschreiben")
|
||||
(running "Programm läuft")
|
||||
|
|
@ -854,7 +851,6 @@
|
|||
|
||||
;; used in the bottom left of the drscheme frame as the label
|
||||
;; above the programming language's name
|
||||
(programming-language-label "Programmiersprache:")
|
||||
;; used the popup menu from the just above; greyed out and only
|
||||
;; visible when some languages are in the history
|
||||
(recent-languages "Kürzlich verwendete Sprachen:")
|
||||
|
|
|
|||
|
|
@ -196,10 +196,7 @@ please adhere to these guidelines:
|
|||
|
||||
;;; info bar at botttom of drscheme frame
|
||||
(collect-button-label "GC")
|
||||
(read-only-line1 "Apenas")
|
||||
(read-only-line2 "Leitura")
|
||||
(read/write-line1 "Leitura/")
|
||||
(read/write-line2 "Escrita")
|
||||
(read-only "Apenas Leitura")
|
||||
(auto-extend-selection "Auto-Extensível")
|
||||
(overwrite "Reescrever")
|
||||
(running "a executar")
|
||||
|
|
|
|||
|
|
@ -123,10 +123,7 @@
|
|||
|
||||
;;; info bar at botttom of drscheme frame
|
||||
(collect-button-label "垃圾回收")
|
||||
(read-only-line1 "只")
|
||||
(read-only-line2 "读")
|
||||
(read/write-line1 "读/")
|
||||
(read/write-line2 "写")
|
||||
(read-only "只读")
|
||||
(auto-extend-selection "自动扩展")
|
||||
(overwrite "覆盖")
|
||||
(running "运行中")
|
||||
|
|
@ -886,7 +883,6 @@
|
|||
|
||||
; used in the bottom left of the drscheme frame as the label
|
||||
; above the programming language's name
|
||||
(programming-language-label "编程语言：")
|
||||
; used the popup menu from the just above; greyed out and only
|
||||
; visible when some languages are in the history
|
||||
(recent-languages "最近使用的语言：")
|
||||
|
|
|
|||
|
|
@ -104,10 +104,7 @@
|
|||
|
||||
;;; info bar at botttom of drscheme frame
|
||||
(collect-button-label "Recolectar")
|
||||
(read-only-line1 "Sólo")
|
||||
(read-only-line2 "lectura")
|
||||
(read/write-line1 "Lectura/")
|
||||
(read/write-line2 "Escritura")
|
||||
(read-only "Sólo lectura")
|
||||
(auto-extend-selection "Selección Auto-Extendida")
|
||||
(overwrite "Sobreescribir")
|
||||
(running "ejecutando")
|
||||
|
|
|
|||
|
|
@ -122,10 +122,7 @@
|
|||
|
||||
;;; info bar at botttom of drscheme frame
|
||||
(collect-button-label "垃圾回收")
|
||||
(read-only-line1 "只")
|
||||
(read-only-line2 "讀")
|
||||
(read/write-line1 "讀/")
|
||||
(read/write-line2 "寫")
|
||||
(read-only "只讀")
|
||||
(auto-extend-selection "自動擴展")
|
||||
(overwrite "覆蓋")
|
||||
(running "運行中")
|
||||
|
|
@ -885,7 +882,6 @@
|
|||
|
||||
; used in the bottom left of the drscheme frame as the label
|
||||
; above the programming language's name
|
||||
(programming-language-label "程式語言：")
|
||||
; used the popup menu from the just above; greyed out and only
|
||||
; visible when some languages are in the history
|
||||
(recent-languages "最近使用的語言：")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user