;; --------------------------------------------------------------------------

;;; CLFSWM - FullScreen Window Manager
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Main functions
;;; --------------------------------------------------------------------------
;;;

;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>

;;;
;;; This program 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 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program 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 program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;;
;;; --------------------------------------------------------------------------

(in-package :clfswm)

(defgeneric child-border-size (child))

(defmethod child-border-size ((child frame))
  (x-drawable-border-width (frame-window child)))

(defmethod child-border-size ((child xlib:window))
  (x-drawable-border-width child))

(defmethod child-border-size (child)

  (declare (ignore child))

  0)

(defgeneric set-child-border-size (child value))

(defmethod set-child-border-size ((child frame) value)
  (setf (x-drawable-border-width (frame-window child)) value))

(defmethod set-child-border-size ((child xlib:window) value)
  (setf (x-drawable-border-width child) value))

(defmethod set-child-border-size (child value)
  (declare (ignore child value)))

(defsetf child-border-size set-child-border-size)

;;; Conversion functions
;;; Float -> Pixel conversion
(defun x-fl->px (x parent)
  "Convert float X coordinate to pixel"
  (round (+ (* x (frame-rw parent)) (frame-rx parent))))

(defun y-fl->px (y parent)
  "Convert float Y coordinate to pixel"
  (round (+ (* y (frame-rh parent)) (frame-ry parent))))

(defun w-fl->px (w parent)
  "Convert float Width coordinate to pixel"
  (round (* w (frame-rw parent))))

(defun h-fl->px (h parent)
  "Convert float Height coordinate to pixel"
  (round (* h (frame-rh parent))))

;;; Pixel -> Float conversion
(defun x-px->fl (x parent)
  "Convert pixel X coordinate to float"

  (/ (- x (frame-rx parent) (child-border-size parent)) (frame-rw parent)))

(defun y-px->fl (y parent)
  "Convert pixel Y coordinate to float"

  (/ (- y (frame-ry parent) (child-border-size parent)) (frame-rh parent)))

(defun w-px->fl (w parent)
  "Convert pixel Width coordinate to float"
  (/ w (frame-rw parent)))

(defun h-px->fl (h parent)
  "Convert pixel Height coordinate to float"
  (/ h (frame-rh parent)))

(defun rect-hidden-p (rect1 rect2)
  "Return T if child-rect1 hide child-rect2"

  (and *show-hide-policy*
       (funcall *show-hide-policy* (child-rect-x rect1) (child-rect-x rect2))
       (funcall *show-hide-policy* (child-rect-y rect1) (child-rect-y rect2))

       (funcall *show-hide-policy* (+ (child-rect-x rect2) (child-rect-w rect2))
                (+ (child-rect-x rect1) (child-rect-w rect1)))
       (funcall *show-hide-policy* (+ (child-rect-y rect2) (child-rect-h rect2))
                (+ (child-rect-y rect1) (child-rect-h rect1)))))

(defgeneric frame-p (frame))
(defmethod frame-p ((frame frame))
  (declare (ignore frame))
  t)
(defmethod frame-p (frame)
  (declare (ignore frame))
  nil)

;;; in-*: Find if point (x,y) is in frame, window or child

(defun in-rect (x y xr yr wr hr)
  (and (<= xr x (+ xr wr))
       (<= yr y (+ yr hr))))

(defun in-frame (frame x y)
  (and (frame-p frame)

       (in-rect x y (frame-rx frame) (frame-ry frame) (frame-rw frame) (frame-rh frame))))

(defun in-window (window x y)
  (and (xlib:window-p window)

       (in-rect x y
                (x-drawable-x window) (x-drawable-y window)
                (x-drawable-width window) (x-drawable-height window))))

(defgeneric in-child (child x y))

(defmethod in-child ((child frame) x y)
  (in-frame child x y))
(defmethod in-child ((child xlib:window) x y)
  (in-window child x y))
(defmethod in-child (child x y)
  (declare (ignore child x y))
  nil)

