..

original commit: 7d32fff4834107ff756e281296a24a88b8fb0d31

collects/framework/framework.ss

@@ -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%))
      ()

collects/framework/private/editor.ss

@@ -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)])
+      (let ([delta (make-object style-delta% 'change-normal)])
-          (send delta set-delta 'change-family 'modern)
+        (send delta set-delta 'change-family 'modern)
-          delta))
+        (let ([style (send standard-style-list find-named-style "Standard")])
-      (let ([style (send standard-style-list find-named-style "Standard")])
+          (if style
-        (if style
+              (send style set-delta delta)
-            (send style set-delta delta)
+              (send standard-style-list new-named-style "Standard"
-            (send standard-style-list new-named-style "Standard"
+                    (send standard-style-list find-or-create-style
-                  (send standard-style-list find-or-create-style
+                          (send standard-style-list find-named-style "Basic")
-                        (send standard-style-list find-named-style "Basic")
+                          delta)))))
-                        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<%>)

collects/framework/private/main.ss

@@ -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

collects/framework/private/sig.ss

@@ -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^)))