Rackety
This commit is contained in:
Robby Findler
parent
4d5bc17f85
commit
88f4ddabcc
|
|
@ -1,218 +1,211 @@
|
|||
#lang racket/base
|
||||
(require racket/unit
|
||||
racket/class
|
||||
racket/gui/base
|
||||
"drsig.rkt"
|
||||
framework
|
||||
string-constants)
|
||||
(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 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)
|
||||
#;(string-constant drscheme)) ;; thre is no help desk font configuration anymore ...
|
||||
(λ (panel)
|
||||
(letrec ([main (make-object vertical-panel% panel)]
|
||||
[min-size 1]
|
||||
[max-size 72]
|
||||
[options-panel (make-object horizontal-panel% main)]
|
||||
[size-panel (new group-box-panel%
|
||||
(parent options-panel)
|
||||
(label (string-constant font-size)))]
|
||||
[adjust-font-size
|
||||
(λ (f)
|
||||
(preferences:set
|
||||
'framework:standard-style-list:font-size
|
||||
(f (preferences:get
|
||||
'framework:standard-style-list:font-size))))]
|
||||
[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)))]
|
||||
[size-hp (new horizontal-pane% (parent size-panel))]
|
||||
[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)))]
|
||||
[size-sub1 (mk-size-button "-1" sub1)]
|
||||
[size-add1 (mk-size-button "+1" add1)]
|
||||
|
||||
[mono-list 'mono-list-not-yet-computed]
|
||||
[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...))))
|
||||
(let ([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])))]
|
||||
[font-name-control
|
||||
(let* ([choice
|
||||
(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)
|
||||
(let ([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
|
||||
(let* ([all-faces (get-face-list)]
|
||||
[init-choices
|
||||
(let ([init (preferences:get 'framework:standard-style-list:font-name)])
|
||||
(let loop ([faces all-faces]
|
||||
[num 0])
|
||||
(cond
|
||||
[(null? faces) null]
|
||||
[else
|
||||
(let ([face (car faces)])
|
||||
(if (equal? init face)
|
||||
(list num)
|
||||
(loop (cdr faces)
|
||||
(+ num 1))))])))]
|
||||
[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)))))])))))]
|
||||
[font-name (preferences:get 'framework:standard-style-list:font-name)]
|
||||
[set-choice-selection
|
||||
(λ (font-name)
|
||||
(cond
|
||||
[(send choice find-string font-name)
|
||||
(send choice set-string-selection font-name)]
|
||||
[else
|
||||
(send choice set-selection (- (send choice get-number) 1))]))])
|
||||
|
||||
(preferences:add-callback
|
||||
'framework:standard-style-list:font-name
|
||||
(λ (p v)
|
||||
(set-choice-selection v)))
|
||||
(set-choice-selection font-name)
|
||||
choice)]
|
||||
[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])))))]
|
||||
|
||||
[text (make-object (text:foreground-color-mixin
|
||||
(editor:standard-style-list-mixin
|
||||
text:line-spacing%)))]
|
||||
[ex-panel (make-object horizontal-panel% main)]
|
||||
[msg (make-object message% (string-constant example-text) ex-panel)]
|
||||
[canvas (make-object canvas:color% main text)]
|
||||
[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)))))
|
||||
(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))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user