[STUMP] Mouse mode first shoot

[Philippe Brochard]

Hi everyboy,

Here is a first shoot for the mouse mode :)

I've tried to keep the stumpwm way. So you define commands as usual
with define-stumpwm-command.
Then you can bind them to a button event with define-mouse (see
below).

My default binding is as follow:

button 1: leave the mouse mode and focus the frame under the pointer
button 2: idem but maximize the frame after leaving

Control + button 1: first click select a window
                    second click move the selected window in frame
                    under the pointer
button 4/5  (mouse wheel): focus previous/next window in the frame
                    under the pointer.

Shift button 2: split horizontally the frame under the pointer
Alt button 2: split vertically the frame under the pointer
Shift button 2: remove the split in the frame under the pointer

And so on.

I haven't try this a lot, so maybe I'll rebind the default binding.

And maybe you'll fall in love again with you mouse :)

For me, icewm, sawfish and fvwm are FAR FAR away from stumpwm !!!





-- mouse.lisp --------------------------------------------------------
(in-package :stumpwm)

(defstruct mouse-event button state root-x root-y)

;;; This is a little bit uggly but this prevent to redefine all the 
;;; interactive-command way.
(defvar *current-mouse-event* nil)  

(defvar *ignore-next-mouse-event* nil)

(defvar *frame-number-wins* nil)

;;; Little helpers
(defun define-mouse (map button command)
  (define-key map button command))

(defun button (buttons)
  (kbd buttons))


;;; Default binding
(defparameter *mouse-map*
  (let ((m (make-sparse-keymap)))
    (define-mouse m (button "1") "leave-mouse-mode")
    (define-mouse m (button "3") "leave-mouse-mode-and-maximize")
    (define-mouse m (button "C-1") "select-or-move-window")
    (define-mouse m (button "4") "wheel-prev-window")
    (define-mouse m (button "5") "wheel-next-window")
    (define-mouse m (button "S-2") "mouse-h-split")
    (define-mouse m (button "A-2") "mouse-v-split")
    (define-mouse m (button "C-2") "mouse-remove-split")
    m))

(define-key *root-map* (kbd "x") "mouse-mode")


(define-stumpwm-command "mouse-mode" (screen)
  (mouse-mode screen))


;;; If command return t we leave mouse-mode, else we stay in it
(define-stumpwm-command "leave-mouse-mode" (screen)
  (focus-frame screen (find-frame-under-cursor screen *current-mouse-event*))
  t)

(define-stumpwm-command "leave-mouse-mode-and-maximize" (screen)
  (let ((frame (find-frame-under-cursor screen *current-mouse-event*)))
    (focus-frame screen frame)
    (maximize-frame screen frame))
  t)


(define-stumpwm-command "wheel-prev-window" (screen)
  (focus-frame screen (find-frame-under-cursor screen *current-mouse-event*))
  (focus-prev-window screen)
  (when *ignore-next-mouse-event*
    (read-mouse))
  (display-frame-numbers screen)
  nil)

(define-stumpwm-command "wheel-next-window" (screen)
  (focus-frame screen (find-frame-under-cursor screen *current-mouse-event*))
  (focus-next-window screen)
  (when *ignore-next-mouse-event*
    (read-mouse))
  (display-frame-numbers screen)
  nil)



;; First clic: select the window under the pointer
;; Second clic: move the selected window in frame under the pointer
(let ((current-window nil))
  (define-stumpwm-command "select-or-move-window" (screen)
    (let ((frame (find-frame-under-cursor screen *current-mouse-event*)))
      (if current-window
          (progn
            (setf (window-frame screen current-window) frame)
            (sync-frame-windows screen frame)
            (frame-raise-window screen frame current-window)
            (setf current-window nil))
          (setf current-window (first (frame-windows screen frame)))))
    (display-frame-numbers screen)
    nil))



(define-stumpwm-command "mouse-h-split" (screen)
  (focus-frame screen (find-frame-under-cursor screen *current-mouse-event*))
  (split-frame screen (lambda (f) (split-frame-h screen f)))
  (display-frame-numbers screen)
  nil)

