From pbrochard at common-lisp.net Mon Aug 17 20:58:59 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 17 Aug 2009 16:58:59 -0400 Subject: [clfswm-cvs] r252 - in clfswm: . src Message-ID: 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 + + * 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 * 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))))