├── .Xmodmap ├── README.md └── cl-keyboard.lisp /.Xmodmap: -------------------------------------------------------------------------------- 1 | ! 2 | ! Swap Caps_Lock and Control_L 3 | ! 4 | remove Lock = Caps_Lock 5 | remove Control = Control_L 6 | keysym Control_L = Caps_Lock 7 | keysym Caps_Lock = Control_L 8 | add Lock = Caps_Lock 9 | add Control = Control_L 10 | 11 | ! 12 | ! Switch ( with [ and ) with ] 13 | ! 14 | keycode 18 = 9 bracketleft 9 bracketleft 15 | keycode 19 = 0 bracketright 0 bracketright 16 | keycode 34 = parenleft braceleft parenleft braceleft 17 | keycode 35 = parenright braceright parenright braceright 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cl-keyboard 2 | cl-keyboard is a useful keyboard remap for Common Lispers on Windows. After load it, the `[` and `]` keys will be remap to `(` and `)`, `(` and `)`, which are `Shift+9` and `Shift+0` will be remap to `[` and `]`. The left control (`Ctrl`) is swapped with `Capslock`. The keyboard change will be affect to any program on Windows, unless you close the Lisp process. If you want to automatically load this small utility, you can append this to your Lisp init file (e.g. `~/.sbclrc` for SBCL and `~/ccl-init.lisp` for CCL): 3 | ```lisp 4 | #+quicklisp 5 | (let ((cl-keyboard-init (merge-pathnames "common-lisp/cl-keyboard.lisp" 6 | (user-homedir-pathname)))) 7 | (when (probe-file cl-keyboard-init) 8 | (load cl-keyboard-init))) 9 | ``` 10 | ## Why this remap? 11 | This is actually the keyboard map similar to [Symbolics Lisp Machine's keyboard](https://en.wikipedia.org/wiki/Space-cadet_keyboard). In this keyboard map, you need only move your little finger of right hand a little from `P` key to input a `(` or `)`, without press `Shift`. As Common Lisp use `[]` little, it's more convinient to use them to type `()`, but this may not for Scheme and Clojure programmers. As for swap `Capslock` and `LCtrl`, it's a common practice for most emacs users. 12 | 13 | ## What about on Linux? 14 | I put my `.Xmodmap` file in this responsitory. If you like it, install xmodmap via your system's package manager and put `.Xmodmap` to your home folder, it will automatically work for lightdm, kdm and gdm, other desktop managers are not tested. If it's not automatically start, just run or put to your system startup file `xmodmap ~/.Xmodmap`. It will work just as cl-keyboard on Windows. 15 | 16 | ## A note on cl-keyboard 17 | When I start maintain [Graphic-Forms](https://gitlab.common-lisp.net/byao/Graphic-Forms), I had to work on windows. On Linux, I can use a single `.Xmodmap` file to swap these keys, but on Windows, there seems no software can finish this remap. There are several candidates, one of them is a group of remap tools, such as sharpkeys, but they can only swap key X to Y, not X to Shift-Y. Another kind of tool is listen to what user input and send modified keyboard events, such as AutoHotKey. This works similar to cl-keyboard, but when I tried to define such remap rules in AutoHotKey script, either would I ran into an infinite loop or `[` remap to `(` but also `Shift+[` remap to `(`: the `{` key got lost! A third way is to do some remap in `.emacs` file, but it doesn't work for keystrokes, such as `C-(` or `M-(`, and when you are out of emacs it changed back -- you have to remember two sets of keys. So I have to write this small tool to precisely cope with low level windows keyboard events. 18 | 19 | (I hope this small utility help you writing Common Lisp \:) 20 | -------------------------------------------------------------------------------- /cl-keyboard.lisp: -------------------------------------------------------------------------------- 1 | ;;;; cl-keyboard.lisp 2 | (in-package :cl-user) 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (ql:quickload '(cffi bordeaux-threads))) 5 | (defpackage :cl-keyboard 6 | (:use :cl :cffi)) 7 | (in-package :cl-keyboard) 8 | 9 | (define-foreign-library user32 10 | (:windows (:default "user32"))) 11 | 12 | (use-foreign-library user32) 13 | 14 | (defctype HHOOK :pointer) 15 | (defctype HOOKPROC :pointer) 16 | (defctype HINSTANCE :pointer) 17 | (defctype DWORD :unsigned-int) 18 | (defcfun ("SetWindowsHookExA" set-windows-hook-ex) HHOOK 19 | (id-hook :int) 20 | (lpfn HOOKPROC) 21 | (h-mod HINSTANCE) 22 | (dw-thread-id DWORD)) 23 | 24 | (defctype LRESULT :long) 25 | (defctype WPARAM :unsigned-int) 26 | (defctype LPARAM :long) 27 | (defconstant +hc-action+ 0) 28 | (defconstant +wm-keydown+ 256) 29 | (defconstant +wm-keyup+ 257) 30 | (defconstant +wm-syskeydown+ 260) 31 | (defconstant +wm-syskeyup+ 261) 32 | (defparameter +null+ (make-pointer 0)) 33 | (defcfun ("CallNextHookEx" call-next-hook-ex) LRESULT 34 | (hhk HHOOK) 35 | (n-code :int) 36 | (w-param WPARAM) 37 | (l-param LPARAM)) 38 | 39 | (defcallback low-level-keyboard-proc LRESULT 40 | ((n-code :int) (w-param WPARAM) (l-param LPARAM)) 41 | (when (eql n-code +hc-action+) 42 | (let ((event-processed-p 43 | (cond 44 | ((find w-param `(,+wm-keydown+ ,+wm-syskeydown+)) 45 | (let ((key-info (get-key-info l-param))) 46 | (if (real-key-event-p key-info) 47 | (process-key-down (get-key-info l-param)) 48 | nil))) 49 | ((find w-param `(,+wm-keyup+ ,+wm-syskeyup+)) 50 | (let ((key-info (get-key-info l-param))) 51 | (if (real-key-event-p key-info) 52 | (process-key-up (get-key-info l-param)) 53 | nil)))))) 54 | (if event-processed-p 55 | 1 56 | (call-next-hook-ex +null+ n-code w-param l-param))))) 57 | 58 | (defun real-key-event-p (key-info) 59 | (> (key-info-scan-code key-info) 0)) 60 | 61 | (defcstruct tag-kbdllhookstruct 62 | (vk-code DWORD) 63 | (scan-code DWORD) 64 | (flags DWORD) 65 | (time DWORD) 66 | (dw-extra-info DWORD)) 67 | (defctype KBDLLHOOKSTRUCT (:struct tag-kbdllhookstruct)) 68 | (defctype PKBDLLHOOKSTRUCT :pointer) 69 | (defstruct key-info 70 | vk-code scan-code flags time dw-extra-info) 71 | (defun get-key-info (ptr) 72 | (with-foreign-slots ((vk-code scan-code flags time dw-extra-info) (make-pointer ptr) KBDLLHOOKSTRUCT) 73 | (make-key-info :vk-code vk-code 74 | :scan-code scan-code 75 | :flags flags 76 | :time time 77 | :dw-extra-info dw-extra-info))) 78 | ;;; The following two funciton, if event has been processed return t otherwise nil! 79 | (defvar *down-keys* nil) 80 | (defun mark-key-down (key-info) 81 | (pushnew key-info *down-keys* :key #'key-info-vk-code)) 82 | (defun mark-key-up (key-info) 83 | (setf *down-keys* (delete (key-info-vk-code key-info) *down-keys* :key #'key-info-vk-code))) 84 | (defun key-down-p (vk-code) 85 | (find vk-code *down-keys* :key #'key-info-vk-code)) 86 | (defun key-up-p (vk-code) 87 | (not (key-down-p vk-code))) 88 | 89 | (defconstant +vk-lshift+ #xA0) 90 | (defconstant +vk-rshift+ #xA1) 91 | (defconstant +vk-lcontrol+ #xA2) 92 | 93 | (defconstant +vk-capital+ #x14) 94 | 95 | (defconstant +vk-oem-4+ #xDB) ; in us keyboard {[ key 96 | (defconstant +vk-oem-5+ #xDD) ; in us keyboard }] key 97 | (defconstant +vk-9+ #x39) ; the main keyboard 9 key 98 | (defconstant +vk-0+ #x30) ; the main keyboard 0 key 99 | 100 | (defun process-key-down (key-info) 101 | (mark-key-down key-info) 102 | (let ((vk-code (key-info-vk-code key-info))) 103 | (cond 104 | ((eql vk-code +vk-capital+) 105 | (send-key-down-event +vk-lcontrol+) 106 | t) 107 | ((eql vk-code +vk-lcontrol+) 108 | (send-key-down-event +vk-capital+) 109 | t) 110 | ((and (eql vk-code +vk-oem-4+) 111 | (key-up-p +vk-lshift+) 112 | (key-up-p +vk-rshift+)) 113 | (send-key-down-event +vk-lshift+) 114 | (send-key-down-event +vk-9+) 115 | t) 116 | ((and (eql vk-code +vk-oem-5+) 117 | (key-up-p +vk-lshift+) 118 | (key-up-p +vk-rshift+)) 119 | (send-key-down-event +vk-lshift+) 120 | (send-key-down-event +vk-0+) 121 | t) 122 | ((and (eql vk-code +vk-9+) 123 | (or (key-down-p +vk-lshift+) 124 | (key-down-p +vk-rshift+))) 125 | (when (key-down-p +vk-lshift+) 126 | (send-key-up-event +vk-lshift+)) 127 | (when (key-down-p +vk-rshift+) 128 | (send-key-up-event +vk-rshift+)) 129 | (send-key-down-event +vk-oem-4+) 130 | t) 131 | ((and (eql vk-code +vk-0+) 132 | (or (key-down-p +vk-lshift+) 133 | (key-down-p +vk-rshift+))) 134 | (when (key-down-p +vk-lshift+) 135 | (send-key-up-event +vk-lshift+)) 136 | (when (key-down-p +vk-rshift+) 137 | (send-key-up-event +vk-rshift+)) 138 | (send-key-down-event +vk-oem-5+) 139 | t)))) 140 | (defun process-key-up (key-info) 141 | (mark-key-up key-info) 142 | (let ((vk-code (key-info-vk-code key-info))) 143 | (cond 144 | ((eql vk-code +vk-capital+) 145 | (send-key-up-event +vk-lcontrol+) 146 | t) 147 | ((eql vk-code +vk-lcontrol+) 148 | (send-key-up-event +vk-capital+) 149 | t) 150 | ((and (eql vk-code +vk-oem-4+) 151 | (key-up-p +vk-lshift+) 152 | (key-up-p +vk-rshift+)) 153 | (send-key-up-event +vk-9+) 154 | (send-key-up-event +vk-lshift+) 155 | t) 156 | ((and (eql vk-code +vk-oem-5+) 157 | (key-up-p +vk-lshift+) 158 | (key-up-p +vk-rshift+)) 159 | (send-key-up-event +vk-0+) 160 | (send-key-up-event +vk-lshift+) 161 | t) 162 | ((and (eql vk-code +vk-9+) 163 | (or (key-down-p`+vk-lshift+) 164 | (key-down-p +vk-rshift+))) 165 | (send-key-up-event +vk-oem-4+) 166 | t) 167 | ((and (eql vk-code +vk-0+) 168 | (or (key-down-p +vk-lshift+) 169 | (key-down-p +vk-rshift+))) 170 | (send-key-up-event +vk-oem-5+) 171 | t)))) 172 | 173 | (defcfun ("keybd_event" keybd-event) :void 174 | (b-vk :unsigned-char) 175 | (b-scan :unsigned-char) 176 | (dw-flags DWORD) 177 | (dw-extra-info DWORD)) 178 | (defconstant +keyenventf-keyup+ 2) 179 | 180 | (defun send-key-down-event (vk-code) 181 | (keybd-event vk-code 0 0 0)) 182 | (defun send-key-up-event (vk-code) 183 | (keybd-event vk-code 0 +keyenventf-keyup+ 0)) 184 | 185 | (defctype HWND :pointer) 186 | (defctype UINT :unsigned-int) 187 | (defctype LONG :long) 188 | (defcstruct tag-point 189 | (x LONG) 190 | (y LONG)) 191 | (defctype POINT (:struct tag-point)) 192 | (defcstruct tag-msg 193 | (hwnd HWND) 194 | (message UINT) 195 | (w-param WPARAM) 196 | (l-param LPARAM) 197 | (time DWORD) 198 | (pt POINT)) 199 | 200 | (defctype MSG (:struct tag-msg)) 201 | (defctype LPMSG :pointer) 202 | (defctype BOOL :int) 203 | (defcfun ("GetMessageA" get-message) BOOL 204 | (lp-msg LPMSG) 205 | (h-wnd HWND) 206 | (w-msg-filter-min UINT) 207 | (w-msg-filter-max UINT)) 208 | 209 | (defcfun ("TranslateMessage" translate-message) BOOL 210 | (lp-msg :pointer)) 211 | 212 | (defcfun ("DispatchMessageA" dispatch-message) LRESULT 213 | (lp-msg :pointer)) 214 | 215 | (defun message-loop () 216 | (with-foreign-object (msg 'MSG) 217 | (let (result) 218 | (loop do (setf result (get-message msg +null+ 0 0)) 219 | until (zerop result) 220 | do (progn 221 | (translate-message msg) 222 | (dispatch-message msg))) 223 | (foreign-slot-value msg 'MSG 'w-param)))) 224 | (defcfun ("UnhookWindowsHookEx" unhook-windows-hook-ex) BOOL 225 | (hhk HHOOK)) 226 | 227 | (defconstant +wh-keyboard-ll+ 13) 228 | (defun main () 229 | (let ((hhk-low-level-kbd 230 | (set-windows-hook-ex +wh-keyboard-ll+ (callback low-level-keyboard-proc) +null+ 0))) 231 | (message-loop) 232 | (unhook-windows-hook-ex hhk-low-level-kbd))) 233 | 234 | (bt:make-thread #'main) 235 | 236 | 237 | --------------------------------------------------------------------------------