(defun frame-selected-child (frame)
  (when (frame-p frame)
    (with-slots (child selected-pos) frame
      (let ((len (length child)))
	(cond ((minusp selected-pos) (setf selected-pos 0))
	      ((>= selected-pos len) (setf selected-pos (max (1- len) 0)))))
      (nth selected-pos child))))

(defgeneric child-equal-p (child-1 child-2))

(defmethod child-equal-p ((child-1 xlib:window) (child-2 xlib:window))
  (xlib:window-equal child-1 child-2))

(defmethod child-equal-p ((child-1 frame) (child-2 frame))
  (equal child-1 child-2))

(defmethod child-equal-p (child-1 child-2)
  (declare (ignore child-1 child-2))
  nil)

(declaim (inline child-member child-remove child-position))

(defun child-member (child list)
  (member child list :test #'child-equal-p))

(defun child-remove (child list)
  (remove child list :test #'child-equal-p))

(defun child-position (child list)
  (position child list :test #'child-equal-p))

;;; Frame data manipulation functions
(defun frame-data-slot (frame slot)
  "Return the value associated to data slot"
  (when (frame-p frame)
    (second (assoc slot (frame-data frame)))))

(defun set-frame-data-slot (frame slot value)
  "Set the value associated to data slot"
  (when (frame-p frame)
    (with-slots (data) frame
      (setf data (remove (assoc slot data) data))
      (push (list slot value) data))
    value))

(defsetf frame-data-slot set-frame-data-slot)

(defun remove-frame-data-slot (frame slot)
  "Remove a slot in frame data slots"
  (when (frame-p frame)
    (with-slots (data) frame
      (setf data (remove (assoc slot data) data)))))

(defun managed-window-p (window frame)
  "Return t only if window is managed by frame"

  (if (frame-p frame)
      (with-slots ((managed forced-managed-window)
		   (unmanaged forced-unmanaged-window)) frame

	(and (xlib:window-p window)
	     (not (child-member window unmanaged))

	     (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p))
	     (or (member :all (frame-managed-type frame))
		 (member (window-type window) (frame-managed-type frame))
		 (child-member window managed)
		 (member (xlib:wm-name window) managed :test #'string-equal-p))))

      t))

(defun add-in-never-managed-window-list (value)
  (pushnew value *never-managed-window-list* :test #'equal))

(defun never-managed-window-p (window)

  (when (xlib:window-p window)
    (dolist (type *never-managed-window-list*)

      (when (funcall (first type) window)
	(return (values t (second type)))))))

(defgeneric child-name (child))

(defmethod child-name ((child xlib:window))
  (xlib:wm-name child))

(defmethod child-name ((child frame))
  (frame-name child))

(defmethod child-name (child)
  (declare (ignore child))
  "???")

(defgeneric set-child-name (child name))

(defmethod set-child-name ((child xlib:window) name)
  (setf (xlib:wm-name child) name))

(defmethod set-child-name ((child frame) name)
  (setf (frame-name child) name))

(defmethod set-child-name (child name)
  (declare (ignore child name)))

(defsetf child-name set-child-name)

(defgeneric child-fullname (child))

(defmethod child-fullname ((child xlib:window))

  (format nil "~A (~A)" (or (xlib:wm-name child) "?") (or (xlib:get-wm-class child) "?")))

(defmethod child-fullname ((child frame))
  (aif (frame-name child)
       (format nil "~A (Frame ~A)" it (frame-number child))
       (format nil "Frame ~A" (frame-number child))))

(defmethod child-fullname (child)
  (declare (ignore child))
  "???")

(defgeneric child-transparency (child))

(defmethod child-transparency ((child xlib:window))
  (window-transparency child))

(defmethod child-transparency ((child frame))
  (window-transparency (frame-window child)))

(defmethod child-transparency (child)
  (declare (ignore child))
  1)

(defgeneric set-child-transparency (child value))

(defmethod set-child-transparency ((child xlib:window) value)
  (setf (window-transparency child) value))

(defmethod set-child-transparency ((child frame) value)
  (setf (window-transparency (frame-window child)) value))

(defmethod set-child-transparency (child value)
  (declare (ignore child value)))

(defsetf child-transparency set-child-transparency)

(defgeneric child-x (child))
(defmethod child-x ((child xlib:window))

  (x-drawable-x child))

(defmethod child-x ((child frame))
  (frame-rx child))

(defgeneric child-y (child))
(defmethod child-y ((child xlib:window))

  (x-drawable-y child))

(defmethod child-y ((child frame))
  (frame-ry child))

(defgeneric child-width (child))
(defmethod child-width ((child xlib:window))

  (x-drawable-width child))

(defmethod child-width ((child frame))
  (frame-rw child))

(defgeneric child-height (child))
(defmethod child-height ((child xlib:window))

  (x-drawable-height child))

(defmethod child-height ((child frame))
  (frame-rh child))

(defgeneric child-x2 (child))
(defmethod child-x2 ((child xlib:window))

  (+ (x-drawable-x child) (x-drawable-width child)))

(defmethod child-x2 ((child frame))
  (+ (frame-rx child) (frame-rw child)))

(defgeneric child-y2 (child))
(defmethod child-y2 ((child xlib:window))

  (+ (x-drawable-y child) (x-drawable-height child)))

(defmethod child-y2 ((child frame))
  (+ (frame-ry child) (frame-rh child)))



(defgeneric child-center (child))

(defmethod child-center ((child xlib:window))

  (values (+ (x-drawable-x child) (/ (x-drawable-width child) 2))
          (+ (x-drawable-y child) (/ (x-drawable-height child) 2))))

(defmethod child-center ((child frame))
  (values (+ (frame-rx child) (/ (frame-rw child) 2))
          (+ (frame-ry child) (/ (frame-rh child) 2))))

(defun child-distance (child1 child2)
  (multiple-value-bind (x1 y1) (child-center child1)
    (multiple-value-bind (x2 y2) (child-center child2)
      (values (+ (abs (- x2 x1)) (abs (- y2 y1)))
              (- x2 x1)
              (- y2 y1)))))

(defun middle-child-x (child)
  (+ (child-x child) (/ (child-width child) 2)))

(defun middle-child-y (child)
  (+ (child-y child) (/ (child-height child) 2)))

(declaim (inline adj-border-xy adj-border-wh))
(defgeneric adj-border-xy (value child))
(defgeneric adj-border-wh (value child))

(defmethod adj-border-xy (v (child xlib:window))

  (+ v (x-drawable-border-width child)))

(defmethod adj-border-xy (v (child frame))

  (+ v (x-drawable-border-width (frame-window child))))

(defmethod adj-border-wh (v (child xlib:window))

  (- v (* (x-drawable-border-width child) 2)))

(defmethod adj-border-wh (v (child frame))

  (- v (* (x-drawable-border-width (frame-window child)) 2)))

(declaim (inline anti-adj-border-xy anti-adj-border-wh))
(defgeneric anti-adj-border-xy (value child))
(defgeneric anti-adj-border-wh (value child))

(defmethod anti-adj-border-xy (v (child xlib:window))

  (- v (x-drawable-border-width child)))

(defmethod anti-adj-border-xy (v (child frame))

  (- v (x-drawable-border-width (frame-window child))))

(defmethod anti-adj-border-wh (v (child xlib:window))

  (+ v (* (x-drawable-border-width child) 2)))

(defmethod anti-adj-border-wh (v (child frame))

  (+ v (* (x-drawable-border-width (frame-window child)) 2)))

(defmacro with-focus-window ((window) &body body)
  `(let ((,window (xlib:input-focus *display*)))
     (when (and ,window (not (xlib:window-equal ,window *no-focus-window*)))
       ,@body)))

;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
(defmacro with-all-children ((root child) &body body)
  (let ((rec (gensym))
	(sub-child (gensym)))

    `(block nil
       (labels ((,rec (,child)
		  ,@body
		  (when (frame-p ,child)
		    (dolist (,sub-child (reverse (frame-child ,child)))
		      (,rec ,sub-child)))))
	 (,rec ,root)))))

;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
(defmacro with-all-children-reversed ((root child) &body body)
  (let ((rec (gensym))
	(sub-child (gensym)))

    `(block nil
       (labels ((,rec (,child)
		  ,@body
		  (when (frame-p ,child)
		    (dolist (,sub-child (frame-child ,child))
		      (,rec ,sub-child)))))
	 (,rec ,root)))))

;; (with-all-frames (*root-frame* frame) (print (frame-number frame)))
(defmacro with-all-frames ((root frame) &body body)
  (let ((rec (gensym))
	(child (gensym)))

    `(block nil
       (labels ((,rec (,frame)
		  (when (frame-p ,frame)
		    ,@body
		    (dolist (,child (reverse (frame-child ,frame)))
		      (,rec ,child)))))
	 (,rec ,root)))))

;; (with-all-windows (*root-frame* window) (print window))
(defmacro with-all-windows ((root window) &body body)
  (let ((rec (gensym))
	(child (gensym)))

    `(block nil
       (labels ((,rec (,window)
		  (when (xlib:window-p ,window)
		    ,@body)
		  (when (frame-p ,window)
		    (dolist (,child (reverse (frame-child ,window)))
		      (,rec ,child)))))
	 (,rec ,root)))))

;; (with-all-frames-windows (*root-frame* child) (print child) (print (frame-number child)))
(defmacro with-all-windows-frames ((root child) body-window body-frame)
  (let ((rec (gensym))
	(sub-child (gensym)))

    `(block nil
       (labels ((,rec (,child)
		  (typecase ,child
		    (xlib:window ,body-window)
		    (frame ,body-frame
			   (dolist (,sub-child (reverse (frame-child ,child)))
			     (,rec ,sub-child))))))
	 (,rec ,root)))))

(defmacro with-all-windows-frames-and-parent ((root child parent) body-window body-frame)
  (let ((rec (gensym))
	(sub-child (gensym)))

    `(block nil
       (labels ((,rec (,child ,parent)
		  (typecase ,child
		    (xlib:window ,body-window)
		    (frame ,body-frame
			   (dolist (,sub-child (reverse (frame-child ,child)))
			     (,rec ,sub-child ,child))))))
	 (,rec ,root nil)))))

(defun create-frame-window ()

  (let ((win (xlib:create-window :parent *root*
                                 :x 0
                                 :y 0
                                 :width 200
                                 :height 200
                                 :background (get-color *frame-background*)
                                 :colormap (xlib:screen-default-colormap *screen*)
                                 :border-width *border-size*
                                 :border (get-color *color-selected*)
                                 :event-mask '(:exposure :button-press :button-release :pointer-motion :enter-window))))
    (setf (window-transparency win) *frame-transparency*)
    win))

(defun create-frame-gc (window)
  (xlib:create-gcontext :drawable window
                        :foreground (get-color *frame-foreground*)
                        :background (get-color *frame-background*)
                        :font *default-font*
                        :line-style :solid))


(defun destroy-all-frames-window ()
  (with-all-frames (*root-frame* frame)
    (when (frame-gc frame)
      (xlib:free-gcontext (frame-gc frame))
      (setf (frame-gc frame) nil))
    (when (frame-window frame)
      (xlib:destroy-window (frame-window frame))
      (setf (frame-window frame) nil))))

(defun create-all-frames-window ()
  (with-all-frames (*root-frame* frame)
    (unless (frame-window frame)
      (setf (frame-window frame) (create-frame-window)))
    (unless (frame-gc frame)
      (setf (frame-gc frame) (create-frame-gc (frame-window frame)))))
  (with-all-frames (*root-frame* frame)
    (dolist (child (frame-child frame))
      (handler-case
          (dbg (child-fullname child))
        (error (c)
          (setf (frame-child frame) (remove child (frame-child frame) :test #'child-equal-p))
          (dbg c child))))))

(defun frame-find-free-number ()
  (let ((all-numbers nil))
    (with-all-frames (*root-frame* frame)
      (pushnew (frame-number frame) all-numbers))
    (find-free-number all-numbers)))


(defun create-frame (&rest args &key (number (frame-find-free-number)) &allow-other-keys)

  (let* ((window (create-frame-window))
	 (gc (create-frame-gc window)))

    (apply #'make-instance 'frame :number number :window window :gc gc args)))


(defun add-frame (frame parent)
  (push frame (frame-child parent))
  frame)


(defun place-frame (frame parent prx pry prw prh)
  "Place a frame from real (pixel) coordinates"

  (when (and (frame-p frame) (frame-p parent))
    (with-slots (window x y w h) frame

      (setf (x-drawable-x window) prx
	    (x-drawable-y window) pry
	    (x-drawable-width window) prw
	    (x-drawable-height window) prh

	    x (x-px->fl prx parent)
	    y (y-px->fl pry parent)
	    w (w-px->fl prw parent)

	    h (h-px->fl prh parent))
      (xlib:display-finish-output *display*))))

(defun find-child (to-find root)
  "Find to-find in root or in its children"
  (with-all-children (root child)

    (when (child-equal-p child to-find)

      (return-from find-child t))))

(defmacro with-find-in-all-frames (test &optional return-value)
  `(let (ret)
     (block return-block
       (with-all-frames (root frame)
	 (when ,test
	   (if first-foundp
	       (return-from return-block (or ,return-value frame))
	       (setf ret frame))))
       (or ,return-value ret))))

(defun find-parent-frame  (to-find &optional (root *root-frame*) first-foundp)
  "Return the parent frame of to-find"
  (with-find-in-all-frames

      (child-member to-find (frame-child frame))))

(defun find-frame-window (window &optional (root *root-frame*) first-foundp)

  "Return the frame with the window window"

  (with-find-in-all-frames
      (xlib:window-equal window (frame-window frame))))

(defun find-frame-by-name (name &optional (root *root-frame*) first-foundp)

  "Find a frame from its name"
  (when name

    (with-find-in-all-frames
	(string-equal name (frame-name frame)))))

(defun find-frame-by-number (number &optional (root *root-frame*) first-foundp)

  "Find a frame from its number"
  (when (numberp number)

    (with-find-in-all-frames
	(= number (frame-number frame)))))

(defun find-child-in-parent (child base)
  "Return t if child is in base or in its parents"
  (labels ((rec (base)

	     (when (child-equal-p child base)

	       (return-from find-child-in-parent t))
	     (let ((parent (find-parent-frame base)))
	       (when parent
		 (rec parent)))))
    (rec base)))

;;; Multiple roots support (replace the old *current-root* variable)

(let ((root-list nil)
      (current-child nil))

  (defun get-root-list ()
    root-list)

  (let ((save-root-list nil))
    (defun save-root-list ()
      (setf save-root-list nil)
      (dolist (root root-list)
        (push (copy-root root) save-root-list)))
    (defun restore-root-list ()
      (setf root-list nil)
      (dolist (root save-root-list)
        (push (copy-root root) root-list))))

  (defmacro with-saved-root-list (() &body body)
    `(progn
       (save-root-list)
       ,@body
       (restore-root-list)))

  (defun reset-root-list ()
    (setf root-list nil
          current-child nil))

  (defun define-as-root (child x y width height)

    (push (make-root :child child :original child :current-child nil :x x :y y :w width :h height) root-list))

  (defun find-root-by-coordinates (x y)
    (dolist (root root-list)
      (when (in-rect x y (root-x root) (root-y root) (root-w root) (root-h root))
        (return root))))

  (defun root (x &optional y)
    "Return the root at coordinates (x,y) if y is not nil.
     Otherwise, return the x nth root in root-list"
    (if y
        (find-root-by-coordinates x y)
        (nth x root-list)))

  (defun all-root-child ()
    (loop for root in root-list

       collect (root-child root)))

  (defmacro with-all-root-child ((root) &body body)
    (let ((root-symb (gensym)))
      `(dolist (,root-symb (get-root-list))
         (let ((,root (root-child ,root-symb)))
           ,@body))))

  (labels ((generic-child-root-p (child function)
             (dolist (root root-list)
               (when (child-equal-p child (funcall function root))
                 (return root)))))
    (defun child-root-p (child)
      (generic-child-root-p child #'root-child))

    (defun child-original-root-p (child)
      (generic-child-root-p child #'root-original)))

  (defun change-root (old-root new-child)
    (when (and old-root new-child)
      (setf (root-child old-root) new-child)))

  (defun find-root (child)

    (aif (child-original-root-p child)

         it
         (awhen (find-parent-frame child)

           (find-root it))))

  (defun find-child-in-all-root (child)
    (dolist (root root-list)

      (when (find-child child (root-child root))

        (return-from find-child-in-all-root root))))

  (defun find-current-root ()

    (root-child (find-root current-child)))

  (defun exchange-root-geometry (root-1 root-2)

    (when (and root-1 root-2)
      (rotatef (root-x root-1) (root-x root-2))
      (rotatef (root-y root-1) (root-y root-2))
      (rotatef (root-w root-1) (root-w root-2))
      (rotatef (root-h root-1) (root-h root-2))))

  (defun rotate-root-geometry ()

    (let* ((current (first root-list))
           (orig-x (root-x current))
           (orig-y (root-y current))
           (orig-w (root-w current))
           (orig-h (root-h current)))
      (dolist (elem (rest root-list))
        (setf (root-x current) (root-x elem)
              (root-y current) (root-y elem)
              (root-w current) (root-w elem)
              (root-h current) (root-h elem)
              current elem))
      (let ((last (car (last root-list))))
        (setf (root-x last) orig-x
              (root-y last) orig-y
              (root-w last) orig-w
              (root-h last) orig-h))))

  (defun anti-rotate-root-geometry ()
    (setf root-list (nreverse root-list))
    (rotate-root-geometry)
    (setf root-list (nreverse root-list)))

  ;;; Current child functions

  (defun current-child ()
    current-child)

  (defun current-child-setter (value)

    (when value
      (awhen (find-root value)
        (setf (root-current-child it) value))
      (setf current-child value)))

  (defmacro with-current-child ((new-child) &body body)
    "Temporarly change the current child"
    (let ((old-child (gensym))
          (ret (gensym)))
      `(let ((,old-child (current-child)))
         (setf (current-child) ,new-child)
         (let ((,ret (multiple-value-list (progn ,@body))))
           (setf (current-child) ,old-child)

           (values-list ,ret)))))

  (defun child-is-a-current-child-p (child)
    (find child root-list :test #'child-equal-p :key #'root-current-child)))

(defsetf current-child current-child-setter)

(defun ensure-at-least-one-root ()
  (unless (get-root-list)
    (let ((frame (create-frame)))
      (add-frame frame *root-frame*)
      (define-as-root frame 0 0 (xlib:screen-width *screen*) (xlib:screen-height *screen*))
      (add-frame (create-frame) frame))))

(defun is-in-current-child-p (child)
  (and (frame-p (current-child))
       (child-member child (frame-child (current-child)))))

(defun fixe-real-size (frame parent)
  "Fixe real (pixel) coordinates in float coordinates"
  (when (frame-p frame)
    (with-slots (x y w h rx ry rw rh) frame
      (setf x (x-px->fl rx parent)
	    y (y-px->fl ry parent)
	    w (w-px->fl (anti-adj-border-wh rw parent) parent)
	    h (h-px->fl (anti-adj-border-wh rh parent) parent)))))

(defun fixe-real-size-current-child ()
  "Fixe real (pixel) coordinates in float coordinates for children in the current child"
  (when (frame-p (current-child))
    (dolist (child (frame-child (current-child)))
      (fixe-real-size child (current-child)))))