Changeset 642

Timestamp:

Mar 8, 2004, 5:56:23 AM (21 years ago)

Author:

Gary Byers

Message:

Factor in window creation.

File:

• trunk/ccl/examples/cocoa-window.lisp (modified) (1 diff)

trunk/ccl/examples/cocoa-window.lisp

@@ -355 +355 @@
     dict))
 
+
+(defun get-cocoa-window-flag (w flagname)
+  (case flagname
+    (:accepts-mouse-moved-events
+     (send w 'accepts-mouse-moved-events))
+    (:cursor-rects-enabled
+     (send w 'are-cursor-rects-enabled))
+    (:auto-display
+     (send w 'is-autodisplay))))
+
+
+
+(defun (setf get-cocoa-window-flag) (value w flagname)
+  (case flagname
+    (:accepts-mouse-moved-events
+     (send w :set-accepts-mouse-moved-events value))
+    (:auto-display
+     (send w :set-autodisplay value))))
+
+
+
+(defun activate-window (w)
+  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
+  (send w :make-key-and-order-front nil))
+
+(defun new-cocoa-window (&key
+                         (class (find-class 'ns:ns-window))
+                         (title nil)
+                         (x 200.0)
+                         (y 200.0)
+                         (height 200.0)
+                         (width 500.0)
+                         (closable t)
+                         (iconifyable t)
+                         (metal t)
+                         (expandable t)
+                         (backing :buffered)
+                         (defer nil)
+                         (accepts-mouse-moved-events nil)
+                         (auto-display t)
+                         (activate t))
+  (rlet ((frame :<NSR>ect :origin.x (float x) :origin.y (float y) :size.width (float width) :size.height (float height)))
+    (let* ((stylemask
+            (logior #$NSTitledWindowMask
+                    (if closable #$NSClosableWindowMask 0)
+                    (if iconifyable #$NSMiniaturizableWindowMask 0)
+                    (if expandable #$NSResizableWindowMask 0)
+                    (if metal #$NSTexturedBackgroundWindowMask 0)))
+           (backing-type
+            (ecase backing
+              ((t :retained) #$NSBackingStoreRetained)
+              ((nil :nonretained) #$NSBackingStoreNonretained)
+              (:buffered #$NSBackingStoreBuffered)))
+           (w (make-instance
+               class
+               :with-content-rect frame
+               :style-mask stylemask
+               :backing backing-type
+               :defer defer)))
+      (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
+            accepts-mouse-moved-events
+            (get-cocoa-window-flag w :auto-display)
+            auto-display)
+      (when activate (activate-window w))
+      (when title (send w :set-title (%make-nsstring title)))
+      w)))