added some font sizing information to the insert large letters dialog

svn: r16561

collects/drscheme/private/insert-large-letters.ss

@@ -70,19 +70,24 @@
                         [parent dlg]
                         [stretchable-height #f]))
   (define: font-choice : (Instance Choice%)
-    (new choice%
+    (let ([tmp-bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #f))])
-         [label (string-constant fonts)]
+      (new choice%
-         [parent info-bar]
+           [label (string-constant fonts)]
-         [choices (get-face-list)]
+           [parent info-bar]
-         [callback
+           [choices (map (λ: ((x : String)) (format "~a~a" x (get-w-size tmp-bdc x))) 
-          (λ: ([x : Any] [y : Any])
+                         (get-face-list))]
-            (let ([old (preferences:get 'drscheme:large-letters-font)])
+           [callback
-              (preferences:set 'drscheme:large-letters-font
+            (λ: ([x : Any] [y : Any])
-                               (cons (send font-choice get-string-selection)
+                (let ([old (preferences:get 'drscheme:large-letters-font)]
-                                     (if old
+                      [choice (send font-choice get-selection)])
-                                         (cdr old)
+                  (when choice
-                                         (send (get-default-font) get-point-size))))
+                    (preferences:set 'drscheme:large-letters-font
-              (update-txt (send text-field get-value))))]))
+                                     (cons (list-ref (get-face-list)
+                                                     choice)
+                                           (if old
+                                               (cdr old)
+                                               (send (get-default-font) get-point-size))))
+                    (update-txt (send text-field get-value)))))])))
   
   (: count (Instance Message%))
   (define count (new message% [label (format columns-string 1000)] [parent info-bar]))
@@ -122,12 +127,18 @@
       (send dark-msg set-bm bm)))
   
   
-  
-  
   ;; CHANGE - get-face can return #f
   (let ([face (send (get-chosen-font) get-face)])
     (when face
-      (send font-choice set-string-selection face)))
+      (let loop ([i 0]
+                 [faces (get-face-list)])
+        (cond
+          [(null? faces) (void)]
+          [else (cond
+                  [(equal? face (car faces))
+                   (send font-choice set-selection i)]
+                  [else
+                   (loop (+ i 1) (cdr faces))])]))))
   
   (send txt auto-wrap #f)
   (update-txt " ")
@@ -135,6 +146,13 @@
   (send dlg show #t)
   (and ok? (send text-field get-value)))
 
+(: get-w-size ((Instance Bitmap-DC%) String -> String))
+(define (get-w-size dc face-name)
+  (let ([font (send the-font-list find-or-create-font 24 face-name 'default 'normal 'normal)])
+    (let-values ([(w h a d) (send dc get-text-extent "w" font)])
+      (format " (~a)" (floor (inexact->exact w))))))
+  
+
 (: get-max-line-width ((Instance Scheme:Text%) -> Number))
 (define (get-max-line-width txt)
   (let loop ([i (+ (send txt last-paragraph) 1)]

collects/scribblings/drscheme/menus.scrbl

@@ -358,7 +358,13 @@ background that signals the source location of an error.}
   
  @item{@defmenuitem{Insert Large Letters...} Opens a dialog for a line of
    text, and inserts a large version of the text (using semicolons and
-   spaces).}
+   spaces).
+          
+   Most of the dialog is self-explanatory: type in the top space to 
+   preview the semicolons in the bottom area. The numbers in the font
+   choice item show the (relative) widths of the letter ``w'' in the
+   given font to help you pick out the more boldfaced fonts (which
+   tend to look better).}
 
  @item{@defmenuitem{Insert @|lam-str|} Inserts the symbol @|lam-str|
    (as a Unicode character) into the program. The @|lam-str| symbol is

collects/typed/mred/mred.ss

@@ -23,7 +23,9 @@
                              ()))
 (dt Choice% (Class ()
                    ([parent Any] [label String] [choices (Listof Any)] [callback Any])
-                   ([get-string-selection (-> (Option String))]
+                   ([get-selection (-> (Option Integer))]
+                    [set-selection (Integer -> Any)]
+                    [get-string-selection (-> (Option String))]
                     [set-string-selection (String -> Void)])))
 (dt Message% (Class ()
                     ([parent Any] [label String])