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

tab-choice changes

Browse Source 
svn: r53
This commit is contained in:
Matthew Flatt 2005-06-02 17:41:28 +00:00
parent 724c893b1f
commit 44ea72dd13
1 changed files with 16 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/mrlib/tab-choice.ss
View File

@ -9,7 +9,7 @@
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "list.ss")) (lib "list.ss"))
(provide tab-choice% (provide auto-tab-panel%
single<%> single-mixin) single<%> single-mixin)
(define single<%> (interface (area-container<%>) active-child)) (define single<%> (interface (area-container<%>) active-child))
@ -32,16 +32,10 @@
(send c show #f) (send c show #f)
(set! current-active-child c))) (set! current-active-child c)))
[define/override (container-size l) [define/override (container-size l)
(let-values ([(w h) (super container-size l)] (if (null? l)
[(dw dh) (if (this . is-a? . window<%>) (values 0 0)
(let-values ([(cw ch) (send this get-client-size)] (values (apply max (map car l))
[(nw nh) (send this get-size)]) (apply max (map cadr l))))]
(values (- nw cw) (- nh ch)))
(values 0 0))])
(if (null? l)
(values w h)
(values (+ dw (apply max (- w dw) (map car l)))
(+ dh (apply max (- h dh) (map cadr l))))))]
[define/override (place-children l width height) [define/override (place-children l width height)
(let-values ([(h-align-spec v-align-spec) (get-alignment)]) (let-values ([(h-align-spec v-align-spec) (get-alignment)])
(let ([align (let ([align
@ -86,8 +80,8 @@
(end-container-sequence))])) (end-container-sequence))]))
(super-instantiate ()))) (super-instantiate ())))
(define tab-choice% (define auto-tab-panel%
(class (single-mixin tab-panel%) (class tab-panel%
(init choices (init choices
parent parent
[callback (lambda (b e) (void))]) [callback (lambda (b e) (void))])
@ -98,23 +92,26 @@
[parent parent] [parent parent]
[callback [callback
(lambda (b e) (lambda (b e)
(super active-child (list-ref panels (get-selection))) (send single-panel active-child (list-ref panels (get-selection)))
(callback b e))]) (callback b e))])
(define single-panel (new (single-mixin pane%)
[parent this]))
(inherit get-number) (inherit get-number)
(define panels (let loop ([i (get-number)]) (define panels (let loop ([i (get-number)])
(unless (zero? i) (unless (zero? i)
(cons (new vertical-panel% [parent this]) (cons (new vertical-panel% [parent single-panel])
(loop (sub1 i)))))) (loop (sub1 i))))))
(define/public (get-panel i) (define/public (get-panel i)
(list-ref panels i)) (list-ref panels i))
(define/override active-child (define/public active-child
(case-lambda (case-lambda
[() (super active-child)] [() (send single-panel active-child)]
[(c) [(c)
(super active-child c) (send single-panel active-child c)
(let loop ([i 0][l panels]) (let loop ([i 0][l panels])
(unless (null? l) (unless (null? l)
(if (eq? (car l) c) (if (eq? (car l) c)
@ -123,4 +120,4 @@
(define/override (set-selection i) (define/override (set-selection i)
(super set-selection i) (super set-selection i)
(super active-child (list-ref panels i)))))) (send single-panel active-child (list-ref panels i))))))