After a conversation with tychoish on #stumpwm, I send current state of window
tagging that I use.
wse*.lisp and frame-tag*.lisp seem generic enough, they are stable and I would
like to hear whether this can be included in StumpWM contrib (maybe in separate
wse/ and frame-tags/ directories..)
WSE - window selection expressions - is a set of helpers to iterate over
windows satisfying some conditions, and to define said consitions.
;; Copyright 2011 Michael Raskin
;;
;; Maintainer: Michael Raskin
;;
;; This file is part of stumpwm.
;;
;; stumpwm is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; stumpwm is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;; Frame groups based on tagging
(defun frame-tagged-group (f)
(or
(loop for x in (frame-tags f) when (cl-ppcre:scan "^TG/.*$" x)
return x)
"DEFAULT"))
(defun in-frame-tg-p (w x)
(equalp (frame-tagged-group (window-frame w)) x))
(defun in-current-ftg-p (w)
(equalp (frame-tagged-group (window-frame w))
(frame-tagged-group (tile-group-current-frame (current-group)))))
(defcommand
frame-group-push-pull-tags (argtags) ((:rest "Tags: "))
"Move away all windows from current frame group not with tags in argtags
and pull into current frame all windows with tags amongs argtags placed
in other frame groups or in other groups"
(let*
((tag (if (stringp argtags)
(remove "" (cl-ppcre:split " " (string-upcase argtags))
:test 'equalp)
(mapcar 'string-upcase argtags)))
(ftg (frame-tagged-group (tile-group-current-frame (current-group)))))
(fclear)
(act-on-matching-windows
(w :group) (and (in-frame-tg-p w ftg)
(not (tagged-any-p w tag)))
(push-w w))
(act-on-matching-windows
(w :screen) (and
(not (in-current-group-p w))
(tagged-any-p w tag))
(pull-w w))
(act-on-matching-windows
(w :screen) (and
(not (in-frame-tg-p w ftg))
(tagged-any-p w tag))
(pull-window w))))
(defcommand
ftg-set-tags (Argtags) ((:rest "Tags: "))
"My default tag-chooser"
(when
(equal (group-name (current-group)) ".tag-store")
(gselect (find-group (current-screen) "Default")))
(frame-group-push-pull-tags argtags)
(number-by-tags))
(defcommand
ftg-next-window () ()
"Switch to next window in frame group"
(focus-forward
(current-group)
(sort
(act-on-matching-windows
(w :group)
(in-frame-tg-p w (frame-tagged-group
(tile-group-current-frame (current-group))))
w)
'< :key 'window-number)
nil))
(defcommand
(set-frame-group tile-group) (name) ((:rest "Name: "))
"Set tagged-group of current frame"
(unless (cl-ppcre:scan " " name)
(setf (frame-tags (tile-group-current-frame (current-group)))
(cons
(format nil "TG/~a" (string-upcase name))
(remove-if
(lambda (s) (cl-ppcre:scan "^TG/" s))
(frame-tags (tile-group-current-frame (current-group))))))))
(defun eat-frame (group eater food)
(dformat 7 "~%Eat frame? ~s:~%~s ~s~%@~%~s ~s~%"
group eater food (frame-head group eater) (frame-head group food))
(when
(equal (frame-head group eater) (frame-head group food))
(dformat 9 "Frame tree was: ~s~%"
(tile-group-frame-tree group))
(if (= (frame-y eater) (frame-y food))
(progn
(setf (frame-width eater) (+ (frame-width eater) (frame-width food)))
(when (> (frame-x eater) (frame-x food))
(setf (frame-x eater) (frame-x food)
(frame-x food) (1+ (frame-x food))))
(setf (frame-width food) 0))
(progn
(setf (frame-height eater)
(+ (frame-height eater) (frame-height food)))
(when (> (frame-y eater) (frame-y food))
(setf (frame-y eater) (frame-y food)
(frame-y food) (1+ (frame-y food))))
(setf (frame-height food) 0)))
(dformat 9 "Frame tree is: ~s~%"
(tile-group-frame-tree group))
(remove-split group food)))
(defun every-in-tree (p tr)
(cond
((null tr) t)
((atom tr) (funcall p tr))
(t (not (find-if (lambda (x) (not (every-in-tree p x))) tr)))))
(defun eat-ftg-siblings (&key (group (current-group))
(frame (tile-group-current-frame group)))
(let*
((tr (tile-group-frame-tree group))
(ftg (frame-tagged-group frame))
(s tr)
(d 0)
(n (position frame s))
(l (length s)))
(loop while (not n)
do (progn
(setf s (next-sibling s frame))
(setf n (position frame s))
(setf l (length s))
(incf d)))
(if (= d 0) nil
(< 0
(+
(if (> n 0)
(let*
((food (nth (1- n) s)))
(if
(every-in-tree
(lambda (x) (equalp (frame-tagged-group x) ftg))
food)
(progn
(if (listp food)
(progn
(focus-frame group (tree-leaf food))
(ftg-only))
(eat-frame group frame food))
1)
0))
0)
(if (< n (1- l))
(let*
((eater (nth (1+ n) s)))
(if
(every-in-tree
(lambda (x) (equalp (frame-tagged-group x) ftg))
eater)
(progn
(if (listp eater)
(progn
(focus-frame group (tree-leaf eater))
(ftg-only))
(eat-frame group eater frame))
1)
0))
0))))))
(defcommand ftg-only () ()
(loop while (eat-ftg-siblings)))
(defcommand
ftg-mark-windows (argtags) ((:rest "Tags: "))
"Mark all windows in the frames of current tagged group with argtags"
(act-on-matching-windows
(w :group)
(in-frame-tg-p w (frame-tagged-group
(tile-group-current-frame (current-group))))
(tag-window argtags w)))
(defcommand
ftg-set-tag-re (re &optional keep-old) ((:rest "Tag pattern: "))
"In current ftg there will be all windows with tags matching re"
(fclear)
(setf re (string-upcase re))
(unless keep-old
(act-on-matching-windows
(w :group)
(and
(in-current-ftg-p w)
(not (find-if (lambda (x) (cl-ppcre:scan re x)) (window-tags w))))
(push-w w)))
(act-on-matching-windows
(w :screen)
(and
(not
(and
(in-current-ftg-p w)
(in-current-group-p w)))
(find-if (lambda (x) (cl-ppcre:scan re x)) (window-tags w)))
(pull-w w))
(act-on-matching-windows
(w :group)
(and
(not (in-current-ftg-p w))
(find-if (lambda (x) (cl-ppcre:scan re x)) (window-tags w)))
(pull-window w)))
(defcommand
ftg-add-tag-re (re) ((:rest "Tag pattern: "))
"Add all windows with tags matching re to current ftg"
(ftg-set-tag-re re t))
(defun frame-split-tagging-hook (p f1 f2)
(setf (frame-tags f1) (frame-tags p))
(setf (frame-tags f2) (frame-tags p)))
;; Copyright 2011 Michael Raskin
;;
;; Maintainer: Michael Raskin
;;
;; This file is part of stumpwm.
;;
;; stumpwm is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; stumpwm is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;; Frame tagging
(in-package :stumpwm)
(defvar *frame-tags* (make-hash-table))
(defcommand frame-tags (&optional (argframe nil)) ()
"Show frame tags"
(let* ((frame (or argframe (tile-group-current-frame
(current-group))))
(tags (gethash frame *frame-tags*)))
(if argframe tags (message "Tags: ~{~%~a~}" tags))))
(defun (setf frame-tags)
(argtags &optional (frame (tile-group-current-frame
(current-group))))
"Set frame tags"
(let*
((tags (if (stringp argtags)
(remove "" (cl-ppcre:split " " (string-upcase argtags))
:test 'equalp)
(mapcar 'string-upcase argtags))))
(setf (gethash frame *frame-tags*) tags)))
(defun remove-frame-tags
(argtags &optional (frame (tile-group-current-frame
(current-group))))
(let*
((tags (if (stringp argtags)
(remove "" (cl-ppcre:split " " (string-upcase argtags)) :test
'equal)
(mapcar 'string-upcase argtags))))
(setf (frame-tags frame)
(remove-if (lambda (x) (find x tags :test 'equalp))
(frame-tags frame)))))
(defcommand
tag-frame (argtags &optional (frame (tile-group-current-frame
(current-group))))
((:rest "Tag to set: ") :rest)
"Add a tag to current frame"
(let*
((tags
(if (stringp argtags)
(remove "" (cl-ppcre:split " " (string-upcase argtags)) :test 'equal)
(mapcar 'string-upcase argtags))))
(setf (frame-tags frame) (union tags (frame-tags frame) :test 'equalp))))
(defcommand
clear-all-frame-tags (&optional (frame (tile-group-current-frame
(current-group)))) ()
(setf (frame-tags frame) nil))
(defun first-frame-by-tag (tag &optional (group (current-group)))
(loop for x in (group-frames group)
when (find (string-upcase tag) (frame-tags x) :test 'equal)
return x))
(defun first-frame-by-tag-re (tag &optional (group (current-group)))
(loop for x in (group-frames group)
when (find (string-upcase tag) (frame-tags x) :test
(lambda (x y) (cl-ppcre:Scan x y)))
return x))
(defcommand focus-frame-by-tag (tag) ((:rest "Tag: "))
(let*
((frame (first-frame-by-tag tag)))
(when frame (focus-frame (current-group) frame))))
(defcommand focus-frame-by-tag-re (tag) ((:rest "Tag: "))
(let*
((frame (first-frame-by-tag-re tag)))
(when frame (focus-frame (current-group) frame))))
(in-package :stumpwm)
(defun in-frame-tagged-p (w name)
(find name (frame-tags (window-frame w)) :test 'equalp))
(defun to-tagged-frame (w name)
(let*
((frame (find-if (lambda (x) (find name (frame-tags x) :Test 'equalp))
(group-frames (current-group (current-screen))))))
(when frame (pull-window w frame))))
(in-package :stumpwm)
(defun push-w (w) (move-windows-to-group (list w) ".tag-store"))
(defun tagged-p (w tag)
(or (equal tag "T") (find tag (window-tags w) :test 'equalp)))
(defun tagged-any-p (w argtags)
(let*
((tag (if (stringp argtags)
(remove "" (cl-ppcre:split " " (string-upcase argtags))
:test 'equalp)
(mapcar 'string-upcase argtags))))
(intersection tag (cons "T" (window-tags w)) :test 'equalp)))
(defun tag-re-p (w tre)
(find-if (lambda (tag) (cl-ppcre:scan tre tag)) (cons "T" (window-tags w))))
;; Copyright 2011 Michael Raskin
;;
;; Maintainer: Michael Raskin
;;
;; This file is part of stumpwm.
;;
;; stumpwm is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; stumpwm is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;; Window Selection Expressions
(in-package :stumpwm)
(defmacro act-on-matching-windows
((var &optional (range '(current-screen))) condition &rest code)
"Run code on all windows matching condition; var is the shared lambda
variable"
`(let
((range ,range))
(loop for ,var in
(cond
((typep range 'screen) (screen-windows range))
((typep range 'group) (group-windows range))
((typep range 'frame) (frame-windows (current-group) range))
((typep range 'list) range)
((eq range :screen) (screen-windows (current-screen)))
((eq range :group)
(group-windows (current-group)))
((eq range :frame)
(frame-windows (current-group)
(tile-group-current-frame
(current-group))))
(t (error "Unknown kind of window set")))
when ,condition
collect (progn ,@code))))
(defun pull-w (w) (move-windows-to-group (list w) (current-group)))
(defun titled-p (w title) (equal (window-title w) title))
(defun title-re-p (w tre) (cl-ppcre:Scan tre (window-title w)))
(defun classed-p (w class) (equal (window-class w) class))
(defun class-re-p (w cre) (cl-ppcre:Scan cre (window-class w)))
(defun typed-p (w type) (equal (window-type w) type))
(defun type-re-p (w tre) (cl-ppcre:Scan tre (window-type w)))
(defun roled-p (w role) (equal (window-role w) role))
(defun role-re-p (w rre) (cl-ppcre:Scan rre (window-role w)))
(defun resed-p (w res) (equal (window-res w) res))
(defun res-re-p (w rre) (cl-ppcre:Scan rre (window-res w)))
(defun classed-p (w class) (equal (window-class w) class))
(defun class-re-p (w cre) (cl-ppcre:Scan cre (window-class w)))
(defun grouped-p (w name) (equal name (group-name (window-group w))))
(defun in-current-group-p (w) (equal (window-group w) (current-group)))
(defun in-frame-p (w f) (eq (window-frame w) f))
(defun in-current-frame-p (w)
(equal (window-frame w) (tile-group-current-frame
(current-group (current-screen)))))
_______________________________________________
Stumpwm-devel mailing list
Stumpwm-devel@nongnu.org
https://lists.nongnu.org/mailman/listinfo/stumpwm-devel
