Newer
Older
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Keys functions definition
;;; --------------------------------------------------------------------------
;;;
;;; (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 *fun-press* #'first)
(defparameter *fun-release* #'second)
Philippe Brochard
committed
Philippe Brochard
committed
(defun with-capslock ()
(pushnew :lock *default-modifiers*))
(defun without-capslock ()
(setf *default-modifiers* (remove :lock *default-modifiers*)))
(defun with-numlock ()
(pushnew :mod-2 *default-modifiers*))
(defun without-numlock ()
Philippe Brochard
committed
(setf *default-modifiers* (remove :mod-2 *default-modifiers*)))
Philippe Brochard
committed
Philippe Brochard
committed
(defmacro define-init-hash-table-key (hash-table name)
(let ((init-name (create-symbol "init-" (format nil "~A" hash-table))))
`(progn
(defun ,init-name ()
(setf ,hash-table (make-hash-table :test 'equal))
(setf (gethash 'name ,hash-table) ,name))
(,init-name))))
(define-init-hash-table-key *main-keys* "Main mode keys")
(define-init-hash-table-key *main-mouse* "Mouse buttons actions in main mode")
(define-init-hash-table-key *second-keys* "Second mode keys")
(define-init-hash-table-key *second-mouse* "Mouse buttons actions in second mode")
(define-init-hash-table-key *info-keys* "Info mode keys")
(define-init-hash-table-key *info-mouse* "Mouse buttons actions in info mode")
(define-init-hash-table-key *query-keys* "Query mode keys")
(define-init-hash-table-key *circulate-keys* "Circulate mode keys")
(define-init-hash-table-key *circulate-keys-release* "Circulate mode release keys")
Philippe Brochard
committed
(define-init-hash-table-key *expose-keys* "Expose windows mode keys")
(define-init-hash-table-key *expose-mouse* "Mouse buttons actions in expose windows mode")
Philippe Brochard
committed
(defun unalias-modifiers (list)
(dolist (mod *modifier-alias*)
(setf list (substitute (second mod) (first mod) list)))
list)
Philippe Brochard
committed
(defun key->list (key)
Philippe Brochard
committed
(list (first key) (modifiers->state (append (unalias-modifiers (rest key))
(unalias-modifiers *default-modifiers*)))))
(defmacro define-define-key (name hashtable)
(let ((name-key-fun (create-symbol "define-" name "-key-fun"))
(name-key (create-symbol "define-" name "-key"))
Philippe Brochard
committed
(undefine-name-fun (create-symbol "undefine-" name "-key-fun"))
(undefine-name (create-symbol "undefine-" name "-key"))
(undefine-multi-name (create-symbol "undefine-" name "-multi-keys")))
`(progn
Philippe Brochard
committed
(defun ,name-key-fun (key function &rest args)
Philippe Brochard
committed
"Define a new key, a key is '(char modifier1 modifier2...))"
(setf (gethash (key->list key) ,hashtable) (list function args)))
Philippe Brochard
committed
(defmacro ,name-key ((key &rest modifiers) function &rest args)
Philippe Brochard
committed
`(,',name-key-fun (list ,key ,@modifiers) ,function ,@args))
(defun ,undefine-name-fun (key)
"Undefine a new key, a key is '(char modifier1 modifier2...))"
(remhash (key->list key) ,hashtable))
Philippe Brochard
committed
(defmacro ,undefine-name ((key &rest modifiers))
Philippe Brochard
committed
`(,',undefine-name-fun (list ,key ,@modifiers)))
Philippe Brochard
committed
(defmacro ,undefine-multi-name (&rest keys)
`(progn
,@(loop for k in keys
collect `(,',undefine-name ,k)))))))
(defmacro define-define-mouse (name hashtable)
(let ((name-mouse-fun (create-symbol "define-" name "-fun"))
(name-mouse (create-symbol "define-" name))
(undefine-name (create-symbol "undefine-" name)))
`(progn
(defun ,name-mouse-fun (button function-press &optional function-release &rest args)
"Define a new mouse button action, a button is '(button number '(modifier list))"
Philippe Brochard
committed
(setf (gethash (key->list button) ,hashtable) (list function-press function-release args)))
(defmacro ,name-mouse ((button &rest modifiers) function-press &optional function-release &rest args)
Philippe Brochard
committed
`(,',name-mouse-fun (list ,button ,@modifiers) ,function-press ,function-release ,@args))
Philippe Brochard
committed
`(remhash (list ,key ,@modifiers) ,',hashtable)))))
(define-define-key "main" *main-keys*)
(define-define-key "second" *second-keys*)
(define-define-key "info" *info-keys*)
(define-define-key "query" *query-keys*)
(define-define-key "circulate" *circulate-keys*)
(define-define-key "circulate-release" *circulate-keys-release*)
Philippe Brochard
committed
(define-define-key "expose" *expose-keys*)
(define-define-mouse "main-mouse" *main-mouse*)
(define-define-mouse "second-mouse" *second-mouse*)
(define-define-mouse "info-mouse" *info-mouse*)
Philippe Brochard
committed
(define-define-mouse "expose-mouse" *expose-mouse*)
(defun add-in-state (state modifier)
"Add a modifier in a state"
(modifiers->state (append (state->modifiers state) (list modifier))))
(defmacro define-ungrab/grab (name function hashtable)
`(defun ,name ()
(maphash #'(lambda (k v)
(declare (ignore v))
(when (consp k)
(let* ((key (first k))
(modifiers (second k))
(keycode (typecase key
Philippe Brochard
committed
(character (multiple-value-list (char->keycode key)))
(number key)
(string (let* ((keysym (keysym-name->keysym key))
Philippe Brochard
committed
(ret-keycode (multiple-value-list
(xlib:keysym->keycodes *display* keysym))))
Philippe Brochard
committed
(let ((found nil))
(dolist (kc ret-keycode)
(when (= keysym (xlib:keycode->keysym *display* kc 0))
(setf found t)))
Philippe Brochard
committed
(unless found
(setf modifiers (add-in-state modifiers :shift))))
Philippe Brochard
committed
(if (consp keycode)
(dolist (kc (remove-duplicates keycode))
(,function *root* kc :modifiers modifiers))
(,function *root* keycode :modifiers modifiers))
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
(format t "~&Grabbing error: Can't find key '~A'~%" key)))
(error (c)
;;(declare (ignore c))
(format t "~&Grabbing error: Can't grab key '~A' (~A)~%" k c)))
(force-output)))
,hashtable)))
(define-ungrab/grab grab-main-keys xlib:grab-key *main-keys*)
(define-ungrab/grab ungrab-main-keys xlib:ungrab-key *main-keys*)
(defun find-key-from-code (hash-table-key code state)
"Return the function associated to code/state"
(labels ((function-from (key &optional (new-state state))
(multiple-value-bind (function foundp)
(gethash (list key new-state) hash-table-key)
(when (and foundp (first function))
function)))
(from-code ()
(function-from code))
(from-char ()
(let ((char (keycode->char code state)))
(function-from char)))
(from-string ()
(let ((string (keysym->keysym-name (xlib:keycode->keysym *display* code 0))))
(function-from string)))
(from-string-shift ()
(let* ((modifiers (state->modifiers state))
(string (keysym->keysym-name (keycode->keysym code modifiers))))
(function-from string)))
(from-string-no-shift ()
(let* ((modifiers (state->modifiers state))
(string (keysym->keysym-name (keycode->keysym code modifiers))))
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
(function-from string (modifiers->state (remove :shift modifiers))))))
(or (from-code) (from-char) (from-string) (from-string-shift) (from-string-no-shift))))
(defun funcall-key-from-code (hash-table-key code state &rest args)
(let ((function (find-key-from-code hash-table-key code state)))
(when function
(apply (first function) (append args (second function)))
t)))
(defun funcall-button-from-code (hash-table-key code state window root-x root-y
&optional (action *fun-press*) args)
(let ((state (modifiers->state (set-difference (state->modifiers state)
'(:button-1 :button-2 :button-3 :button-4 :button-5)))))
(multiple-value-bind (function foundp)
(gethash (list code state) hash-table-key)
(if (and foundp (funcall action function))
(progn
(apply (funcall action function) `(,window ,root-x ,root-y ,@(append args (third function))))
t)
nil))))
Philippe Brochard
committed
(defun binding-substitute-modifier (to from &optional (hashtables (list *main-keys* *main-mouse*
*second-keys* *second-mouse*
*info-keys* *info-mouse*
*query-keys*
*circulate-keys* *circulate-keys-release*
*expose-keys* *expose-mouse*)))
"Utility to change modifiers after binding definition"
(labels ((change (&optional (hashtable *main-keys*) to from)
(maphash (lambda (k v)
(when (consp k)
(let ((state (modifiers->state (substitute to from (state->modifiers (second k))))))
(remhash k hashtable)
(setf (gethash (list (first k) state) hashtable) v))))
hashtable)))
(dolist (h hashtables)
(change h to from))))
(defmacro define-keys ((mode) &body keys)
Philippe Brochard
committed
(let ((symbol (create-symbol "DEFINE-" mode "-KEY")))
`(progn
Philippe Brochard
committed
,@(loop for k in keys collect `(,symbol ,@k)))))
Philippe Brochard
committed
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
(defun find-associated-key-bindings (function)
"Return keys in main and second mode bounds to function"
(labels ((key-string (hash)
(let ((binding (or (find-in-hash function hash)
(search-in-hash function hash))))
(when binding
(let ((key (first binding))
(modifier (and (second binding) (state->modifiers (second binding)))))
(with-output-to-string (str)
(when key
(dolist (mod modifier)
(format str "~A-" (cond
((string-equal mod "MOD-1") "M")
((string-equal mod "CONTROL") "C")
((string-equal mod "SHIFT") "S")
(t mod))))
(format str "~A" key))))))))
(let ((main-string (key-string *main-keys*))
(second-string (key-string *second-keys*)))
(if (or main-string second-string)
(if (string-equal main-string second-string)
(format nil "[~A]" main-string)
(format nil "[~A|~A]" (or main-string "-") (or second-string "-")))
""))))