#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))))