gui/collects/framework/panel.ss
Robby Findler 717c8a68e2 ..
original commit: 7f2ef8748ff2a4b840732f0334ece5b20bfd78e0
2000-05-22 13:40:06 +00:00

143 lines
4.3 KiB
Scheme

(unit/sig framework:panel^
(import mred^
[mzlib:function : mzlib:function^])
(rename [-editor<%> editor<%>])
(define single<%> (interface (area-container<%>) active-child))
(define single-mixin
(mixin (area-container<%>) (single<%>) args
(inherit get-alignment)
(rename [super-after-new-child after-new-child])
(override
[after-new-child
(lambda (c)
(if current-active-child
(send c show #f)
(set! current-active-child c)))]
[container-size
(lambda (l)
(if (null? l)
(values 0 0)
(values (apply max (map car l)) (apply max (map cadr l)))))]
[place-children
(lambda (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)
(private [current-active-child #f])
(public
[active-child
(case-lambda
[() current-active-child]
[(x)
(unless (eq? x current-active-child)
(for-each (lambda (x) (send x show #f))
(get-children))
(set! current-active-child x)
(send current-active-child show #t))])])
(sequence
(apply super-init args))))
(define single-window<%> (interface (single<%> window<%>)))
(define single-window-mixin
(mixin (single<%> window<%>) (single-window<%>) args
(inherit get-client-size get-size)
(rename [super-container-size container-size])
(override
[container-size
(lambda (l)
(let-values ([(super-width super-height) (super-container-size l)]
[(client-width client-height) (get-client-size)]
[(window-width window-height) (get-size)]
[(calc-size)
(lambda (super client window)
(+ super (max 0 (- window client))))])
(values
(calc-size super-width client-width window-width)
(calc-size super-height client-height window-height))))])
(sequence
(apply super-init args))))
(define multi-view<%>
(interface (area-container<%>)
split-vertically
split-horizontally
collapse))
(define multi-view-mixin
(mixin (area-container<%>) (multi-view<%>) (parent editor)
(public
[get-editor-canvas%
(lambda ()
editor-canvas%)]
[get-vertical%
(lambda ()
vertical-panel%)]
[get-horizontal%
(lambda ()
horizontal-panel%)])
(private
[split
(lambda (p%)
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
[ec% (get-editor-canvas%)])
(when (and canvas
(is-a? canvas ec%)
(eq? (send canvas get-editor) editor))
(let ([p (send canvas get-parent)])
(send p change-children (lambda (x) null))
(let ([pc (make-object p% p)])
(send (make-object ec% (make-object vertical-panel% pc) editor) focus)
(make-object ec% (make-object vertical-panel% pc) editor))))))])
(public
[collapse
(lambda ()
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
[ec% (get-editor-canvas%)])
(when (and canvas
(is-a? canvas ec%)
(eq? (send canvas get-editor) editor))
(let ([p (send canvas get-parent)])
(if (eq? p this)
(bell)
(let* ([sp (send p get-parent)]
[p-to-remain (send sp get-parent)])
(send p-to-remain change-children (lambda (x) null))
(send (make-object ec% p-to-remain editor) focus)))))))])
(public
[split-vertically
(lambda ()
(split (get-vertical%)))]
[split-horizontally
(lambda ()
(split (get-horizontal%)))])
(sequence
(super-init parent)
(make-object (get-editor-canvas%) this editor))))
(define single% (single-window-mixin (single-mixin panel%)))
(define single-pane% (single-mixin pane%))
(define multi-view% (multi-view-mixin vertical-panel%)))