.

original commit: c890bfa5f7a67912afe1f213df848b460b593976

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,6 +2991,8 @@
 	     [(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)
+	      (if (not (eq? (system-type) 'unix))
+		  (wx:file-selector message directory filename extension "*.*" (if put? '(put) '(get)) parent)
 		  (letrec ([ok? #t]
 			   [typed-name #f]
 			   [dir (or directory (current-directory))]
@@ -3101,12 +3105,92 @@
 		    (reset-directory)
 		    (send f center)
 		    (send f show #t)
-		(get-filename))])])
+		    (get-filename)))])])
     sel))
 
 (define get-file (mk-file-selector #f))
 (define put-file (mk-file-selector #t))
 
+(define get-color-from-user 
+  (if (not (eq? (system-type) 'unix))
+      wx:get-color-from-user
+      (case-lambda
+       [() (get-color-from-user #f #f #f)]
+       [(message) (get-color-from-user message #f #f)]
+       [(message parent) (get-color-from-user message parent #f)]
+       [(message parent color)
+	(let* ([ok? #t]
+	       [f (make-object dialog-box% "Choose Color" #t 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))]
+	       [red (make-color-slider "Red:")]
+	       [green (make-color-slider "Green:")]
+	       [blue (make-color-slider "Blue:")]
+	       [bp (make-object horizontal-pane% f)])
+	  (when color
+	    (send red set-value (send color red))
+	    (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))
+	  (send bp set-alignment 'right 'center)
+	  (send p set-alignment 'right 'center)
+	  (send f show #t)
+	  (and ok?
+	       (make-object wx:color% 
+                            (send red get-value)
+                            (send green get-value)
+			    (send blue get-value))))])))
+
+(define get-font-from-user 
+  (if (eq? (system-type) 'windows)
+      wx:get-font-from-user
+      (case-lambda
+       [() (get-font-from-user #f #f #f)]
+       [(message) (get-font-from-user message #f #f)]
+       [(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)]
+		 [refresh-sample (lambda (b e) (let ([f (get-font)])
+						 (send ok-button enable f)
+						 (when f
+						   (let ([s (send (send edit get-style-list) find-named-style "Standard")]
+							 [d (make-object wx:style-delta%)])
+						     (send d set-delta-face (send f get-face))
+						     (send d set-delta 'change-size (send f get-point-size))
+						     (send d set-delta 'change-style (send f get-style))
+						     (send d set-delta 'change-weight (send f get-weight))
+						     (send s set-delta d)))))]
+		 [p (make-object horizontal-pane% f)]
+		 [face (make-object list-box% "Font:" (wx:get-font-list) p refresh-sample)]
+		 [p2 (make-object vertical-pane% p)]
+		 [style (make-object radio-box% "Style:" '("Normal" "Italic" "Slant") p2 refresh-sample)]
+		 [weight (make-object radio-box% "Weight:" '("Normal" "Bold" "Light") p2 refresh-sample)]
+		 [size (make-object slider% "Size:" 4 127 p2 refresh-sample 12)]
+		 [sample (make-object multi-text% "Sample" f void "The quick brown fox jumped over the lazy dog")]
+		 [edit (send sample get-edit)]
+		 [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))]
+		 [get-font (lambda () (let ([face (send face get-string-selection)])
+					(and face
+					     (make-object wx:font% (send size get-value) face 'default
+							  (case (send style get-selection) [(0) 'normal] [(1) 'italic] [(2) 'slant])
+							  (case (send weight get-selection) [(0) 'normal] [(1) 'bold] [(2) 'light])))))]
+		 [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))])
+	  (when font
+	    (let ([f (send face find-string (send font get-face))])
+	      (and f (>= 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?)