suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

..

Browse Source 
original commit: 7d32fff4834107ff756e281296a24a88b8fb0d31
This commit is contained in:
Robby Findler 2003-06-19 22:51:07 +00:00
parent 4d0c3c94af
commit b2bd5ad8ae
4 changed files with 120 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/framework/framework.ss
View File

@ -1293,6 +1293,27 @@
()
"Returns a keymap with binding suitable for Scheme.")
(editor:set-standard-style-list-pref-callbacks
(-> any)
()
"Installs the font preference callbacks that"
"update the style list returned by"
"@flink editor:get-standard-style-list"
"based on the font preference symbols.")
(editor:get-fixed-faces
(-> (listof string?))
()
"Returns a list of the fixed width fonts available on this system,"
"except on unix, where it returns a list of all of the fonts."
""
"It finds the fixed width fonts by making a dummy canvas object,"
"and computes the width of both `i' and `w'. If they are the same,"
"the font is fixed width and if not, the font is not fixed width."
""
"This is very expensive under X Windows, which is why the function"
"just returns all fonts.")
(editor:get-standard-style-list
(-> (is-a?/c style-list%))
()

84
collects/framework/private/editor.ss
View File

@ -311,19 +311,42 @@
(super-instantiate ())))
(define standard-style-list (make-object style-list%))
(define standard-style-list (new style-list%))
(define (get-standard-style-list) standard-style-list)
(define delta
(let ([delta (make-object style-delta% 'change-normal)])
(send delta set-delta 'change-family 'modern)
delta))
(let ([style (send standard-style-list find-named-style "Standard")])
(if style
(send style set-delta delta)
(send standard-style-list new-named-style "Standard"
(send standard-style-list find-or-create-style
(send standard-style-list find-named-style "Basic")
delta))))
(let ([delta (make-object style-delta% 'change-normal)])
(send delta set-delta 'change-family 'modern)
(let ([style (send standard-style-list find-named-style "Standard")])
(if style
(send style set-delta delta)
(send standard-style-list new-named-style "Standard"
(send standard-style-list find-or-create-style
(send standard-style-list find-named-style "Basic")
delta)))))
(define (set-font-size size)
(update-standard-style
(lambda (scheme-delta)
(send scheme-delta set-size-mult 0)
(send scheme-delta set-size-add size))))
(define (set-font-name name)
(update-standard-style
(lambda (scheme-delta)
(send scheme-delta set-delta-face name)
(send scheme-delta set-family 'modern))))
(define (set-font-smoothing sym)
(update-standard-style
(lambda (scheme-delta)
(send scheme-delta set-smoothing-on sym))))
(define (update-standard-style cng-delta)
(let* ([scheme-standard (send standard-style-list find-named-style "Standard")]
[scheme-delta (make-object style-delta%)])
(send scheme-standard get-delta scheme-delta)
(cng-delta scheme-delta)
(send scheme-standard set-delta scheme-delta)))
(define standard-style-list<%>
(interface (editor<%>)
@ -336,6 +359,43 @@
(set-style-list standard-style-list)
(set-load-overwrites-styles #f)))
(define (set-standard-style-list-pref-callbacks)
(set-font-size (preferences:get 'framework:standard-style-list:font-size))
(set-font-name (preferences:get 'framework:standard-style-list:font-name))
(set-font-smoothing (preferences:get 'framework:standard-style-list:font-smoothing))
(preferences:add-callback 'framework:standard-style-list:font-size (lambda (p v) (set-font-size v)))
(preferences:add-callback 'framework:standard-style-list:font-name (lambda (p v) (set-font-name v)))
(preferences:add-callback 'framework:standard-style-list:font-smoothing (lambda (p v) (set-font-smoothing v)))
(unless (member (preferences:get 'framework:standard-style-list:font-name) (get-fixed-faces))
(preferences:set 'framework:standard-style-list:font-name (get-family-builtin-face 'modern))))
(define get-fixed-faces
(cond
[(eq? (system-type) 'unix)
(lambda () (get-face-list))]
[else
(let ([compute-ans
(lambda ()
(let* ([canvas (make-object canvas% (make-object frame% "bogus"))]
[dc (send canvas get-dc)])
(let loop ([faces (get-face-list)])
(cond
[(null? faces) null]
[else (let* ([face (car faces)]
[font (make-object font% 12 face 'default 'normal 'normal #f)])
(let*-values ([(wi _1 _2 _3) (send dc get-text-extent "i" font)]
[(ww _1 _2 _3) (send dc get-text-extent "w" font)])
(if (and (= ww wi)
(not (zero? ww)))
(cons face (loop (cdr faces)))
(loop (cdr faces)))))]))))]
[ans #f])
(lambda ()
(unless ans
(set! ans (compute-ans)))
ans))]))
(define -keymap<%> (interface (basic<%>) get-keymaps))
(define keymap-mixin
(mixin (basic<%>) (-keymap<%>)

25
collects/framework/private/main.ss
View File

@ -15,10 +15,33 @@
[preferences : framework:preferences^]
[exit : framework:exit^]
[group : framework:group^]
[handler : framework:handler^])
[handler : framework:handler^]
[editor : framework:editor^])
(application-preferences-handler (lambda () (preferences:show-dialog)))
(preferences:set-default 'framework:standard-style-list:font-name
(get-family-builtin-face 'modern)
string?)
(preferences:set-default
'framework:standard-style-list:font-size
(let* ([txt (make-object text%)]
[stl (send txt get-style-list)]
[bcs (send stl basic-style)])
(send bcs get-size))
(lambda (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
(preferences:set-default
'framework:standard-style-list:font-smoothing
(case (system-type)
[(macosx) 'partly-smoothed]
[else 'unsmoothed])
(lambda (x)
(memq x '(unsmoothed partly-smoothed smoothed))))
(editor:set-standard-style-list-pref-callbacks)
(preferences:set-default 'framework:paren-match-color
(let ([gray-level
;; old gray-level 192

4
collects/framework/private/sig.ss
View File

@ -262,7 +262,9 @@
file-mixin
backup-autosave-mixin))
(define-signature framework:editor-fun^
(get-standard-style-list))
(get-standard-style-list
set-standard-style-list-pref-callbacks
get-fixed-faces))
(define-signature framework:editor^
((open framework:editor-class^)
(open framework:editor-fun^)))