[cells-cvs] CVS Celtk

[fgoenninger]

Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv31920

Modified Files:
	composites.lisp 
Log Message:
Added:
 + Methods iconify and deiconify for class window
 + new class FULL-SCREEN-NO-DECO-WINDOW as a convenience function
   for creating a window with no decorations that occupies the
   whole screen
 + New functions screen-width and screen-height
 
Changed:
 + now the symbols application, iconify, deiconify,
   full-screen-no-deco-window, screen-width, screen-height are
   exported from the Celtk package.

--- /project/cells/cvsroot/Celtk/composites.lisp	2006/09/29 09:15:24	1.17
+++ /project/cells/cvsroot/Celtk/composites.lisp	2006/09/29 16:08:31	1.18
@@ -18,6 +18,19 @@
 
 (in-package :Celtk)
 
+(eval-now!
+  (export '(title$ active .time decoration)))
+
+(export! application
+         keyboard-modifiers
+	 iconify
+	 deiconify
+	 full-screen-no-deco-window
+	 screen-width
+	 screen-height)
+
+;;; --- decoration -------------------------------------------
+
 (defmd decoration-mixin ()
   (decoration (c-in :normal)))
 
@@ -70,9 +83,6 @@
 (defmodel composite-widget (widget)
   ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil)))
 
-(eval-now!
-  (export '(title$ active .time decoration)))
-
 (defvar *app*)
 
 (defmodel application (family)
@@ -87,8 +97,6 @@
 (defun app-idle (self)
   (setf (^app-time) (get-internal-real-time)))
 
-(export! keyboard-modifiers)
-
 (defmd window (composite-widget decoration-mixin)
   (title$ (c? (string-capitalize (class-name (class-of self)))))
   (dictionary (make-hash-table :test 'equalp))
@@ -105,6 +113,26 @@
   on-key-down
   on-key-up)
 
+(defun screen-width ()
+  (let ((*tkw* *tkw*))
+    (tk-format-now "winfo screenwidth .")))
+
+(defun screen-height ()
+  (let ((*tkw* *tkw*))
+    (tk-format-now "winfo screenheight .")))
+
+(defmodel full-screen-no-deco-window (window)
+  ())
+
+(defmethod initialize-instance :before ((self full-screen-no-deco-window)
+					&key &allow-other-keys)
+  (tk-format '(:pre-make-tk self)
+	     "wm geometry . [winfo screenwidth .]x[winfo screenheight .]+0+0")
+  (tk-format '(:pre-make-tk self) "update idletasks")
+  #-macosx (tk-format '(:pre-make-tk self) "wm attributes . -topmost yes")
+  (tk-format '(:pre-make-tk self) "wm overrideredirect . yes")
+  )
+
 (defmethod do-on-key-down :before (self &rest args &aux (keysym (car args)))
   (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw))
   (bwhen (mod (keysym-to-modifier keysym))
@@ -188,3 +216,14 @@
 (defmethod path ((self window)) ".")
 (defmethod parent-path ((self window)) "")
 
+(defmethod iconify ((self window))
+  (%%do-decoration self :normal)
+  (tk-format `(:fini) "wm iconify ~a" (^path)))
+
+(defmethod deiconify ((self window))
+  (%%do-decoration self (decoration self))
+  (tk-format `(:fini) "wm deiconify ~a" (^path)))
+
+
+
+