From b1c41523bff3980a73ca7d9e07559133d62652cb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 17 Aug 1998 22:20:02 +0000 Subject: [PATCH] . original commit: e784c7a4e0efbbc7b706c69db2694db35080da1a --- src/mred/wrap/mred.ss | 116 +++++++++++++++++++++--------------------- 1 file changed, 58 insertions(+), 58 deletions(-) diff --git a/src/mred/wrap/mred.ss b/src/mred/wrap/mred.ss index 862e9811..159aea43 100644 --- a/src/mred/wrap/mred.ss +++ b/src/mred/wrap/mred.ss @@ -24,9 +24,7 @@ ; this structure holds the information that a child will need to send ; to its parent when the parent must resize itself. -(define-struct child-info (x-posn ; current x position w.r.t parent - y-posn ; current y position - x-min y-min ; includes margins! +(define-struct child-info (x-min y-min ; includes margins! x-margin y-margin ; requested margin space x-stretch y-stretch)) ; booleans indicating strechability @@ -122,7 +120,7 @@ (let loop ([window this]) (cond [(or (is-a? window wx:frame%) - (is-a? window wx:dialog-box%)) + (is-a? window wx:dialog%)) (set! top-level window)] [else (loop (send window get-parent))]))) top-level)]) @@ -149,9 +147,9 @@ (define (wx-make-container% %) %) ; make-top-container%: adds the necessary functionality to wx:frame% and -; wx:dialog-box%. +; wx:dialog%. ; input: base%: the base class from which to descend the new class. -; Intended to be either wx:frame% or wx:dialog-box%, but can +; Intended to be either wx:frame% or wx:dialog%, but can ; be anything which contains all methods in the inherit section ; below. ; returns: a new class, descended from base%, which possesses the added @@ -204,7 +202,7 @@ [get-focus-window (lambda () focus)] [get-edit-target-window - (lambda () target)] + (lambda () (and target (send (wx->proxy target) is-shown?) target))] [get-focus-object (lambda () (window->focus-object focus))] @@ -521,8 +519,7 @@ [get-info (lambda () (let* ([min-size (get-min-size)] - [result (make-child-info (get-x) (get-y) - (car min-size) (cadr min-size) + [result (make-child-info (car min-size) (cadr min-size) (x-margin) (y-margin) (stretchable-in-x) (stretchable-in-y))]) @@ -725,9 +722,9 @@ (sequence (apply super-init args))))) -(define wx-dialog-box% +(define wx-dialog% (make-top-level-window-glue% - (class (make-top-container% wx:dialog-box%) args + (class (make-top-container% wx:dialog%) args (sequence (apply super-init args))))) @@ -1112,11 +1109,17 @@ (error 'change-children (string-append "Not all members of the new list are " - "children of this panel ~s~nlist: ~s") + "children of the container ~e; list: ~e") this new-children)) ; show all new children, hide all deleted children. (let ([added-children (list-diff new-children children)] [removed-children (list-diff children new-children)]) + (unless (andmap (lambda (child) + (is-a? wx:window% child)) + removed-children) + (error 'change-children + "Cannot make non-window areas inactive in ~e" + this)) (for-each (lambda (child) (send child show #f)) removed-children) (set! children new-children) @@ -1276,10 +1279,9 @@ (let ([curr-info (car children-info)]) (cons (list - (child-info-x-margin curr-info) - (child-info-y-margin curr-info) - (child-info-x-min curr-info) - (child-info-y-min curr-info)) + 0 0 + (car curr-info) ; child-info-x-min + (cadr curr-info)) ; child-info-y-min (loop (cdr children-info)))))))] [spacing ; does nothing! @@ -1306,7 +1308,11 @@ (lambda (width height) (let ([children-info (get-children-info)]) (panel-redraw children children-info - (place-children children-info width height))))] + (place-children (map (lambda (i) + (list (child-info-x-min i) (child-info-y-min i) + (child-info-x-stretch i) (child-info-y-stretch i))) + children-info) + width height))))] [panel-redraw (lambda (childs child-infos placements) (for-each @@ -1515,11 +1521,11 @@ [do-place-children (lambda (l w h) (place-linear-children l w h - child-info-x-min - child-info-x-stretch + car ; child-info-x-min + caddr ; child-info-x-stretch major-offset - child-info-y-min - child-info-y-stretch + cadr ; child-info-y-min + cadddr ; child-info-y-stretch minor-offset (lambda (width height) width) (lambda (width height) height) @@ -1553,11 +1559,11 @@ [do-place-children (lambda (l w h) (place-linear-children l w h - child-info-y-min - child-info-y-stretch + cadr ; child-info-y-min + cadddr ; child-info-y-stretch major-offset - child-info-x-min - child-info-x-stretch + car ; child-info-x-min + caddr ; child-info-x-stretch minor-offset (lambda (width height) height) (lambda (width height) width) @@ -1870,7 +1876,6 @@ enable is-enabled? get-label set-label get-client-size get-geometry get-width get-height get-x get-y - get-text-extent get-cursor set-cursor show is-shown? refresh)) @@ -1921,13 +1926,6 @@ [get-x (lambda () (- (send wx get-x) (if top? 0 (send (send wx get-parent) dx))))] [get-y (lambda () (- (send wx get-y) (if top? (send (send wx get-parent) dy))))] - [get-text-extent (letrec ([l (case-lambda - [(s w h) (l s w h #f #f #f)] - [(s w h d) (l s w h d #f #f)] - [(s w h d a) (l s w h d a #f)] - [(s w h d a f) (send wx get-text-extent s w h d a f)])]) - l)] - [get-cursor (lambda () cursor)] [set-cursor (lambda (x) (send wx set-cursor x) @@ -1981,8 +1979,8 @@ [eventspace (wx:current-eventspace)]) (override [set-label (lambda (l) - (send wx set-title l) - (super-set-label))]) + (send wx set-title (wx:label->plain-label l)) + (super-set-label l))]) (public [get-eventspace (lambda () eventspace)] [can-close? (lambda () #t)] @@ -2047,24 +2045,26 @@ [create-status-line (lambda () (unless status-line? (send wx create-status-line) (set! status-line? #t)))] [set-status-line (lambda () (send wx create-status-line))] [has-status-line? (lambda () status-line?)] - [iconize (lambda () (send wx iconize))] + [iconize (lambda (on?) (send wx iconize on?))] + [is-iconized? (lambda () (send wx iconized?))] + [set-icon (lambda (i) (send wx set-icon i))] [maximize (lambda () (send wx maximize))] [get-menu-bar (lambda () (let ([mb (ivar wx menu-bar)]) (and mb (wx->mred mb))))]) (sequence (super-init (lambda (finish) (set! wx (finish (make-object wx-frame% this this - (and parent (mred->wx parent)) label + (and parent (mred->wx parent)) (wx:label->plain-label label) (or x -1) (or y -1) (or width -1) (or height -1) style))) wx) label parent)))) -(define dialog-box% - (class basic-top-level-window% (label [modal? #t] [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]) +(define dialog% + (class basic-top-level-window% (label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]) (sequence - (super-init (lambda (finish) (finish (make-object wx-dialog-box% this this - (and parent (mred->wx parent)) label modal? + (super-init (lambda (finish) (finish (make-object wx-dialog% this this + (and parent (mred->wx parent)) (wx:label->plain-label label) #t (or x -1) (or y -1) (or width 0) (or height 0) style))) label parent)))) @@ -2202,8 +2202,8 @@ [clear (lambda () (send wx clear))] [get-number (lambda () (send wx number))] [get-string (lambda (n) (send wx get-string n))] - [get-selection (lambda () (-1=>false (send wx get-selection)))] - [get-string-selection (lambda () (send wx get-string-selection))] + [get-selection (lambda () (and (positive? (get-number)) (-1=>false (send wx get-selection))))] + [get-string-selection (lambda () (and (positive? (get-number)) (send wx get-string-selection)))] [set-selection (lambda (s) (send wx set-selection s))] [set-string-selection (lambda (s) (send wx set-string-selection s))] [find-string (lambda (x) (-1=>false (send wx find-string x)))]) @@ -2739,7 +2739,7 @@ [get-item (lambda () item)]))) (define popup-menu% - (class basic-menu% (title) + (class basic-menu% ([title #f]) (sequence (super-init title (lambda (m e) @@ -2904,7 +2904,7 @@ [(title message) (message-box title message #f '(ok))] [(title message parent) (message-box title message parent '(ok))] [(title message parent style) - (let* ([f (make-object dialog-box% title #t parent box-width)] + (let* ([f (make-object dialog% title parent box-width)] [result 'ok] [strings (let loop ([s message]) (let ([m (regexp-match (let ([nl (string #\newline #\return)]) @@ -2925,7 +2925,7 @@ (let* ([p (make-object horizontal-pane% f)] [mk-button (lambda (title v default?) (let ([b (make-object button% title p (lambda (b e) (set! result v) (send f show #f)) - (if default? '(default) null))]) + (if default? '(border) null))]) (when default? (send b focus))))]) (send p stretchable-height #f) (send p stretchable-width #f) @@ -2946,13 +2946,13 @@ [(message parent) (get-ps-setup-from-user message parent null)] [(message parent style) (define pss (wx:current-ps-setup)) - (define f (make-object dialog-box% "PostScript Setup" #t parent)) + (define f (make-object dialog% "PostScript Setup" parent)) (define papers '("A4 210 x 297 mm" "A3 297 x 420 mm" "Letter 8 1/2 x 11 in" "Legal 8 1/2 x 14 in")) (define p (make-object horizontal-pane% f)) (define paper (make-object choice% #f papers p void)) (define _0 (make-object vertical-pane% p)) - (define ok (make-object button% "Ok" p (lambda (b e) (done #t)) '(default))) + (define ok (make-object button% "Ok" p (lambda (b e) (done #t)) '(border))) (define cancel (make-object button% "Cancel" p (lambda (b e) (done #f)))) (define unix? (eq? (system-type) 'unix)) (define dp (make-object horizontal-pane% f)) @@ -3042,7 +3042,7 @@ [(title message init-val) (get-text-from-user title message init-val #f null)] [(title message init-val parent) (get-text-from-user title message init-val parent null)] [(title message init-val parent style) - (let* ([f (make-object dialog-box% title #t parent box-width)] + (let* ([f (make-object dialog% title parent box-width)] [ok? #f] [done (lambda (?) (lambda (b e) (set! ok? ?) (send f show #f)))]) (send f set-label-position 'vertical) @@ -3053,7 +3053,7 @@ (send p set-alignment 'right 'center) (send p stretchable-height #f) (make-object button% "Cancel" p (done #f)) - (make-object button% "Ok" p (done #t) '(default)) + (make-object button% "Ok" p (done #t) '(border)) (send t focus) (send f show #t) (and ok? (send t get-value))))])) @@ -3064,7 +3064,7 @@ [(title message choices parent) (get-choice-from-user title message choices parent null '(single))] [(title message choices parent init-vals) (get-choice-from-user title message choices parent init-vals '(single))] [(title message choices parent init-vals style) - (let* ([f (make-object dialog-box% title #t parent box-width)] + (let* ([f (make-object dialog% title parent box-width)] [ok-button #f] [update-ok (lambda (l) (send ok-button enable (not (null? (send l get-selections)))))] [ok? #f] @@ -3081,7 +3081,7 @@ (send p set-alignment 'right 'center) (send p stretchable-height #f) (make-object button% "Cancel" p (done #f)) - (set! ok-button (make-object button% "Ok" p (done #t) '(default))) + (set! ok-button (make-object button% "Ok" p (done #t) '(border))) (update-ok l) (send f show #t) (and ok? (send l get-selections))))])) @@ -3101,7 +3101,7 @@ (letrec ([ok? #t] [typed-name #f] [dir (or directory (current-directory))] - [f (make-object dialog-box% (if put? "Put File" "Get File") #t parent 500 300)] + [f (make-object dialog% (if put? "Put File" "Get File") parent 500 300)] [__ (when message (let ([p (make-object vertical-pane% f)]) (send p stretchable-height #f) @@ -3159,7 +3159,7 @@ (if (send files is-enabled?) (done) ; normal mode (do-text-name))) ; handle typed text - '(default))] + '(border))] [update-ok (lambda () (send ok-button enable (not (null? (send files get-selections)))))] [reset-directory (lambda () (wx:begin-busy-cursor) @@ -3225,7 +3225,7 @@ [(message parent) (get-color-from-user message parent #f)] [(message parent color) (let* ([ok? #t] - [f (make-object dialog-box% "Choose Color" #t parent)] + [f (make-object dialog% "Choose Color" parent)] [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))] [p (make-object vertical-pane% f)] [make-color-slider (lambda (l) (make-object slider% l 0 255 p void))] @@ -3238,7 +3238,7 @@ (send green set-value (send color green)) (send blue set-value (send color blue))) (make-object button% "Cancel" bp (done #f)) - (make-object button% "Ok" bp (done #t) '(default)) + (make-object button% "Ok" bp (done #t) '(border)) (send bp set-alignment 'right 'center) (send p set-alignment 'right 'center) (send f show #t) @@ -3257,7 +3257,7 @@ [(message parent) (get-font-from-user message parent #f)] [(message parent font) (letrec ([ok? #f] - [f (make-object dialog-box% "Choose Font" #t parent 500 300)] + [f (make-object dialog% "Choose Font" parent 500 300)] [refresh-sample (lambda (b e) (let ([f (get-font)]) (send ok-button enable f) (when f @@ -3281,7 +3281,7 @@ (send underlined get-value)))))] [bp (make-object horizontal-pane% f)] [cancel-button (make-object button% "Cancel" bp (done #f))] - [ok-button (make-object button% "Ok" bp (done #t) '(default))]) + [ok-button (make-object button% "Ok" bp (done #t) '(border))]) (when font (let ([f (send face find-string (send font get-face))]) (and f (>= f 0) (send face set-selection f)))