suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 2013007981c432cb2a3538e5a21f53ac7700e6ad
This commit is contained in:
Matthew Flatt 1998-08-09 20:58:01 +00:00
parent 6476f4e6e0
commit b5819e3e0b
2 changed files with 178 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

236
notes/mred/MrEd_100.txt
View File

@ -5,7 +5,7 @@
>>> Proposal <<< >>> Proposal <<<
Between version 53 and 100 or MrEd, the windowing portion of the MrEd Between version 53 and 100 of MrEd, the windowing portion of the MrEd
toolbox was drastically simplified and Scheme-ified. In general, we toolbox was drastically simplified and Scheme-ified. In general, we
did not try to develop an improved windowing model, but instead tried did not try to develop an improved windowing model, but instead tried
to clean up the existing model. to clean up the existing model.
@ -63,8 +63,8 @@ The following are a few highlights of the revision:
"editor". Here's the mapping for some commonly used classes: "editor". Here's the mapping for some commonly used classes:
media-canvas => editor-canvas media-canvas => editor-canvas
media-buffer => editor (now an interface) media-buffer => editor (now an interface)
media-edit => buffer media-edit => text-editor
media-pasteboard => pasteboard media-pasteboard => pasteboard-editor
snip => snip snip => snip
media-snip => editor-snip media-snip => editor-snip
One nice thing about this renaming is that matches a lot of the One nice thing about this renaming is that matches a lot of the
@ -153,8 +153,8 @@ dc<%>
|- postscript-dc% |- postscript-dc%
editor<%> (maybe has an edit-admin% and some editor-canvas<%>s) editor<%> (maybe has an edit-admin% and some editor-canvas<%>s)
|- buffer% |- text-editor%
|- pasteboard% |- pasteboard-editor%
snip% (as a snip-admin%) snip% (as a snip-admin%)
|- text-snip% |- text-snip%
@ -167,13 +167,11 @@ editor-admin% (formerly media-admin%)
snip-admin% snip-admin%
(pens, styles, fonts, etc. as before)
event% event%
|- control-event% (formerly command-event%; for control/menu-item callbacks) |- control-event% (formerly command-event%; for control/menu-item callbacks)
|- mouse-event% |- mouse-event%
|- key-event% |- key-event%
|- scroll-event% |- scroll-event% (new; used for on-scroll)
====================================================================== ======================================================================
2. Interface/Class Methods (Selected Excerpts) 2. Interface/Class Methods (Selected Excerpts)
@ -182,120 +180,134 @@ event%
arguments are listed after "<=" for classes. arguments are listed after "<=" for classes.
====================================================================== ======================================================================
window<%> area<%>
get-parent
get-top-level - returns the area's frame/dialog-box
min-width min-height
stretchable-width stretchable-height
subarea<%> : area<%>
horiz-margin vert-margin
window<%> : area<%>
focus on-focus focus on-focus
enable is-enabled? enable is-enabled?
on-size on-size
pre-on-char pre-on-event pre-on-char pre-on-event
client-to-screen screen-to-client client->screen screen->client
get-label set-label get-label set-label
get-plain-label - e.g., "Button" instead of "&Button" get-plain-label - e.g., "Button" instead of "&Button"
get-parent
get-client-size get-geometry get-width get-height get-x get-y get-client-size get-geometry get-width get-height get-x get-y
get-text-extent get-text-extent
get-cursor set-cursor get-cursor set-cursor
show is-shown? show is-shown?
refresh refresh
get-top-level *
subwindow-container<%> container<%> : area<%>
get-subwindows get-children change-children place-children
add-child delete-child
border - parameter-like
spacing - parameter-like
set-alignment - takes two syms: 'left/'center/'right 'top/'center/'bottom
get-alignment - returns two syms...
top-level-window<%> area-container-window<%> : container<%> window<%>
set-control-font get-control-font
set-label-font get-label-font
set-label-position get-label-position
subwindow<%> : subarea<%> window<%>
panel% : area-container-window<%> subwindow<%>
<= parent [style null]
styles: 'border
horizontal-panel%: panel%
<= parent [style null]
styles: 'border
vertical-panel%: panel%
<= parent [style null]
styles: 'border
pane% : container<%> subwindow<%>
<= parent
horizontal-pane%: pane%
<= parent
vertical-pane%: pane%
<= parent
top-level-window<%> : area-container-window<%>
get-eventspace get-eventspace
on-activate on-activate
can-close? on-close
get-focus-window - the window with the current focus (or #f) get-focus-window - the window with the current focus (or #f)
get-edit-target-window - the window to last have the focus (or #f) get-edit-target-window - the window to last have the focus (or #f)
get-focus-object - the window/editor with the curent focus (or #f) get-focus-object - the window/editor with the curent focus (or #f)
get-edit-target-object - the window/editor to last have the focus (or #f) get-edit-target-object - the window/editor to last have the focus (or #f)
center move resize center move resize
frame% frame% : top-level-window<%>
<= label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null] <= label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]
styles: 'no-thick-border 'no-resize-border 'no-caption 'no-system-menu
'iconize 'maximize 'mdi-parent 'mdi-child
create-status-line set-status-line create-status-line set-status-line
get-menu-bar get-menu-bar
dialog-box% dialog-box% : top-level-window<%>
<= label [modal? #t] [parent #f] [width #f] [height #f] [x #f] [y #f] [style null] <= label [modal? #t] [parent #f] [width #f] [height #f] [x #f] [y #f]
[style null]
styles: 'no-caption
subwindow<%> control<%> : subwindow<%>
min-width min-height command - just invokes the callback; no longer changes the control value
stretchable-width stretchable-height
horiz-margin vert-margin
panel<%> message% : control<%>
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 - parameter-like
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]
linear-panel<%>
spacing - parameter-like
set-alignment - takes two syms: 'left/'center/'right 'top/'center/'bottom
get-alignment - returns two syms...
vertical-panel%
<= parent [style null]
horizontal-panel
<= parent [style null]
control<%>
command - just invokes the callback; no longer changes the control
message%
<= label parent [style null] <= label parent [style null]
styles: none
button% button% : control<%>
<= label parent callback [style null] <= label parent callback [style null]
styles: 'default
check-box% check-box% : control<%>
<= label parent callback [style null] <= label parent callback [style null]
styles: none
set-value get-value set-value get-value
slider% slider% : control<%>
<= label min-val max-val parent callback [value min-val] [style '(horizontal)] <= label min-val max-val parent callback [value min-val]
[style '(horizontal)]
styles: 'horizontal 'vertical
set-value get-value set-value get-value
gauge% gauge% : control<%>
<= label parent range [style '(horizontal)] <= label parent range [style '(horizontal)]
styles: 'horizontal 'vertical
set-value get-value set-value get-value
text-control<%> text-control<%> : control<%>
get-value set-value get-edit get-value set-value get-edit
text% text% : control<%>
<= label parent callback [init-val ""] [style null] <= label parent callback [init-val ""] [style null]
styles: none
multi-text% multi-text% : control<%>
<= label parent callback [init-val ""] [style null] <= label parent callback [init-val ""] [style null]
styles: non
radio-box% radio-box% : control<%>
<= label choices parent callback [style '(vertical)] <= label choices parent callback [style '(vertical)]
styles: 'horizontal 'vertical
get-number get-number
get-item-label - label for one of the choices get-item-label - label for one of the choices
get-item-plain-label - e.g., "Cut" intsead of "Cut Cmd-X" get-item-plain-label - e.g., "Cut" intsead of "Cut Cmd-X"
get-selection set-selection get-selection set-selection
list-control<%> list-control<%> : control<%>
clear append clear append
get-number get-number
get-string find-string get-string find-string
@ -304,11 +316,13 @@ list-control<%>
set-selection set-selection
set-string-selection set-string-selection
choice% choice% : list-control<%>
<= label choices parent callback [style null] <= label choices parent callback [style null]
styles: none
list-box% list-box% : list-control<%>
<= label choices parent callback [style '(single)] <= label choices parent callback [style '(single)]
styles: 'single 'multiple 'extended 'always-vscroll 'hscroll
delete delete
get-data get-data
get-selections get-selections
@ -317,28 +331,30 @@ list-box%
number-of-visible-items number-of-visible-items
get-first-visible set-first-visible get-first-visible set-first-visible
canvas<%> canvas<%> : subwindow<%>
on-char on-event on-paint on-scroll on-char on-event on-paint on-scroll
popup-menu warp-pointer get-dc popup-menu warp-pointer get-dc
canvas% canvas% : canvas<%>
<= parent [style null] <= parent [style null]
styles: 'border 'vscroll 'hscroll
virtual-size view-start virtual-size view-start
set-scrollbars scroll set-scrollbars scroll
get-scroll-pos set-scroll-pos get-scroll-pos set-scroll-pos
get-scroll-range set-scroll-range get-scroll-range set-scroll-range
get-scroll-page set-scroll-page get-scroll-page set-scroll-page
editor-canvas% editor-canvas% : canvas<%>
<= parent [buffer #f] [style null] [scrolls-per-page 100] <= parent [editor #f] [style null] [scrolls-per-page 100]
styles: 'no-hscroll 'no-vscroll 'hide-hscroll 'hide-vscroll
call-as-primary-owner call-as-primary-owner
allow-scroll-to-last - parameter-like * allow-scroll-to-last - parameter-like
scroll-with-bottom-base - parameter-like * scroll-with-bottom-base - parameter-like
lazy-refresh - parameter-like * lazy-refresh - parameter-like
force-display-focus - parameter-like * force-display-focus - parameter-like
edit-target - parameter-like * edit-target - parameter-like
get-edit set-edit - formerly get-media and set-media get-edit set-edit - formerly get-media and set-media
set-line-count * set-line-count
menu-item<%> menu-item<%>
get-parent get-parent
@ -426,9 +442,42 @@ key-event%
scroll-event% scroll-event%
<= <=
get-position set-position
get-event-type set-event-type get-event-type set-event-type
get-direction set-direction get-direction set-direction
======================================================================
3. Procedures
If an old procedure isn't listed here, we got rid of it.
======================================================================
file-selector
<= directory filename [parent #f] [style '(get)] [extension #f]
styles: 'get 'put
message-box
<= title message [parent #f] [style '(ok)]
styles: 'yes-no 'ok 'ok-cancel
get-text-from-user
<= title message [init-val #f] [parent #f] [style null]
styles: none
get-choice-from-user (returns an integer, not the value)
<= title message choices [init-choice 0] [parent #f] [style null]
get-choices-from-user
<= title message choices [init-choices null] [parent #f] [style null]
color-display? display-size
begin-busy-cursor end-busy-cursor is-busy-cursor?
bell
label->plain-label
get-resource write-resource
yield flush-display
get-top-level-windows
====================================================================== ======================================================================
3. Subtle changes 3. Subtle changes
====================================================================== ======================================================================
@ -455,14 +504,13 @@ wx:media-buffer%'s do-edit takes a symbol instead of a number; extract
====================================================================== ======================================================================
4. Constant Mapping 4. Constant Mapping
The following atble details the conversion from the old wx:const- The following table maps old wx:const- identifiers to new symbols.
identifiers to symbols.
====================================================================== ======================================================================
wx:const-align-bottom 'bottom wx:const-align-bottom 'bottom
wx:const-align-center 'center wx:const-align-center 'center
wx:const-align-top 'top wx:const-align-top 'top
wx:const-always-sb 'always-sb wx:const-always-sb 'always-hscroll
wx:const-and 'and wx:const-and 'and
wx:const-and-invert 'and-invert wx:const-and-invert 'and-invert
wx:const-and-reverse 'and-reverse wx:const-and-reverse 'and-reverse
@ -536,12 +584,10 @@ wx:media-buffer%'s do-edit takes a symbol instead of a number; extract
wx:const-cursor-watch 'watch wx:const-cursor-watch 'watch
wx:const-decorative 'decorative wx:const-decorative 'decorative
wx:const-default 'default wx:const-default 'default
wx:const-default-dialog-style (NOT A SYMBOL: wx:wx:const-default-dialog-style)
wx:const-default-frame (NOT A SYMBOL: wx:wx:const-default-frame-style)
wx:const-default-select 'default wx:const-default-select 'default
wx:const-dot 'dot wx:const-dot 'dot
wx:const-dot-dash 'dot-dash wx:const-dot-dash 'dot-dash
wx:const-edit-buffer 'edit-buffer wx:const-edit-buffer 'text
wx:const-edit-clear 'clear wx:const-edit-clear 'clear
wx:const-edit-copy 'copy wx:const-edit-copy 'copy
wx:const-edit-cut 'cut wx:const-edit-cut 'cut
@ -684,10 +730,10 @@ wx:media-buffer%'s do-edit takes a symbol instead of a number; extract
wx:const-long-dash 'long-dash wx:const-long-dash 'long-dash
wx:const-maximize 'maximize wx:const-maximize 'maximize
wx:const-maximize-box 'maximize-box wx:const-maximize-box 'maximize-box
wx:const-mcanvas-hide-h-scroll 'hide-h-scroll wx:const-mcanvas-hide-h-scroll 'hide-hscroll
wx:const-mcanvas-hide-v-scroll 'hide-v-scroll wx:const-mcanvas-hide-v-scroll 'hide-vscroll
wx:const-mcanvas-no-h-scroll 'no-h-scroll wx:const-mcanvas-no-h-scroll 'no-hscroll
wx:const-mcanvas-no-v-scroll 'no-v-scroll wx:const-mcanvas-no-v-scroll 'no-vscroll
wx:const-mdi-child 'mdi-child wx:const-mdi-child 'mdi-child
wx:const-mdi-parent 'mdi-parent wx:const-mdi-parent 'mdi-parent
wx:const-media-ff-copy 'copy wx:const-media-ff-copy 'copy
@ -727,7 +773,7 @@ wx:media-buffer%'s do-edit takes a symbol instead of a number; extract
wx:const-or-reverse 'or-reverse wx:const-or-reverse 'or-reverse
wx:const-overwrite-prompt 'overwrite-prompt wx:const-overwrite-prompt 'overwrite-prompt
wx:const-password (NO LONGER USED) wx:const-password (NO LONGER USED)
wx:const-pasteboard-buffer 'pasteboard-buffer wx:const-pasteboard-buffer 'pasteboard
wx:const-pos-use-minus-one (NO LONGER USED) wx:const-pos-use-minus-one (NO LONGER USED)
wx:const-print-ask 'ask wx:const-print-ask 'ask
wx:const-print-postscript 'postscript wx:const-print-postscript 'postscript
@ -822,3 +868,5 @@ screen's depth, #f means a B&W bitmap).
Remove add-edit-items and add-font-items from the wx:media-buffer% Remove add-edit-items and add-font-items from the wx:media-buffer%
class, re-implementing them (as necessary) as Scheme top-level class, re-implementing them (as necessary) as Scheme top-level
procedures. procedures.
Enable/cursor support with exclusions?

49
src/mred/wrap/mred.ss
View File

@ -1737,7 +1737,7 @@
(define area<%> (define area<%>
(interface () (interface ()
get-parent get-parent get-top-level
min-width min-height min-width min-height
stretchable-width stretchable-height)) stretchable-width stretchable-height))
@ -1745,6 +1745,7 @@
(class* mred% (area<%>) (mk-wx get-wx-panel parent) (class* mred% (area<%>) (mk-wx get-wx-panel parent)
(public (public
[get-parent (lambda () parent)] [get-parent (lambda () parent)]
[get-top-level (lambda () (wx->mred (send wx get-top-level)))]
[min-width (param get-wx-panel 'min-width)] [min-width (param get-wx-panel 'min-width)]
[min-height (param get-wx-panel 'min-height)] [min-height (param get-wx-panel 'min-height)]
[stretchable-width (param get-wx-panel 'stretchable-in-x)] [stretchable-width (param get-wx-panel 'stretchable-in-x)]
@ -1837,12 +1838,14 @@
[get-geometry (lambda () [get-geometry (lambda ()
(let ([x (box 0)][y (box 0)][w (box 0)][h (box 0)]) (let ([x (box 0)][y (box 0)][w (box 0)][h (box 0)])
(send wx get-size w h x y) (send wx get-size w h x y)
(values (unbox x) (unbox y) (unbox w) (unbox h))))] (values (- (unbox x) (send wx dx))
(- (unbox y) (send wx dy))
(unbox w) (unbox h))))]
[get-width (lambda () (send wx get-width))] [get-width (lambda () (send wx get-width))]
[get-height (lambda () (send wx get-height))] [get-height (lambda () (send wx get-height))]
[get-x (lambda () (send wx get-x))] [get-x (lambda () (- (send wx get-x) (send wx dx))]
[get-y (lambda () (send wx get-y))] [get-y (lambda () (- (send wx get-y) (send wx dy))]
[get-text-extent (letrec ([l (case-lambda [get-text-extent (letrec ([l (case-lambda
[(s w h) (l s w h #f #f #f)] [(s w h) (l s w h #f #f #f)]
@ -2247,18 +2250,38 @@
(define media-canvas% (define media-canvas%
(class basic-canvas% (parent [buffer #f] [style null] [scrolls-per-page 100]) (class basic-canvas% (parent [buffer #f] [style null] [scrolls-per-page 100])
(sequence (check-container-parent 'canvas parent)) (sequence (check-container-parent 'canvas parent))
(private
[force-focus? #f]
[scroll-to-last? #f]
[scroll-bottom? #f])
(public (public
[call-as-primary-owner (lambda (f) (send wx call-as-primary-owner f))] [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?))] [allow-scroll-to-last
[scroll-with-bottom-base (lambda (on?) (send wx scroll-with-bottom-base on?))] (case-lambda
[() scroll-to-last?]
[has-lazy-refresh? (lambda () (send wx get-lazy-refresh))] [(on?) (set! scroll-to-last? (and on? #t))
[lazy-refresh (lambda (on?) (send wx set-lazy-referesh))] (send wx allow-scroll-to-last on?)])]
[scroll-with-bottom-base
[force-display-focus (lambda (on?) (send wx force-display-focus on?))] (case-lambda
[() scroll-bottom?]
[(on?) (set! scroll-bottom? (and on? #t))
(send wx scroll-with-bottom-base on?)])]
[lazy-refresh
(case-lambda
[() (send wx get-lazy-refresh)]
[(on?) (send wx set-lazy-refresh)])]
[force-display-focus
(case-lambda
[() force-focus?]
[(on?) (set! force-focus? (and on? #t))
(send wx force-display-focus on?)])]
[edit-target
(case-lambda
[() (and (send wx get-edit-target) #t)]
[(on?) (send wx set-edit-target (and on? wx))])]
[edit-target (lambda (on?) (send x set-edit-target (and on? wx)))] [set-line-count
[is-edit-target? (lambda () (and #t (send x get-edit-target)))] (lambda (n) (send wx set-line-count n))]
[get-media (lambda () (send wx get-media))] [get-media (lambda () (send wx get-media))]
[set-media (lambda (m) (send wx set-media m))]) [set-media (lambda (m) (send wx set-media m))])