make-keymap.lisp

Revision 3252, 17.7 kB (checked in by hans, 7 months ago)
Add scan code documentation from Microsoft. Modify layout so that Local is the Windows key, not F-Mode Shift, suggested by Bill Clementson.

Line
1	;;; -- Lisp --
2
3	;;; Layout generation tools for Symbolics kbdbabel.
4
5	;;; MAKE-KEYMAP generates a keymap suitable to be included in the kbdbabel assembler source
6	;;; DRAW-KEYBOARD generates a PDF file documenting the mapping as generated
7
8	;;; This file is meant to be LOADed
9	;;; Depends on :CL-PDF, :ALEXANDRIA and :CL-PPCRE
10
11	;;; Copyright 2008 by Hans Huebner, All Rights Reserved
12
13	;;; Redistribution and use in source and binary forms, with or without
14	;;; modification, are permitted provided that the following conditions
15	;;; are met:
16
17	;;; * Redistributions of source code must retain the above copyright
18	;;; notice, this list of conditions and the following disclaimer.
19
20	;;; * Redistributions in binary form must reproduce the above
21	;;; copyright notice, this list of conditions and the following
22	;;; disclaimer in the documentation and/or other materials
23	;;; provided with the distribution.
24
25	;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
26	;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
27	;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
28	;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
29	;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
30	;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
31	;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
32	;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33	;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
34	;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
35	;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36
37	(in-package :cl-user)
38
39	(asdf:oos 'asdf:load-op :cl-pdf)
40	(asdf:oos 'asdf:load-op :alexandria)
41	(asdf:oos 'asdf:load-op :cl-ppcre)
42
43	(defpackage :symbolics-keyboard
44	(:nicknames "SKBD")
45	(:use :cl :alexandria))
46
47	(setf pdf:compress-streams nil)
48
49	(in-package :symbolics-keyboard)
50
51	(defparameter key-map
52	'(("Select" "F1")
53	("Network" "F2")
54	("Function" "F3")
55	("Suspend" "F4")
56	("Resume" "F5")
57	("Abort" "F6")
58	("Local" "WindowsL")
59	("SuperL" "F7")
60	("HyperL" "F8")
61	("Scroll" "F9" "PgDn")
62	("ClearInput" "F10")
63	("SymbolR" "KP5" "Up")
64	("Scroll" "KP3" "Scroll")
65	("RubOut" "Del")
66	("Complete" "F11" "Home")
67	("Help" "F12")
68	("End" "KP1" "End")
69	("MetaL" "AltL")
70	("MetaR" "AltGr" "Left")
71	("SuperR" "KP." "Down")
72	("HyperR" "KP+" "Right")
73	("Repeat" "KP/" "PgUp")
74	("ControlL" "CtrlL")
75	("ControlR" "CtrlR")
76	("(" "[")
77	(")" "]")
78	("Triangle" "KP2")
79	("Circle" "KP3")
80	("Square" "KP4")
81	("Refresh" "KP0")
82	("Page" "KP6")
83	("Line" "KP7")
84	("SymbolL" "KP8")
85	("\|" "KP-")
86	(":" "KP*")
87	("CapsLock" "Caps"))
88	"Mappings for keys. By default, Symbolics keys which have the same
89	name (keycap label) as a PS/2 key are mapped to that corresponding
90	key. Before the default mapping is considered, this list of lists
91	is checked for an explicit definition. Each list consists
92	of (KEYNAME PS2-KEYNAME [ F-MODE-PS2-KEYNAME ] ) with KEYNAME being
93	the name of the Symbolics key, PS2-KEYNAME the name of the PS/2 key
94	name whose PS/2 scancode should be sent and F-MODE-PS2-KEYNAME being
95	the name of the PS/2 key whose PS/2 scancode should be sent in
96	F-mode. PS2-KEYNAME may be NIL to indicate that no PS/2 scancode is
97	associated to the key when not in F-Mode. F-MODE-PS2-KEYNAME
98	defaults to PS2-KEYNAME if not specified.")
99
100	(defparameter ps2-map
101	'(("F9" #x01)
102	("F5" #x03)
103	("F3" #x04)
104	("F1" #x05)
105	("F2" #x06)
106	("F12" #x07)
107	("F10" #x09)
108	("F8" #x0a)
109	("F6" #x0b)
110	("F4" #x0c)
111	("Tab" #x0d)
112	("`" #x0e)
113	("AltL" #x11)
114	("ShiftL" #x12)
115	("CtrlL" #x14)
116	("Q" #x15)
117	("1" #x16)
118	("Z" #x1a)
119	("S" #x1b)
120	("A" #x1c)
121	("W" #x1d)
122	("2" #x1e)
123	("C" #x21)
124	("X" #x22)
125	("D" #x23)
126	("E" #x24)
127	("4" #x25)
128	("3" #x26)
129	("Space" #x29)
130	("V" #x2a)
131	("F" #x2b)
132	("T" #x2c)
133	("R" #x2d)
134	("5" #x2e)
135	("N" #x31)
136	("B" #x32)
137	("H" #x33)
138	("G" #x34)
139	("Y" #x35)
140	("6" #x36)
141	("M" #x3a)
142	("J" #x3b)
143	("U" #x3c)
144	("7" #x3d)
145	("8" #x3e)
146	("," #x41)
147	("K" #x42)
148	("I" #x43)
149	("O" #x44)
150	("0" #x45)
151	("9" #x46)
152	("." #x49)
153	("/" #x4a)
154	("L" #x4b)
155	(";" #x4c)
156	("P" #x4d)
157	("-" #x4e)
158	("KP0" #x70)
159	("[" #x54)
160	("=" #x55)
161	("Caps" #x58)
162	("ShiftR" #x59)
163	("'" #x52)
164	("Return" #x5a)
165	("]" #x5b)
166	("\\" #x5d)
167	("BackSpace" #x66)
168	("KP1" #x69)
169	("KP4" #x6b)
170	("KP7" #x6c)
171	("KP0" #x70)
172	("KP." #x71)
173	("KP2" #x72)
174	("KP5" #x73)
175	("KP6" #x74)
176	("KP8" #x75)
177	("Escape" #x76)
178	("NumLock" #x77)
179	("F11" #x78)
180	("KP+" #x79)
181	("KP3" #x7a)
182	("KP-" #x7b)
183	("KP*" #x7c)
184	("KP9" #x7d)
185	("Scroll" #x7e)
186	("F7" #x83)
187	("AltGr" #xe0 #x11)
188	("CtrlR" #xe0 #x14)
189	("KP/" #xe0 #x4a)
190	("KPEnter" #xe0 #x5a)
191	("End" #xe0 #x69)
192	("Left" #xe0 #x6b)
193	("Home" #xe0 #x6c)
194	("Ins" #xe0 #x70)
195	("Del" #xe0 #x71)
196	("Down" #xe0 #x72)
197	("Right" #xe0 #x74)
198	("Up" #xe0 #x75)
199	("PgDn" #xe0 #x7a)
200	("PgUp" #xe0 #x7d)
201	("WindowsL" #xe0 #x1f)
202	("WindowsR" #xe0 #x27)
203	("App" #xe0 #x2f)))
204
205	(defparameter symbolics-map
206	'(("Function" #x43 0 5 2)
207	("Escape" #x6f 1 5 2)
208	("Refresh" #x70 2 5 2)
209	("Square" #x71 3 5 2)
210	("Circle" #x72 4 5 2)
211	("Triangle" #x73 5 5 2)
212	("ClearInput" #x74 6 5 2)
213	("Suspend" #x75 7 5 2)
214	("Resume" #x76 8 5 2)
215	("Abort" #x1e 9 5 2)
216	("Network" #x38 0 4 2)
217	(":" #x59 1 4)
218	(("1" "!") #x64 2 4)
219	(("2" "@") #x5a 3 4)
220	(("3" "#") #x65 4 4)
221	(("4" "$") #x5b 5 4)
222	(("5" "%") #x66 6 4)
223	(("6" "^") #x5c 7 4)
224	(("7" "&") #x67 8 4)
225	(("8" "*") #x5d 9 4)
226	(("9" "(") #x68 10 4)
227	(("0" ")") #x5e 11 4)
228	(("-" "_") #x69 12 4)
229	(("=" "+") #x5f 13 4)
230	(("`" "~") #x6a 14 4)
231	(("\\" "{") #x60 15 4)
232	(("\|" "}") #x6b 16 4)
233	("Help" #x29 17 4 2)
234	("Local" #x01 0 3 2)
235	("Tab" #x4e 1 3 1.5)
236	("Q" #x4f 2 3)
237	("W" #x44 3 3)
238	("E" #x50 4 3)
239	("R" #x45 5 3)
240	("T" #x51 6 3)
241	("Y" #x46 7 3)
242	("U" #x52 8 3)
243	("I" #x47 9 3)
244	("O" #x53 10 3)
245	("P" #x48 11 3)
246	(("(" "[") #x54 12 3)
247	((")" "]") #x49 13 3)
248	("BackSpace" #x55 14 3)
249	("Page" #x4a 15 3 1.5)
250	("Complete" #x34 16 3 2)
251	("Select" #x0c 0 2 2)
252	("RubOut" #x2d 1 2 1.75)
253	("A" #x39 2 2)
254	("S" #x2e 3 2)
255	("D" #x3a 4 2)
256	("F" #x2f 5 2)
257	("G" #x3b 6 2)
258	("H" #x30 7 2)
259	("J" #x3c 8 2)
260	("K" #x31 9 2)
261	("L" #x3d 10 2)
262	((";" ":") #x32 11 2)
263	(("'" "\"") #x3e 12 2)
264	("Return" #x33 13 2 2)
265	("Line" #x3f 14 2 1.25)
266	("End" #x13 15 2 2)
267	("CapsLock" #x02 0 1)
268	("SymbolL" #x0d 1 1 1.25)
269	("ShiftL" #x22 2 1 2)
270	("Z" #x17 3 1)
271	("X" #x23 4 1)
272	("C" #x18 5 1)
273	("V" #x24 6 1)
274	("B" #x19 7 1)
275	("N" #x25 8 1)
276	("M" #x1a 9 1)
277	(("," "<") #x26 10 1)
278	(("." ">") #x1b 11 1)
279	(("/" "?") #x27 12 1)
280	("ShiftR" #x1c 13 1 2)
281	("SymbolR" #x28 14 1 1.25)
282	("Repeat" #x1d 15 1 1.25)
283	("ModeLock" #x08 16 1 1.25)
284	("HyperL" #x03 0 0)
285	("SuperL" #x0e 1 0)
286	("MetaL" #x04 2 0)
287	("ControlL" #x0f 3 0 2)
288	("Space" #x10 4 0 8.5)
289	("ControlR" #x05 5 0 2)
290	("MetaR" #x11 6 0)
291	("SuperR" #x06 7 0)
292	("HyperR" #x12 8 0)
293	("Scroll" #x07 9 0 1.5))
294	"Definition of Symbolics keyboard scan codes. One list (NAME
295	SCANCODE XPOS YPOS [ SIZE ] ) for each key. NAME is the name of the
296	key, as printed on the key cap. SCANCODE is the scan code. XPOS is
297	the relative X position of the key, counted from the left. YPOS is
298	the relative Y position of the key, counted from the bottom row.
299	SIZE is the size of the key relative to a letter key, which has size
300	1 and is the default.")
301
302	(defun key-labels (entry)
303	(if (listp (first entry))
304	(first entry)
305	(list (first entry))))
306
307	(defun key-name (entry)
308	(if (listp (first entry))
309	(first (first entry))
310	(first entry)))
311
312	(defun key-scancode (entry)
313	(second entry))
314
315	(defun key-x (entry)
316	(third entry))
317
318	(defun key-y (entry)
319	(fourth entry))
320
321	(defun key-width (entry)
322	(or (fifth entry) 1))
323
324	(defun group-on (list &key (test #'eql) (key #'identity) (include-key t))
325	(let ((hash (make-hash-table :test test))
326	keys)
327	(dolist (el list)
328	(let ((key (funcall key el)))
329	(unless (nth-value 1 (gethash key hash))
330	(push key keys))
331	(push el (gethash key hash))))
332	(mapcar (lambda (key) (let ((keys (nreverse (gethash key hash))))
333	(if include-key
334	(cons key keys)
335	keys)))
336	(nreverse keys))))
337
338	(defun find-explicit-mapping (symbolics-keyname &optional f-mode-p)
339	(let ((mapping-entry (assoc symbolics-keyname key-map :test #'equal)))
340	(when mapping-entry
341	(let ((mapping (nth (if f-mode-p 2 1) mapping-entry)))
342	(cond
343	((listp mapping)
344	mapping)
345	((or (symbolp mapping)
346	(stringp mapping))
347	(or (assoc mapping ps2-map :test #'equal)
348	(error "invalid special key map entry ~S, PS/2 key ~A not found"
349	mapping-entry mapping)))
350	(t
351	(error "unexpected mapping value in map definition entry ~S" mapping-entry)))))))
352
353	(defun find-direct-mapping (symbolics-keyname)
354	(assoc symbolics-keyname ps2-map :test #'equal))
355
356	;; bit definitions for flag map
357
358	(defconstant +e0-escape+ 1)
359	(defconstant +prtscr-escape+ 2)
360	(defconstant +pause+ 4)
361	(defconstant +key-is-switch+ 8)
362	(defconstant +f-mode-switch+ 128)
363
364	(defun dump-map (map prefix &optional flagsp)
365	(dotimes (row 8)
366	(format t "~A~A DB " prefix row)
367	(dotimes (col 16)
368	(let ((symbolics-scancode (+ (* row 16) col)))
369	(format t (if (or flagsp
370	(find symbolics-scancode symbolics-map :test #'eql :key #'second))
371	"~2,'0Xh~@[, ~]"
372	"~2,' Xh~@[, ~]")
373	(aref map symbolics-scancode) (not (eql col 15)))))
374	(terpri))
375	(terpri))
376
377	(defun define-key (symbolics-scancode ps2-keycode map flag-map &optional f-mode-p)
378	(let ((e0-escape-flag (ash +e0-escape+ (if f-mode-p 4 0))))
379	(cond
380	((eql #xe0 (car ps2-keycode))
381	(setf (aref flag-map symbolics-scancode)
382	(logior e0-escape-flag (aref flag-map symbolics-scancode)))
383	(setf ps2-keycode (cdr ps2-keycode)))
384	(t
385	(setf (aref flag-map symbolics-scancode)
386	(logand (lognot e0-escape-flag) (aref flag-map symbolics-scancode)))))
387	(setf (aref map symbolics-scancode) (car ps2-keycode))))
388
389	(defun map-symbolics-key (symbolics-keyname &optional f-mode)
390	"Given the name of a symbolics key, return the corresponding PS/2 scan code(s) as a list."
391	(cdr (or (when f-mode
392	(find-explicit-mapping symbolics-keyname t))
393	(find-explicit-mapping symbolics-keyname)
394	(find-direct-mapping symbolics-keyname))))
395
396	(defun f-mode-key-p (symbolics-key-entry)
397	"Return a true value if the key desribed by SYMBOLICS-KEY-ENTRY is the F-mode switch."
398	(equal (key-name symbolics-key-entry) "ModeLock"))
399
400	(defun make-keymap ()
401	"Print mapping definition arrays in assembler format to
402	standard-output. The labels are chosen so that the tables can be
403	copied into the kbdlabel assembler source."
404	(let ((normal-map (make-array 128 :initial-element 0))
405	(f-mode-map (make-array 128 :initial-element 0))
406	(flag-map (make-array 128 :initial-element 0))
407	unmapped-symbolics-keys
408	(unmapped-ps2-keys ps2-map))
409	(dolist (symbolics-key-entry symbolics-map)
410	(let ((symbolics-keyname (key-name symbolics-key-entry))
411	(symbolics-scancode (key-scancode symbolics-key-entry)))
412	(cond
413	((f-mode-key-p symbolics-key-entry)
414	(setf (aref flag-map symbolics-scancode) +f-mode-switch+))
415	(t
416	(let* ((ps2-keycode (map-symbolics-key symbolics-keyname))
417	(f-mode-ps2-keycode (map-symbolics-key symbolics-keyname t)))
418	(cond
419	((or ps2-keycode f-mode-ps2-keycode)
420	(when ps2-keycode
421	(setf unmapped-ps2-keys (remove ps2-keycode unmapped-ps2-keys :key #'cdr :test #'equal))
422	(define-key symbolics-scancode ps2-keycode normal-map flag-map))
423	(when f-mode-ps2-keycode
424	(setf unmapped-ps2-keys (remove f-mode-ps2-keycode unmapped-ps2-keys :key #'cdr :test #'equal))
425	(define-key symbolics-scancode f-mode-ps2-keycode f-mode-map flag-map t)))
426	(t
427	(push symbolics-keyname unmapped-symbolics-keys))))))))
428	(dump-map normal-map "Symbolics2ATXlt")
429	(dump-map f-mode-map "Symbolics2ATXltF")
430	(dump-map flag-map "Symbolics2ATXlte" t)
431	(when unmapped-symbolics-keys
432	(format t "Unmapped Symbolics keys: ~S~%" unmapped-symbolics-keys))
433	(when unmapped-ps2-keys
434	(format t "Unmapped PS/2 keys: ~S~%" (mapcar #'car unmapped-ps2-keys)))))
435
436	(defun draw-keyboard (&optional (label-function #'key-name))
437	(pdf:with-saved-state
438	(pdf:translate 70 0)
439	(pdf:scale 25 25)
440	(pdf:set-line-width .05)
441	(pdf:set-rgb-stroke 0.2 0.2 0.2)
442	(let ((keys (sort (group-on symbolics-map
443	:test #'eql
444	:key #'key-y
445	:include-key nil)
446	#'> :key (compose #'key-y #'car)))
447	(helvetica (pdf:get-font "Helvetica")))
448	(do* ((y 0 (incf y)))
449	((> y 5))
450	(let ((row (nth (- 5 y) keys)))
451	(pdf:move-to 0 y)
452	(pdf:line-to 20 y)
453	(do* ((i 0 (incf i))
454	(entry (nth i row) (nth i row))
455	(x 0))
456	((null (nth i row)))
457	(pdf:move-to x y)
458	(pdf:line-to x (+ y 1))
459	(pdf:stroke)
460	(pdf:in-text-mode
461	(pdf:set-font helvetica 0.3)
462	(pdf:move-text (+ x 0.1) (+ y 0.6))
463	(let ((label-text (funcall label-function entry)))
464	(cond
465	((null label-text))
466	((= 1 (length label-text))
467	(pdf:move-text 0 -0.4)
468	(pdf:draw-text (first label-text)))
469	((= 2 (length label-text))
470	(pdf:draw-text (first label-text))
471	(pdf:move-text 0 -0.4)
472	(pdf:draw-text (second label-text)))
473	(t
474	(error "unexpected number of elements in labels list ~S returned by label function for entry ~S"
475	label-text entry)))))
476	(incf x (key-width entry)))))
477	(pdf:move-to 0 6)
478	(pdf:line-to 20 6)
479	(pdf:stroke)
480	(pdf:move-to 20 6)
481	(pdf:line-to 20 0)
482	(pdf:stroke))))
483
484	(defun split-label (string)
485	"Split camel case label into multiple words."
486	(cl-ppcre:split "(?<=[a-z])(?=[A-Z])" string))
487
488	(defun format-key-name (entry)
489	"Given a Symbolics key definition entry, return one or two strings
490	to be used as label for the key."
491	(if (= 1 (length (key-labels entry)))
492	(split-label (key-name entry))
493	(reverse (key-labels entry))))
494
495	(defun format-key-scancodes (entry)
496	"Given a Symbolics key definition entry, return one or two strings
497	representing the PS/2 scan code of the key."
498	(list (format nil "~{~2,'0X~^ ~}" (map-symbolics-key (key-name entry)))
499	(format nil "~{~2,'0X~^ ~}" (map-symbolics-key (key-name entry) t))))
500
501	(defun format-key-ps2-name (entry &optional f-mode)
502	(cond
503	((equal "ModeLock" (car entry))
504	'("F-Mode" "Lock"))
505	(t
506	(let ((scan-codes (map-symbolics-key (key-name entry) f-mode)))
507	(split-label (or (car (find scan-codes ps2-map :key #'cdr :test #'equal))
508	""))))))
509
510	(defun draw-label (x y text &key (size 12) (font-name "Helvetica-Bold"))
511	(let ((helvetica (pdf:get-font font-name)))
512	(pdf:in-text-mode
513	(pdf:set-font helvetica size)
514	(pdf:move-text x y)
515	(pdf:draw-text text))))
516
517	(defun draw-layout (&optional (pathname #P"layout.pdf"))
518	(pdf:with-document ()
519	(pdf:with-page ()
520	(pdf:with-outline-level ("Symbolics keyboard layout" (pdf:register-page-reference))
521	(draw-label 70 800 "kbdbabel-symbolics Symbolics to PS/2 Adapter key code mapping" :size 14)
522	(draw-label 240 10 "kbdbabel for Symbolics keyboard - by Alexander Kurz and Hans Hübner - http://kbdbabel.net/"
523	:size 8 :font-name "Helvetica")
524	(draw-label 70 35 "PS/2 scan codes (top: standard, bottom: F-mode)")
525	(pdf:translate 0 50)
526	(draw-keyboard #'format-key-scancodes)
527	(draw-label 70 175 "F-Mode mapping")
528	(pdf:translate 0 190)
529	(draw-keyboard (rcurry #'format-key-ps2-name t))
530	(draw-label 70 175 "Standard mapping")
531	(pdf:translate 0 190)
532	(draw-keyboard #'format-key-ps2-name)
533	(draw-label 70 175 "Key caps")
534	(pdf:translate 0 190)
535	(draw-keyboard #'format-key-name)))
536	(pdf:write-document pathname)))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format