[beirc-cvs] CVS beirc

[afuchs]

Update of /project/beirc/cvsroot/beirc
In directory clnet:/tmp/cvs-serv30518

Modified Files:
	application.lisp 
Log Message:
add /interesting window {previous,next} and add keystrokes to /window {next,prev}


--- /project/beirc/cvsroot/beirc/application.lisp	2006/02/26 00:07:15	1.45
+++ /project/beirc/cvsroot/beirc/application.lisp	2006/02/26 15:53:30	1.46
@@ -348,27 +348,36 @@
 (define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver"))
   (raise-receiver receiver))
 
-(define-beirc-command (com-window-next :name t);; :keystroke (:right :meta))
-    ()
-  (let* ((current-pane (tab-layout::tab-pane-pane
-                        (enabled-pane (find-pane-named *application-frame* 'query))))
-         (list-of-panes (sheet-children (sheet-parent current-pane)))
-         (position     (position current-pane list-of-panes)))
-    (when list-of-panes
-      (if (>= position (1- (length list-of-panes)))
-          (switch-to-pane (car list-of-panes) 'tab-layout-pane)
-          (switch-to-pane (nth (1+ position) list-of-panes) 'tab-layout-pane)))))
-
-(define-beirc-command (com-window-previous :name t);; :keystroke (:left :meta))
-    ()
-  (let* ((current-pane (tab-layout::tab-pane-pane
-                        (enabled-pane (find-pane-named *application-frame* 'query))))
-         (list-of-panes (sheet-children (sheet-parent current-pane)))
-         (position     (position current-pane list-of-panes)))
-    (when list-of-panes
-      (if (<= position 0)
-          (switch-to-pane (car (last list-of-panes)) 'tab-layout-pane)
-          (switch-to-pane (nth (1- position) list-of-panes) 'tab-layout-pane)))))
+(macrolet ((define-window-switcher (name keystroke direction predicate)
+               `(define-beirc-command (,name :name t :keystroke ,keystroke)
+                    ()
+                  (let* ((current-pane (tab-layout::tab-pane-pane
+                                        (enabled-pane (find-pane-named *application-frame* 'query))))
+                         (list-of-panes (sheet-children (sheet-parent current-pane)))
+                         (n-panes (length list-of-panes))
+                         (current-pane-position (position current-pane list-of-panes))
+                         (position current-pane-position)
+                         (predicate ,predicate)
+                         (step-by ,direction)
+                         (start-position (- current-pane-position (* step-by n-panes)))
+                         (end-position (+ current-pane-position (* step-by n-panes))))
+                    (when list-of-panes
+                      (setf position
+                            (loop for i = (+ step-by start-position) then (+ i step-by)
+                                  until (or (= i end-position)
+                                            (funcall predicate (nth (mod (+ n-panes i) n-panes) list-of-panes)))
+                                  finally (return i)))
+                      (switch-to-pane (nth (mod (+ n-panes position) n-panes) list-of-panes)
+                                      'tab-layout-pane))))))
+  (labels ((pane-interesting-p (pane)
+             (let ((receiver (receiver-from-tab-pane
+                              (find-in-tab-panes-list pane 'tab-layout-pane))))
+               (or (> (messages-directed-to-me receiver) 0)
+                   (> (unseen-messages receiver) 0)))))
+    (define-window-switcher com-interesting-window-next (#\Tab :control) 1 #'pane-interesting-p)
+    (define-window-switcher com-interesting-window-previous (:iso-left-tab :control :shift) -1 #'pane-interesting-p)
+    (define-window-switcher com-window-next (:next :control) 1 (constantly t))
+    (define-window-switcher com-window-previous (:prior :control) -1 (constantly t))))
 
 (define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver"))
   (let* ((connection (current-connection *application-frame*))