From 88f4ddabcc1316dbc57ae6eaf925bfe2c01d3991 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 17 Jun 2012 03:33:43 -0500 Subject: [PATCH] Rackety --- collects/drracket/private/font.rkt | 425 ++++++++++++++--------------- 1 file changed, 209 insertions(+), 216 deletions(-) diff --git a/collects/drracket/private/font.rkt b/collects/drracket/private/font.rkt index 43e210eae4..0fa51f581a 100644 --- a/collects/drracket/private/font.rkt +++ b/collects/drracket/private/font.rkt @@ -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))))