Changeset 6726
- Timestamp:
- Jun 14, 2007, 12:38:03 AM (17 years ago)
- File:
-
- 1 edited
-
branches/ide-1.0/ccl/examples/cocoa-prefs.lisp (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
branches/ide-1.0/ccl/examples/cocoa-prefs.lisp
r6588 r6726 21 21 22 22 23 (defloadvar *lisp-preferences-panel* nil) 23 24 24 (defclass prefs-view (ns:ns-view) 25 ((form :foreign-type :id :accessor prefs-view-form) 26 (nvalues :foreign-type :int :accessor prefs-view-nvalues) 27 (nchanges :foreign-type :int :accessor prefs-view-nchanges) 28 (revert-button :foreign-type :id :accessor prefs-view-revert-button) 29 (commit-button :foreign-type :id :accessor prefs-view-commit-button) 30 (scroll-view :foreign-type :id :reader prefs-view-scroll-view) 31 (domain :foreign-type :id 32 :accessor prefs-view-domain) 33 (defaults-vector :initform nil :accessor prefs-view-defaults-vector)) 25 (defclass lisp-preferences-panel (ns:ns-panel) 26 () 27 (:metaclass ns:+ns-object)) 28 29 (defclass lisp-preferences-window-controller (ns:ns-window-controller) 30 () 34 31 (:metaclass ns:+ns-object)) 35 32 36 33 37 (defmethod set-prefs-cell-from-default ((self prefs-view) cell default form val index) 38 (let* ((doc (cocoa-default-doc default)) 39 (type (cocoa-default-type default))) 40 (#/setTag: cell index) 41 (#/setStringValue: cell val) 42 (when doc 43 (#/setToolTip:forCell: form (%make-nsstring doc) cell)) 44 (case type 45 (:int 46 (#/setEntryType: cell #$NSIntType) 47 '(#/setAlignment: cell #$NSRightTextAlignment)) 48 (:float 49 (#/setEntryType: cell #$NSFloatType) 50 '(#/setAlignment: cell #$NSRightTextAlignment)) 51 (t 52 (#/setScrollable: cell t))) 53 (#/setAction: cell (@selector #/notePrefsChange:)) 54 (#/setTarget: cell self))) 34 (objc:defmethod (#/changeColor: :void) ((self lisp-preferences-panel) 35 sender) 36 (declare (ignore sender))) 55 37 56 (defmethod create-prefs-view-form ((self prefs-view))57 (let* ((scrollview (prefs-view-scroll-view self))58 (contentsize (#/contentSize scrollview)))59 (ns:with-ns-rect (form-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))60 (ns:with-ns-size (intercell-spacing-size 1 4)61 (ns:with-ns-size (cell-size 500 22)62 (let* ((form (make-instance 'ns:ns-form :with-frame form-frame)))63 (#/setScrollable: form t)64 (#/setIntercellSpacing: form intercell-spacing-size)65 (#/setCellSize: form cell-size)66 (setf (prefs-view-form self) form)67 (#/setDocumentView: scrollview form)68 form))))))69 38 70 (defmethod init-prefs-form-from-defaults ((self prefs-view)) 71 (let* ((defaults (setf (prefs-view-defaults-vector self) 72 (apply #'vector (reverse (cocoa-defaults))))) 73 (form (create-prefs-view-form self)) 74 (domain (setf (prefs-view-domain self) (#/standardUserDefaults ns:ns-user-defaults))) 75 (n (length defaults))) 76 (setf (prefs-view-nvalues self) n) 77 (dotimes (i n) 78 (let* ((d (svref defaults i)) 79 (key (objc-constant-string-nsstringptr (cocoa-default-string d))) 80 (val (#/objectForKey: domain key))) 81 (when (%null-ptr-p val) 82 (#/setObject:forKey: 83 domain (setq val (%make-nsstring (format nil "~a" (cocoa-default-value d)))) key)) 84 (set-prefs-cell-from-default self 85 (#/addEntry: form key) 86 d 87 form 88 val 89 i))) 90 (setf (prefs-view-nchanges self) 0) 91 (#/setEnabled: (prefs-view-revert-button self) nil) 92 (#/setEnabled: (prefs-view-commit-button self) nil) 93 (#/sizeToCells form))) 39 (objc:defmethod (#/observeValueForKeyPath:ofObject:change:context: :void) 40 ((self lisp-preferences-panel) 41 path 42 object 43 change 44 (key (:* :void))) 45 (declare (ignorable path object change key)) 46 (#_NSLog #@"key = %@, path = %@, change = %@" :id key :id path :id change) 47 (let* ((default (find key (cocoa-defaults) 48 :key (lambda (d) 49 (objc-constant-string-nsstringptr (cocoa-default-string d))) 50 :test #'#/isEqualToString:))) 51 (when default 52 (let* ((newval (#/valueForKey: (#/values object) key))) 53 (unless (%null-ptr-p newval) 54 (update-cocoa-default default newval)))))) 94 55 95 (objc:defmethod (#/notePrefsChange: :void) ((self prefs-view) form) 96 (let* ((cell (#/cellAtIndex: form (#/indexOfSelectedItem form))) 97 (n (prefs-view-nvalues self)) 98 (form (prefs-view-form self)) 99 (current (#/tag cell)) 100 (d (svref (prefs-view-defaults-vector self) current)) 101 (next (mod (1+ current) n)) 102 (value (#/stringValue cell))) 103 (unless (#/isEqualTo: value 104 (#/objectForKey: (prefs-view-domain self) 105 (objc-constant-string-nsstringptr (cocoa-default-string d)))) 106 ;; If there's a constraint, sanity-check the value. 107 (when (zerop (prefs-view-nchanges self)) 108 (#/setEnabled: (prefs-view-commit-button self) t) 109 (#/setEnabled: (prefs-view-revert-button self) t)) 110 (incf (prefs-view-nchanges self))) 111 (#/selectCell: form (#/cellAtIndex: form next)))) 56 (objc:defmethod #/sharedPanel ((self +lisp-preferences-panel)) 57 (cond (*lisp-preferences-panel*) 58 (t 59 (update-cocoa-defaults) 60 (let* ((sdc (#/sharedUserDefaultsController ns:ns-user-defaults-controller))) 61 (#/setAppliesImmediately: sdc nil) 62 (let* ((controller (make-instance lisp-preferences-window-controller 63 :with-window-nib-name #@"preferences")) 64 (window (#/window controller))) 65 (unless (%null-ptr-p window) 66 (#/setFloatingPanel: window nil) 67 (dolist (d (cocoa-defaults)) 68 (let* ((key (objc-constant-string-nsstringptr (cocoa-default-string d)))) 69 (#/addObserver:forKeyPath:options:context: 70 sdc 71 window 72 (#/stringWithFormat: ns:ns-string #@"values.%@" key) 73 0 74 key))) 75 (setq *lisp-preferences-panel* window))))))) 112 76 113 (objc:defmethod (#/commitPrefs: :void) ((self prefs-view) sender)114 (declare (ignore sender))115 (let* ((form (prefs-view-form self))116 (domain (prefs-view-domain self)))117 (dotimes (i (prefs-view-nvalues self))118 (let* ((cell (#/cellAtIndex: form i))119 (key (#/title cell))120 (val (#/stringValue cell)))121 (#/setObject:forKey: domain val key)))122 (#/synchronize domain)123 (setf (prefs-view-nchanges self) 0)124 (#/setEnabled: (prefs-view-revert-button self) nil)125 (#/setEnabled: (prefs-view-commit-button self) nil)126 (update-cocoa-defaults-vector domain (prefs-view-defaults-vector self))))127 77 128 (objc:defmethod (#/revertPrefs: :void) ((self prefs-view) sender) 129 (declare (ignore sender)) 130 (let* ((form (prefs-view-form self)) 131 (domain (prefs-view-domain self))) 132 (dotimes (i (prefs-view-nvalues self)) 133 (let* ((cell (#/cellAtIndex: form i)) 134 (key (#/title cell))) 135 (#/setStringValue: cell (#/objectForKey: domain key)))) 136 (setf (prefs-view-nchanges self) 0) 137 (#/setEnabled: (prefs-view-revert-button self) nil) 138 (#/setEnabled: (prefs-view-commit-button self) nil))) 78 79 139 80 140 81 141 (objc:defmethod #/initWithFrame: ((self prefs-view) (frame :<NSR>ect)) 142 (call-next-method frame) 143 (ns:with-ns-rect (scroll-frame 20 40 (- (ns:ns-rect-width frame) 40) (- (ns:ns-rect-height frame) 60)) 144 (let* ((scrollview (make-instance 'ns:ns-scroll-view 145 :with-frame scroll-frame)) 146 (scroll-content (#/contentView scrollview))) 147 (#/setBorderType: scrollview #$NSBezelBorder) 148 (#/setHasVerticalScroller: scrollview t) 149 (#/setHasHorizontalScroller: scrollview t) 150 (#/setRulersVisible: scrollview nil) 151 (#/setAutoresizingMask: scrollview (logior 152 #$NSViewWidthSizable 153 #$NSViewHeightSizable)) 154 (#/setAutoresizesSubviews: scroll-content t) 155 (setf (slot-value self 'scroll-view) scrollview) 156 (ns:with-ns-rect (revert-frame 20 10 80 20) 157 (ns:with-ns-rect (commit-frame (- (+ (ns:ns-rect-x frame) 158 (ns:ns-rect-width frame)) 159 (+ 80.0f0 20.0f0)) 160 10 80 20) 161 (let* ((commit-button (make-instance 162 'ns:ns-button 163 :with-frame commit-frame)) 164 (revert-button (make-instance 165 'ns:ns-button 166 :with-frame revert-frame))) 167 (#/setTitle: commit-button #@"Commit") 168 (#/setTitle: revert-button #@"Revert") 169 (#/setEnabled: commit-button nil) 170 (#/setEnabled: revert-button nil) 171 (#/setAction: commit-button (@selector "commitPrefs:")) 172 (#/setTarget: commit-button self) 173 (#/setAction: revert-button (@selector "revertPrefs:")) 174 (#/setTarget: revert-button self) 175 (#/setAutoresizingMask: commit-button #$NSViewMinXMargin) 176 (#/setAutoresizingMask: revert-button #$NSViewMaxXMargin) 177 (#/setBezelStyle: revert-button #$NSRoundedBezelStyle) 178 (#/setBezelStyle: commit-button #$NSRoundedBezelStyle) 179 (setf (prefs-view-revert-button self) revert-button 180 (prefs-view-commit-button self) commit-button) 181 (#/addSubview: self revert-button) 182 (#/addSubview: self commit-button) 183 (#/addSubview: self scrollview) 184 self)))))) 185 186 (defloadvar *preferences-panel* nil) 187 188 (defclass preferences-panel (ns:ns-panel) 189 ((prefs-view :foreign-type :id :accessor preferences-panel-prefs-view)) 190 (:metaclass ns:+ns-object)) 191 192 (objc:defmethod #/sharedPanel ((self +preferences-panel)) 193 (cond (*preferences-panel*) 194 (t 195 (let* ((panel (new-cocoa-window :class self 196 :title "Preferences" 197 :activate nil)) 198 (view (#/contentView panel)) 199 (bounds (#/bounds view)) 200 (v (make-instance 'prefs-view :with-frame bounds))) 201 (#/setContentView: panel v) 202 (#/setNeedsDisplay: v t) 203 (setf (slot-value panel 'prefs-view) v) 204 (setq *preferences-panel* panel))))) 205 206 (objc:defmethod #/init ((self preferences-panel)) 82 (objc:defmethod #/init ((self lisp-preferences-panel)) 207 83 (let* ((class (class-of self))) 208 84 (#/dealloc self) 209 85 (#/sharedPanel class))) 210 86 211 (objc:defmethod (#/show :void) ((self preferences-panel)) 212 (init-prefs-form-from-defaults (preferences-panel-prefs-view self)) 87 (objc:defmethod (#/show :void) ((self lisp-preferences-panel)) 213 88 (#/makeKeyAndOrderFront: self +null-ptr+)) 214 89 90 91
Note:
See TracChangeset
for help on using the changeset viewer.
