9b3f2427d7
interactions window pop up a menu to let you change from vertical to horizontal orientation
640 lines
26 KiB
Racket
640 lines
26 KiB
Racket
#lang racket/unit
|
|
|
|
(require racket/class
|
|
racket/list
|
|
"sig.rkt"
|
|
mred/mred-sig)
|
|
|
|
(import [prefix icon: framework:icon^]
|
|
mred^)
|
|
(export framework:panel^)
|
|
(init-depend mred^)
|
|
|
|
(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
|
|
(λ (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
|
|
(λ (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 (λ (l)
|
|
(let*-values ([(min-width min-height h-stretch? v-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 (λ (x) (send x show #f))
|
|
(get-children))
|
|
(set! current-active-child x)
|
|
(send current-active-child show #t)
|
|
(end-container-sequence))]))
|
|
(super-instantiate ())))
|
|
|
|
(define single-window<%> (interface (single<%> window<%>)))
|
|
(define single-window-mixin
|
|
(mixin (single<%> window<%>) (single-window<%>)
|
|
(inherit get-client-size get-size)
|
|
[define/override container-size
|
|
(λ (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)
|
|
(λ (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))))]
|
|
(super-new)))
|
|
|
|
(define multi-view<%>
|
|
(interface (area-container<%>)
|
|
split-vertically
|
|
split-horizontally
|
|
collapse))
|
|
|
|
(define multi-view-mixin
|
|
(mixin (area-container<%>) (multi-view<%>)
|
|
(init-field parent editor)
|
|
(public get-editor-canvas% get-vertical% get-horizontal%)
|
|
[define get-editor-canvas%
|
|
(λ ()
|
|
editor-canvas%)]
|
|
[define get-vertical%
|
|
(λ ()
|
|
vertical-panel%)]
|
|
[define get-horizontal%
|
|
(λ ()
|
|
horizontal-panel%)]
|
|
|
|
(define/private (split 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 (λ (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))))))
|
|
[define/public split-vertically
|
|
(λ ()
|
|
(split (get-vertical%)))]
|
|
[define/public split-horizontally
|
|
(λ ()
|
|
(split (get-horizontal%)))]
|
|
|
|
(define/public (collapse)
|
|
(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 (λ (x) null))
|
|
(send (make-object ec% p-to-remain editor) focus)))))))
|
|
|
|
|
|
(super-instantiate () (parent 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%))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; type gap = (make-gap number area<%> percentage number area<%> percentage)
|
|
(define-struct gap (before before-dim before-percentage after after-dim after-percentage))
|
|
|
|
;; type percentage : (make-percentage number)
|
|
(define-struct percentage (%) #:mutable)
|
|
|
|
(define dragable<%>
|
|
(interface (window<%> area-container<%>)
|
|
after-percentage-change
|
|
set-percentages
|
|
get-percentages
|
|
get-vertical?
|
|
get-default-percentages
|
|
right-click-in-gap
|
|
set-orientation))
|
|
|
|
(define vertical-dragable<%>
|
|
(interface (dragable<%>)))
|
|
|
|
(define horizontal-dragable<%>
|
|
(interface (dragable<%>)))
|
|
|
|
(define dragable-mixin
|
|
(mixin (window<%> area-container<%>) (dragable<%>)
|
|
(init parent)
|
|
|
|
(init-field vertical?)
|
|
(define/public-final (get-vertical?) vertical?)
|
|
(define/public-final (set-orientation h?)
|
|
(define v? (not h?))
|
|
(unless (eq? vertical? v?)
|
|
(set! vertical? v?)
|
|
(container-flow-modified)))
|
|
(define/private (min-extent child)
|
|
(let-values ([(w h) (send child get-graphical-min-size)])
|
|
(if (get-vertical?)
|
|
(max (send child min-height) h)
|
|
(max (send child min-width) w))))
|
|
(define/private (event-get-dim evt)
|
|
(if (get-vertical?)
|
|
(send evt get-y)
|
|
(send evt get-x)))
|
|
(define/private (get-gap-cursor)
|
|
(if (get-vertical?)
|
|
(icon:get-up/down-cursor)
|
|
(icon:get-left/right-cursor)))
|
|
|
|
(define/public (right-click-in-gap evt before after) (void))
|
|
|
|
(inherit get-client-size container-flow-modified)
|
|
|
|
(init-field [bar-thickness 5])
|
|
|
|
;; percentages : (listof percentage)
|
|
(define percentages null)
|
|
|
|
;; get-percentages : -> (listof number)
|
|
(define/public (get-percentages)
|
|
(map percentage-% percentages))
|
|
|
|
(define/public (set-percentages ps)
|
|
(unless (and (list? ps)
|
|
(andmap number? ps)
|
|
(= 1 (apply + ps))
|
|
(andmap positive? ps))
|
|
(error 'set-percentages
|
|
"expected a list of numbers that are all positive and sum to 1, got: ~e"
|
|
ps))
|
|
(unless (= (length ps) (length (get-children)))
|
|
(error 'set-percentages
|
|
"expected a list of numbers whose length is the number of children: ~a, got ~e"
|
|
(length (get-children))
|
|
ps))
|
|
(set! percentages (map make-percentage ps))
|
|
(container-flow-modified))
|
|
|
|
(define/pubment (after-percentage-change) (inner (void) after-percentage-change))
|
|
|
|
(define/private (get-available-extent)
|
|
(let-values ([(width height) (get-client-size)])
|
|
(- (if (get-vertical?) height width)
|
|
(* bar-thickness (- (length (get-children)) 1)))))
|
|
|
|
(inherit get-children)
|
|
|
|
(define/private (update-percentages)
|
|
(let ([len-children (length (get-children))])
|
|
(unless (= len-children (length percentages))
|
|
(cond
|
|
[(zero? len-children)
|
|
(set! percentages '())]
|
|
[else
|
|
(set! percentages (map make-percentage (get-default-percentages len-children)))])
|
|
(after-percentage-change))))
|
|
|
|
(define/pubment (get-default-percentages i)
|
|
(define res (inner (if (zero? i) '() (make-list i (/ i)))
|
|
get-default-percentages i))
|
|
(unless (and (list? res)
|
|
(andmap (λ (x) (and (real? x) (<= 0 x 1))) res)
|
|
(= 1 (apply + res))
|
|
(= (length res) i))
|
|
(error 'get-default-percentages
|
|
"expected inner call to return a list of real numbers that sum to 1 and has length ~a"
|
|
i))
|
|
res)
|
|
|
|
(define/override (after-new-child child)
|
|
(update-percentages))
|
|
|
|
(define resizing-dim #f)
|
|
(define resizing-gap #f)
|
|
|
|
(inherit set-cursor)
|
|
(define/override (on-subwindow-event receiver evt)
|
|
(if (eq? receiver this)
|
|
(let ([gap
|
|
(ormap (λ (gap)
|
|
(and (<= (gap-before-dim gap)
|
|
(event-get-dim evt)
|
|
(gap-after-dim gap))
|
|
gap))
|
|
cursor-gaps)])
|
|
(set-cursor (and (or gap
|
|
resizing-dim)
|
|
(let ([c (get-gap-cursor)])
|
|
(and (send c ok?)
|
|
c))))
|
|
(cond
|
|
[(and gap (send evt button-down? 'right))
|
|
(right-click-in-gap evt (gap-before gap) (gap-after gap))]
|
|
[(and gap (send evt button-down? 'left))
|
|
(set! resizing-dim (event-get-dim evt))
|
|
(set! resizing-gap gap)]
|
|
[(send evt button-up? 'left)
|
|
(set! resizing-dim #f)
|
|
(set! resizing-gap #f)]
|
|
[(and resizing-dim resizing-gap (send evt moving?))
|
|
(let-values ([(width height) (get-client-size)])
|
|
(let* ([before-percentage (gap-before-percentage resizing-gap)]
|
|
[orig-before (percentage-% before-percentage)]
|
|
[after-percentage (gap-after-percentage resizing-gap)]
|
|
[orig-after (percentage-% after-percentage)]
|
|
[available-extent (get-available-extent)]
|
|
[change-in-percentage (/ (- resizing-dim (event-get-dim evt)) available-extent)]
|
|
[new-before (- (percentage-% before-percentage) change-in-percentage)]
|
|
[new-after (+ (percentage-% after-percentage) change-in-percentage)])
|
|
(when ((floor (* new-before available-extent)) . > . (min-extent (gap-before resizing-gap)))
|
|
(when ((floor (* new-after available-extent)) . > . (min-extent (gap-after resizing-gap)))
|
|
(set-percentage-%! before-percentage new-before)
|
|
(set-percentage-%! after-percentage new-after)
|
|
(after-percentage-change)
|
|
(set! resizing-dim (event-get-dim evt))
|
|
(container-flow-modified)))))]
|
|
[else (super on-subwindow-event receiver evt)]))
|
|
(begin
|
|
(set-cursor #f)
|
|
(super on-subwindow-event receiver evt))))
|
|
|
|
(define cursor-gaps null)
|
|
|
|
(define/override (place-children _infos width height)
|
|
(update-percentages)
|
|
(define-values (results gaps)
|
|
(dragable-place-children _infos width height
|
|
(map percentage-% percentages)
|
|
bar-thickness
|
|
(get-vertical?)))
|
|
(set! cursor-gaps
|
|
(let loop ([children (get-children)]
|
|
[percentages percentages]
|
|
[gaps gaps])
|
|
(cond
|
|
[(null? children) '()]
|
|
[(null? (cdr children)) '()]
|
|
[else
|
|
(define gap (car gaps))
|
|
(cons (make-gap (car children)
|
|
(list-ref gap 0)
|
|
(car percentages)
|
|
(cadr children)
|
|
(list-ref gap 1)
|
|
(cadr percentages))
|
|
(loop (cdr children)
|
|
(cdr percentages)
|
|
(cdr gaps)))])))
|
|
|
|
results)
|
|
|
|
(define/override (container-size children-info)
|
|
(update-percentages)
|
|
(dragable-container-size children-info bar-thickness (get-vertical?)))
|
|
|
|
(super-new [parent parent])))
|
|
|
|
;; this function repeatedly checks to see if the current set of percentages and children
|
|
;; would violate any minimum size constraints. If not, the percentages are used and the
|
|
;; function termiantes. If some minimum sizes would be violated, the function pulls those
|
|
;; children out of the list under consideration, gives them their minimum sizes, rescales
|
|
;; the remaining percentages back to 1, adjusts the available space after removing those
|
|
;; panels, and tries again.
|
|
(define (dragable-place-children infos width height percentages bar-thickness vertical?)
|
|
(define original-major-dim-tot (- (if vertical? height width)
|
|
(* (max 0 (- (length infos) 1)) bar-thickness)))
|
|
;; vec : id -o> major-dim size (width)
|
|
(define vec (make-vector (length infos) 0))
|
|
(let loop ([percentages percentages] ;; sums to 1.
|
|
[major-dim-mins (map (λ (info) (if vertical? (list-ref info 1) (list-ref info 0)))
|
|
infos)]
|
|
[major-dim-tot original-major-dim-tot]
|
|
[ids (build-list (length percentages) values)])
|
|
(define fitting-ones (extract-fitting-percentages percentages major-dim-mins major-dim-tot))
|
|
(cond
|
|
[(andmap not fitting-ones)
|
|
;; all of them (perhaps none) fit, terminate.
|
|
(for ([id (in-list ids)]
|
|
[percentage (in-list percentages)])
|
|
(vector-set! vec id (* percentage major-dim-tot)))]
|
|
[else
|
|
;; something doesn't fit; remove them and try again
|
|
(let ([next-percentages '()]
|
|
[next-major-dim-mins '()]
|
|
[next-major-dim-tot major-dim-tot]
|
|
[next-ids '()])
|
|
(for ([percentage (in-list percentages)]
|
|
[major-dim-min (in-list major-dim-mins)]
|
|
[id (in-list ids)]
|
|
[fitting-one (in-list fitting-ones)])
|
|
(cond
|
|
[fitting-one
|
|
(vector-set! vec id fitting-one)
|
|
(set! next-major-dim-tot (- major-dim-tot fitting-one))]
|
|
[else
|
|
(set! next-percentages (cons percentage next-percentages))
|
|
(set! next-major-dim-mins (cons major-dim-min next-major-dim-mins))
|
|
(set! next-ids (cons id next-ids))]))
|
|
(define next-percentage-sum (apply + next-percentages))
|
|
(loop (map (λ (x) (/ x next-percentage-sum)) next-percentages)
|
|
next-major-dim-mins
|
|
next-major-dim-tot
|
|
next-ids))]))
|
|
|
|
;; adjust the contents of the vector if there are any fractional values
|
|
(let loop ([i 0]
|
|
[maj-val 0])
|
|
(cond
|
|
[(= i (vector-length vec))
|
|
(unless (= maj-val original-major-dim-tot)
|
|
(unless (zero? (vector-length vec))
|
|
(define last-index (- (vector-length vec) 1))
|
|
(vector-set! vec last-index (+ (vector-ref vec last-index) (- original-major-dim-tot maj-val)))))]
|
|
[else
|
|
(vector-set! vec i (floor (vector-ref vec i)))
|
|
(loop (+ i 1)
|
|
(+ maj-val (vector-ref vec i)))]))
|
|
|
|
;; build the result for the function from the major dim sizes
|
|
(let loop ([i 0]
|
|
[infos '()]
|
|
[gaps '()]
|
|
[maj-start 0])
|
|
(cond
|
|
[(= i (vector-length vec))
|
|
(values (reverse infos)
|
|
(reverse gaps))]
|
|
[else
|
|
(define maj-stop (+ maj-start (vector-ref vec i)))
|
|
(define has-gap? (not (= i (- (vector-length vec) 1))))
|
|
(loop (+ i 1)
|
|
(cons (if vertical?
|
|
(list 0
|
|
maj-start
|
|
width
|
|
(- maj-stop maj-start))
|
|
(list maj-start
|
|
0
|
|
(- maj-stop maj-start)
|
|
height))
|
|
infos)
|
|
(if has-gap?
|
|
(cons (list maj-stop (+ maj-stop bar-thickness)) gaps)
|
|
gaps)
|
|
(if has-gap?
|
|
(+ maj-stop bar-thickness)
|
|
maj-stop))])))
|
|
|
|
(define (extract-fitting-percentages percentages major-dim-mins major-dim-tot)
|
|
(for/list ([percentage (in-list percentages)]
|
|
[major-dim-min (in-list major-dim-mins)])
|
|
(if (<= major-dim-min (* percentage major-dim-tot))
|
|
#f
|
|
major-dim-min)))
|
|
|
|
(define (dragable-container-size orig-children-info bar-thickness vertical?)
|
|
(let loop ([children-info orig-children-info]
|
|
[major-size 0]
|
|
[minor-size 0])
|
|
(cond
|
|
[(null? children-info)
|
|
(let ([major-size (+ major-size
|
|
(* (max 0 (- (length orig-children-info) 1))
|
|
bar-thickness))])
|
|
(if vertical?
|
|
(values (ceiling minor-size) (ceiling major-size))
|
|
(values (ceiling major-size) (ceiling minor-size))))]
|
|
[else
|
|
(let ([child-info (car children-info)])
|
|
(let-values ([(child-major major-stretch? child-minor minor-stretch?)
|
|
(if vertical?
|
|
;; 0 = width/horiz, 1 = height/vert
|
|
(values (list-ref child-info 1)
|
|
(list-ref child-info 3)
|
|
(list-ref child-info 0)
|
|
(list-ref child-info 2))
|
|
(values (list-ref child-info 0)
|
|
(list-ref child-info 2)
|
|
(list-ref child-info 1)
|
|
(list-ref child-info 3)))])
|
|
(loop (cdr children-info)
|
|
(+ child-major major-size)
|
|
(max child-minor minor-size))))])))
|
|
|
|
(define three-bar-pen-bar-width 8)
|
|
|
|
(define three-bar-canvas%
|
|
(class canvas%
|
|
(inherit get-dc get-client-size)
|
|
(define/override (on-paint)
|
|
(let ([dc (get-dc)])
|
|
(let-values ([(w h) (get-client-size)])
|
|
(let ([sx (floor (- (/ w 2) (/ three-bar-pen-bar-width 2)))])
|
|
(send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
|
|
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
|
|
(send dc draw-rectangle 0 0 w h)
|
|
|
|
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(send dc draw-line sx 1 (+ sx three-bar-pen-bar-width) 1)
|
|
(send dc draw-line sx 4 (+ sx three-bar-pen-bar-width) 4)
|
|
(send dc draw-line sx 7 (+ sx three-bar-pen-bar-width) 7)
|
|
|
|
(send dc set-pen (send the-pen-list find-or-create-pen "gray" 1 'solid))
|
|
(send dc draw-line sx 2 (+ sx three-bar-pen-bar-width) 2)
|
|
(send dc draw-line sx 5 (+ sx three-bar-pen-bar-width) 5)
|
|
(send dc draw-line sx 8 (+ sx three-bar-pen-bar-width) 8)))))
|
|
|
|
(super-new [style '(no-focus)])
|
|
(inherit stretchable-height min-height)
|
|
(stretchable-height #f)
|
|
(min-height 10)))
|
|
|
|
(define vertical-dragable-mixin
|
|
(mixin (dragable<%>) (vertical-dragable<%>)
|
|
(super-new [vertical? #t])))
|
|
|
|
(define horizontal-dragable-mixin
|
|
(mixin (dragable<%>) (horizontal-dragable<%>)
|
|
(super-new [vertical? #f])))
|
|
|
|
(define vertical-dragable% (vertical-dragable-mixin (dragable-mixin panel%)))
|
|
|
|
(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
|
|
;; FIXME: this is probably a library function somewhere
|
|
(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
|
|
;; FIXME: this is probably a library function somewhere
|
|
(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))])))
|
|
|
|
;; remove a canvas and merge split panels if necessary
|
|
;; TODO: restore percentages
|
|
(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 panel if the panel 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)))
|
|
|
|
))
|