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

...

Browse Source 
original commit: 17547f17d7985a74086a5f0da7ccf34326340598
This commit is contained in:
Robby Findler 2001-08-29 04:27:20 +00:00
parent 77ce0a58a4
commit a19fd059a3
3 changed files with 46 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/framework/private/main.ss
View File

@ -53,7 +53,7 @@
(for-each (lambda (x) (for-each (lambda (x)
(hash-table-put! hash-table (add-#% x) 'begin) (hash-table-put! hash-table (add-#% x) 'begin)
(hash-table-put! hash-table x 'begin)) (hash-table-put! hash-table x 'begin))
'(cond '(cond case-lambda
begin begin0 delay begin begin0 delay
unit compound-unit compound-unit/sig unit compound-unit compound-unit/sig
public private override public private override

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

@ -1,3 +1,4 @@
(module panel mzscheme (module panel mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
@ -51,15 +52,21 @@
[(center) (- (/ total-size 2) (/ item-size 2))] [(center) (- (/ total-size 2) (/ item-size 2))]
[(left top) 0] [(left top) 0]
[(right bottom) (- total-size item-size)] [(right bottom) (- total-size item-size)]
[else (error 'place-children "alignment spec is unknown ~a~n" spec)])))]) [else (error 'place-children
"alignment spec is unknown ~a~n" spec)])))])
(map (lambda (l) (map (lambda (l)
(let*-values ([(min-width min-height v-stretch? h-stretch?) (apply values l)] (let*-values ([(min-width min-height v-stretch? h-stretch?)
[(x this-width) (if h-stretch? (apply values l)]
(values 0 width) [(x this-width)
(values (align width h-align-spec min-width) min-width))] (if h-stretch?
[(y this-height) (if v-stretch? (values 0 width)
(values 0 height) (values (align width h-align-spec min-width)
(values (align height v-align-spec min-height) min-height))]) min-width))]
[(y this-height)
(if v-stretch?
(values 0 height)
(values (align height v-align-spec min-height)
min-height))])
(list x y this-width this-height))) (list x y this-width this-height)))
l))))] l))))]
@ -262,7 +269,8 @@
(let loop ([percentages percentages] (let loop ([percentages percentages]
[i i]) [i i])
(cond (cond
[(null? percentages) (error 'panel:vertical-resizable "internal error: sub-percentages")] [(null? percentages)
(error 'panel:vertical-resizable "internal error: sub-percentages")]
[(= i 0) (car percentages)] [(= i 0) (car percentages)]
[else (+ (car percentages) (loop (cdr percentages) (- i 1)))])))] [else (+ (car percentages) (loop (cdr percentages) (- i 1)))])))]
[update-percentage/draw [update-percentage/draw
@ -274,7 +282,9 @@
[y-min [y-min
(let ([min-child-height (let ([min-child-height
(max thumb-height (max thumb-height
(let-values ([(w h) (send (list-ref (send parent get-children) (+ grabbed 1)) get-graphical-min-size)]) (let-values ([(w h) (send (list-ref (send parent get-children)
(+ grabbed 1))
get-graphical-min-size)])
h))]) h))])
(if (= grabbed 0) (if (= grabbed 0)
min-child-height min-child-height
@ -480,6 +490,11 @@
(define vertical-resizable% (vertical-resizable-mixin panel%)) (define vertical-resizable% (vertical-resizable-mixin panel%))
(define vertical-resizable-pane% (vertical-resizable-mixin pane%)) (define vertical-resizable-pane% (vertical-resizable-mixin pane%))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define bar-canvas% (define bar-canvas%
(class canvas% (class canvas%
(init vertical?) (init vertical?)
@ -529,67 +544,24 @@
(super-instantiate (parent)) (super-instantiate (parent))
(inherit get-client-size container-flow-modified) (inherit get-client-size container-flow-modified)
(define/public (vertical?) (error 'vertical? "abstract")) (init-field [bar-thickness 6]
(define/public (get-sub-panel%) (error 'get-sub-panel% "abstract"))
(init-field [first-percent 0.30]
[bar-thickness 5]
[min-pane-size 5]) [min-pane-size 5])
(define size 0) (define size 0)
(define start-percent 0.0) (define start-percent 0.0)
(define/private (pick-dir w h) (define/override (after-new-child child)
(if (vertical?) h w)) (refresh-bars (get-children)))
(define/private (rotate l)
(if (vertical?)
l
(list (cadr l) (car l)
(cadddr l) (caddr l))))
(define first-pane (make-object (get-sub-panel%) this))
(define bar-canvas (instantiate bar-canvas% ()
[parent this]
[min-height bar-thickness]
[stretchable-height #f]
[vertical? (vertical?)]
[bar-start
(lambda ()
(set! start-percent first-percent)
(let-values ([(w h) (get-client-size)])
(set! size (pick-dir w h))))]
[bar-move
(lambda (dx dy)
(set! first-percent
(/ (+ (* size start-percent) (pick-dir dx dy))
size))
(container-flow-modified))]
[bar-done
(lambda ()
'ok)]))
(define second-pane (make-object (get-sub-panel%) this))
(define bar-gaps null)
(rename [super-place-children place-children])
(define/override (place-children info w h) (define/override (place-children info w h)
(if (= 3 (length info)) 'hm
(let* ([min-first-size (max min-pane-size ;; cannot use the super-method, since I want to use
(list-ref (car info) (pick-dir 0 1)))] ;; percentages.
[min-second-size (max min-pane-size ;; just assume that all children are stretchable and
(list-ref (caddr info) (pick-dir 0 1)))] ;; what about minimum sizes?
[first-size )
(min (max min-first-size
(inexact->exact (floor (* (- (pick-dir w h) bar-thickness)
first-percent))))
(- (pick-dir w h) bar-thickness min-second-size))]
[common-size (pick-dir h w)])
(list
(rotate (list 0 0 common-size first-size))
(rotate (list 0 first-size common-size bar-thickness))
(rotate (list 0 (+ first-size bar-thickness)
common-size (- (pick-dir w h)
first-size
bar-thickness)))))
(map (lambda (i) (list 0 0 w h)) info)))
(inherit change-children) (inherit change-children)
(define/public (show-both-panels) (define/public (show-both-panels)

17
collects/framework/private/sig.ss
View File

@ -50,13 +50,13 @@
vertical-resizable<%> vertical-resizable<%>
vertical-resizable-mixin vertical-resizable-mixin
two-panel<%> ;two-panel<%>
horizontal-two-panel<%> ;horizontal-two-panel<%>
vertical-two-panel<%> ;vertical-two-panel<%>
two-panel-mixin ;two-panel-mixin
horizontal-two-panel-mixin ;horizontal-two-panel-mixin
vertical-two-panel-mixin ;vertical-two-panel-mixin
single% single%
single-pane% single-pane%
@ -64,8 +64,9 @@
vertical-resizable% vertical-resizable%
vertical-resizable-pane% vertical-resizable-pane%
horizontal-two-panel% ;horizontal-two-panel%
vertical-two-panel%)) ;vertical-two-panel%
))
(define-signature framework:exn^ (define-signature framework:exn^
((struct exn ()) ((struct exn ())