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,9 +402,18 @@
(send memory-text begin-edit-sequence)
(send memory-text lock #f)
(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 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
(when show-memory-text?
@ -414,7 +423,7 @@
(collect-garbage)
(update-memory-text)))]
[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)
(set! memory-cleanup
(lambda ()

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

@ -380,7 +380,35 @@
(cdr children)
(cdr infos)
(+ 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
(mixin (dragable<%>) (vertical-dragable<%>)

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

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