(define-stumpwm-command "mouse-v-split" (screen)
  (focus-frame screen (find-frame-under-cursor screen *current-mouse-event*))
  (split-frame screen (lambda (f) (split-frame-v screen f)))
  (display-frame-numbers screen)
  nil)

(define-stumpwm-command "mouse-remove-split" (screen)
  (focus-frame screen (find-frame-under-cursor screen *current-mouse-event*))
  (remove-split screen)
  (display-frame-numbers screen)
  nil)




;;; Main code begin here


(defun find-frame-under-cursor (screen event)
  (mapc (lambda (f)
          (when (and (<= (frame-x f)
                         (mouse-event-root-x event)
                         (+ (frame-x f) (frame-width f)))
                     (<= (frame-y f)
                         (mouse-event-root-y event)
                         (+ (frame-y f) (frame-height f))))
            (return-from find-frame-under-cursor f)))
        (screen-frames screen)))


;;; Maybe an additional cursor font parameter and event-mask
;;; in grab-pointer in core.lisp is a better way.
(defun mouse-grab-pointer (screen)
  "Grab the pointer and set the pointer shape."
  (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
         (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0))
         (cursor-font (xlib:open-font *display* "cursor"))
         (cursor (xlib:create-glyph-cursor :source-font cursor-font
                                           :source-char 20
                                           :mask-font cursor-font
                                           :mask-char 65
                                           :foreground black
                                           :background white)))
    (xlib:grab-pointer (xlib:screen-root (screen-number screen))
                       (xlib:make-event-mask :button-press)
                       :owner-p nil
                       :cursor cursor)))



(defun mouse-handle-event (&rest event-slots &key display event-key 
&allow-other-keys)
  (declare (ignorable display))
  (labels ((button-press (&rest event-slots &key root code state root-x root-y 
&allow-other-keys)
             (declare (ignorable event-slots))
             (declare (ignorable root))
             (make-mouse-event :button code :state state :root-x root-x :root-y 
root-y)))
    (case event-key
      (:button-press
       (apply #'button-press event-slots))
      (t nil))))

(defun read-mouse ()
  "Return a mouse-event structure"
  (do ((ret nil (xlib:process-event *display* :handler #'mouse-handle-event 
:timeout nil)))
      (ret ret)))


(defun mouse-event->key (event)
  (let ((mods (xlib:make-state-keys (mouse-event-state event))))
    (make-key :char (char-code (character (format nil "~A" (mouse-event-button 
event))))
              :control (and (find :control mods) t)
              :shift (and (find :shift mods) t)
              :alt (or (and (find :alt mods) t)
                       (and (find :mod-1 mods) t)))))
                          

(defun mouse-interactive-command (cmd screen)
  "exec cmd and return the result."
  (let ((result (handler-case (parse-and-run-command cmd screen)
                              (error (c)
                                     (format nil "~A" c)))))
    (when (stringp result)
      (echo-string screen result))
    result))


(defun analyse-mouse-event (screen event)
  (setf *current-mouse-event* event)
  (let ((cmd (lookup-key *mouse-map* (mouse-event->key event))))
    (when cmd
      (prog1
          (mouse-interactive-command cmd screen)
        (setf *current-mouse-event* nil)))))


(defun display-frame-numbers (screen)
  (hide-frame-numbers)
  (setf *frame-number-wins* (draw-frame-numbers screen)))

(defun hide-frame-numbers ()
  (mapc #'xlib:destroy-window *frame-number-wins*)
  (setf *frame-number-wins* nil))

(defun mouse-mode (screen)
  (minimize-frame screen)
  (mouse-grab-pointer screen)
  (display-frame-numbers screen)
  (do ((ret (read-mouse) (read-mouse)))
      ((analyse-mouse-event screen ret)))
  (hide-frame-numbers)
  (ungrab-pointer))
----------------------------------------------------------------------

Philippe

-- 
Philippe Brochard    <address@hidden>
                      http://hocwp.free.fr

-=-= http://www.gnu.org/home.fr.html =-=-