src/clfswm-keys.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Keys functions definition
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software
  22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26 (in-package :clfswm)
  27
  28
  29 (defparameter *fun-press* #'first)
  30 (defparameter *fun-release* #'second)
  31
  32
  33
  34 (defun with-capslock ()
  35   (pushnew :lock *default-modifiers*))
  36
  37 (defun without-capslock ()
  38   (setf *default-modifiers* (remove :lock *default-modifiers*)))
  39
  40 (defun with-numlock ()
  41   (pushnew :mod-2 *default-modifiers*))
  42
  43 (defun without-numlock ()
  44   (setf *default-modifiers* (remove :mod-2 *default-modifiers*)))
  45
  46
  47
  48 ;;; CONFIG - Key mode names
  49 (defmacro define-init-hash-table-key (hash-table name)
  50   (let ((init-name (create-symbol "init-" (format nil "~A" hash-table))))
  51     `(progn
  52       (defun ,init-name ()
  53         (setf ,hash-table (make-hash-table :test 'equal))
  54         (setf (gethash 'name ,hash-table) ,name))
  55       (,init-name))))
  56
  57 (define-init-hash-table-key *main-keys* "Main mode keys")
  58 (define-init-hash-table-key *main-mouse* "Mouse buttons actions in main mode")
  59 (define-init-hash-table-key *second-keys* "Second mode keys")
  60 (define-init-hash-table-key *second-mouse* "Mouse buttons actions in second mode")
  61 (define-init-hash-table-key *info-keys* "Info mode keys")
  62 (define-init-hash-table-key *info-mouse* "Mouse buttons actions in info mode")
  63 (define-init-hash-table-key *query-keys* "Query mode keys")
  64
  65 (define-init-hash-table-key *circulate-keys* "Circulate mode keys")
  66 (define-init-hash-table-key *circulate-keys-release* "Circulate mode release keys")
  67
  68 (define-init-hash-table-key *expose-keys* "Expose windows mode keys")
  69 (define-init-hash-table-key *expose-mouse* "Mouse buttons actions in expose windows mode")
  70
  71 (defun unalias-modifiers (list)
  72   (dolist (mod *modifier-alias*)
  73     (setf list (substitute (second mod) (first mod) list)))
  74   list)
  75
  76 (defun key->list (key)
  77   (list (first key) (modifiers->state (append (unalias-modifiers (rest key))
  78                                               (unalias-modifiers *default-modifiers*)))))
  79
  80 (defmacro define-define-key (name hashtable)
  81   (let ((name-key-fun (create-symbol "define-" name "-key-fun"))
  82         (name-key (create-symbol "define-" name "-key"))
  83         (undefine-name-fun (create-symbol "undefine-" name "-key-fun"))
  84         (undefine-name (create-symbol "undefine-" name "-key"))
  85         (undefine-multi-name (create-symbol "undefine-" name "-multi-keys")))
  86     `(progn
  87       (defun ,name-key-fun (key function &rest args)
  88         "Define a new key, a key is '(char modifier1 modifier2...))"
  89         (setf (gethash (key->list key) ,hashtable) (list function args)))
  90       (defmacro ,name-key ((key &rest modifiers) function &rest args)
  91         `(,',name-key-fun (list ,key ,@modifiers) ,function ,@args))
  92       (defun ,undefine-name-fun (key)
  93         "Undefine a new key, a key is '(char modifier1 modifier2...))"
  94         (remhash (key->list key) ,hashtable))
  95       (defmacro ,undefine-name ((key &rest modifiers))
  96         `(,',undefine-name-fun (list ,key ,@modifiers)))
  97       (defmacro ,undefine-multi-name (&rest keys)
  98         `(progn
  99           ,@(loop for k in keys
 100                   collect `(,',undefine-name ,k)))))))
 101
 102
 103 (defmacro define-define-mouse (name hashtable)
 104   (let ((name-mouse-fun (create-symbol "define-" name "-fun"))
 105         (name-mouse (create-symbol "define-" name))
 106         (undefine-name (create-symbol "undefine-" name)))
 107     `(progn
 108        (defun ,name-mouse-fun (button function-press &optional function-release &rest args)
 109          "Define a new mouse button action, a button is '(button number '(modifier list))"
 110          (setf (gethash (key->list button) ,hashtable) (list function-press function-release args)))
 111        (defmacro ,name-mouse ((button &rest modifiers) function-press &optional function-release &rest args)
 112          `(,',name-mouse-fun (list ,button ,@modifiers) ,function-press ,function-release ,@args))
 113        (defmacro ,undefine-name ((key &rest modifiers))
 114          `(remhash (list ,key ,@modifiers) ,',hashtable)))))
 115
 116
 117
 118 (define-define-key "main" *main-keys*)
 119 (define-define-key "second" *second-keys*)
 120 (define-define-key "info" *info-keys*)
 121 (define-define-key "query" *query-keys*)
 122
 123 (define-define-key "circulate" *circulate-keys*)
 124 (define-define-key "circulate-release" *circulate-keys-release*)
 125
 126 (define-define-key "expose" *expose-keys*)
 127
 128 (define-define-mouse "main-mouse" *main-mouse*)
 129 (define-define-mouse "second-mouse" *second-mouse*)
 130 (define-define-mouse "info-mouse" *info-mouse*)
 131 (define-define-mouse "expose-mouse" *expose-mouse*)
 132
 133
 134
 135
 136
 137
 138 (defun add-in-state (state modifier)
 139   "Add a modifier in a state"
 140   (modifiers->state (append (state->modifiers state) (list modifier))))
 141
 142 (defmacro define-ungrab/grab (name function hashtable)
 143   `(defun ,name ()
 144      (maphash #'(lambda (k v)
 145                   (declare (ignore v))
 146                   (when (consp k)
 147                     (handler-case
 148                         (let* ((key (first k))
 149                                (modifiers (second k))
 150                                (keycode (typecase key
 151                                           (character (multiple-value-list (char->keycode key)))
 152                                           (number key)
 153                                           (string (let* ((keysym (keysym-name->keysym key))
 154                                                          (ret-keycode (multiple-value-list (xlib:keysym->keycodes *display* keysym))))
 155                                                     (let ((found nil))
 156                                                       (dolist (kc ret-keycode)
 157                                                         (when (= keysym (xlib:keycode->keysym *display* kc 0))
 158                                                           (setf found t)))
 159                                                       (unless found
 160                                                         (setf modifiers (add-in-state modifiers :shift))))
 161                                                     ret-keycode)))))
 162                           (if keycode
 163                               (if (consp keycode)
 164                                   (dolist (kc (remove-duplicates keycode))
 165                                     (,function *root* kc :modifiers modifiers))
 166                                   (,function *root* keycode :modifiers modifiers))
 167                               (format t "~&Grabbing error: Can't find key '~A'~%" key)))
 168                       (error (c)
 169                         ;;(declare (ignore c))
 170                         (format t "~&Grabbing error: Can't grab key '~A' (~A)~%" k c)))
 171                     (force-output)))
 172               ,hashtable)))
 173
 174 (define-ungrab/grab grab-main-keys xlib:grab-key *main-keys*)
 175 (define-ungrab/grab ungrab-main-keys xlib:ungrab-key *main-keys*)
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186 (defun find-key-from-code (hash-table-key code state)
 187   "Return the function associated to code/state"
 188   (labels ((function-from (key &optional (new-state state))
 189              (multiple-value-bind (function foundp)
 190                  (gethash (list key new-state) hash-table-key)
 191                (when (and foundp (first function))
 192                  function)))
 193            (from-code ()
 194              (function-from code))
 195            (from-char ()
 196              (let ((char (keycode->char code state)))
 197                (function-from char)))
 198            (from-string ()
 199              (let ((string (keysym->keysym-name (xlib:keycode->keysym *display* code 0))))
 200                (function-from string)))
 201            (from-string-shift ()
 202              (let* ((modifiers (state->modifiers state))
 203                     (string (keysym->keysym-name (keycode->keysym code modifiers))))
 204                (function-from string)))
 205            (from-string-no-shift ()
 206              (let* ((modifiers (state->modifiers state))
 207                     (string (keysym->keysym-name (keycode->keysym code modifiers))))
 208                (function-from string (modifiers->state (remove :shift modifiers))))))
 209     (or (from-code) (from-char) (from-string) (from-string-shift) (from-string-no-shift))))
 210
 211
 212
 213 (defun funcall-key-from-code (hash-table-key code state &rest args)
 214   (let ((function (find-key-from-code hash-table-key code state)))
 215     (when function
 216       (apply (first function) (append args (second function)))
 217       t)))
 218
 219
 220 (defun funcall-button-from-code (hash-table-key code state window root-x root-y
 221                                  &optional (action *fun-press*) args)
 222   (let ((state (modifiers->state (set-difference (state->modifiers state)
 223                                                  '(:button-1 :button-2 :button-3 :button-4 :button-5)))))
 224     (multiple-value-bind (function foundp)
 225         (gethash (list code state) hash-table-key)
 226       (if (and foundp (funcall action function))
 227           (progn
 228             (apply (funcall action function) `(,window ,root-x ,root-y ,@(append args (third function))))
 229             t)
 230           nil))))
 231
 232
 233
 234
 235 (defun binding-substitute-modifier (to from &optional (hashtables (list *main-keys* *main-mouse*
 236                                                                         *second-keys* *second-mouse*
 237                                                                         *info-keys* *info-mouse*
 238                                                                         *query-keys*
 239                                                                         *circulate-keys* *circulate-keys-release*
 240                                                                         *expose-keys* *expose-mouse*)))
 241   "Utility to change modifiers after binding definition"
 242   (labels ((change (&optional (hashtable *main-keys*) to from)
 243              (maphash (lambda (k v)
 244                         (when (consp k)
 245                           (let ((state (modifiers->state (substitute to from (state->modifiers (second k))))))
 246                             (remhash k hashtable)
 247                             (setf (gethash (list (first k) state) hashtable) v))))
 248                       hashtable)))
 249     (dolist (h hashtables)
 250       (change h to from))))
 251
 252
 253 (defmacro define-keys ((mode) &body keys)
 254   (let ((symbol (create-symbol "DEFINE-" mode "-KEY")))
 255     `(progn
 256        ,@(loop for k in keys collect `(,symbol ,@k)))))
 257
 258
 259 (defun find-associated-key-bindings (function)
 260   "Return keys in main and second mode bounds to function"
 261   (labels ((key-string (hash)
 262              (let ((binding (or (find-in-hash function hash)
 263                                 (search-in-hash function hash))))
 264                (when binding
 265                  (let ((key (first binding))
 266                        (modifier (and (second binding) (state->modifiers (second binding)))))
 267                    (with-output-to-string (str)
 268                      (when key
 269                        (dolist (mod modifier)
 270                          (format str "~A-" (cond
 271                                              ((string-equal mod "MOD-1") "M")
 272                                              ((string-equal mod "CONTROL") "C")
 273                                              ((string-equal mod "SHIFT") "S")
 274                                              (t mod))))
 275                        (format str "~A" key))))))))
 276     (let ((main-string (key-string *main-keys*))
 277           (second-string (key-string *second-keys*)))
 278       (if (or main-string second-string)
 279           (if (string-equal main-string second-string)
 280               (format nil "[~A]" main-string)
 281               (format nil "[~A|~A]" (or main-string "-") (or second-string "-")))
 282           ""))))
 283
 284
 285