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

(defparameter *circulate-window* nil)
(defparameter *circulate-font* nil)
(defparameter *circulate-gc* nil)

(defparameter *circulate-hit* 0)
(defparameter *circulate-orig* nil)
(defparameter *circulate-parent* nil)

(defun draw-circulate-mode-window ()
  (raise-window *circulate-window*)
  (clear-pixmap-buffer *circulate-window* *circulate-gc*)

  (let* ((text (format nil "~A [~A]"
		       (limit-length (ensure-printable (child-name (xlib:input-focus *display*)))
				     *circulate-text-limite*)

		       (limit-length (ensure-printable (child-name (current-child)))

				     *circulate-text-limite*)))

	 (len (length text)))
    (xlib:draw-glyphs *pixmap-buffer* *circulate-gc*
		      (truncate (/ (- *circulate-width* (* (xlib:max-char-width *circulate-font*) len)) 2))
		      (truncate (/ (+ *circulate-height* (- (xlib:font-ascent *circulate-font*) (xlib:font-descent *circulate-font*))) 2))
		      text))
  (copy-pixmap-buffer *circulate-window* *circulate-gc*))



(defun leave-circulate-mode ()
  "Leave the circulate mode"
  (throw 'exit-circulate-loop nil))

(defun reset-circulate-child ()
  (setf *circulate-hit* 0
	*circulate-parent* nil

	*circulate-orig* (frame-child (current-child))))

(defun reset-circulate-brother ()

  (setf *circulate-parent* (find-parent-frame (current-child))

        *circulate-hit* 0)

  (when (frame-p *circulate-parent*)
    (setf *circulate-orig* (frame-child *circulate-parent*))))

(defun reorder-child (direction)

  (no-focus)

  (with-slots (child selected-pos) (current-child)

    (unless *circulate-orig*
      (reset-circulate-child))

    (let ((len (length *circulate-orig*)))
      (when (plusp len)
	(let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*)))

	  (setf child (cons elem (child-remove elem *circulate-orig*))
                selected-pos 0)))

      (show-all-children)
      (draw-circulate-mode-window))))

(defun reorder-brother (direction)

  (no-focus)

  (let ((old-child (current-child)))

    (select-current-frame nil)

    (unless (and *circulate-orig* *circulate-parent*)
      (reset-circulate-brother))

    (let ((len (length *circulate-orig*)))
      (when (plusp len)

	(when (frame-p *circulate-parent*)

	  (let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*)))

	    (setf (frame-child *circulate-parent*) (cons elem (child-remove elem *circulate-orig*))

                  (frame-selected-pos *circulate-parent*) 0

		  (current-child) (frame-selected-child *circulate-parent*))))
        (when (and (not (child-root-p (current-child)))

                   (child-root-p old-child))

          (change-root (find-root old-child) (current-child)))))

    (show-all-children t)

    (draw-circulate-mode-window)))

(defun reorder-subchild (direction)
  (declare (ignore direction))

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

      (when (frame-p selected-child)
	(no-focus)

	(with-slots (child selected-pos) selected-child

	  (let ((elem (first (last child))))

            (when elem
              (setf child (cons elem (child-remove elem child))
                    selected-pos 0))
            (show-all-children)

	    (draw-circulate-mode-window)))))))

(defun circulate-select-next-child ()
  "Select the next child"

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

    (when *circulate-parent*
      (reset-circulate-child))
    (reorder-child +1)))

(defun circulate-select-previous-child ()
  "Select the previous child"

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

    (when *circulate-parent*
      (reset-circulate-child))
    (reorder-child -1)))


(defun circulate-select-next-brother ()
  "Select the next brother"
  (unless *circulate-parent*
    (reset-circulate-brother))
  (reorder-brother +1))

(defun circulate-select-previous-brother ()
  "Select the previous borther"
  (unless *circulate-parent*
    (reset-circulate-brother))
  (reorder-brother -1))

(defun circulate-select-next-subchild ()
  "Select the next subchild"
  (reorder-subchild +1))

