124 lines
3.7 KiB
Racket
124 lines
3.7 KiB
Racket
#lang racket
|
|
|
|
(require racket/gui)
|
|
|
|
(provide columns-pane%)
|
|
|
|
(define columns-pane%
|
|
(class vertical-pane%
|
|
(super-new)
|
|
|
|
;; Internal data
|
|
(define hpanes #f)
|
|
(define column-min-widths (make-vector columns 0))
|
|
(define creating-row #f)
|
|
(define current-col 0)
|
|
(define current-row 0)
|
|
|
|
(define/private (mk-hpane*)
|
|
(set! creating-row #t)
|
|
(let ((new-pane (new horizontal-pane% [parent this]
|
|
[spacing spacing] [horiz-margin horiz-margin] [vert-margin (round (/ spacing 2))]
|
|
[stretchable-height #f])))
|
|
(set! creating-row #f)
|
|
new-pane)
|
|
)
|
|
|
|
(define/private (get-row* i)
|
|
(when (eq? hpanes #f)
|
|
(set! hpanes (make-vector (+ i 1) #f)))
|
|
(when (>= i (vector-length hpanes))
|
|
(let ((v hpanes))
|
|
(set! hpanes (make-vector (+ i 1) #f))
|
|
(vector-copy! hpanes 0 v)))
|
|
(let ((p (vector-ref hpanes i)))
|
|
(when (eq? p #f)
|
|
(set! p (mk-hpane*))
|
|
(vector-set! hpanes i p))
|
|
p))
|
|
|
|
(define/private (child* c r)
|
|
(let* ((hpane (vector-ref hpanes r))
|
|
(children (send hpane get-children))
|
|
(child (if (>= c (length children)) #f (list-ref children c)))
|
|
)
|
|
child))
|
|
|
|
(define/private (max-width* c r w)
|
|
(if (< r (vector-length hpanes))
|
|
(let* ((child (child* c r))
|
|
(child-width (if (eq? child #f) 0 (send child get-width))))
|
|
(max-width* c (+ r 1) (if (> child-width w) child-width w)))
|
|
w))
|
|
|
|
(define/private (set-min-width* c r w)
|
|
(when (< r (vector-length hpanes))
|
|
(let ((child (child* c r)))
|
|
(when (not (eq? child #f))
|
|
(send child min-width w))
|
|
(set-min-width* c (+ r 1) w))))
|
|
|
|
(define/private (arrange-col* c)
|
|
(let* ((w (max-width* c 0 -1))
|
|
(col-min-width (vector-ref column-min-widths c))
|
|
(w* (if (> col-min-width w) col-min-width w))
|
|
)
|
|
(set-min-width* c 0 w*)))
|
|
|
|
(define/private (arrange*)
|
|
(letrec ((cols (length (send (vector-ref hpanes 0) get-children)))
|
|
(f (lambda (c)
|
|
(when (< c cols)
|
|
(arrange-col* c)
|
|
(f (+ c 1)))))
|
|
)
|
|
(f 0)))
|
|
|
|
;; Fields that can be given
|
|
(init-field [vert-margin 5] [horiz-margin 5] [spacing 5] [columns 1])
|
|
|
|
;; Public methods
|
|
(define/public (column-min-width c . w)
|
|
(unless (null? w)
|
|
(vector-set! column-min-widths c w))
|
|
(vector-ref column-min-widths c))
|
|
|
|
|
|
;; Overridden methods
|
|
(define/override (after-new-child child)
|
|
(super after-new-child child)
|
|
(when (eq? creating-row #f)
|
|
(let ((hpane (get-row* current-row)))
|
|
(send child reparent hpane)
|
|
(set! current-col (+ current-col 1))
|
|
(when (>= current-col columns)
|
|
(set! current-row (+ current-row 1))
|
|
(set! current-col 0))
|
|
)))
|
|
|
|
(define/override (place-children info width height)
|
|
(let ((r (super place-children info width height)))
|
|
(arrange*)
|
|
r
|
|
))
|
|
|
|
))
|
|
|
|
|
|
;;; GUI Testing
|
|
|
|
;(define win (new frame% [label "Hi there!"]))
|
|
;(define grid-group (new group-box-panel% [label "My group"] [parent win] [horiz-margin 10] [vert-margin 10]))
|
|
|
|
;(define g (new columns-pane% [parent grid-group] [columns 3]))
|
|
|
|
;(define btn1 (new button% [parent g] [label "Button 1"]))
|
|
;(define g1 (new gauge% [parent g] [stretchable-width #t] [label "gauge 1"] [range 100]))
|
|
;(define lbl1 (new message% [parent g] [label "This is lbl 1"]))
|
|
|
|
;(define btn2 (new button% [parent g] [label "Btn 2"]))
|
|
;(define lbl2 (new message% [parent g] [label "This is lbl 2"]))
|
|
|
|
;(send win show #t)
|
|
|