1;; decode-events.jl -- symbolic event manipulation
2
3;; Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
4
5;; This file is part of sawfish.
6
7;; sawfish is free software; you can redistribute it and/or modify it
8;; under the terms of the GNU General Public License as published by
9;; the Free Software Foundation; either version 2, or (at your option)
10;; any later version.
11
12;; sawfish is distributed in the hope that it will be useful, but
13;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with sawfish; see the file COPYING.  If not, write to
19;; the Free Software Foundation, 51 Franklin Street, Fifth Floor,
20;; Boston, MA 02110-1301 USA.
21
22(define-structure sawfish.wm.util.decode-events
23
24    (export decode-modifier
25	    encode-modifier
26	    substitute-wm-modifier
27	    decode-event
28	    encode-event
29	    string->keysym
30	    modifier->keysyms
31	    modifier-keysym-p
32	    should-grab-button-event-p)
33
34    (open rep
35	  sawfish.wm.events)
36
37  (define-structure-alias decode-events sawfish.wm.util.decode-events)
38
39  (define (decode-modifier mods)
40    (let ((out '()))
41      (do ((i 0 (1+ i)))
42	  ((= i 13))
43	(when (not (zerop (logand mods (lsh 1 i))))
44	  (setq out (cons (aref [shift lock control mod-1 mod-2
45				       mod-3 mod-4 mod-5 button-1
46				       button-2 button-3 button-4
47				       button-5] i) out))))
48      (when (not (zerop (logand mods (lsh 1 20))))
49	(setq out (cons 'meta out)))
50      (when (not (zerop (logand mods (lsh 1 21))))
51	(setq out (cons 'alt out)))
52      (when (not (zerop (logand mods (lsh 1 24))))
53	(setq out (cons 'hyper out)))
54      (when (not (zerop (logand mods (lsh 1 25))))
55	(setq out (cons 'super out)))
56      (when (not (zerop (logand mods (lsh 1 26))))
57	(setq out (cons 'wm out)))
58      (when (not (zerop (logand mods (lsh 1 22))))
59	(setq out (cons 'any out)))
60      (when (not (zerop (logand mods (lsh 1 23))))
61	(setq out (cons 'release out)))
62      out))
63
64  (define (encode-modifier in)
65    (let ((encode-mod-map '((shift . 1) (lock . 2)
66			    (control . 4) (mod-1 . 8)
67			    (mod-2 . 16) (mod-3 . 32) (mod-4 . 64)
68			    (mod-5 . 128) (button-1 . 256)
69			    (button-2 . 512) (button-3 . 1024)
70			    (button-4 . 2048) (button-5 . 4096)
71			    (meta . #x100000) (alt . #x200000)
72			    (hyper . #x1000000) (super . #x2000000)
73			    (wm . #x4000000) (any . #x400000)
74			    (release . #x800000))))
75
76      (apply + (mapcar (lambda (m)
77			 (cdr (assq m encode-mod-map))) in))))
78
79  (define (substitute-wm-modifier event)
80    (if (/= (logand (cdr event) #x04000000) 0)
81	(cons (car event) (logior (wm-modifier) (logand (cdr event)
82							(lognot #x04000000))))
83      event))
84
85  (define (decode-event event)
86    "Return a symbol description of the low-level event structure
87EVENT (a cons cell). The symbolic description has the form `(TYPE
88MODIFIER-LIST ACTION)'."
89    (let* ((code (car event))
90	   (mods (cdr event)))
91
92      (cond ((not (zerop (logand mods (lsh 1 16))))
93	     ;; keyboard event
94	     (list 'key (decode-modifier mods) (x-keysym-name code)))
95	    ((not (zerop (logand mods (lsh 1 17))))
96	     ;; mouse event
97	     (list 'mouse (decode-modifier mods)
98		   (aref [click-1 click-2 move off-1 click-3 off-2 off-3]
99			 (1- code))))
100	    (t (error "Unknown event type")))))
101
102  (define (encode-event event)
103    "Return the low-level event structure (cons cell) representing the
104symbolic event description EVENT, a list `(TYPE MODIFIER-LIST
105ACTION)'."
106    (let* ((code 0)
107	   (mods (encode-modifier (cadr event))))
108
109      (cond ((eq (car event) 'key)
110	     (setq mods (logior mods (lsh 1 16)))
111	     (setq code (x-lookup-keysym (caddr event))))
112	    ((eq (car event) 'mouse)
113	     (setq mods (logior mods (lsh 1 17)))
114	     (setq code (cdr (assq (caddr event) '((click . 1)
115						   (click-1 . 1)
116						   (click-2 . 2)
117						   (move . 3)
118						   (off . 4)
119						   (off-1 . 4)
120						   (click-3 . 5)
121						   (off-2 . 6)
122						   (off-3 . 7))))))
123	    (t (error "Unknown event type: %s" (car event))))
124      (cons code mods)))
125
126  (define (string->keysym string)
127    "Convert a string naming a key into a symbol naming an X11 keysym."
128    (x-keysym-name (car (lookup-event string))))
129
130  (define (modifier->keysyms modifier)
131    "Convert a symbol naming an event modifier into a list of symbols
132representing the X11 keysyms that may generate the modifier."
133    (cond ((eq modifier 'alt)
134	   (mapcar string->keysym alt-keysyms))
135	  ((eq modifier 'meta)
136	   (mapcar string->keysym meta-keysyms))
137	  ((eq modifier 'hyper)
138	   (mapcar string->keysym hyper-keysyms))
139	  ((eq modifier 'super)
140	   (mapcar string->keysym super-keysyms))
141	  ((eq modifier 'shift)
142	   '(Shift_L Shift_R))
143	  ((eq modifier 'control)
144	   '(Control_L Control_R))
145	  (t (error "Unknown modifier: %s" modifier))))
146
147  (define (modifier-keysym-p keysym)
148    "Returns true if KEYSYM is a modifier keysym."
149    (or (memq keysym '(Shift_L Shift_R Control_L Control_R))
150	(member (symbol-name keysym) alt-keysyms)
151	(member (symbol-name keysym) meta-keysyms)
152	(member (symbol-name keysym) hyper-keysyms)
153	(member (symbol-name keysym) super-keysyms)))
154
155  (define (member-event ev lst)
156    (let loop ((rest lst))
157         (cond ((null rest) nil)
158               ((event-match ev (car rest)) rest)
159               (t (loop (cdr rest))))))
160
161  (define (should-grab-button-event-p event keymap)
162    (let* ((decoded (decode-event event))
163	   (variants (mapcar (lambda (action)
164			       (encode-event
165				(list (car decoded) (cadr decoded) action)))
166			     '(click-2 click-3 move off-1 off-2 off-3))))
167      (let loop ((rest (cdr keymap)))
168           (cond ((null rest) nil)
169                 ((member-event (cdar rest) variants) t)
170                 (t (loop (cdr rest))))))))
171