124 lines
3.5 KiB
Racket
124 lines
3.5 KiB
Racket
|
|
;; This code is not yet complete...
|
|
|
|
;; !!!!!! FIXME: code copied from framework !!!!!!
|
|
;; -- The copy in framework should be removed --
|
|
|
|
(module tab-choice mzscheme
|
|
(require mzlib/class
|
|
mred
|
|
mzlib/list)
|
|
|
|
(provide auto-tab-panel%
|
|
single<%> single-mixin)
|
|
|
|
(define single<%> (interface (area-container<%>) active-child))
|
|
(define single-mixin
|
|
(mixin (area-container<%>) (single<%>)
|
|
(inherit get-alignment change-children)
|
|
(define/override (after-new-child c)
|
|
(unless (is-a? c window<%>)
|
|
|
|
;; would like to remove the child here, waiting on a PR submitted
|
|
;; about change-children during after-new-child
|
|
(change-children
|
|
(lambda (l)
|
|
(remq c l)))
|
|
|
|
(error 'single-mixin::after-new-child
|
|
"all children must implement window<%>, got ~e"
|
|
c))
|
|
(if current-active-child
|
|
(send c show #f)
|
|
(set! current-active-child c)))
|
|
[define/override (container-size l)
|
|
(if (null? l)
|
|
(values 0 0)
|
|
(values (apply max (map car l))
|
|
(apply max (map cadr l))))]
|
|
[define/override (place-children l width height)
|
|
(let-values ([(h-align-spec v-align-spec) (get-alignment)])
|
|
(let ([align
|
|
(lambda (total-size spec item-size)
|
|
(floor
|
|
(case spec
|
|
[(center) (- (/ total-size 2) (/ item-size 2))]
|
|
[(left top) 0]
|
|
[(right bottom) (- total-size item-size)]
|
|
[else (error 'place-children
|
|
"alignment spec is unknown ~a\n" spec)])))])
|
|
(map (lambda (l)
|
|
(let*-values ([(min-width min-height v-stretch? h-stretch?)
|
|
(apply values l)]
|
|
[(x this-width)
|
|
(if h-stretch?
|
|
(values 0 width)
|
|
(values (align width h-align-spec min-width)
|
|
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)))
|
|
l)))]
|
|
|
|
(inherit get-children begin-container-sequence end-container-sequence)
|
|
[define current-active-child #f]
|
|
(define/public active-child
|
|
(case-lambda
|
|
[() current-active-child]
|
|
[(x)
|
|
(unless (memq x (get-children))
|
|
(error 'active-child "got a panel that is not a child: ~e" x))
|
|
(unless (eq? x current-active-child)
|
|
(begin-container-sequence)
|
|
(for-each (lambda (x) (send x show #f))
|
|
(get-children))
|
|
(set! current-active-child x)
|
|
(send current-active-child show #t)
|
|
(end-container-sequence))]))
|
|
(super-instantiate ())))
|
|
|
|
(define auto-tab-panel%
|
|
(class tab-panel%
|
|
(init choices
|
|
parent
|
|
[callback (lambda (b e) (void))])
|
|
|
|
(inherit get-selection)
|
|
|
|
(super-new [choices choices]
|
|
[parent parent]
|
|
[callback
|
|
(lambda (b e)
|
|
(send single-panel active-child (list-ref panels (get-selection)))
|
|
(callback b e))])
|
|
|
|
(define single-panel (new (single-mixin pane%)
|
|
[parent this]))
|
|
|
|
(inherit get-number)
|
|
(define panels (let loop ([i (get-number)])
|
|
(unless (zero? i)
|
|
(cons (new vertical-panel% [parent single-panel])
|
|
(loop (sub1 i))))))
|
|
|
|
(define/public (get-panel i)
|
|
(list-ref panels i))
|
|
|
|
(define/public active-child
|
|
(case-lambda
|
|
[() (send single-panel active-child)]
|
|
[(c)
|
|
(send single-panel active-child c)
|
|
(let loop ([i 0][l panels])
|
|
(unless (null? l)
|
|
(if (eq? (car l) c)
|
|
(super set-selection i)
|
|
(loop (add1 i) (cdr l)))))]))
|
|
|
|
(define/override (set-selection i)
|
|
(super set-selection i)
|
|
(send single-panel active-child (list-ref panels i))))))
|