diff --git a/collects/framework/private/panel.rkt b/collects/framework/private/panel.rkt index 86d56509..1099a2cc 100644 --- a/collects/framework/private/panel.rkt +++ b/collects/framework/private/panel.rkt @@ -505,3 +505,115 @@ (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%))) +(define splitter<%> (interface () split-horizontal split-vertical collapse)) +;; we need a private interface so we can use `generic' because `generic' +;; doesn't work on mixins +(define splitter-private<%> (interface () self-vertical? self-horizontal?)) + +(define splitter-mixin + (mixin (area-container<%> dragable<%>) (splitter<%> splitter-private<%>) + (super-new) + (inherit get-children add-child + delete-child + change-children + begin-container-sequence + end-container-sequence) + + (field [horizontal-panel% horizontal-dragable%] + [vertical-panel% vertical-dragable%]) + + (define/public (self-vertical?) + (send this get-vertical?)) + + (define/public (self-horizontal?) + (not (send this get-vertical?))) + + ;; insert an item into a list after some element + (define/private (insert-after list before item) + (let loop ([so-far '()] + [list list]) + (cond + [(null? list) (reverse so-far)] + [(eq? (car list) before) (loop (cons item (cons before so-far)) + (cdr list))] + [else (loop (cons (car list) so-far) (cdr list))]))) + + ;; replace an element with a list of stuff + (define/private (replace list at stuff) + (let loop ([so-far '()] + [list list]) + (cond + [(null? list) (reverse so-far)] + [(eq? (car list) at) (append (reverse so-far) stuff (cdr list))] + [else (loop (cons (car list) so-far) (cdr list))]))) + + (define/public (collapse canvas) + (begin-container-sequence) + (for ([child (get-children)]) + (cond + [(eq? child canvas) + (when (> (length (get-children)) 1) + (change-children + (lambda (old-children) + (remq canvas old-children))))] + [(is-a? child splitter<%>) + (send child collapse canvas)])) + (change-children + (lambda (old-children) + (for/list ([child old-children]) + (if (and (is-a? child splitter<%>) + (= (length (send child get-children)) 1)) + (let () + (define single (car (send child get-children))) + (send single reparent this) + single) + child)))) + (end-container-sequence)) + + ;; split a canvas by creating a new editor and either + ;; 1) adding it to the canvas if the canvas is already using the same + ;; orientation as the split that is about to occur + ;; 2) create a new panel with the orientation of the split about to + ;; occur and add a new editor + ;; + ;; in both cases the new editor is returned + (define/private (do-split canvas maker orientation? orientation% split) + (define new-canvas #f) + (for ([child (get-children)]) + (cond + [(eq? child canvas) + (begin-container-sequence) + (change-children + (lambda (old-children) + (if (send-generic this orientation?) + (let ([new (maker this)]) + (set! new-canvas new) + (insert-after old-children child new)) + (let () + (define container (new (splitter-mixin orientation%) + [parent this])) + (send canvas reparent container) + (define created (maker container)) + (set! new-canvas created) + ;; this throws out the old child but we should probably + ;; try to keep it + (replace old-children child (list container)))))) + (end-container-sequence)] + + [(is-a? child splitter<%>) + (let ([something (send-generic child split canvas maker)]) + (when something + (set! new-canvas something)))])) + new-canvas) + + ;; canvas (widget -> editor) -> editor + (define/public (split-horizontal canvas maker) + (do-split canvas maker (generic splitter-private<%> self-horizontal?) + horizontal-panel% (generic splitter<%> split-horizontal))) + + ;; canvas (widget -> editor) -> editor + (define/public (split-vertical canvas maker) + (do-split canvas maker (generic splitter-private<%> self-vertical?) + vertical-panel% (generic splitter<%> split-vertical))) + + )) diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index d37a6dd0..5d342e98 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -57,7 +57,10 @@ horizontal-dragable<%> horizontal-dragable-mixin - horizontal-dragable%)) + horizontal-dragable% + + splitter<%> + splitter-mixin)) (define-signature panel^ extends panel-class^ (dragable-container-size dragable-place-children))