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

.

Browse Source 
original commit: 9da7b9ac7c240b10e40e0b5fa785ff8edf5eaa10
This commit is contained in:
Matthew Flatt 1998-10-20 18:54:05 +00:00
parent 5f367c3f85
commit f37af6ed72
1 changed files with 49 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,4 +1,3 @@
;;;;;;;;;;;;;;; Constants ;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;; Constants ;;;;;;;;;;;;;;;;;;;;
; default spacing between items. ; default spacing between items.
@ -327,7 +326,7 @@
(define (make-top-container% base%) (define (make-top-container% base%)
(class (wx-make-container% (wx-make-window% base%)) args (class (wx-make-container% (wx-make-window% base%)) args
(inherit get-x get-y get-width get-height set-size (inherit get-x get-y get-width get-height set-size
get-client-size is-shown?) get-client-size is-shown? on-close)
(rename [super-show show] [super-move move] [super-center center] (rename [super-show show] [super-move move] [super-center center]
[super-on-size on-size] [super-on-size on-size]
[super-enable enable]) [super-enable enable])
@ -342,6 +341,7 @@
[ignore-redraw-request? #f] [ignore-redraw-request? #f]
[already-trying? #f] ; hack around stubborn Motif bug [already-trying? #f] ; hack around stubborn Motif bug
[was-bad? #f] ; hack around min-frame-size limitations
; pointer to panel in the frame for use in on-size ; pointer to panel in the frame for use in on-size
[panel #f] [panel #f]
@ -404,6 +404,7 @@
[add-child [add-child
(lambda (new-panel) (lambda (new-panel)
(set! panel new-panel) (set! panel new-panel)
(set! pending-redraws? #t)
(let-values ([(client-w client-h) (let-values ([(client-w client-h)
(get-two-int-values get-client-size)]) (get-two-int-values get-client-size)])
(send panel set-size 0 0 client-w client-h)) (send panel set-size 0 0 client-w client-h))
@ -441,12 +442,13 @@
(set! pending-redraws? #t)))] (set! pending-redraws? #t)))]
[force-redraw [force-redraw
(lambda () (lambda ()
(when panel (if panel
(dynamic-wind (dynamic-wind
(lambda () (set! ignore-redraw-request? #t)) (lambda () (set! ignore-redraw-request? #t))
resized resized
(lambda () (set! ignore-redraw-request? #f)))) (lambda () (set! ignore-redraw-request? #f)))
(set! pending-redraws? #f))]
(set! pending-redraws? #f)))]
[correct-size [correct-size
(lambda (frame-w frame-h) (lambda (frame-w frame-h)
@ -482,6 +484,7 @@
(when panel (when panel
(let-values ([(f-client-w f-client-h) (get-two-int-values get-client-size)]) (let-values ([(f-client-w f-client-h) (get-two-int-values get-client-size)])
(send panel set-size 0 0 f-client-w f-client-h) (send panel set-size 0 0 f-client-w f-client-h)
(set! pending-redraws? #f)
(send panel on-container-resize))))] (send panel on-container-resize))))]
@ -491,11 +494,15 @@
(let ([new-width (get-width)] (let ([new-width (get-width)]
[new-height (get-height)]) [new-height (get-height)])
(let-values ([(correct-w correct-h) (correct-size new-width new-height)]) (let-values ([(correct-w correct-h) (correct-size new-width new-height)])
(if (and (= new-width correct-w) (= new-height correct-h)) (if (or (and (= new-width correct-w) (= new-height correct-h))
was-bad?)
;; Good size; do panel ;; Good size; do panel
(set-panel-size)
;; Too small; fix it
(begin (begin
(set! was-bad? #f)
(set-panel-size))
;; Too large/small; try to fix it, but give up after a while
(begin
(set! was-bad? #t)
(set! already-trying? #t) (set! already-trying? #t)
(set-size -1 -1 correct-w correct-h) (set-size -1 -1 correct-w correct-h)
(set! already-trying? #f)))))))]) (set! already-trying? #f)))))))])
@ -569,6 +576,12 @@
#t))) #t)))
objs) objs)
#t)))] #t)))]
[(escape)
(let ([o (get-focus-window)])
(if (and o (send o handles-key-code code))
#f
(when (on-close)
(show #f))))]
[(#\space) [(#\space)
(let ([o (get-focus-window)]) (let ([o (get-focus-window)])
(cond (cond
@ -592,8 +605,9 @@
(memq code '(right down)))] (memq code '(right down)))]
[normal-move [normal-move
(lambda () (lambda ()
(let* ([dests (map object->position (container->children panel o))] (let* ([o (if (is-a? o wx:item%) o #f)]
[pos (if o (object->position o) (list 'x 0 0 0 0))] [dests (map object->position (container->children panel o))]
[pos (if o (object->position o) (list 'x 0 0 1 1))]
[o (traverse (cadr pos) (caddr pos) (cadddr pos) (list-ref pos 4) [o (traverse (cadr pos) (caddr pos) (cadddr pos) (list-ref pos 4)
(case code (case code
[(#\tab) (if shift? 'prev 'next)] [(#\tab) (if shift? 'prev 'next)]
@ -1055,10 +1069,10 @@
const-default-x-margin const-default-y-margin const-default-x-margin const-default-y-margin
#t #f) #t #f)
(parent label range style) (parent label range style)
(inherit get-client-size get-width get-height (inherit get-client-size get-width get-height set-size
set-size
stretchable-in-x stretchable-in-y set-min-height set-min-width stretchable-in-x stretchable-in-y set-min-height set-min-width
get-parent) get-parent)
(override [gets-focus? (lambda () #f)])
(private (private
; # pixels per unit of value. ; # pixels per unit of value.
[pixels-per-value 1]) [pixels-per-value 1])
@ -1221,7 +1235,7 @@
[handles-key-code [handles-key-code
(lambda (x) (lambda (x)
(case x (case x
[(#\tab #\return) (not single-line-canvas?)] [(#\tab #\return escape) (not single-line-canvas?)]
[else #t]))]) [else #t]))])
(public (public
[set-single-line (lambda () (set! single-line-canvas? #t))] [set-single-line (lambda () (set! single-line-canvas? #t))]
@ -1411,8 +1425,7 @@
x-margin y-margin x-margin y-margin
get-client-size area-parent) get-client-size area-parent)
(rename [super-set-focus set-focus] (rename [super-set-focus set-focus])
[super-set-size set-size])
(private (private
; cache to prevent on-size from recomputing its result every ; cache to prevent on-size from recomputing its result every
@ -1619,15 +1632,6 @@
(+ (* 2 (y-margin)) (+ (* 2 (y-margin))
(max (cadr graphical-min-size) (min-height))))))] (max (cadr graphical-min-size) (min-height))))))]
; set-size:
[set-size
(lambda (x y width height)
(unless (and (same-dimension? x (get-x))
(same-dimension? y (get-y))
(same-dimension? width (get-width))
(same-dimension? height (get-height)))
(super-set-size x y width height)))]
[on-container-resize [on-container-resize
(lambda () (lambda ()
(let-values ([(client-width client-height) (let-values ([(client-width client-height)
@ -3644,10 +3648,12 @@
(send p stretchable-height #f) (send p stretchable-height #f)
(send p stretchable-width #f) (send p stretchable-width #f)
(case (car style) (case (car style)
[(ok) (mk-button "&Ok" 'ok #t)] [(ok) (mk-button "Ok" 'ok #t)]
[(ok-cancel) (mk-button "&Cancel" 'cancel #f) [(ok-cancel) (set! result 'cancel)
(mk-button "&Ok" 'ok #t)] (mk-button "Cancel" 'cancel #f)
[(yes-no) (mk-button "&Yes" 'yes #f) (mk-button "Ok" 'ok #t)]
[(yes-no) (set! result 'no)
(mk-button "&Yes" 'yes #f)
(mk-button "&No" 'no #f)])) (mk-button "&No" 'no #f)]))
(send f center) (send f center)
(send f show #t) (send f show #t)
@ -3697,9 +3703,10 @@
(define l2 (make-object check-box% "PostScript Level 2" f void)) (define l2 (make-object check-box% "PostScript Level 2" f void))
(define (done ok?) (define ok? #f)
(define (done ?)
(send f show #f) (send f show #f)
(set! ok ok?)) (set! ok? ?))
(define-values (xsb ysb xtb ytb) (values (box 0) (box 0) (box 0) (box 0))) (define-values (xsb ysb xtb ytb) (values (box 0) (box 0) (box 0) (box 0)))
@ -3734,7 +3741,7 @@
(send f show #t) (send f show #t)
(if ok (if ok?
(let ([s (make-object wx:ps-setup%)] (let ([s (make-object wx:ps-setup%)]
[gv (lambda (c b) [gv (lambda (c b)
(or (string->number (send c get-value)) (unbox b)))]) (or (string->number (send c get-value)) (unbox b)))])
@ -3837,7 +3844,7 @@
(check-style who #f null style) (check-style who #f null style)
(if (not (eq? (system-type) 'unix)) (if (not (eq? (system-type) 'unix))
(wx:file-selector message directory filename extension "*.*" (if put? 'put 'get) parent) (wx:file-selector message directory filename extension "*.*" (if put? 'put 'get) parent)
(letrec ([ok? #t] (letrec ([ok? #f]
[typed-name #f] [typed-name #f]
[dir (or directory last-visted-directory (current-directory))] [dir (or directory last-visted-directory (current-directory))]
[f (make-object dialog% (if put? "Put File" "Get File") parent 500 300)] [f (make-object dialog% (if put? "Put File" "Get File") parent 500 300)]
@ -3893,11 +3900,11 @@
[bp (make-object horizontal-pane% f)] [bp (make-object horizontal-pane% f)]
[dot-check (make-object check-box% "Show files/directories that start with \".\"" bp (lambda (b e) (reset-directory)))] [dot-check (make-object check-box% "Show files/directories that start with \".\"" bp (lambda (b e) (reset-directory)))]
[spacer (make-object vertical-pane% bp)] [spacer (make-object vertical-pane% bp)]
[cancel-button (make-object button% "&Cancel" bp (lambda (b e) (set! ok? #f) (send f show #f)))] [cancel-button (make-object button% "Cancel" bp (lambda (b e) (set! ok? #f) (send f show #f)))]
[ok-button (make-object button% "&Ok" bp (lambda (b e) [ok-button (make-object button% "Ok" bp (lambda (b e)
(if (send files is-enabled?) (if (send files is-enabled?)
(done) ; normal mode (done) ; normal mode
(do-text-name))) ; handle typed text (do-text-name))) ; handle typed text
'(border))] '(border))]
[update-ok (lambda () (send ok-button enable (not (null? (send files get-selections)))))] [update-ok (lambda () (send ok-button enable (not (null? (send files get-selections)))))]
[reset-directory (lambda () [reset-directory (lambda ()
@ -3945,6 +3952,7 @@
(unless (and put? (file-exists? name) (unless (and put? (file-exists? name)
(eq? (message-box "Warning" (format "Replace ~s?" name) f '(yes-no)) 'no) (eq? (message-box "Warning" (format "Replace ~s?" name) f '(yes-no)) 'no)
(set! typed-name #f)) (set! typed-name #f))
(set! ok? #t)
(send f show #f))))]) (send f show #f))))])
(send bp stretchable-height #f) (send bp stretchable-height #f)
(send m stretchable-width #t) (send m stretchable-width #t)
@ -3970,7 +3978,7 @@
(check-top-level-parent/false 'get-color-from-user parent) (check-top-level-parent/false 'get-color-from-user parent)
(check-instance 'get-color-from-user wx:color% 'color% #t color) (check-instance 'get-color-from-user wx:color% 'color% #t color)
(check-style 'get-color-from-user #f null style) (check-style 'get-color-from-user #f null style)
(let* ([ok? #t] (let* ([ok? #f]
[f (make-object dialog% "Choose Color" parent)] [f (make-object dialog% "Choose Color" parent)]
[done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))] [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))]
[p (make-object vertical-pane% f)] [p (make-object vertical-pane% f)]