.
original commit: 65ca42ace367a2704f0ddd35af21b908d41db0f8
This commit is contained in:
Matthew Flatt
parent
c7499274c5
commit
24fccbc8d7
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user