(add-hook *binding-hook* 'set-default-circulate-keys)

(defun set-default-circulate-keys ()
  (define-circulate-key ("Escape") 'leave-circulate-mode)

  (define-circulate-key ("g" :control) 'leave-circulate-mode)
  (define-circulate-key ("Escape" :alt) 'leave-circulate-mode)
  (define-circulate-key ("g" :control :alt) 'leave-circulate-mode)

  (define-circulate-key ("Tab" :mod-1) 'circulate-select-next-child)

  (define-circulate-key ("Tab" :mod-1 :control) 'circulate-select-next-subchild)

  (define-circulate-key ("Tab" :mod-1 :shift) 'circulate-select-previous-child)

  (define-circulate-key ("Iso_Left_Tab" :mod-1 :shift) 'circulate-select-previous-child)

  (define-circulate-key ("Right" :mod-1) 'circulate-select-next-brother)
  (define-circulate-key ("Left" :mod-1) 'circulate-select-previous-brother)

  (define-circulate-release-key ("Alt_L" :alt) 'leave-circulate-mode)
  (define-circulate-release-key ("Alt_L") 'leave-circulate-mode))

(defun circulate-leave-function ()

  (when *circulate-gc*
    (xlib:free-gcontext *circulate-gc*))

  (when *circulate-window*
    (xlib:destroy-window *circulate-window*))
  (when *circulate-font*
    (xlib:close-font *circulate-font*))
  (setf *circulate-window* nil

	*circulate-gc* nil

	*circulate-font* nil)
  (xlib:display-finish-output *display*))

(defun circulate-loop-function ()

  (unless (is-a-key-pressed-p)
    (leave-circulate-mode)))

(define-handler circulate-mode :key-press (code state)

  (unless (funcall-key-from-code *circulate-keys* code state)
    (setf *circulate-hit* 0
	  *circulate-orig* nil
	  *circulate-parent* nil)
    (funcall-key-from-code *main-keys* code state)))

(define-handler circulate-mode :key-release (code state)

  (funcall-key-from-code *circulate-keys-release* code state))

(defun circulate-mode (&key child-direction brother-direction subchild-direction)

  (setf *circulate-hit* 0)

  (with-placement (*circulate-mode-placement* x y *circulate-width* *circulate-height*)
    (setf *circulate-font* (xlib:open-font *display* *circulate-font-string*)
	  *circulate-window* (xlib:create-window :parent *root*
						 :x x
						 :y y
						 :width *circulate-width*
						 :height *circulate-height*
						 :background (get-color *circulate-background*)

						 :border-width *border-size*

						 :border (get-color *circulate-border*)
						 :colormap (xlib:screen-default-colormap *screen*)
						 :event-mask '(:exposure :key-press))
	  *circulate-gc* (xlib:create-gcontext :drawable *circulate-window*
					       :foreground (get-color *circulate-foreground*)

					       :background (get-color *circulate-background*)

					       :font *circulate-font*
					       :line-style :solid))

    (setf (window-transparency *circulate-window*) *circulate-transparency*)

    (map-window *circulate-window*)
    (draw-circulate-mode-window)
    (when child-direction
      (reorder-child child-direction))
    (when brother-direction
      (reorder-brother brother-direction))

    (when subchild-direction
      (reorder-subchild subchild-direction))

    (with-grab-keyboard-and-pointer (92 93 66 67 t)

      (generic-mode 'circulate-mode 'exit-circulate-loop

                    :loop-function #'circulate-loop-function
                    :leave-function #'circulate-leave-function
                    :original-mode '(main-mode))
      (circulate-leave-function))))

(defun select-next-child ()
  "Select the next child"

  (when (frame-p (current-child))
    (setf *circulate-orig* (frame-child (current-child))

	  *circulate-parent* nil)
    (circulate-mode :child-direction +1)))

(defun select-previous-child ()

  "Select the previous child"

  (when (frame-p (current-child))
    (setf *circulate-orig* (frame-child (current-child))

	  *circulate-parent* nil)
    (circulate-mode :child-direction -1)))


(defun select-next-brother ()
  "Select the next brother"

  (setf *circulate-parent* (find-parent-frame (current-child)))

  (when (frame-p *circulate-parent*)
    (setf *circulate-orig* (frame-child *circulate-parent*)))
  (circulate-mode :brother-direction +1))

(defun select-previous-brother ()
  "Select the previous brother"

  (setf *circulate-parent* (find-parent-frame (current-child)))

  (when (frame-p *circulate-parent*)
    (setf *circulate-orig* (frame-child *circulate-parent*)))
  (circulate-mode :brother-direction -1))

(defmacro with-move-current-focused-window (() &body body)
  (let ((window (gensym)))
    `(with-focus-window (,window)
       ,@body
       (move-child-to ,window (if (frame-p (current-child))
                                  (current-child)
                                  (find-parent-frame (current-child) (find-current-root)))))))



(defun select-next-brother-take-current ()
  "Select the next brother and move the current focused child in it"
  (with-move-current-focused-window ()
    (select-next-brother)))

(defun select-previous-brother-take-current ()
  "Select the previous brother and move the current focused child in it"
  (with-move-current-focused-window ()
    (select-previous-brother)))

(defun select-next-subchild ()
  "Select the next subchild"

  (when (and (frame-p (current-child))
	     (frame-p (frame-selected-child (current-child))))
    (setf *circulate-orig* (frame-child (current-child))

	  *circulate-parent* nil)
    (circulate-mode :subchild-direction +1)))

(defun select-next-child-simple ()
  "Select the next child (do not enter in circulate mode)"

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

      (setf child (rotate-list child)))
    (show-all-children)))

(defun select-previous-child-simple ()
  "Select the previous child (do not enter circulate mode)"
  (when (frame-p (current-child))
    (with-slots (child) (current-child)
      (setf child (anti-rotate-list child)))
    (show-all-children)))

(defun reorder-brother-simple (reorder-fun)

  (unless (child-root-p (current-child))

    (no-focus)
    (select-current-frame nil)

    (let ((parent-frame (find-parent-frame (current-child))))

      (when (frame-p parent-frame)
        (with-slots (child) parent-frame
          (setf child (funcall reorder-fun child)

                (current-child) (frame-selected-child parent-frame))))

      (show-all-children t))))


(defun select-next-brother-simple ()
  "Select the next brother frame (do not enter in circulate mode)"
  (reorder-brother-simple #'rotate-list))

(defun select-previous-brother-simple ()
  "Select the previous brother frame (do not enter in circulate mode)"
  (reorder-brother-simple #'anti-rotate-list))

;;; Spatial move functions
(defun select-brother-generic-spatial-move (fun-found)
  "Select the nearest brother of the current child based on the fun-found function"

  (let ((is-root-p (child-root-p (current-child))))

    (when is-root-p

      (leave-frame)
      (sleep *spatial-move-delay-before*))
    (no-focus)
    (select-current-frame nil)

    (let ((parent-frame (find-parent-frame (current-child))))

      (when (frame-p parent-frame)
        (with-slots (child selected-pos) parent-frame
          (let ((found nil)
                (found-dist nil))
            (dolist (c child)

              (let ((dist (funcall fun-found (current-child) c)))

                (when (and dist

                           (not (child-equal-p (current-child) c))

                           (or (not found)
                               (and found-dist (< dist found-dist))))
                  (setf found c
                        found-dist dist))))
            (when found

              (setf (current-child) found

                    selected-pos 0
                    child (cons found (child-remove found child)))))))
      (show-all-children t)

      (when is-root-p

        (sleep *spatial-move-delay-after*)
        (enter-frame)))))



(defun select-brother-spatial-move-right ()
  "Select spatially the nearest brother of the current child in the right direction"
  (select-brother-generic-spatial-move #'(lambda (current child)
                                           (when (> (child-x2 child) (child-x2 current))
                                             (distance (child-x2 current) (middle-child-y current)
                                                       (child-x child) (middle-child-y child))))))



(defun select-brother-spatial-move-left ()
  "Select spatially the nearest brother of the current child in the left direction"
  (select-brother-generic-spatial-move #'(lambda (current child)
                                           (when (< (child-x child) (child-x current))
                                             (distance (child-x current) (middle-child-y current)
                                                       (child-x2 child) (middle-child-y child))))))


(defun select-brother-spatial-move-down ()
  "Select spatially the nearest brother of the current child in the down direction"
  (select-brother-generic-spatial-move #'(lambda (current child)
                                           (when (> (child-y2 child) (child-y2 current))
                                             (distance (middle-child-x current) (child-y2 current)
                                                       (middle-child-x child) (child-y child))))))


(defun select-brother-spatial-move-up ()
  "Select spatially the nearest brother of the current child in the up direction"
  (select-brother-generic-spatial-move #'(lambda (current child)
                                           (when (< (child-y child) (child-y current))
                                             (distance (middle-child-x current) (child-y current)
                                                       (middle-child-x child) (child-y2 child))))))