From bd7dadba04a24805ee0078ea4e433008bdedfa4b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Aug 1998 15:06:42 +0000 Subject: [PATCH] . original commit: c890bfa5f7a67912afe1f213df848b460b593976 --- src/mred/wrap/mred.ss | 324 ++++++++++++++++++++++++++---------------- 1 file changed, 204 insertions(+), 120 deletions(-) diff --git a/src/mred/wrap/mred.ss b/src/mred/wrap/mred.ss index 68231129..df515bbb 100644 --- a/src/mred/wrap/mred.ss +++ b/src/mred/wrap/mred.ss @@ -2167,6 +2167,8 @@ set-selection set-string-selection)) +(define (-1=>false v) (if (negative? v) #f v)) + (define basic-list-control% (class* basic-control% (list-control<%>) (mk-wx label parent) (public @@ -2174,11 +2176,11 @@ [clear (lambda () (send wx clear))] [get-number (lambda () (send wx number))] [get-string (lambda (n) (send wx get-string n))] - [get-selection (lambda () (send wx get-selection))] + [get-selection (lambda () (-1=>false (send wx get-selection)))] [get-string-selection (lambda () (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) (send wx find-string x))]) + [find-string (lambda (x) (-1=>false (send wx find-string x)))]) (private [wx #f]) (sequence @@ -2790,6 +2792,7 @@ (wx:yield waiting)) (define box-width 300) +(define (no-stretch a) (send a stretchable-width #f) (send a stretchable-height #f)) (define message-box (case-lambda @@ -2833,9 +2836,10 @@ (define get-ps-setup-from-user (case-lambda - [() (get-ps-setup-from-user #f null)] - [(parent) (get-ps-setup-from-user parent null)] - [(parent style) + [() (get-ps-setup-from-user #f #f null)] + [(message) (get-ps-setup-from-user message #f null)] + [(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 papers @@ -2870,8 +2874,6 @@ (send f show #f) (set! ok ok?)) - (define (no-stretch a) (send a stretchable-width #f) (send a stretchable-height #f)) - (define-values (xsb ysb xtb ytb) (values (box 0) (box 0) (box 0) (box 0))) (send paper set-selection (or (find-pos papers (send pss get-paper-name) equal?) 0)) @@ -2989,124 +2991,206 @@ [(message parent directory filename) (sel message parent directory filename #f null)] [(message parent directory filename extension) (sel message parent directory filename extension null)] [(message parent directory filename extension style) - (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)] - [__ (when message - (let ([p (make-object vertical-pane% f)]) - (send p stretchable-height #f) - (make-object message% message p)))] - [m (make-object message% dir f)] - [lp (make-object horizontal-pane% f)] - [dirs (make-object list-box% #f null lp (lambda (d e) - (when (eq? (send e get-event-type) 'list-box-dclick) - (let ([sd (send d get-string-selection)]) - (set! dir (simplify-path (build-path dir sd))) - (reset-directory)))))] - [files (make-object list-box% #f null lp (lambda (d e) - (update-ok) - (when (eq? (send e get-event-type) 'list-box-dclick) - (done))))] - [do-text-name (lambda () - (let ([v (send dir-text get-value)]) - (if (directory-exists? v) - (begin - (set! dir v) - (reset-directory)) - ; Maybe specifies a file: - (let-values ([(super file) - (with-handlers ([void #f]) - (let-values ([(base name dir?) (split-path v)]) - (let ([super (and (not dir?) - (or (and (string? base) - (directory-exists? base) - base) - (and (eq? base 'relative) - (directory-exists? dir) dir)))]) - (if super - (values super name) - (values #f #f)))))]) - (if super - (begin - (set! dir super) - (set! typed-name file) - (done)) - (begin - (set! dir v) - (reset-directory)))))))] - [dir-text (make-object text% #f f (lambda (t e) - (if (eq? (send e get-event-type) 'text-enter) - (do-text-name) - (begin - ; typing in the box; disable the file list and enable ok - (send files enable #f) - (send ok-button enable #t)))))] - [bp (make-object horizontal-pane% f)] - [dot-check (make-object check-box% "Show files/directories that start with \".\"" bp (lambda (b e) (reset-directory)))] - [spacer (make-object vertical-pane% bp)] - [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) - (if (send files is-enabled?) - (done) ; normal mode - (do-text-name))) ; handle typed text - '(default))] - [update-ok (lambda () (send ok-button enable (not (null? (send files get-selections)))))] - [reset-directory (lambda () - (wx:begin-busy-cursor) - (send m set-label (if (directory-exists? dir) - dir - (string-append "BAD DIRECTORY: " dir))) - (send dir-text set-value dir) - (let ([l (with-handlers ([void (lambda (x) null)]) - (directory-list dir))] - [dot? (send dot-check get-value)]) - (letrec ([sort (lambda (l) - (if (or (null? l) (null? (cdr l))) - l - (let-values ([(l1 l2) (split l null null)]) - (merge (sort l1) (sort l2)))))] - [split (lambda (l l1 l2) - (cond - [(null? l) (values l1 l2)] - [(null? (cdr l)) (values (cons (car l) l1) l2)] - [else (split (cddr l) (cons (car l) l1) (cons (cadr l) l2))]))] - [merge (lambda (l1 l2) - (cond - [(null? l1) l2] - [(null? l2) l1] - [(string= f 0) (send face set-selection f))) + (send style set-selection (case (send font get-style) [(normal) 0] [(italic) 1] [(slant) 2])) + (send weight set-selection (case (send font get-weight) [(normal) 0] [(bold) 1] [(light) 2])) + (send size set-value (send font get-point-size))) + (send bp set-alignment 'right 'center) + (refresh-sample (void) (void)) + (send f show #t) + (and ok? (get-font)))]))) + (define (play-sound f async?) (if (not (eq? (system-type) 'unix)) (wx:play-sound f async?)