From 24fccbc8d7a149bc2cde3a773f37e14c81ccffdc Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 9 May 2003 16:44:10 +0000
Subject: [PATCH] .

original commit: 65ca42ace367a2704f0ddd35af21b908d41db0f8
---
 collects/mred/mred.ss | 157 +++++++++++++++++++++---------------------
 1 file changed, 78 insertions(+), 79 deletions(-)

diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss
index 184e5725..a048570b 100644
--- a/collects/mred/mred.ss
+++ b/collects/mred/mred.ss
@@ -6675,85 +6675,84 @@
     (check-top-level-parent/false 'get-font-from-user parent)
     (check-instance 'get-font-from-user wx:font% 'font% #t font)
     (check-style 'get-font-from-user #f null style)
-    (if (eq? (system-type) 'windows-no-more)
-	(wx:get-font-from-user message (and parent (mred->wx parent)) font)
-	(letrec ([ok? #f]
-		 [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
-						   (let ([s (send (send edit get-style-list) find-named-style "Standard")])
-						     (send s set-delta (font->delta f))))))]
-		 [p (make-object horizontal-pane% f)]
-		 [face (make-object list-box% "Font:" 
-				    (let ([l (wx:get-face-list)])
-				      (if (memq (system-type) '(macos macosx))
-					  (sort l (lambda (a b)
-						    (cond
-						     [(eq? (char-alphabetic? (string-ref a 0))
-							   (char-alphabetic? (string-ref b 0)))
-						      (string-locale<? a b)]
-						     [else (char-alphabetic? (string-ref a 0))])))
-					  (sort l string-ci<?)))
-				    p refresh-sample)]
-		 [p2 (make-object vertical-pane% p)]
-		 [p3 (instantiate horizontal-pane% (p2) [stretchable-width #f])]
-		 [style (let ([pnl (instantiate group-box-panel% ("Style" p3) [stretchable-height #f] [stretchable-width #f])])
-			  (make-object radio-box% #f '("Normal" "Italic" "Slant") pnl refresh-sample))]
-		 [weight (let ([pnl (instantiate group-box-panel% ("Weight" p3) [stretchable-height #f] [stretchable-width #f])])
-			   (make-object radio-box% #f '("Normal" "Bold" "Light") pnl refresh-sample))]
-		 [p4 (instantiate vertical-pane% (p3) [alignment '(left center)])]
-		 [underlined (make-object check-box% "Underlined" p4 refresh-sample)]
-		 [smoothing (make-object choice% "Smoothing:" '("Default" "Some" "Full" "None") p4 refresh-sample)]
-		 [size (make-object slider% "Size:" 4 127 p2 refresh-sample 12)]
-		 [sample (make-object text-field% "Sample" f void "The quick brown fox jumped over the lazy dog" '(multiple))]
-		 [edit (send sample get-editor)]
-		 [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])
-							  (send underlined get-value)
-							  (case (send smoothing get-selection) 
-							    [(0) 'default] 
-							    [(1) 'partly-smoothed]
-							    [(2) 'smoothed]
-							    [(3) 'unsmoothed])))))]
-		 [bp (instantiate horizontal-pane% (f) [stretchable-height #f])]
-		 [ms-button (if (eq? (system-type) 'windows)
-				(begin0
-				 (make-object button% "Use System Dialog..." bp
-					      (lambda (b e)
-						(let ([new-font (wx:get-font-from-user 
-								 message 
-								 (mred->wx f)
-								 (get-font))])
-						  (when new-font
-						    (reset-font new-font)))))
-				 ;; Spacer:
-				 (make-object pane% bp))
-				(void))]
-		 [cancel-button (make-object button% "Cancel" bp (done #f))]
-		 [ok-button (make-object button% "OK" bp (done #t) '(border))]
-		 [reset-font 
-		  (lambda (font)
-		    (let* ([facen (if font
-				     (send font get-face)
-				     (get-family-builtin-face 'default))]
-			   [f (and facen (send face find-string facen))])
-		      (and f (>= f 0) (send face set-selection f)))
-		    (when font
-		      (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 underlined set-value (send font get-underlined))
-		      (send size set-value (send font get-point-size)))
-		    (refresh-sample (void) (void)))])
-	  (send bp set-alignment 'right 'center)
-	  (reset-font font)
-	  (send f center)
-	  (send f show #t)
-	  (and ok? (get-font))))]))
+    (letrec ([ok? #f]
+	     [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
+					       (let ([s (send (send edit get-style-list) find-named-style "Standard")])
+						 (send s set-delta (font->delta f))))))]
+	     [p (make-object horizontal-pane% f)]
+	     [face (make-object list-box% #f
+				(let ([l (wx:get-face-list)])
+				  (if (memq (system-type) '(macos macosx))
+				      (sort l (lambda (a b)
+						(cond
+						 [(eq? (char-alphabetic? (string-ref a 0))
+						       (char-alphabetic? (string-ref b 0)))
+						  (string-locale<? a b)]
+						 [else (char-alphabetic? (string-ref a 0))])))
+				      (sort l string-ci<?)))
+				p refresh-sample)]
+	     [p2 (make-object vertical-pane% p)]
+	     [p3 (instantiate horizontal-pane% (p2) [stretchable-width #f])]
+	     [style (let ([pnl (instantiate group-box-panel% ("Style" p3) [stretchable-height #f] [stretchable-width #f])])
+		      (make-object radio-box% #f '("Normal" "Italic" "Slant") pnl refresh-sample))]
+	     [weight (let ([pnl (instantiate group-box-panel% ("Weight" p3) [stretchable-height #f] [stretchable-width #f])])
+		       (make-object radio-box% #f '("Normal" "Bold" "Light") pnl refresh-sample))]
+	     [p4 (instantiate vertical-pane% (p3) [alignment '(left center)])]
+	     [underlined (make-object check-box% "Underlined" p4 refresh-sample)]
+	     [smoothing (make-object choice% "Smoothing:" '("Default" "Some" "Full" "None") p4 refresh-sample)]
+	     [size (make-object slider% "Size:" 4 127 p2 refresh-sample 12)]
+	     [sample (make-object text-field% "Sample" f void "The quick brown fox jumped over the lazy dog" '(multiple))]
+	     [edit (send sample get-editor)]
+	     [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])
+						      (send underlined get-value)
+						      (case (send smoothing get-selection) 
+							[(0) 'default] 
+							[(1) 'partly-smoothed]
+							[(2) 'smoothed]
+							[(3) 'unsmoothed])))))]
+	     [bp (instantiate horizontal-pane% (f) [stretchable-height #f])]
+	     [ms-button (if (eq? (system-type) 'windows)
+			    (begin0
+			     (make-object button% "Use System Dialog..." bp
+					  (lambda (b e)
+					    (let ([new-font (wx:get-font-from-user 
+							     message 
+							     (mred->wx f)
+							     (get-font))])
+					      (when new-font
+						(reset-font new-font)))))
+			     ;; Spacer:
+			     (make-object pane% bp))
+			    (void))]
+	     [cancel-button (make-object button% "Cancel" bp (done #f))]
+	     [ok-button (make-object button% "OK" bp (done #t) '(border))]
+	     [reset-font 
+	      (lambda (font)
+		(let* ([facen (if font
+				  (send font get-face)
+				  (get-family-builtin-face 'default))]
+		       [f (and facen (send face find-string facen))])
+		  (and f (>= f 0) (send face set-selection f)))
+		(when font
+		  (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 underlined set-value (send font get-underlined))
+		  (send size set-value (send font get-point-size)))
+		(refresh-sample (void) (void)))])
+      (send bp set-alignment 'right 'center)
+      (send face min-width (max 200 (let-values ([(w h) (send face get-graphical-min-size)]) w)))
+      (reset-font font)
+      (send f center)
+      (send f show #t)
+      (and ok? (get-font)))]))
 
 (define (play-sound f async?)
   (if (not (eq? (system-type) 'unix))