Initial revision

original commit: f68a59590bd680f9698a970db1e582bcc6b06a65
This commit is contained in:
Robby Findler 1996-10-04 14:37:39 +00:00
parent 098fdca233
commit d05811a657

100
collects/mred/panel.ss Normal file
View File

@ -0,0 +1,100 @@
(define mred:panel@
(unit/sig mred:panel^
(import [mred:debug : mred:debug^]
[mred:container : mred:container^]
[mred:canvas : mred:canvas^]
mzlib:function^)
(mred:debug:printf 'invoke "mred:panel@")
(define make-edit-panel%
(lambda (super%)
(class-asi super%
(rename [super-change-children change-children])
(inherit children get-parent)
(public [get-canvas% (lambda () mred:canvas:editor-canvas%)])
(private
[edit-mapping (make-hash-table)]
[bind
(lambda (panel edit)
(hash-table-put! edit-mapping edit panel))]
[lookup/add
(lambda (child)
(if (is-a? child wx:media-edit%)
(let ([add-new
(lambda ()
(let ([p (make-object (get-canvas%) this)])
(send p set-media child)
(send child add-canvas p)
(bind p child)
p))])
(hash-table-get edit-mapping child add-new))
child))])
(public
; this contains the edits and panels that are children of
; this panel, but the canvases of these edits are not
; necessarily immediate children, since they may be split.
[actual-children null]
[collapse
(lambda (canvas)
(letrec* ([media (send canvas get-media)]
[helper
(lambda (canvas/panel)
(printf "collapse; canvas/panel: ~a~n" canvas/panel)
(let* ([parent (send canvas/panel get-parent)])
(if (is-a? parent wx:frame%)
(begin (send canvas/panel change-children
(lambda (l) (list media)))
(wx:bell))
(let* ([parents-children (ivar parent children)]
[num-children (length parents-children)])
(printf "collapse; parent: ~a num-children: ~a~n" parent num-children)
(if (<= num-children 1)
(collapse parent)
(begin (send parent delete-child canvas/panel)
(send (car (ivar parent children)) set-focus)))))))])
(send media remove-canvas canvas)
(helper canvas)))]
[split
(opt-lambda (canvas [panel% mred:container:horizontal-panel%])
(let ([frame (ivar canvas frame)])
(dynamic-wind
(lambda () (send frame set-perform-updates #f))
(lambda () (letrec* ([media (send canvas get-media)]
[canvas% (object-class canvas)]
[parent (send canvas get-parent)]
[new-panel (make-object panel% parent)]
[left-split (make-object canvas% new-panel)]
[right-split (make-object canvas% new-panel)])
(send parent change-children
(lambda (l)
(let ([before (remq new-panel l)])
(map (lambda (x) (if (eq? x canvas)
new-panel
x))
before))))
(send* media (remove-canvas canvas)
(add-canvas left-split)
(add-canvas right-split))
(send* left-split (set-media media) (set-frame frame) (set-focus))
(send* right-split (set-media media) (set-frame frame))
(when (eq? this parent)
(bind media new-panel))))
(lambda () (send frame set-perform-updates #t)))))]
[change-children
(lambda (f)
(let ([new-children (f actual-children)])
(super-change-children (lambda (l)
(map lookup/add
new-children)))
(set! actual-children new-children)))]))))
(define horizontal-edit-panel%
(make-edit-panel% mred:container:horizontal-panel%))
(define vertical-edit-panel%
(make-edit-panel% mred:container:vertical-panel%))))