119 lines
5.2 KiB
Racket
119 lines
5.2 KiB
Racket
(module fontdialog mzscheme
|
|
(require mzlib/class
|
|
mzlib/etc
|
|
mzlib/list
|
|
(prefix wx: "kernel.rkt")
|
|
"lock.rkt"
|
|
"wx.rkt"
|
|
"cycle.rkt"
|
|
"check.rkt"
|
|
"helper.rkt"
|
|
"gdi.rkt"
|
|
"editor.rkt"
|
|
"mrtop.rkt"
|
|
"mrcanvas.rkt"
|
|
"mrpopup.rkt"
|
|
"mrmenu.rkt"
|
|
"mritem.rkt"
|
|
"mrpanel.rkt"
|
|
"mrtextfield.rkt")
|
|
|
|
(provide get-font-from-user)
|
|
|
|
(define get-font-from-user
|
|
(case-lambda
|
|
[() (get-font-from-user #f #f #f null)]
|
|
[(message) (get-font-from-user message #f #f null)]
|
|
[(message parent) (get-font-from-user message parent #f null)]
|
|
[(message parent font) (get-font-from-user message parent font null)]
|
|
[(message parent font style)
|
|
(check-label-string/false 'get-font-from-user message)
|
|
(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)
|
|
(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 (wx:get-face-list) 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)]
|
|
[sip (make-object check-box% "Size in Pixels" p4 refresh-sample)]
|
|
[sym (make-object check-box% "Map as Symbol" 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\n(\u3bb (x) x)\n"
|
|
'(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
|
|
(if (send sym get-value)
|
|
'symbol
|
|
'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])
|
|
(send sip get-value)))))]
|
|
[bp (instantiate horizontal-pane% (f) [stretchable-height #f])]
|
|
[ms-button (if (eq? (wx:font-from-user-platform-mode) 'dialog)
|
|
(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))]
|
|
[ok+cancel (call-with-values
|
|
(lambda ()
|
|
(ok-cancel
|
|
(lambda () (make-object button% "OK" bp (done #t) '(border)))
|
|
(lambda () (make-object button% "Cancel" bp (done #f)))))
|
|
cons)]
|
|
[ok-button (car ok+cancel)]
|
|
[cancel-button (cdr ok+cancel)]
|
|
[reset-font
|
|
(lambda (font)
|
|
(let* ([facen (if font
|
|
(send font get-face)
|
|
(wx: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))
|
|
(send sip set-value (send font get-size-in-pixels)))
|
|
(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)))]))
|
|
|
|
(set-get-font-from-user! get-font-from-user))
|