diff --git a/collects/drscheme/private/insert-large-letters.ss b/collects/drscheme/private/insert-large-letters.ss index ea55ecfbfb..446d94e09d 100644 --- a/collects/drscheme/private/insert-large-letters.ss +++ b/collects/drscheme/private/insert-large-letters.ss @@ -70,19 +70,24 @@ [parent dlg] [stretchable-height #f])) (define: font-choice : (Instance Choice%) - (new choice% - [label (string-constant fonts)] - [parent info-bar] - [choices (get-face-list)] - [callback - (λ: ([x : Any] [y : Any]) - (let ([old (preferences:get 'drscheme:large-letters-font)]) - (preferences:set 'drscheme:large-letters-font - (cons (send font-choice get-string-selection) - (if old - (cdr old) - (send (get-default-font) get-point-size)))) - (update-txt (send text-field get-value))))])) + (let ([tmp-bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #f))]) + (new choice% + [label (string-constant fonts)] + [parent info-bar] + [choices (map (λ: ((x : String)) (format "~a~a" x (get-w-size tmp-bdc x))) + (get-face-list))] + [callback + (λ: ([x : Any] [y : Any]) + (let ([old (preferences:get 'drscheme:large-letters-font)] + [choice (send font-choice get-selection)]) + (when choice + (preferences:set 'drscheme:large-letters-font + (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)] diff --git a/collects/scribblings/drscheme/menus.scrbl b/collects/scribblings/drscheme/menus.scrbl index 31a8d70401..ba31862ff4 100644 --- a/collects/scribblings/drscheme/menus.scrbl +++ b/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 diff --git a/collects/typed/mred/mred.ss b/collects/typed/mred/mred.ss index c42b478fc2..053d102a12 100644 --- a/collects/typed/mred/mred.ss +++ b/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])