Index: /branches/ide-1.0/ccl/examples/cocoa-prefs.lisp
===================================================================
--- /branches/ide-1.0/ccl/examples/cocoa-prefs.lisp	(revision 6734)
+++ /branches/ide-1.0/ccl/examples/cocoa-prefs.lisp	(revision 6735)
@@ -27,7 +27,51 @@
   (:metaclass ns:+ns-object))
 
-(defclass lisp-preferences-window-controller (ns:ns-window-controller)
+(defclass font-name-transformer (ns:ns-value-transformer)
     ()
   (:metaclass ns:+ns-object))
+
+(objc:defmethod #/transformedNameClass ((self +font-name-transformer))
+  ns:ns-string)
+
+
+(objc:defmethod (#/allowsReverseTransformation :<BOOL>)
+    ((self +font-name-transformer))
+  nil)
+
+(objc:defmethod #/transformValue ((self font-name-transformer) value)
+  ;; Is there any better way of doing this that doesn't involve
+  ;; making a font ?
+  (#/displayName (make-instance ns:ns-font
+                                :with-name value
+                                :size (float 12.0 +cgfloat-zero+))))
+
+
+
+(defclass lisp-preferences-window-controller (ns:ns-window-controller)
+    ((selected-font-index :foreign-type :int))
+  (:metaclass ns:+ns-object))
+
+(objc:defmethod (#/fontPanelForDefaultFont: :void)
+    ((self lisp-preferences-window-controller) sender)
+  (with-slots (selected-font-index) self
+    (setq selected-font-index 1))
+  (#/orderFrontFontPanel: *NSApp* sender))
+
+
+(objc:defmethod (#/fontPanelForModelineFont: :void)
+    ((self lisp-preferences-window-controller) sender)
+  (with-slots (selected-font-index) self
+    (setq selected-font-index 2))
+  (#/orderFrontFontPanel: *NSApp* sender))
+
+(objc:defmethod (#/changeFont: :void) ((self lisp-preferences-window-controller) sender)
+  #+debug (#_NSLog #@"ChangeFont.")
+  (with-slots ((idx selected-font-index)) self
+    (when (> idx 0)
+      (let* ((f (#/convertFont: sender (default-font))))
+        (when (is-fixed-pitch-font f)
+          (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
+            (#/setValue:forKey: values (#/fontName f) (if (eql 1 idx) #@"defaultFontName" #@"modelineFontName:"))
+            (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) (if (eql 1 idx) #@"defaultFontSize" #@"modelineFontSize"))))))))
 
 
@@ -58,5 +102,11 @@
         (t
          (update-cocoa-defaults)
-         (let* ((sdc (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))
+         (#/setValueTransformer:forName:
+          ns:ns-value-transformer
+          (make-instance 'font-name-transformer)
+          #@"FontNameTransformer")
+         (let* ((sdc (make-instance ns:ns-user-defaults-controller
+                                    :with-defaults +null-ptr+
+                                    :initial-values (cocoa-defaults-initial-values))))
            (#/setAppliesImmediately: sdc nil)
            (let* ((controller (make-instance lisp-preferences-window-controller
@@ -64,5 +114,5 @@
                   (window (#/window controller)))
              (unless (%null-ptr-p window)
-               (#/setFloatingPanel: window nil)
+               (#/setFloatingPanel: window t)
                (dolist (d (cocoa-defaults))
                  (let* ((key (objc-constant-string-nsstringptr (cocoa-default-string d))))
@@ -85,4 +135,10 @@
     (#/sharedPanel class)))
 
+
+(objc:defmethod (#/makeKeyAndOrderFront: :void)
+    ((self lisp-preferences-panel) sender)
+  (#/setShowsAlpha: (#/sharedColorPanel ns:ns-color-panel) t)
+  (call-next-method sender))
+
 (objc:defmethod (#/show :void) ((self lisp-preferences-panel))
   (#/makeKeyAndOrderFront: self +null-ptr+))