From 1dee3a5d9cb078c74ae9022a85d41adcc6916048 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 8 Aug 1998 18:27:22 +0000 Subject: [PATCH] . original commit: 24b74bbdb285d6005c1953e26d663ac131fd3448 --- notes/mred/MrEd_100.txt | 69 +++--- src/mred/wrap/mred.ss | 502 +++++++++++++++++++++++----------------- 2 files changed, 335 insertions(+), 236 deletions(-) diff --git a/notes/mred/MrEd_100.txt b/notes/mred/MrEd_100.txt index 139e0629..9ee4c4ff 100644 --- a/notes/mred/MrEd_100.txt +++ b/notes/mred/MrEd_100.txt @@ -105,35 +105,35 @@ The following are a few highlights of the revision: ====================================================================== 1. Interface/Class Type Hierarchy (Selected Excerpts) ====================================================================== - -window<%> - |-- subwindow-container<%> - | |-- top-level-window<%> - | | |- frame% - |-- subwindow<%> |--- |- dialog-box% - | | - |---------- panel<%> - | |- panel% - | |- single-panel% - | |- linear-panel<%> - | |- horizontal-panel% - |- control<%> |- vertical-panel% - | |- message% - | |- button% - | |- check-box% - | |- slider% - | |- gauge% - | |- text-control<%> - | | |- text% - | | |- multi-text% - | |- radio-box% - | |- list-control<%> - | |- choice% - | |- list-box% - | - |- canvas<%> - |- canvas% - |- editor-canvas% (has an editor-admin%, maybe an editor<%>) + + area<%> + | + ------------------------------------ + | | | + subarea<%> window<%> area-container<%> +<<<____|____ _____|__________ __|___ ___________________<<< + | | | | | | + subwindow<%> | | | | +<<<______________|___________ | | | | _<<< + | | | | pane% | + control<%> | | | |- single-pane% | + |- message% | | | |- horizontal-pane% | + |- button% | | | |- vertical-pane% | + |- check-box% | | | | + |- slider% | area-container-window<%> | + |- gauge% | | _ ________________| + |- text-control<%> | | | + | |- text% | |--------- panel% + | |- multi-text% | | |- single-panel% + |- radio-box% | | |- horizontal-panel% + |- list-control<%> | | |- vertical-panel% + |- choice% | | + |- list-box | |- top-level-window<%> + | |- frame% + | |- dialog-box% + canvas<%> + |- canvas% + |- editor-canvas% menu-item<%> |- separator-menu-item% @@ -236,6 +236,17 @@ panel<%> panel% <= parent [style null] +panel% : containee<%> window<%> container<%> +single-panel%: containee<%> window<%> single-container<%> +horizontal-panel%: containee<%> window<%> linear-container<%> +vertical-panel%: containee<%> window<%> linear-container<%> + +pane% : containee<%> container<%> +single-pane%: containee<%> single-container<%> +horizontal-pane%: containee<%> linear-container<%> +vertical-pane%: containee<%> linear-container<%> + + single-panel% <= parent [style null] diff --git a/src/mred/wrap/mred.ss b/src/mred/wrap/mred.ss index 2d50cc1a..15198053 100644 --- a/src/mred/wrap/mred.ss +++ b/src/mred/wrap/mred.ss @@ -104,8 +104,14 @@ [super-on-kill-focus on-kill-focus]) (private [top-level #f] - [focus? #f]) + [focus? #f] + [container this]) (public + [get-container (lambda () container)] + [set-container (lambda (c) (set! container c))] + [get-window (lambda () this)] + [dx (lambda () 0)] + [dy (lambda () 0)] [get-edit-target (lambda () this)] [get-top-level (lambda () @@ -371,7 +377,7 @@ (rename [super-on-set-focus on-set-focus] [super-on-kill-focus on-kill-focus]) (inherit get-width get-height get-x get-y - get-parent get-client-size get-size) + get-parent get-client-size) (rename [super-enable enable]) (private [enabled? #t]) (public @@ -473,6 +479,8 @@ (stretchable-in-y))]) result))] + [area-parent (lambda () (car args))] + ; force-redraw: unconditionally trigger redraw. ; input: none ; returns: nothing @@ -481,11 +489,12 @@ ; invalid. [force-redraw (lambda () - (let ([parent (get-parent)]) + (let ([parent (area-parent)]) (unless parent (send parent child-redraw-request this))))] - ; set-size: caches calls to set-size to avoid unnecessary work. + ; set-size: caches calls to set-size to avoid unnecessary work, + ; and works with windowsless panels ; input: x/y: new position for object ; width/height: new size for object ; returns: nothing @@ -494,6 +503,8 @@ ; Otherwise, does nothing. [set-size (lambda (x y width height) + (set! x (+ x (send (area-parent) dx))) + (set! y (+ y (send (area-parent) dy))) (unless (and (same-dimension? x (get-x)) (same-dimension? y (get-y)) (same-dimension? width (get-width)) @@ -513,11 +524,11 @@ (list w h)))]) (sequence - (apply super-init args) + (apply super-init (send (car args) get-window) (cdr args)) (set-min-width (get-width)) (set-min-height (get-height)) - (send (get-parent) add-child this)))))) + (send (area-parent) add-child this)))))) ; make-control% - for non-panel items (define (make-control% item% x-margin y-margin @@ -540,16 +551,21 @@ (define wx<%> (interface () get-mred)) (define wx/proxy<%> (interface (wx<%>) get-proxy)) -(define (make-window-glue% %) +(define (make-glue% %) (class* % (wx/proxy<%>) (mred proxy . args) + (public + [get-mred (lambda () mred)] + [get-proxy (lambda () proxy)]) + (sequence (apply super-init args)))) + +(define (make-window-glue% %) ; implies make-glue% + (class (make-glue% %) (mred proxy . args) (rename [super-on-size on-size] [super-on-set-focus on-set-focus] [super-on-kill-focus on-kill-focus] [super-pre-on-char pre-on-char] [super-pre-on-event pre-on-event]) (public - [get-mred (lambda () mred)] - [get-proxy (lambda () proxy)] [on-size (lambda (x y) (super-on-size x y) (and mred (send mred on-size x y)))] @@ -565,9 +581,20 @@ [pre-on-event (lambda (w e) (super-pre-on-event w e) (send proxy pre-on-event (wx->proxy w) e))]) - (sequence (apply super-init args)))) + (sequence (apply super-init mred proxy args)))) -(define (make-top-level-window-glue% %) +(define (make-container-glue% %) + (class % (mred proxy . args) + (inherit do-place-children) + (public + [place-children (lambda (l w h) (cond + [(null? l) null] + [mred (send mred place-children l w h)] + [else (do-place-children l w h)]))]) + (sequence + (apply super-init mred proxy args)))) + +(define (make-top-level-window-glue% %) ; implies make-window-glue% (class (make-window-glue% %) (mred proxy . args) (rename [super-on-activate on-activate]) (public @@ -576,17 +603,7 @@ (send mred on-activate on?))]) (sequence (apply super-init mred proxy args)))) -(define (make-panel-glue% %) - (class (make-window-glue% %) (mred proxy . args) - (inherit do-place-children) - (public - [place-children (lambda (l w h) (if mred - (send mred place-children l w h) - (do-place-children l w h)))]) - (sequence - (apply super-init mred proxy args)))) - -(define (make-canvas-glue% %) +(define (make-canvas-glue% %) ; implies make-window-glue% (class (make-window-glue% %) (mred proxy . args) (rename [super-on-char on-char] [super-on-event on-event] @@ -754,7 +771,7 @@ (define (make-media-canvas% %) (class % (parent x y w h name style spp init-buffer) - (inherit get-media get-parent force-redraw + (inherit get-media force-redraw call-as-primary-owner min-height get-size hard-min-height set-min-height) (private @@ -929,13 +946,37 @@ ;--------------------- wx Panel Classes ------------------------- -(define wx-panel% - (make-panel-glue% +(define wx:windowless-panel% + (class null (parent x y w h style) + (private + [pos-x 0] [pos-y 0] [width 1] [height 1]) + (public + [on-set-focus void] + [on-kill-focus void] + [set-focus void] + [on-size void] + [enable void] + [show void] + [get-parent (lambda () parent)] + [get-client-size (lambda (wb hb) + (when wb (set-box! wb width)) + (when hb (set-box! hb height)))] + [set-size (lambda (x y w h) + (unless (negative? x) (set! pos-x x)) + (unless (negative? y) (set! pos-y y)) + (unless (negative? w) (set! width w)) + (unless (negative? h) (set! height h)))] + [get-x (lambda () pos-x)] + [get-y (lambda () pos-y)] + [get-width (lambda () width)] + [get-height (lambda () height)]))) + +(define (wx-make-basic-panel% wx:panel%) (class (make-container% (make-item% wx:panel% 0 0 #t #t)) (parent style) (inherit get-x get-y get-width get-height min-width min-height x-margin y-margin - get-client-size get-parent) + get-client-size area-parent) (rename [super-set-focus set-focus] [super-on-size on-size] @@ -979,7 +1020,7 @@ ; effects: adds new-child to end of list of children. [add-child (lambda (new-child) - (unless (eq? this (send new-child get-parent)) + (unless (eq? this (send new-child area-parent)) (error 'add-child "not a child window")) (change-children (lambda (l) @@ -994,7 +1035,7 @@ (lambda (f) (let ([new-children (f children)]) (unless (andmap (lambda (child) - (eq? this (send child get-parent))) + (eq? this (send child area-parent))) new-children) (error 'change-children (string-append @@ -1048,7 +1089,7 @@ (lambda () (set! children-info #f) (set! curr-width #f) - (let ([parent (get-parent)]) + (let ([parent (area-parent)]) (send parent child-redraw-request this)))] ; do-graphical-size: creates a function which returns the minimum @@ -1168,7 +1209,7 @@ (loop (cdr children-info)))))))] ; redraw: redraws panel and all children - ; input: width, height: size of drawable area in panel. + ; input: width, height: size of area area in panel. ; returns: nothing ; effects: places children at default positions in panel. [redraw @@ -1196,9 +1237,22 @@ child-infos placements))]) (sequence - (super-init parent -1 -1 -1 -1 style))))) + (super-init parent -1 -1 -1 -1 style)))) -(define wx-linear-panel% +(define (wx-make-pane% wx:panel%) + (class (make-container-glue% (make-glue% (wx-make-basic-panel% wx:panel%))) args + (inherit get-parent get-x get-y) + (public + [get-window (lambda () (send (get-parent) get-window))] + [dx (lambda () (get-x))] + [dy (lambda () (get-y))]) + (sequence + (apply super-init args)))) + +(define (wx-make-panel% wx:panel%) + (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel%)))) + +(define (wx-make-linear-panel% wx-panel%) (class wx-panel% args (private [major-align-pos 'left] @@ -1350,7 +1404,7 @@ ; to fit the dialog box if they are stretchable). The items are evenly ; spaced horizontally, with any extra space divided evenly among the ; stretchable items. -(define wx-horizontal-panel% +(define (wx-make-horizontal-panel% wx-linear-panel%) (class wx-linear-panel% args (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset spacing border do-graphical-size place-linear-children) @@ -1388,7 +1442,7 @@ ; vertical-panel%. See horizontal-panel%, but reverse ; "horizontal" and "vertical." -(define wx-vertical-panel% +(define (wx-make-vertical-panel% wx-linear-panel%) (class wx-linear-panel% args (inherit major-align minor-align do-align do-get-alignment major-offset minor-offset spacing border do-graphical-size place-linear-children) @@ -1425,15 +1479,10 @@ (lambda (major minor) major)))]) (sequence (apply super-init args)))) -(define add-at-end - (lambda (object) - (lambda (list-of-kids) - (append list-of-kids (list object))))) - ; implement a panel which can hold multiple objects but only displays ; one at a time. The size of the panel is the smallest size possible ; for displaying each of the panel's children. -(define wx-single-panel% +(define (wx-make-single-panel% wx-panel%) (class wx-panel% args (inherit children set-children force-redraw panel-redraw) @@ -1468,7 +1517,7 @@ (lambda (f) (let ([new-children (f children)]) (unless (andmap (lambda (child) - (eq? this (send child get-parent))) + (eq? this (send child area-parent))) new-children) (unless (memq (active-child) new-children) (active-child #f)) @@ -1480,7 +1529,7 @@ [() active] [(new-child) (unless (or (not new-child) - (eq? this (send new-child get-parent))) + (eq? this (send new-child area-parent))) (error 'active-child (string-append "The child specified (~s) is not " @@ -1523,6 +1572,17 @@ (sequence (apply super-init args)))) +(define wx-panel% (wx-make-panel% wx:panel%)) +(define wx-linear-panel% (wx-make-linear-panel% wx-panel%)) +(define wx-horizontal-panel% (wx-make-horizontal-panel% wx-linear-panel%)) +(define wx-vertical-panel% (wx-make-vertical-panel% wx-linear-panel%)) +(define wx-single-panel% (wx-make-single-panel% wx-panel%)) + +(define wx-pane% (wx-make-pane% wx:windowless-panel%)) +(define wx-linear-pane% (wx-make-linear-panel% wx-pane%)) +(define wx-horizontal-pane% (wx-make-horizontal-panel% wx-linear-pane%)) +(define wx-vertical-pane% (wx-make-vertical-panel% wx-linear-pane%)) +(define wx-single-pane% (wx-make-single-panel% wx-pane%)) ;-------------------- Text control simulation ------------------------- @@ -1590,7 +1650,7 @@ [horiz? (eq? (send parent get-label-position) 'horizontal)] [p (if horiz? this - (make-object wx-vertical-panel% #f proxy this null))] + (make-object wx-vertical-pane% #f proxy this null))] [l (and label (make-object wx-message% #f proxy p label -1 -1 null))] [c (make-object wx-text-media-canvas% #f proxy this p @@ -1706,10 +1766,10 @@ [() ((ivar/proc (get-obj) method))] [(v) ((ivar/proc (get-obj) method) v)])) -(define (panel-parent-only who p) - (unless (is-a? p internal-panel<%>) +(define (check-container-parent who p) + (unless (is-a? p internal-container<%>) (raise-type-error (string->symbol (format "~a-constructor" who)) - "parent panel% object" p))) + "built-in container<%> object" p))) (define (check-orientation who l) (unless (and (list? l) (andmap symbol? l) @@ -1722,15 +1782,6 @@ [else "style specification does not include an orientation: ~e"]) l))) -(define (any-legal-parent p) - (cond - [(is-a? p internal-panel<%>) (void)] - [(or (is-a? p frame%) (is-a? p dialog-box%)) - (when (send p get-panel) - (error 'panel-constructor "the specified top-level window already has a panel"))] - [else - (raise-type-error 'panel-constructor "parent mred:panel%, mred:frame%, or mred:dialog-box% object" p)])) - (define double-boxed (lambda (x y f) (let ([x (box x)][y (box y)]) @@ -1755,25 +1806,94 @@ (define wx-key (gensym)) (define (mred->wx w) ((mred-get-low-level-window w) wx-key)) +(define (mred->wx-container w) (send (mred->wx w) get-container)) + ;---------------- Window interfaces and base classes ------------ -(define window<%> +(define area<%> (interface () + get-parent + min-width min-height + stretchable-width stretchable-height)) + +(define area% + (class* mred% (area<%>) (mk-wx get-wx-panel parent) + (public + [get-parent (lambda () parent)] + [min-width (param get-wx-panel 'min-width)] + [min-height (param get-wx-panel 'min-height)] + [stretchable-width (param get-wx-panel 'stretchable-in-x)] + [stretchable-height (param get-wx-panel 'stretchable-in-y)]) + (private + [wx (mk-wx)]) + (sequence (super-init wx)))) + +(define subarea<%> + (interface (area<%>) + horiz-margin vert-margin)) + +(define (make-subarea% %) ; % implements area<%> + (class* % (subarea<%>) (mk-wx get-wx-panel parent) + (public + [horiz-margin (param get-wx-panel 'x-margin)] + [vert-margin (param get-wx-panel 'y-margin)]) + (sequence (super-init mk-wx get-wx-panel parent)))) + +(define container<%> + (interface (area<%>) + get-children change-children place-children + add-child delete-child + border)) + +(define internal-container<%> (interface ())) + +(define (make-container% %) ; % implements area<%> + (class* % (container<%> internal-container<%>) (mk-wx get-wx-panel parent) + (public + [get-children (lambda () (map wx->mred (ivar (get-wx-panel) children)))] + [border (param get-wx-panel 'border)] + [change-children (lambda (f) + (map mred->wx + (send (get-wx-panel) change-children + (lambda (kids) + (f (map wx->mred kids))))))] + [place-children (lambda (l w h) (send (get-wx-panel) do-place-children l w h))] + [add-child (lambda (c) (send (get-wx-panel) add-child (mred->wx c)))] + [delete-child (lambda (c) (send (get-wx-panel) delete-child (mred->wx c)))]) + (sequence + (super-init mk-wx get-wx-panel parent)))) + +(define linear-container<%> + (interface (container<%>) + spacing + set-alignment)) + +(define (make-linear-container% %) ; % implements container<%> + (class* % (linear-container<%>) (mk-wx get-wx-panel parent) + (public + [spacing (param get-wx-panel 'spacing)] + [set-alignment (lambda (h v) (send (get-wx-panel) alignment h v))] + [get-alignment (lambda () (send (get-wx-panel) get-alignment))]) + (sequence + (super-init mk-wx get-wx-panel parent)))) + + +(define window<%> + (interface (area<%>) on-focus focus on-size pre-on-char pre-on-event client->screen screen->client enable is-enabled? get-label set-label - get-parent get-client-size get-geometry get-width get-height get-x get-y get-text-extent get-cursor set-cursor show is-shown? refresh)) -(define basic-window% - (class* mred% (window<%>) (mk-wx label cursor) +(define (make-window% %) ; % implements area<%> + (class* % (window<%>) (mk-wx get-wx-panel label parent cursor) (public [on-focus void] [on-size void] @@ -1784,9 +1904,6 @@ [has-focus? (lambda () (send wx has-focus?))] [enable (lambda (on?) (send wx enable on?))] [is-enabled? (lambda () (send wx is-enabled?))] - [get-parent (lambda () - (let ([p (send wx get-parent)]) - (and p (wx->mred p))))] [get-label (lambda () label)] [set-label (lambda (l) (set! label l))] @@ -1830,22 +1947,37 @@ [refresh (lambda () (send wx refresh))]) (private - [wx (mk-wx)]) + [wx #f]) (sequence - (super-init wx)))) + (super-init (lambda () (set! wx (mk-wx)) wx) get-wx-panel parent)))) -(define subwindow-container<%> (interface (window<%>) get-subwindows)) +(define area-container-window<%> + (interface (window<%> container<%>) + set-control-font get-control-font + set-label-font get-label-font + set-label-position get-label-position)) + +(define (make-area-container-window% %) ; % implements window<%> (and container<%>) + (class* % (area-container-window<%>) (mk-wx get-wx-panel label parent cursor) + (public + [get-control-font (lambda () (send (get-wx-panel) get-button-font))] + [set-control-font (lambda (x) (send (get-wx-panel) set-button-font x))] + [get-label-font (lambda () (send (get-wx-panel) get-label-font))] + [set-label-font (lambda (x) (send (get-wx-panel) set-label-font x))] + [get-label-position (lambda () (send (get-wx-panel) get-label-position))] + [set-label-position (lambda (x) (send (get-wx-panel) set-label-position x))]) + (sequence + (super-init mk-wx get-wx-panel label parent cursor)))) (define top-level-window<%> - (interface (subwindow-container<%>) + (interface (linear-container<%> area-container-window<%>) on-activate get-focus-window get-edit-target-window get-focus-object get-edit-target-object - center move resize - get-panel)) + center move resize)) (define basic-top-level-window% - (class* basic-window% (top-level-window<%>) (mk-wx label) + (class* (make-area-container-window% (make-window% (make-linear-container% (make-container% area%)))) (top-level-window<%>) (mk-wx label parent) (rename [super-set-label set-label]) (private [wx-object->mred @@ -1854,12 +1986,6 @@ (wx->mred o) o))]) (public - [get-panel (lambda () - (let ([p (send wx get-top-panel)]) - (and p (wx->mred p))))] - [get-subwindows (lambda () - (let ([p (get-panel)]) - (if p (list p) null)))] [on-activate void] [center (case-lambda [() (send wx center)] @@ -1881,33 +2007,23 @@ [get-edit-target-object (lambda () (let ([o (send wx get-edit-target-object)]) (and o (wx-object->mred o))))]) (private - [wx #f]) - (sequence (super-init (lambda () (set! wx (mk-wx)) wx) label #f)))) + [wx #f] + [wx-panel #f] + [finish (lambda (top-level) + (set! wx-panel (make-object wx-vertical-panel% #f this top-level null)) + (send top-level set-container wx-panel) + top-level)]) + (sequence (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) label parent #f)))) -(define subwindow<%> - (interface (window<%>) - min-width min-height - horiz-margin vert-margin - stretchable-width stretchable-height)) - -(define basic-subwindow% - (class* basic-window% (subwindow<%>) (mk-wx label cursor) - (public - [min-width (param (lambda () wx) 'min-width)] - [min-height (param (lambda () wx) 'min-height)] - [horiz-margin (param (lambda () wx) 'x-margin)] - [vert-margin (param (lambda () wx) 'y-margin)] - [stretchable-width (param (lambda () wx) 'stretchable-in-x)] - [stretchable-height (param (lambda () wx) 'stretchable-in-y)]) - (private - [wx #f]) - (sequence (super-init (lambda () (set! wx (mk-wx)) wx) label cursor)))) +(define subwindow<%> + (interface (window<%> subarea<%>))) (define control<%> - (interface (subwindow<%>))) + (interface (subwindow<%>) + command)) (define basic-control% - (class* basic-subwindow% (control<%>) (mk-wx label cursor) + (class* (make-window% (make-subarea% area%)) (control<%>) (mk-wx label parent cursor) (rename [super-set-label set-label]) (public [set-label (lambda (l) @@ -1917,12 +2033,12 @@ (private [wx #f]) (sequence - (super-init (lambda () (set! wx (mk-wx)) wx) label cursor)))) + (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) label parent cursor)))) ;--------------------- Final mred class construction -------------------- (define frame% - (class basic-top-level-window% (label [parent #f] [x #f] [y #f] [width #f] [height #f] [style wx:const-default-frame-style]) + (class basic-top-level-window% (label [parent #f] [x #f] [y #f] [width #f] [height #f] [style null]) (private [wx #f]) (public @@ -1931,44 +2047,44 @@ [get-menu-bar (lambda () (let ([mb (ivar wx menu-bar)]) (and mb (wx->mred mb))))]) (sequence - (super-init (lambda () - (set! wx (make-object wx-frame% this this - (and parent (mred->wx parent)) label - (or x -1) (or y -1) (or width -1) (or height -1) - style)) + (super-init (lambda (finish) + (set! wx (finish (make-object wx-frame% this this + (and parent (mred->wx parent)) label + (or x -1) (or y -1) (or width -1) (or height -1) + style))) wx) - label)))) + label parent)))) (define dialog-box% - (class basic-top-level-window% (label [modal? #t] [parent #f] [x #f] [y #f] [width #f] [height #f] [style wx:const-default-dialog-style]) + (class basic-top-level-window% (label [modal? #t] [parent #f] [x #f] [y #f] [width #f] [height #f] [style null]) (sequence - (super-init (lambda () (make-object wx-dialog-box% this this - (and parent (mred->wx parent)) label modal? - (or x -1) (or y -1) (or width -1) (or height -1) - style)) - label)))) + (super-init (lambda (finish) (finish (make-object wx-dialog-box% this this + (and parent (mred->wx parent)) label modal? + (or x -1) (or y -1) (or width -1) (or height -1) + style))) + label parent)))) (define message% (class basic-control% (label parent [style null]) (sequence - (panel-parent-only 'message parent) + (check-container-parent 'message parent) (super-init (lambda () (make-object wx-message% this this - (mred->wx parent) + (mred->wx-container parent) label -1 -1 style)) - label #f)))) + label parent #f)))) (define button% (class basic-control% (label parent callback [style null]) (sequence - (panel-parent-only 'button parent) + (check-container-parent 'button parent) (super-init (lambda () (make-object wx-button% this this - (mred->wx parent) (wrap-callback callback) + (mred->wx-container parent) (wrap-callback callback) label -1 -1 -1 -1 style)) - label #f)))) + label parent #f)))) (define check-box% (class basic-control% (label parent callback [style null]) - (sequence (panel-parent-only 'check-box parent)) + (sequence (check-container-parent 'check-box parent)) (private [wx #f]) (public @@ -1977,14 +2093,14 @@ (sequence (super-init (lambda () (set! wx (make-object wx-check-box% this this - (mred->wx parent) (wrap-callback callback) + (mred->wx-container parent) (wrap-callback callback) label -1 -1 -1 -1 style)) wx) - label #f)))) + label parent #f)))) (define radio-box% (class basic-control% (label choices parent callback [style '(vertical)]) - (sequence (panel-parent-only 'radio-box parent) (check-orientation 'radio-box style)) + (sequence (check-container-parent 'radio-box parent) (check-orientation 'radio-box style)) (private [wx #f]) (public @@ -2006,14 +2122,14 @@ (sequence (super-init (lambda () (set! wx (make-object wx-radio-box% this this - (mred->wx parent) (wrap-callback callback) + (mred->wx-container parent) (wrap-callback callback) label -1 -1 -1 -1 choices 0 style)) wx) - label #f)))) + label parent #f)))) (define slider% (class basic-control% (label min-val max-val parent callback [value min-val] [style '(horizontal)]) - (sequence (panel-parent-only 'slider parent) (check-orientation 'slider style)) + (sequence (check-container-parent 'slider parent) (check-orientation 'slider style)) (private [wx #f]) (public @@ -2022,14 +2138,14 @@ (sequence (super-init (lambda () (set! wx (make-object wx-slider% this this - (mred->wx parent) (wrap-callback callback) + (mred->wx-container parent) (wrap-callback callback) label value min-val max-val style)) wx) - label #f)))) + label parent #f)))) (define gauge% (class basic-control% (label parent range [style '(horizontal)]) - (sequence (panel-parent-only 'gauge parent) (check-orientation 'gauge style)) + (sequence (check-container-parent 'gauge parent) (check-orientation 'gauge style)) (private [wx #f]) (public @@ -2038,10 +2154,10 @@ (sequence (super-init (lambda () (set! wx (make-object wx-gauge% this this - (mred->wx parent) + (mred->wx-container parent) label range style)) wx) - label #f)))) + label parent #f)))) (define list-control<%> (interface (control<%>) @@ -2054,7 +2170,7 @@ set-string-selection)) (define basic-list-control% - (class* basic-control% (list-control<%>) (mk-wx label) + (class* basic-control% (list-control<%>) (mk-wx label parent) (public [append (lambda (i) (send wx append i))] [clear (lambda () (send wx clear))] @@ -2068,24 +2184,24 @@ (private [wx #f]) (sequence - (super-init (lambda () (set! wx (mk-wx)) wx) label #f)))) + (super-init (lambda () (set! wx (mk-wx)) wx) label parent #f)))) (define choice% (class basic-list-control% (label choices parent callback [style null]) (sequence - (panel-parent-only 'choice parent) + (check-container-parent 'choice parent) (super-init (lambda () (make-object wx-choice% this this - (mred->wx parent) (wrap-callback callback) + (mred->wx-container parent) (wrap-callback callback) label -1 -1 -1 -1 choices style)) - label)))) + label parent)))) (define list-box% (class basic-list-control% (label choices parent callback [style '(single)]) (sequence - (panel-parent-only 'list-box parent) - (let ([c (+ (if (memq 'single style) 0 1) - (if (memq 'multiple style) 0 1) - (if (memq 'extended style) 0 1))]) + (check-container-parent 'list-box parent) + (let ([c (+ (if (memq 'single style) 1 0) + (if (memq 'multiple style) 1 0) + (if (memq 'extended style) 1 0))]) (when (zero? c) (error 'list-box-constructor "style does not specify single, multiple, or extended: ~a" style)) (when (> c 1) @@ -2118,11 +2234,11 @@ [(memq 'multiple style) (values 'multiple (remq 'multiple style))] [else (values 'extended (remq 'extended style))])]) (set! wx (make-object wx-list-box% this this - (mred->wx parent) (wrap-callback callback) + (mred->wx-container parent) (wrap-callback callback) label kind -1 -1 -1 -1 choices style))) wx) - label)))) + label parent)))) (define text-control<%> (interface (control<%>) @@ -2130,7 +2246,7 @@ (define (make-text% wx-text% who) (class* basic-control% (text-control<%>) (label parent callback [init-val ""] [style null]) - (sequence (panel-parent-only who parent)) + (sequence (check-container-parent who parent)) (private [wx #f]) (public @@ -2140,10 +2256,10 @@ (sequence (super-init (lambda () (set! wx (make-object wx-text% this this - (mred->wx parent) (wrap-callback callback) + (mred->wx-container parent) (wrap-callback callback) label init-val style)) wx) - label ibeam)))) + label parent ibeam)))) (define text% (make-text% wx-text% 'text)) (define multi-text% (make-text% wx-multi-text% 'multi-text)) @@ -2158,7 +2274,7 @@ popup-menu warp-pointer get-dc)) (define basic-canvas% - (class* basic-subwindow% (canvas<%>) (mk-wx) + (class* (make-window% (make-subarea% area%)) (canvas<%>) (mk-wx parent) (public [on-char (lambda (e) (send wx do-on-char e))] [on-event (lambda (e) (send wx do-on-event e))] @@ -2172,11 +2288,11 @@ (private [wx #f]) (sequence - (super-init (lambda () (set! wx (mk-wx)) wx) #f #f)))) + (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) #f parent #f)))) (define canvas% (class basic-canvas% (parent [style null]) - (sequence (panel-parent-only 'canvas parent)) + (sequence (check-container-parent 'canvas parent)) (public [virtual-size (lambda () (double-boxed 0 0 @@ -2202,14 +2318,15 @@ (sequence (super-init (lambda () (set! wx (make-object wx-canvas% this this - (mred->wx parent) + (mred->wx-container parent) -1 -1 canvas-default-size canvas-default-size style)) - wx))))) + wx) + parent)))) (define media-canvas% (class basic-canvas% (parent [buffer #f] [style null] [scrolls-per-page 100]) - (sequence (panel-parent-only 'canvas parent)) + (sequence (check-container-parent 'canvas parent)) (public [call-as-primary-owner (lambda (f) (send wx call-as-primary-owner f))] [allow-scroll-to-last (lambda (on?) (send wx allow-scroll-to-last on?))] @@ -2230,74 +2347,45 @@ (sequence (super-init (lambda () (set! wx (make-object wx-media-canvas% this this - (mred->wx parent) -1 -1 canvas-default-size canvas-default-size + (mred->wx-container parent) -1 -1 canvas-default-size canvas-default-size #f style scrolls-per-page buffer)) - wx))))) + wx) + parent)))) ;-------------------- Final panel interfaces and class constructions -------------------- -(define panel<%> - (interface (subwindow<%> subwindow-container<%>) - set-control-font get-control-font - set-label-font get-label-font - set-label-position get-label-position - change-children place-children add-child delete-child - border)) - -(define internal-panel<%> (interface ())) - -(define basic-panel% - (class* basic-subwindow% (panel<%> internal-panel<%>) (mk-wx) - (public - [get-subwindows (lambda () (map wx->mred (ivar wx children)))] - [get-control-font (lambda () (send wx get-button-font))] - [set-control-font (lambda (x) (send wx set-button-font x))] - [get-label-font (lambda () (send wx get-label-font))] - [set-label-font (lambda (x) (send wx set-label-font x))] - [get-label-position (lambda () (send wx get-label-position))] - [set-label-position (lambda (x) (send wx set-label-position x))] - [border (param (lambda () wx) 'border)] - [change-children (lambda (f) - (map mred->wx - (send wx change-children - (lambda (kids) - (f (map wx->mred kids))))))] - [place-children (lambda (l w h) (send wx do-place-children l w h))] - [add-child (lambda (c) (send wx add-child (mred->wx c)))] - [delete-child (lambda (c) (send wx delete-child (mred->wx c)))]) - (private - [wx #f]) - (sequence - (super-init (lambda () (set! wx (mk-wx)) wx) #f #f)))) - -(define (make-a-panel% panel% wx-panel%) - (class panel% (parent [style null]) +(define (make-pane% who pane% wx-pane%) + (class pane% (parent) + (private [wx #f]) (sequence - (any-legal-parent parent) - (super-init (lambda () (make-object wx-panel% this this (mred->wx parent) style)))))) + (check-container-parent who parent) + (super-init (lambda () (set! wx (make-object wx-pane% this this (mred->wx-container parent) null)) wx) + (lambda () wx) parent)))) -(define panel% (make-a-panel% basic-panel% wx-panel%)) -(define single-panel% (make-a-panel% basic-panel% wx-single-panel%)) +(define basic-pane% (make-subarea% (make-container% area%))) +(define pane% (make-pane% 'pane basic-pane% wx-pane%)) +(define single-pane% (make-pane% 'single-pane basic-pane% wx-single-pane%)) -(define linear-panel<%> - (interface (panel<%>) - spacing - set-alignment)) +(define basic-linear-pane% (make-subarea% (make-linear-container% (make-container% area%)))) +(define vertical-pane% (make-pane% 'vertical-pane basic-linear-pane% wx-vertical-pane%)) +(define horizontal-pane% (make-pane% 'horizontal-pane basic-linear-pane% wx-horizontal-pane%)) -(define basic-linear-panel% - (class basic-panel% (mk-wx) - (public - [spacing (param (lambda () wx) 'spacing)] - [set-alignment (lambda (h v) (send wx alignment h v))] - [get-alignment (lambda () (send wx get-alignment))]) - (private - [wx #f]) - (sequence - (super-init (lambda () (set! wx (mk-wx)) wx))))) +(define (make-panel% who panel% wx-panel%) + (class panel% (parent [style null]) + (private [wx #f]) + (sequence + (check-container-parent who parent) + (super-init (lambda () (set! wx (make-object wx-panel% this this (mred->wx-container parent) style)) wx) + (lambda () wx) #f parent #f)))) -(define vertical-panel% (make-a-panel% basic-linear-panel% wx-vertical-panel%)) -(define horizontal-panel% (make-a-panel% basic-linear-panel% wx-horizontal-panel%)) +(define basic-panel% (make-area-container-window% (make-window% (make-subarea% (make-container% area%))))) +(define panel% (make-panel% 'panel basic-panel% wx-panel%)) +(define single-panel% (make-panel% 'single-panel basic-panel% wx-single-panel%)) + +(define basic-linear-panel% (make-area-container-window% (make-window% (make-linear-container% (make-subarea% (make-container% area%)))))) +(define vertical-panel% (make-panel% 'vertical-panel basic-linear-panel% wx-vertical-panel%)) +(define horizontal-panel% (make-panel% 'horizontal-panel basic-linear-panel% wx-horizontal-panel%)) ;;;;;;;;;;;;;;;;;;;;;; Menu classes ;;;;;;;;;;;;;;;;;;;;;;