993cd40208
For example, a new DrRacket window (with a file named tmp.rkt in the and 356 afterwards. This is under mac os x with, I believe, the default system font sizes. (The file is important because different languages can have different buttons in the toolbar and the filename's length itself can affect the minimum size.) Mostly this change is the addition of a new kind of panel that lets its children have multiple fixed sizes (as opposed to just a single minimum size and (optionally arbitrarily large)) It also adjusts the various toolbar buttons to use this new code. Also, there's a few tweaks to shrink other things that became the limiting factor in shrinking the width of the DrRacket window. Currently, at least for #lang racket programs, the toolbar buttons along the top of the window are the limiting factor (including the save button). With a bogus language (ie, #lang rackeeet), the bottom bar is the limiting factor, since that will have only the Save, Run, and Stop buttons. related to PR 13281
899 lines
36 KiB
Racket
899 lines
36 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class
|
|
racket/list
|
|
racket/unit
|
|
"sig.rkt"
|
|
mred/mred-sig
|
|
mrlib/switchable-button)
|
|
(provide panel@)
|
|
|
|
(define-unit panel@
|
|
(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)))))
|
|
|
|
|
|
(define discrete-child<%>
|
|
(interface ()
|
|
get-discrete-widths
|
|
get-discrete-heights))
|
|
|
|
(define discrete-sizes<%> (interface ((class->interface panel%))
|
|
get-orientation
|
|
set-orientation))
|
|
|
|
(define (discrete-get-widths c)
|
|
(cond
|
|
[(is-a? c switchable-button%)
|
|
(list (send c get-large-width)
|
|
(send c get-small-width))]
|
|
[(is-a? c discrete-sizes<%>)
|
|
(send c get-discrete-widths)]
|
|
[else
|
|
#f]))
|
|
|
|
(define (discrete-get-heights c)
|
|
(cond
|
|
[(is-a? c discrete-sizes<%>)
|
|
(send c get-discrete-heights)]
|
|
[else
|
|
#f]))
|
|
|
|
(define discrete-sizes-mixin
|
|
(mixin ((class->interface panel%)) (discrete-sizes<%> discrete-child<%>)
|
|
(inherit get-children spacing get-alignment border container-flow-modified
|
|
get-size get-client-size)
|
|
(define horizontal? #t)
|
|
(define/public (get-orientation) horizontal?)
|
|
(define/public (set-orientation h?)
|
|
(unless (equal? horizontal? h?)
|
|
(set! horizontal? h?)
|
|
(container-flow-modified)))
|
|
|
|
(define/public (get-discrete-widths)
|
|
(cond
|
|
[horizontal?
|
|
(define ws
|
|
(for/list ([c (in-list (get-children))])
|
|
(discrete-get-widths c)))
|
|
(and (andmap values ws)
|
|
(remove-duplicates
|
|
(map
|
|
(λ (x) (apply + x))
|
|
(candidate-sizes ws))))]
|
|
[else #f]))
|
|
|
|
(define/public (get-discrete-heights)
|
|
(cond
|
|
[horizontal? #f]
|
|
[else
|
|
(define hs
|
|
(for/list ([c (in-list (get-children))])
|
|
(discrete-get-heights c)))
|
|
(and (andmap values hs)
|
|
(remove-duplicates
|
|
(map
|
|
(λ (x) (apply + x))
|
|
(candidate-sizes hs))))]))
|
|
|
|
(define/override (container-size infos)
|
|
(define the-spacing (spacing))
|
|
(define the-border (spacing))
|
|
(define-values (total-min-w total-min-h)
|
|
(for/fold ([w 0] [h 0])
|
|
([info (in-list infos)]
|
|
[n (in-naturals)])
|
|
(define-values (min-w min-h h-stretch? v-stretch?)
|
|
(apply values info))
|
|
(define this-spacing (if (zero? n) 0 the-spacing))
|
|
(cond
|
|
[horizontal?
|
|
(values (+ w this-spacing min-w)
|
|
(max h min-h))]
|
|
[else
|
|
(values (max w min-w)
|
|
(+ h this-spacing min-h))])))
|
|
(define-values (sw sh) (get-size))
|
|
(define-values (cw ch) (get-client-size))
|
|
(values (+ total-min-w the-border the-border
|
|
(- sw cw))
|
|
(+ total-min-h the-border the-border
|
|
(- sh ch))))
|
|
|
|
(define/override (place-children infos w h)
|
|
(define the-spacing (spacing))
|
|
(define the-border (border))
|
|
(define-values (halign valign) (get-alignment))
|
|
(define children (get-children))
|
|
(define all-sizess
|
|
(candidate-sizes
|
|
(for/list ([c (in-list children)]
|
|
[info (in-list infos)]
|
|
#:unless (if horizontal?
|
|
(and (not (discrete-get-widths c))
|
|
(list-ref info 2))
|
|
(and (not (discrete-get-heights c))
|
|
(list-ref info 3))))
|
|
(if horizontal?
|
|
(or (discrete-get-widths c)
|
|
(list (list-ref info 0)))
|
|
(or (discrete-get-heights c)
|
|
(list (list-ref info 1)))))))
|
|
(define fitting-sizes
|
|
(for/or ([sizes (in-list all-sizess)])
|
|
(and (<= (apply + sizes)
|
|
(- (if horizontal? w h)
|
|
(* 2 the-border)))
|
|
sizes)))
|
|
(define fixed-size (apply + fitting-sizes))
|
|
(define number-stretchable
|
|
(for/sum ([info (in-list infos)]
|
|
[c children])
|
|
(if (if horizontal?
|
|
(and (not (discrete-get-widths c))
|
|
(list-ref info 2))
|
|
(and (not (discrete-get-heights c))
|
|
(list-ref info 3)))
|
|
1
|
|
0)))
|
|
(define initial-position
|
|
(+ the-border
|
|
(if (zero? number-stretchable)
|
|
(if horizontal?
|
|
(case halign
|
|
[(right) (- w fixed-size)]
|
|
[(center) (round (/ (- w fixed-size) 2))]
|
|
[(left) 0])
|
|
(case valign
|
|
[(bottom) (- h fixed-size)]
|
|
[(center) (round (/ (- h fixed-size) 2))]
|
|
[(top) 0]))
|
|
0)))
|
|
(define-values (stretchable-size stretchable-leftover)
|
|
(if (zero? number-stretchable)
|
|
(values 0 0)
|
|
(let ([total
|
|
(- (if horizontal?
|
|
w
|
|
h)
|
|
fixed-size)])
|
|
(values (quotient total number-stretchable)
|
|
(modulo total number-stretchable)))))
|
|
(define (take-one)
|
|
(cond
|
|
[(zero? stretchable-leftover)
|
|
0]
|
|
[else
|
|
(set! stretchable-leftover (- stretchable-leftover 1))
|
|
1]))
|
|
(let loop ([infos infos]
|
|
[children children]
|
|
[spot initial-position])
|
|
(cond
|
|
[(null? infos) null]
|
|
[else
|
|
(define-values (min-w min-h h-stretch? v-stretch?)
|
|
(apply values (car infos)))
|
|
(define discrete-child? (if horizontal?
|
|
(discrete-get-widths (car children))
|
|
(discrete-get-heights (car children))))
|
|
(define this-one
|
|
(cond
|
|
[(and horizontal? h-stretch? (not discrete-child?))
|
|
(list spot
|
|
(round (- (/ h 2) (/ min-h 2)))
|
|
(+ stretchable-size (take-one))
|
|
min-h)]
|
|
[(and (not horizontal?) v-stretch? (not discrete-child?))
|
|
(list (round (- (/ w 2) (/ min-w 2)))
|
|
spot
|
|
min-w
|
|
(+ stretchable-size (take-one)))]
|
|
[horizontal?
|
|
(define size (car fitting-sizes))
|
|
(set! fitting-sizes (cdr fitting-sizes))
|
|
(list spot
|
|
(round (- (/ h 2) (/ min-h 2)))
|
|
size
|
|
min-h)]
|
|
[else
|
|
(define size (car fitting-sizes))
|
|
(set! fitting-sizes (cdr fitting-sizes))
|
|
(list (round (- (/ w 2) (/ min-w 2)))
|
|
spot
|
|
min-w
|
|
size)]))
|
|
(cons this-one (loop (cdr infos)
|
|
(cdr children)
|
|
(+ spot
|
|
(if horizontal?
|
|
(list-ref this-one 2)
|
|
(list-ref this-one 3)))))])))
|
|
|
|
(super-new)))
|
|
|
|
(define horizontal-discrete-sizes%
|
|
;; extra wrapper to get the name right
|
|
(class (discrete-sizes-mixin panel%)
|
|
(super-new)))
|
|
(define vertical-discrete-sizes%
|
|
(class (discrete-sizes-mixin panel%)
|
|
(super-new)
|
|
(inherit set-orientation)
|
|
(set-orientation #f))))
|
|
|
|
|
|
;; candidate-sizes : (listof (listof number)) -> (listof (listof number))
|
|
;; in the input, the outer list corresponds to the children for a panel,
|
|
;; and each inner list are the sizes that the children can take on.
|
|
;; This function returns each possible configuration of sizes, starting
|
|
;; with the largest for each and then shrinking each child one size
|
|
;; at a time, starting from the earlier children in the list.
|
|
;; Note that this will not try all combinations of sizes; once a child
|
|
;; has been shrunk one size, larger sizes for that child will not be
|
|
;; considered, and shrinking always proceeds from the left to the right.
|
|
(define (candidate-sizes lolon)
|
|
(define all-boxes (map (λ (x) (box (sort x >=))) lolon))
|
|
(define answer '())
|
|
(define (record-current)
|
|
(set! answer (cons (map car (map unbox all-boxes)) answer)))
|
|
(for ([box (in-list all-boxes)])
|
|
(for ([i (in-range (- (length (unbox box)) 1))])
|
|
(record-current)
|
|
(set-box! box (cdr (unbox box)))))
|
|
(record-current)
|
|
(reverse answer))
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
|
|
(define (log-em lolon) (candidate-sizes lolon))
|
|
|
|
(check-equal? (log-em '((1)))
|
|
(list '(1)))
|
|
(check-equal? (log-em '((1) (2) (3)))
|
|
(list '(1 2 3)))
|
|
(check-equal? (log-em '((4 3 2 1)))
|
|
(list '(4) '(3) '(2) '(1)))
|
|
(check-equal? (log-em '((1 2 3 4)))
|
|
(list '(4) '(3) '(2) '(1)))
|
|
(check-equal? (log-em '((5 1) (6 2) (7 3)))
|
|
(list '(5 6 7)
|
|
'(1 6 7)
|
|
'(1 2 7)
|
|
'(1 2 3)))
|
|
(check-equal? (log-em '((10 9 8) (7 6 5)))
|
|
(list '(10 7)
|
|
'(9 7)
|
|
'(8 7)
|
|
'(8 6)
|
|
'(8 5))))
|