[clfswm-cvs] r252 - in clfswm: . src

[Philippe Brochard]

Author: pbrochard
Date: Mon Aug 17 16:58:58 2009
New Revision: 252

Log:
tile-layout, tile-horizontal-layout:	Keep child order and don't make unnecessary child movement. One-column-layout, One-line-layout: New layouts.

Modified:
   clfswm/ChangeLog
   clfswm/src/clfswm-layout.lisp
   clfswm/src/tools.lisp
   clfswm/src/xlib-util.lisp

Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog	(original)
+++ clfswm/ChangeLog	Mon Aug 17 16:58:58 2009
@@ -1,3 +1,9 @@
+2009-07-29  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* src/clfswm-layout.lisp (tile-layout, tile-horizontal-layout):
+	Keep child order and don't make unnecessary child movement.
+	(one-column-layout, one-line-layout): New layouts.
+
 2009-06-29  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* contrib/cd-player.lisp: New file to handle the CD player.

Modified: clfswm/src/clfswm-layout.lisp
==============================================================================
--- clfswm/src/clfswm-layout.lisp	(original)
+++ clfswm/src/clfswm-layout.lisp	Mon Aug 17 16:58:58 2009
@@ -186,11 +186,28 @@
 
 
 ;;; Tile layout
+(defun set-layout-managed-children ()
+  (when (frame-p *current-child*)
+    (setf (frame-data-slot *current-child* :layout-managed-children)
+	  (copy-list (get-managed-child *current-child*)))))
+
+(defun update-layout-managed-children (child parent)
+  (let ((managed-children (frame-data-slot parent :layout-managed-children))
+	(managed-in-parent (get-managed-child parent)))
+    (dolist (ch managed-in-parent)
+      (unless (member ch managed-children)
+	(setf managed-children (append managed-children (list child)))))
+    (setf managed-children (remove-if-not (lambda (x)
+					    (member x managed-in-parent :test #'equal))
+					  managed-children))
+    (setf (frame-data-slot parent :layout-managed-children) managed-children)
+    managed-children))
+
 (defgeneric tile-layout (child parent)
   (:documentation "Tile child in its frame (vertical)"))
 
 (defmethod tile-layout (child parent)
-  (let* ((managed-children (get-managed-child parent))
+  (let* ((managed-children (update-layout-managed-children child parent))
 	 (pos (position child managed-children))
 	 (len (length managed-children))
 	 (n (ceiling (sqrt len)))
@@ -203,14 +220,17 @@
 
 (defun set-tile-layout ()
   "Tile child in its frame (vertical)"
+  (set-layout-managed-children)
   (set-layout #'tile-layout))
 
 
+
+;; Horizontal tiling layout
 (defgeneric tile-horizontal-layout (child parent)
   (:documentation "Tile child in its frame (horizontal)"))
 
 (defmethod tile-horizontal-layout (child parent)
-  (let* ((managed-children (get-managed-child parent))
+  (let* ((managed-children (update-layout-managed-children child parent))
 	 (pos (position child managed-children))
 	 (len (length managed-children))
 	 (n (ceiling (sqrt len)))
@@ -223,8 +243,54 @@
 
 (defun set-tile-horizontal-layout ()
   "Tile child in its frame (horizontal)"
+  (set-layout-managed-children)
   (set-layout #'tile-horizontal-layout))
 
+
+
+;; One column layout
+(defgeneric one-column-layout (child parent)
+  (:documentation "One column layout"))
+
+(defmethod one-column-layout (child parent)
+  (let* ((managed-children (update-layout-managed-children child parent))
+	 (pos (position child managed-children))
+	 (len (length managed-children))
+	 (dy (/ (frame-rh parent) len)))
+    (values (round (+ (frame-rx parent) 1))
+	    (round (+ (frame-ry parent) (*  pos dy) 1))
+	    (round (- (frame-rw parent) 2))
+	    (round (- dy 2)))))
+
+(defun set-one-column-layout ()
+  "One column layout"
+  (set-layout-managed-children)
+  (set-layout #'one-column-layout))
+
+
+;; One line layout
+(defgeneric one-line-layout (child parent)
+  (:documentation "One line layout"))
+
+(defmethod one-line-layout (child parent)
+  (let* ((managed-children (update-layout-managed-children child parent))
+	 (pos (position child managed-children))
+	 (len (length managed-children))
+	 (dx (/ (frame-rw parent) len)))
+    (values (round (+ (frame-rx parent) (*  pos dx) 1))
+	    (round (+ (frame-ry parent) 1))
+	    (round (- dx 2))
+	    (round (- (frame-rh parent) 2)))))
+
+(defun set-one-line-layout ()
+  "One line layout"
+  (set-layout-managed-children)
+  (set-layout #'one-line-layout))
+
+
+
+
+
 ;;; Space layout
 (defun tile-space-layout (child parent)
   "Tile Space: tile child in its frame leaving spaces between them"
@@ -255,6 +321,8 @@
 (register-layout-sub-menu 'frame-tile-layout-menu "Frame tile layout menu"
 			  '(("v" set-tile-layout)
 			    ("h" set-tile-horizontal-layout)
+			    ("c" set-one-column-layout)
+			    ("l" set-one-line-layout)
 			    ("s" set-tile-space-layout)))
 
 

Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp	(original)
+++ clfswm/src/tools.lisp	Mon Aug 17 16:58:58 2009
@@ -546,7 +546,7 @@
   #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts)
   #+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts)
   #+ecl (apply #'ext:run-program prog args opts)
-  #+ccl (applay #'ccl:run-program prog args opts :wait wait)
+  #+ccl (apply #'ccl:run-program prog args opts :wait wait)
   #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ecl ccl)
   (error 'not-implemented :proc (list 'run-prog prog opts)))
 

Modified: clfswm/src/xlib-util.lisp
==============================================================================
--- clfswm/src/xlib-util.lisp	(original)
+++ clfswm/src/xlib-util.lisp	Mon Aug 17 16:58:58 2009
@@ -70,7 +70,7 @@
 	 , at body)
      ((or xlib:match-error xlib:window-error xlib:drawable-error) (c)
        (declare (ignore c)))))
-       ;;(dbg c ',body))))
+      ;;(dbg c ',body))))