212 lines
8.9 KiB
Racket
212 lines
8.9 KiB
Racket
#lang racket/base
|
|
(require racket/unit
|
|
racket/class
|
|
racket/gui/base
|
|
"drsig.rkt"
|
|
framework
|
|
string-constants)
|
|
|
|
(define sc-smoothing-label (string-constant font-smoothing-label))
|
|
(define sc-smoothing-none (string-constant font-smoothing-none))
|
|
(define sc-smoothing-some (string-constant font-smoothing-some))
|
|
(define sc-smoothing-all (string-constant font-smoothing-all))
|
|
(define sc-smoothing-default (string-constant font-smoothing-default))
|
|
|
|
(provide font@)
|
|
|
|
(define-unit font@
|
|
(import [prefix drracket:language-configuration: drracket:language-configuration/internal^])
|
|
(export drracket:font^)
|
|
|
|
(define (setup-preferences)
|
|
(preferences:add-panel
|
|
(list (string-constant font-prefs-panel-title))
|
|
(λ (panel)
|
|
(define main (make-object vertical-panel% panel))
|
|
(define min-size 1)
|
|
(define max-size 72)
|
|
(define options-panel (make-object horizontal-panel% main))
|
|
(define size-panel (new group-box-panel%
|
|
(parent options-panel)
|
|
(label (string-constant font-size))))
|
|
(define (adjust-font-size f)
|
|
(preferences:set
|
|
'framework:standard-style-list:font-size
|
|
(f (preferences:get
|
|
'framework:standard-style-list:font-size))))
|
|
(define size-slider
|
|
(new slider%
|
|
(label #f)
|
|
(min-value min-size)
|
|
(max-value max-size)
|
|
(parent size-panel)
|
|
(callback
|
|
(λ (size evt)
|
|
(adjust-font-size
|
|
(λ (old-size)
|
|
(send size get-value)))))
|
|
(init-value
|
|
(preferences:get 'framework:standard-style-list:font-size))))
|
|
(define size-hp (new horizontal-pane% (parent size-panel)))
|
|
(define (mk-size-button label chng)
|
|
(new button%
|
|
(parent size-hp)
|
|
(stretchable-width #t)
|
|
(callback
|
|
(λ (x y)
|
|
(adjust-font-size
|
|
(λ (old-size)
|
|
(min max-size (max min-size (chng old-size)))))))
|
|
(label label)))
|
|
(define size-sub1 (mk-size-button "-1" sub1))
|
|
(define size-add1 (mk-size-button "+1" add1))
|
|
|
|
(define mono-list 'mono-list-not-yet-computed)
|
|
(define choice-panel
|
|
(new (class vertical-panel%
|
|
(define/private (force-cache receiver)
|
|
(when (eq? receiver font-name-control)
|
|
(when (symbol? mono-list)
|
|
(begin-busy-cursor)
|
|
(set! mono-list (sort (get-face-list 'mono) string-ci<=?))
|
|
(send font-name-control clear)
|
|
(for-each
|
|
(λ (x) (send font-name-control append x))
|
|
(append mono-list (list (string-constant other...))))
|
|
(define pref (preferences:get 'framework:standard-style-list:font-name))
|
|
(cond
|
|
[(member pref mono-list)
|
|
(send font-name-control set-string-selection pref)]
|
|
[else
|
|
(send font-name-control set-selection (length mono-list))])
|
|
(end-busy-cursor))))
|
|
(define/override (on-subwindow-event receiver evt)
|
|
(unless (or (send evt moving?)
|
|
(send evt entering?)
|
|
(send evt leaving?))
|
|
(force-cache receiver))
|
|
(super on-subwindow-event receiver evt))
|
|
(define/override (on-subwindow-char receiver evt)
|
|
(force-cache receiver)
|
|
(super on-subwindow-char receiver evt))
|
|
(super-new [parent options-panel]))))
|
|
(define font-name-control
|
|
(new choice%
|
|
[label (string-constant font-name)]
|
|
[choices (list (preferences:get 'framework:standard-style-list:font-name))]
|
|
[parent choice-panel]
|
|
[stretchable-width #t]
|
|
[callback
|
|
(λ (font-name evt)
|
|
(define selection (send font-name get-selection))
|
|
(cond
|
|
[(< selection (length mono-list))
|
|
(preferences:set
|
|
'framework:standard-style-list:font-name
|
|
(list-ref mono-list selection))]
|
|
[else
|
|
(define all-faces (get-face-list))
|
|
(define init (preferences:get 'framework:standard-style-list:font-name))
|
|
(define init-choices
|
|
(let loop ([faces all-faces]
|
|
[num 0])
|
|
(cond
|
|
[(null? faces) null]
|
|
[else
|
|
(define face (car faces))
|
|
(if (equal? init face)
|
|
(list num)
|
|
(loop (cdr faces) (+ num 1)))])))
|
|
(define choice
|
|
(get-choices-from-user
|
|
(string-constant select-font-name)
|
|
(string-constant select-font-name)
|
|
all-faces
|
|
#f
|
|
init-choices))
|
|
(when choice
|
|
(preferences:set
|
|
'framework:standard-style-list:font-name
|
|
(list-ref all-faces (car choice))))]))]))
|
|
(define (set-choice-selection font-name)
|
|
(cond
|
|
[(send font-name-control find-string font-name)
|
|
(send font-name-control set-string-selection font-name)]
|
|
[else
|
|
(send font-name-control set-selection (- (send font-name-control get-number) 1))]))
|
|
(preferences:add-callback
|
|
'framework:standard-style-list:font-name
|
|
(λ (p v)
|
|
(set-choice-selection v)))
|
|
(set-choice-selection (preferences:get 'framework:standard-style-list:font-name))
|
|
(define smoothing-contol
|
|
(new choice%
|
|
(label sc-smoothing-label)
|
|
(choices (list sc-smoothing-none
|
|
sc-smoothing-some
|
|
sc-smoothing-all
|
|
sc-smoothing-default))
|
|
(parent choice-panel)
|
|
(stretchable-width #t)
|
|
(selection (case (preferences:get 'framework:standard-style-list:smoothing)
|
|
[(unsmoothed) 0]
|
|
[(partly-smoothed) 1]
|
|
[(smoothed) 2]
|
|
[(default) 3]))
|
|
(callback (λ (x y)
|
|
(preferences:set
|
|
'framework:standard-style-list:smoothing
|
|
(case (send x get-selection)
|
|
[(0) 'unsmoothed]
|
|
[(1) 'partly-smoothed]
|
|
[(2) 'smoothed]
|
|
[(3) 'default]))))))
|
|
|
|
(define text (new (text:foreground-color-mixin
|
|
(editor:standard-style-list-mixin
|
|
text:line-spacing%))))
|
|
(define ex-panel (new horizontal-panel% [parent main]))
|
|
(define msg (new message%
|
|
[label (string-constant example-text)]
|
|
[parent ex-panel]))
|
|
(define canvas (make-object canvas:color% main text))
|
|
(define (update-text setting)
|
|
(send text begin-edit-sequence)
|
|
(send text lock #f)
|
|
(send text erase)
|
|
(send text insert
|
|
(format
|
|
";; howmany : list-of-numbers -> number~
|
|
\n;; to determine how many numbers are in `a-lon'~
|
|
\n(define (howmany a-lon)~
|
|
\n (cond~
|
|
\n [(empty? a-lon) 0]~
|
|
\n [else (+ 1 (howmany (rest a-lon)))]))~
|
|
\n~
|
|
\n;; examples as tests~
|
|
\n(howmany empty)~
|
|
\n\"should be\"~
|
|
\n0~
|
|
\n~
|
|
\n(howmany (cons 1 (cons 2 (cons 3 empty))))~
|
|
\n\"should be\"~
|
|
\n3"))
|
|
(send text set-position 0 0)
|
|
(send text lock #t)
|
|
(send text end-edit-sequence))
|
|
(preferences:add-callback
|
|
'framework:standard-style-list:font-size
|
|
(λ (p v) (send size-slider set-value v)))
|
|
(preferences:add-callback
|
|
drracket:language-configuration:settings-preferences-symbol
|
|
(λ (p v)
|
|
(update-text v)))
|
|
(update-text (preferences:get drracket:language-configuration:settings-preferences-symbol))
|
|
(send ex-panel set-alignment 'left 'center)
|
|
(send ex-panel stretchable-height #f)
|
|
(send canvas allow-tab-exit #t)
|
|
(send options-panel stretchable-height #f)
|
|
(send options-panel set-alignment 'center 'top)
|
|
(send text lock #t)
|
|
main))))
|