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

..

Browse Source 
original commit: bedb0c03983309d6c3c31e19af234aadd08f5f81
This commit is contained in:
Robby Findler 2002-09-23 14:35:51 +00:00
parent 11d21d3f63
commit 40c6ef87c2
3 changed files with 52 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -402,10 +402,19 @@
(send memory-text begin-edit-sequence) (send memory-text begin-edit-sequence)
(send memory-text lock #f) (send memory-text lock #f)
(send memory-text erase) (send memory-text erase)
(send memory-text insert (number->string (current-memory-use))) (send memory-text insert (format-number (current-memory-use)))
(send memory-text lock #t) (send memory-text lock #t)
(send memory-text end-edit-sequence)))] (send memory-text end-edit-sequence)))]
(define/private (format-number n)
(let loop ([n n])
(cond
[(<= n 1000) (number->string n)]
[else
(format "~a,~a"
(loop (quotient n 1000))
(modulo n 1000))])))
; only for CVSers ; only for CVSers
(when show-memory-text? (when show-memory-text?
(let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))] (let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))]
@ -414,7 +423,7 @@
(collect-garbage) (collect-garbage)
(update-memory-text)))] (update-memory-text)))]
[ec (make-object editor-canvas% panel memory-text '(no-hscroll no-vscroll))]) [ec (make-object editor-canvas% panel memory-text '(no-hscroll no-vscroll))])
(determine-width "000000000" ec memory-text) (determine-width "0,000,000,000" ec memory-text)
(update-memory-text) (update-memory-text)
(set! memory-cleanup (set! memory-cleanup
(lambda () (lambda ()

28
collects/framework/private/panel.ss
View File

@ -381,6 +381,34 @@
(cdr infos) (cdr infos)
(+ dim this-space bar-thickness))))])))])))) (+ dim this-space bar-thickness))))])))]))))
(define three-bar-pen-bar-width 8)
(define three-bar-canvas%
(class canvas%
(inherit get-dc get-client-size)
(define/override (on-paint)
(let ([dc (get-dc)])
(let-values ([(w h) (get-client-size)])
(let ([sx (floor (- (/ w 2) (/ three-bar-pen-bar-width 2)))])
(send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
(send dc draw-rectangle 0 0 w h)
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
(send dc draw-line sx 1 (+ sx three-bar-pen-bar-width) 1)
(send dc draw-line sx 4 (+ sx three-bar-pen-bar-width) 4)
(send dc draw-line sx 7 (+ sx three-bar-pen-bar-width) 7)
(send dc set-pen (send the-pen-list find-or-create-pen "gray" 1 'solid))
(send dc draw-line sx 2 (+ sx three-bar-pen-bar-width) 2)
(send dc draw-line sx 5 (+ sx three-bar-pen-bar-width) 5)
(send dc draw-line sx 8 (+ sx three-bar-pen-bar-width) 8)))))
(super-instantiate ())
(inherit stretchable-height min-height)
(stretchable-height #f)
(min-height 10)))
(define vertical-dragable-mixin (define vertical-dragable-mixin
(mixin (dragable<%>) (vertical-dragable<%>) (mixin (dragable<%>) (vertical-dragable<%>)

40
collects/framework/private/preferences.ss
View File

@ -667,7 +667,7 @@
(set! ppanels (set! ppanels
(append ppanels (list (make-ppanel title container #f)))) (append ppanels (list (make-ppanel title container #f))))
(when preferences-dialog (when preferences-dialog
(send preferences-dialog added-pane)))) (send preferences-dialog added-pane title))))
(define (hide-dialog) (define (hide-dialog)
(when preferences-dialog (when preferences-dialog
@ -699,16 +699,9 @@
(make-object (class100 frame% args (make-object (class100 frame% args
(public (public
[added-pane [added-pane
(lambda () (lambda (title)
(ensure-constructed) (ensure-constructed)
(refresh-menu) (send tap-panel append title))])
(unless (null? ppanels)
(send popup-menu set-selection (sub1 (length ppanels)))
(send single-panel active-child
(ppanel-panel
(car
(list-tail ppanels
(sub1 (length ppanels))))))))])
(sequence (sequence
(apply super-init args))) (apply super-init args)))
(string-constant preferences))] (string-constant preferences))]
@ -720,15 +713,12 @@
(ppanel-panel (ppanel-panel
(list-ref ppanels (list-ref ppanels
(send tab-panel get-selection))))))] (send tab-panel get-selection))))))]
[make-popup-menu [tap-panel
(lambda () (instantiate tab-panel% ()
(let ([menu (instantiate tab-panel% ()
(choices (map ppanel-title ppanels)) (choices (map ppanel-title ppanels))
(parent panel) (parent panel)
(callback popup-callback))]) (callback popup-callback))]
menu))] [single-panel (make-object panel:single% tap-panel)]
[popup-menu (make-popup-menu)]
[single-panel (make-object panel:single% panel)]
[bottom-panel (make-object horizontal-panel% panel)] [bottom-panel (make-object horizontal-panel% panel)]
[ensure-constructed [ensure-constructed
(lambda () (lambda ()
@ -745,17 +735,7 @@
(send single-panel change-children (lambda (l) (map ppanel-panel ppanels))) (send single-panel change-children (lambda (l) (map ppanel-panel ppanels)))
(unless (null? ppanels) (unless (null? ppanels)
(send single-panel active-child (ppanel-panel (car ppanels)))))] (send single-panel active-child (ppanel-panel (car ppanels)))))]
[refresh-menu
(lambda ()
(let ([new-popup (make-popup-menu)]
[old-selection (send popup-menu get-selection)])
(when old-selection
(send new-popup set-selection old-selection))
(set! popup-menu new-popup)
(send panel change-children
(lambda (l) (list new-popup
single-panel
bottom-panel)))))]
[ok-callback (lambda args [ok-callback (lambda args
(when (andmap (lambda (f) (f)) (when (andmap (lambda (f) (f))
can-close-dialog-callbacks) can-close-dialog-callbacks)
@ -777,7 +757,7 @@
(set-alignment 'right 'center)) (set-alignment 'right 'center))
(ensure-constructed) (ensure-constructed)
(unless (null? ppanels) (unless (null? ppanels)
(send popup-menu set-selection 0)) (send tap-panel set-selection 0))
(send popup-menu focus) (send tap-panel focus)
(send frame show #t) (send frame show #t)
frame)))))) frame))))))