(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 address@hidden ~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)))