;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Utility
;;; --------------------------------------------------------------------------
;;;

;;; (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)

;;; Configuration file
(defun xdg-config-home ()

  (aif (getenv "XDG_CONFIG_HOME")
       (pathname-directory (concatenate 'string it "/"))
       (append (pathname-directory (user-homedir-pathname)) '(".config"))))

(let ((saved-conf-name nil))
  (defun conf-file-name (&optional alternate-name)
    (unless (and saved-conf-name (not alternate-name))
      (let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p".clfswmrc")))
	     (etc-conf (probe-file #p"/etc/clfswmrc"))
	     (config-user-conf (probe-file (make-pathname :directory (append (xdg-config-home) '("clfswm"))
							  :name "clfswmrc")))

	     (alternate-conf (and alternate-name (probe-file alternate-name))))

	(setf saved-conf-name (or alternate-conf config-user-conf user-conf etc-conf))))
    (print saved-conf-name)
    saved-conf-name))

(defun load-contrib (file)
  "Load a file in the contrib directory"

  (let ((truename (merge-pathnames file *contrib-dir*)))

    (format t "Loading contribution file: ~A~%" truename)
    (when (probe-file truename)

      (load truename :verbose nil))))

(defun reload-clfswm ()
  "Reload clfswm"
  (format t "~&-*- Reloading CLFSWM -*-~%")
  (asdf:oos 'asdf:load-op :clfswm)

  (reset-clfswm))

;;;----------------------------
;;; Lisp image part
;;;----------------------------
(defun build-lisp-image (dump-name)
  #+CLISP (ext:saveinitmem dump-name :init-function (lambda () (clfswm:main) (ext:quit)) :executable t :norc t)
  #+SBCL (sb-ext:save-lisp-and-die dump-name :toplevel 'clfswm:main :executable t))

(defun query-yes-or-no (formatter &rest args)

  (let ((rep (query-string (apply #'format nil formatter args) "" '("Yes" "No"))))

    (or (string= rep "")
	(char= (char rep 0) #\y)
	(char= (char rep 0) #\Y))))

(defun banish-pointer ()
  "Move the pointer to the lower right corner of the screen"
  (with-placement (*banish-pointer-placement* x y)
    (xlib:warp-pointer *root* x y)))

;;; Root functions utility

(defun show-current-root ()
  (when *have-to-show-current-root*
    (let ((*notify-window-placement* *show-current-root-placement*))
      (notify-message *show-current-root-delay* *show-current-root-message*))))

(defun select-generic-root (fun restart-menu)
  (no-focus)
  (let* ((current-root (find-root (current-child)))
         (parent (find-parent-frame (root-original current-root))))
    (when parent
      (setf (frame-child parent) (funcall fun (frame-child parent)))
      (let ((new-root (find-root (frame-selected-child parent))))
        (setf (current-child) (aif (root-current-child new-root)
                                   it
                                   (frame-selected-child parent))))))
  (show-all-children t)

  (show-current-root)

  (if restart-menu
      (open-menu (find-menu 'root-menu))
      (leave-second-mode)))

(defun select-next-root ()
  "Select the next root"
  (select-generic-root #'rotate-list nil))

(defun select-previous-root ()
  "Select the previous root"
  (select-generic-root #'anti-rotate-list nil))


(defun select-next-root-restart-menu ()
  "Select the next root"
  (select-generic-root #'rotate-list t))

(defun select-previous-root-restart-menu ()
  "Select the previous root"
  (select-generic-root #'anti-rotate-list t))


(defun rotate-root-geometry-generic (fun restart-menu)
  (no-focus)
  (funcall fun)
  (show-all-children t)

  (show-current-root)

  (if restart-menu
      (open-menu (find-menu 'root-menu))
      (leave-second-mode)))


(defun rotate-root-geometry-next ()
  "Rotate root geometry to next root"
  (rotate-root-geometry-generic #'rotate-root-geometry nil))

(defun rotate-root-geometry-previous ()
  "Rotate root geometry to previous root"
  (rotate-root-geometry-generic #'anti-rotate-root-geometry nil))

(defun rotate-root-geometry-next-restart-menu ()
  "Rotate root geometry to next root"
  (rotate-root-geometry-generic #'rotate-root-geometry t))

(defun rotate-root-geometry-previous-restart-menu ()
  "Rotate root geometry to previous root"
  (rotate-root-geometry-generic #'anti-rotate-root-geometry t))



(defun exchange-root-geometry-with-mouse ()
  "Exchange two root geometry pointed with the mouse"
  (open-notify-window '("Select the first root to exchange"))
  (wait-no-key-or-button-press)
  (wait-mouse-button-release)
  (close-notify-window)
  (multiple-value-bind (x1 y1) (xlib:query-pointer *root*)
    (open-notify-window '("Select the second root to exchange"))
    (wait-no-key-or-button-press)
    (wait-mouse-button-release)
    (close-notify-window)
    (multiple-value-bind (x2 y2) (xlib:query-pointer *root*)
      (exchange-root-geometry (find-root-by-coordinates x1 y1)
                              (find-root-by-coordinates x2 y2))))

  (show-all-children)

  (show-current-root)

  (leave-second-mode))

(defun change-current-root-geometry ()
  "Change the current root geometry"
  (let* ((root (find-root (current-child)))
         (x (query-number "New root X position" (root-x root)))
         (y (query-number "New root Y position" (root-y root)))
         (w (query-number "New root width" (root-w root)))
         (h (query-number "New root height" (root-h root))))
    (setf (root-x root) x  (root-y root) y
          (root-w root) w  (root-h root) h)

    (show-all-children)

    (show-current-root)

    (leave-second-mode)))

(defun display-all-frame-info ()
  (with-all-frames (*root-frame* frame)
    (display-frame-info frame)))

(defun display-all-root-frame-info ()
  (with-all-root-child (root)
    (display-frame-info root)))

(defun place-window-from-hints (window)
  "Place a window from its hints"
  (let* ((hints (xlib:wm-normal-hints window))
	 (min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0))
	 (min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0))
	 (max-width (or (and hints (xlib:wm-size-hints-max-width hints)) (x-drawable-width *root*)))
	 (max-height (or (and hints (xlib:wm-size-hints-max-height hints)) (x-drawable-height *root*)))
	 (rwidth (or (and hints (or (xlib:wm-size-hints-width hints) (xlib:wm-size-hints-base-width hints)))
		     (x-drawable-width window)))
	 (rheight (or (and hints (or (xlib:wm-size-hints-height hints) (xlib:wm-size-hints-base-height hints)))
		      (x-drawable-height window))))
    (setf (x-drawable-width window) (min (max min-width rwidth *default-window-width*) max-width)
	  (x-drawable-height window) (min (max min-height rheight *default-window-height*) max-height))
    (with-placement (*unmanaged-window-placement* x y (x-drawable-width window) (x-drawable-height window))
      (setf (x-drawable-x window) x
            (x-drawable-y window) y))
    (xlib:display-finish-output *display*)))

(defun rename-current-child ()
  "Rename the current child"

  (let ((name (query-string (format nil "New child name: (last: ~A)" (child-name (current-child)))
			    (child-name (current-child)))))
    (rename-child (current-child) name)

    (leave-second-mode)))

(defun ask-child-transparency (msg child)
  (let ((trans (query-number (format nil "New ~A transparency: (last: ~A)"
                                     msg
                                     (* 100 (child-transparency child)))
                             (* 100 (child-transparency child)))))
    (when (numberp trans)
      (setf (child-transparency child) (float (/ trans 100))))))

(defun set-current-child-transparency ()
  "Set the current child transparency"

  (ask-child-transparency "child" (current-child))

  (leave-second-mode))

(defun ask-child-border-size (msg child)
  (let ((size (query-number (format nil "New ~A border size: (last: ~A)"
                                    msg
                                    (child-border-size child))
                            (child-border-size child))))
    (when (numberp size)
      (setf (child-border-size child) size))))


(defun set-current-child-border-size ()
  "Set the current child border size"
  (ask-child-border-size "child" (current-child))
  (leave-second-mode))

(defun renumber-current-frame ()
  "Renumber the current frame"

  (when (frame-p (current-child))
    (let ((number (query-number (format nil "New child number: (last: ~A)" (frame-number (current-child)))
				(frame-number (current-child)))))
      (setf (frame-number (current-child)) number)

      (leave-second-mode))))

(defun add-default-frame ()

  "Add a default frame in the current frame"

  (when (frame-p (current-child))

    (let ((name (query-string "Frame name")))

      (push (create-frame :name name) (frame-child (current-child)))))

  (leave-second-mode))

(defun add-frame-in-parent-frame ()
  "Add a frame in the parent frame (and reorganize parent frame)"

  (let ((parent (find-parent-frame (current-child))))
    (when (and parent (not (child-original-root-p (current-child))))

      (let ((new-frame (create-frame)))
        (pushnew new-frame (frame-child parent))

        (awhen (child-root-p (current-child))

          (change-root it parent))

        (setf (current-child) parent)

        (set-layout-once #'tile-space-layout)

        (setf (current-child) new-frame)

        (leave-second-mode)))))

(defun add-placed-frame ()

  "Add a placed frame in the current frame"

  (when (frame-p (current-child))

    (let ((name (query-string "Frame name"))
	  (x (/ (query-number "Frame x in percent (%)") 100))
	  (y (/ (query-number "Frame y in percent (%)") 100))

	  (w (/ (query-number "Frame width in percent (%)" 100) 100))
	  (h (/ (query-number "Frame height in percent (%)" 100) 100)))

      (push (create-frame :name name :x x :y y :w w :h h)

	    (frame-child (current-child)))))

  (leave-second-mode))

(defun delete-focus-window-generic (close-fun)

  (with-focus-window (window)

    (when (child-equal-p window (current-child))
      (setf (current-child) (find-current-root)))

    (delete-child-and-children-in-all-frames window close-fun)))

(defun delete-focus-window ()
  "Close focus window: Delete the focus window in all frames and workspaces"
  (delete-focus-window-generic 'delete-window))

(defun destroy-focus-window ()

  "Kill focus window: Destroy the focus window in all frames and workspaces"

  (delete-focus-window-generic 'destroy-window))

(defun remove-focus-window ()

  "Remove the focus window from the current frame"

  (with-focus-window (window)

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

    (hide-child window)
    (remove-child-in-frame window (find-parent-frame window))
    (show-all-children)))

(defun unhide-all-windows-in-current-child ()
  "Unhide all hidden windows into the current child"

  (dolist (window (get-hidden-windows))
    (unhide-window window)
    (process-new-window window)
    (map-window window))

  (show-all-children))




(defun find-window-under-mouse (x y)
  "Return the child window under the mouse"

  (let ((win *root*))

    (with-all-root-child (root)

      (with-all-windows-frames-and-parent (root child parent)
        (when (and (or (managed-window-p child parent) (child-equal-p parent (current-child)))
                   (not (window-hidden-p child))
                   (in-window child x y))
          (setf win child))
        (when (in-frame child x y)
          (setf win (frame-window child)))))

    win))

(defun find-child-under-mouse-in-never-managed-windows (x y)
  "Return the child under mouse from never managed windows"

  (let ((ret nil))
    (dolist (win (xlib:query-tree *root*))
      (unless (window-hidden-p win)
	(multiple-value-bind (never-managed raise)
	    (never-managed-window-p win)
	  (when (and never-managed raise (in-window win x y))
	    (setf ret win)))))
    ret))

(defun find-child-under-mouse-in-child-tree (x y &optional first-foundp)

  "Return the child under the mouse"

  (let ((ret nil))

    (with-all-root-child (root)

      (with-all-windows-frames (root child)
        (when (and (not (window-hidden-p child))
                   (in-window child x y))
          (if first-foundp
              (return-from find-child-under-mouse-in-child-tree child)
              (setf ret child)))
        (when (in-frame child x y)
          (if first-foundp
              (return-from find-child-under-mouse-in-child-tree child)
              (setf ret child)))))

    ret))

(defun find-child-under-mouse (x y &optional first-foundp also-never-managed)
  "Return the child under the mouse"
  (or (and also-never-managed
	   (find-child-under-mouse-in-never-managed-windows x y))
      (find-child-under-mouse-in-child-tree x y first-foundp)))

;;; Selection functions
(defun clear-selection ()
  "Clear the current selection"
  (setf *child-selection* nil)

  (display-all-root-frame-info))

(defun copy-current-child ()
  "Copy the current child to the selection"

  (pushnew (current-child) *child-selection*)

  (display-all-root-frame-info))

(defun cut-current-child (&optional (show-now t))

  "Cut the current child to the selection"

  (unless (child-root-p (current-child))
    (let ((parent (find-parent-frame (current-child))))
      (hide-all (current-child))

      (copy-current-child)

      (remove-child-in-frame (current-child) (find-parent-frame (current-child) (find-current-root)))

      (when parent

        (setf (current-child) parent))

      (when show-now
        (show-all-children t))

      (current-child))))

(defun remove-current-child ()
  "Remove the current child from its parent frame"

  (unless (child-root-p (current-child))
    (let ((parent (find-parent-frame (current-child))))
      (hide-all (current-child))
      (remove-child-in-frame (current-child) (find-parent-frame (current-child) (find-current-root)))

      (when parent

        (setf (current-child) parent))

      (show-all-children t)
      (leave-second-mode))))

(defun delete-current-child ()

  "Delete the current child and its children in all frames"

  (unless (child-root-p (current-child))
    (hide-all (current-child))
    (delete-child-and-children-in-all-frames (current-child))

    (show-all-children t)
    (leave-second-mode)))

(defun paste-selection-no-clear ()
  "Paste the selection in the current frame - Do not clear the selection after paste"

  (when (frame-p (current-child))

    (dolist (child *child-selection*)

      (unless (find-child-in-parent child (current-child))
        (pushnew child (frame-child (current-child)) :test #'child-equal-p)))

    (show-all-children)))

(defun paste-selection ()
  "Paste the selection in the current frame"

  (when (frame-p (current-child))

    (paste-selection-no-clear)
    (setf *child-selection* nil)

    (display-all-root-frame-info)))

(defun copy-focus-window ()
  "Copy the focus window to the selection"
  (with-focus-window (window)

    (with-current-child (window)

      (copy-current-child))))


(defun cut-focus-window ()
  "Cut the focus window to the selection"
  (with-focus-window (window)

    (setf (current-child) (with-current-child (window)

                            (cut-current-child nil)))
    (show-all-children t)))

;;; Maximize function
(defun frame-toggle-maximize ()
  "Maximize/Unmaximize the current frame in its parent frame"

  (when (frame-p (current-child))
    (let ((unmaximized-coords (frame-data-slot (current-child) :unmaximized-coords)))

      (if unmaximized-coords

	  (with-slots (x y w h) (current-child)

	    (destructuring-bind (nx ny nw nh) unmaximized-coords

	      (setf (frame-data-slot (current-child) :unmaximized-coords) nil

		    x nx y ny w nw h nh)))

	  (with-slots (x y w h) (current-child)
	    (setf (frame-data-slot (current-child) :unmaximized-coords)

		  (list x y w h)
		  x 0 y 0 w 1 h 1))))

    (show-all-children)

    (leave-second-mode)))

;;; CONFIG - Identify mode
(defun identify-key ()
  "Identify a key"
  (let* ((done nil)
	 (font (xlib:open-font *display* *identify-font-string*))
	 (window (xlib:create-window :parent *root*
				     :x 0 :y 0

				     :width (- (xlib:screen-width *screen*) (* *border-size* 2))

				     :height (* 5 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font)))
				     :background (get-color *identify-background*)

				     :border-width *border-size*

				     :border (get-color *identify-border*)
				     :colormap (xlib:screen-default-colormap *screen*)
				     :event-mask '(:exposure)))
	 (gc (xlib:create-gcontext :drawable window
				   :foreground (get-color *identify-foreground*)
				   :background (get-color *identify-background*)
				   :font font
				   :line-style :solid)))

    (setf (window-transparency window) *identify-transparency*)

    (labels ((print-doc (msg hash-table-key pos code state)
	       (let ((function (find-key-from-code hash-table-key code state)))
		 (when (and function (fboundp (first function)))

		   (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* pos (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
				     (format nil "~A ~A" msg (documentation (first function) 'function))))))

	     (print-key (code state keysym key modifiers)

	       (clear-pixmap-buffer window gc)

	       (setf (xlib:gcontext-foreground gc) (get-color *identify-foreground*))

	       (xlib:draw-glyphs *pixmap-buffer* gc 5 (+ (xlib:max-char-ascent font) 5)
				 (format nil "Press a key to identify. Press 'q' to stop the identify loop."))

	       (when code

		 (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* 2 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
				   (format nil "Code=~A  KeySym=~S  Key=~S  Modifiers=~A"
					   code keysym key modifiers))

		 (print-doc "Main mode  : " *main-keys* 3 code state)

		 (print-doc "Second mode: " *second-keys* 4 code state))
	       (copy-pixmap-buffer window gc))

	     (handle-identify-key (&rest event-slots &key root code state &allow-other-keys)
	       (declare (ignore event-slots root))
	       (let* ((modifiers (state->modifiers state))
		      (key (keycode->char code state))

		      (keysym (keysym->keysym-name (keycode->keysym code modifiers))))

		 (setf done (and (equal key #\q) (equal modifiers *default-modifiers*)))

		 (dbg code keysym key modifiers)
		 (print-key code state keysym key modifiers)
		 (force-output)))
	     (handle-identify (&rest event-slots &key display event-key &allow-other-keys)
	       (declare (ignore display))
	       (case event-key
		 (:key-press (apply #'handle-identify-key event-slots) t)
		 (:exposure (print-key nil nil nil nil nil)))
	       t))
      (xgrab-pointer *root* 92 93)

      (map-window window)

      (format t "~&Press 'q' to stop the identify loop~%")
      (print-key nil nil nil nil nil)
      (force-output)
      (unwind-protect
	   (loop until done do

                (with-xlib-protect (:Identify-Loop nil)
                  (when (xlib:event-listen *display* *loop-timeout*)
                    (xlib:process-event *display* :handler #'handle-identify))
                  (xlib:display-finish-output *display*)))
        (progn
          (xlib:destroy-window window)
          (xlib:close-font font)
          (xgrab-pointer *root* 66 67))))))

(let ((all-symbols (collect-all-symbols)))
  (defun eval-from-query-string ()
    "Eval a lisp form from the query input"
    (let ((form (query-string (format nil "Eval Lisp <~A> " (package-name *package*))
                              "" all-symbols))
            (result nil))
        (when (and form (not (equal form "")))
          (let ((printed-result
                 (with-output-to-string (*standard-output*)
                   (setf result (handler-case
                                    (loop for i in (multiple-value-list
                                                    (eval (read-from-string form)))
                                       collect (format nil "~S" i))
                                  (error (condition)
                                    (format nil "~A" condition)))))))
            (let ((ret (info-mode (expand-newline (append (ensure-list (format nil "> ~A" form))
                                                          (ensure-list printed-result)
                                                          (ensure-list result)))
                                  :width (- (xlib:screen-width *screen*) 2))))
              (when (or (search "defparameter" form :test #'string-equal)
                        (search "defvar" form :test #'string-equal))
                (let ((elem (split-string form)))
                  (pushnew (string-downcase (if (string= (first elem) "(") (third elem) (second elem)))
                           all-symbols :test #'string=)))
              (when (search "in-package" form :test #'string-equal)

                (let ((*notify-window-placement* 'middle-middle-root-placement))
                  (open-notify-window '("Collecting all symbols for Lisp REPL completion."))
                  (setf all-symbols (collect-all-symbols))
                  (close-notify-window)))

              (when ret
                (eval-from-query-string))))))))

(let ((commands (command-in-path)))

  (defun run-program-from-query-string ()
    "Run a program from the query input"

    (labels ((run-program-from-query-string-fun ()
               (multiple-value-bind (program return)
                   (query-string "Run:" "" commands)
                 (when (and (equal return :return) program (not (equal program "")))
                   (let ((cmd (concatenate 'string "cd $HOME && exec " program)))
                     (lambda ()
                       (do-shell cmd)))))))
      (let ((fun (run-program-from-query-string-fun)))
        (when fun
          (if *in-second-mode*
              (progn
                (setf *second-mode-leave-function* fun)
                (leave-second-mode))
              (funcall fun)))))))

;;; Frame name actions
(defun ask-frame-name (msg)
  "Ask a frame name"

  (let ((all-frame-name nil))

    (with-all-frames (*root-frame* frame)
      (awhen (frame-name frame) (push it all-frame-name)))

    (query-string msg "" all-frame-name)))

;;; Focus by functions
(defun focus-frame-by (frame)
  (when (frame-p frame)

    (focus-all-children frame (or (find-parent-frame frame (find-current-root))

				  (find-parent-frame frame)
				  *root-frame*))

    (show-all-children t)))

(defun focus-frame-by-name ()
  "Focus a frame by name"

  (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame:")))

  (leave-second-mode))

(defun focus-frame-by-number ()
  "Focus a frame by number"
  (focus-frame-by (find-frame-by-number (query-number "Focus frame by number:")))
  (leave-second-mode))


;;; Open by functions
(defun open-frame-by (frame)
  (when (frame-p frame)
    (push (create-frame :name (query-string "Frame name")) (frame-child frame))

    (show-all-children)))

(defun open-frame-by-name ()
  "Open a new frame in a named frame"

  (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in: ")))

  (leave-second-mode))

(defun open-frame-by-number ()
  "Open a new frame in a numbered frame"
  (open-frame-by (find-frame-by-number (query-number "Open a new frame in the group numbered:")))
  (leave-second-mode))


;;; Delete by functions
(defun delete-frame-by (frame)

  (unless (or (child-equal-p frame *root-frame*)

              (child-root-p frame))

    (when (child-equal-p frame (current-child))
      (setf (current-child) (find-current-root)))

    (remove-child-in-frame frame (find-parent-frame frame)))

  (show-all-children t))

(defun delete-frame-by-name ()
  "Delete a frame by name"

  (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame: ")))

  (leave-second-mode))

(defun delete-frame-by-number ()
  "Delete a frame by number"
  (delete-frame-by (find-frame-by-number (query-number "Delete frame by number:")))
  (leave-second-mode))


;;; Move by function

(defun move-child-to (child frame-dest)

  (when (and child (frame-p frame-dest))
    (remove-child-in-frame child (find-parent-frame child))
    (pushnew child (frame-child frame-dest))
    (focus-all-children child frame-dest)

    (show-all-children t)))

(defun move-current-child-by-name ()
  "Move current child in a named frame"

  (move-child-to (current-child)

		 (find-frame-by-name

		  (ask-frame-name (format nil "Move '~A' to frame: " (child-name (current-child))))))

  (leave-second-mode))

(defun move-current-child-by-number ()
  "Move current child in a numbered frame"

  (move-child-to (current-child)