Changeset 3245

Timestamp:

06/02/08 12:10:28 (7 months ago)

Author:

hans

Message:

Add mapping for all keys.
Create PDF with layout.

Files:

• trunk/projects/symbolics-keyboard/layout.pdf (added)
• trunk/projects/symbolics-keyboard/make-keymap.lisp (modified) (6 diffs)

trunk/projects/symbolics-keyboard/make-keymap.lisp

@@ +1 @@
+;; -*- Lisp -*-
+
+;; Layout generation tools for Symbolics kbdbabel.
+
+;; MAKE-KEYMAP generates a keymap suitable to be included in the kbdbabel assembler source
+;; DRAW-KEYBOARD generates a PDF file documenting the mapping as generated
+
+;; Depends on :CL-PDF, :ALEXANDRIA and :CL-PPCRE
+
+;; Written 2008 by Hans Huebner
+;; Placed in the public domain
-
-(in-package :cl-user)
+
+(defpackage :symbolics-keyboard
+  (:nicknames "SKBD")
+  (:use :cl :alexandria))
+
+(in-package :symbolics-keyboard)
+
+(defparameter *key-map*
+  '(("Select"           "F1")
+    ("Network"          "F2")
+    ("Function"         "F3")
+    ("Suspend"          "F4")
+    ("Resume"           "F5")
+    ("Abort"            "F6")
+    ("SuperL"           "F7")
+    ("HyperL"           "F8")
+    ("Scroll"           "F9"    "PgDn")
+    ("ClearInput"       "F10")
+    ("SymbolR"          "KP5"   "Up")
+    ("Scroll"           "KP3"   "Scroll")
+    ("RubOut"           "Del")
+    ("Complete"         "F11"   "Home")
+    ("Help"             "F12")
+    ("End"              "KP1"   "End")
+    ("MetaL"            "AltL")
+    ("MetaR"            "AltGr" "Left")
+    ("SuperR"           "KP."   "Down")
+    ("HyperR"           "KP+"   "Right")
+    ("Repeat"           "KP/"   "PgUp")
+    ("ControlL"         "CtrlL")
+    ("ControlR"         "CtrlR")
+    ("("                "[")
+    (")"                "]")
+    ("Triangle"         "KP2")
+    ("Circle"           "KP3")
+    ("Square"           "KP4")
+    ("Refresh"          "KP0")
+    ("Page"             "KP6")
+    ("Line"             "KP7")
+    ("SymbolL"          "KP8")
+    ("|"                "KP-")
+    (":"                "KP*")
+    ("CapsLock"         "Caps"))
+  "Mappings for keys.  By default, Symbolics keys which have the same
+  name (keycap label) as a PS/2 key are mapped to that corresponding
+  key.  Before the default mapping is considered, this list of lists
+  is checked for an explicit definition.  Each list consists
+  of (KEYNAME PS2-KEYNAME [ F-MODE-PS2-KEYNAME ] ) with KEYNAME being
+  the name of the Symbolics key, PS2-KEYNAME the name of the PS/2 key
+  name whose PS/2 scancode should be sent and F-MODE-PS2-KEYNAME being
+  the name of the PS/2 key whose PS/2 scancode should be sent in
+  F-mode.  PS2-KEYNAME may be NIL to indicate that no PS/2 scancode is
+  associated to the key when not in F-Mode.  F-MODE-PS2-KEYNAME
+  defaults to PS2-KEYNAME if not specified.")
-
-(defparameter *ps2-map*
@@ -65 +130 @@
-    ("Caps"             #x58)
-    ("ShiftR"           #x59)
+    ("'y"               #x52)
-    ("Return"           #x5a)
-    ("]"                #x5b)
@@ -104 +170 @@
-
-(defparameter *symbolics-map*
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-    ("HyperL"           #x03    0 0)
+    ("SuperL"           #x0e    1 0)
-    ("MetaL"            #x04    2 0)
+    ("ControlL"         #x0f    3 0 2)
+    ("Space"            #x10    4 0 8.5)
-    ("ControlR"         #x05    5 0 2)
+    ("MetaR"            #x11    6 0)
-    ("SuperR"           #x06    7 0)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-(defun find-explicit-mapping (symbolics-keyname &optional f-mode-p)
-special-
+
-    (when mapping-entry
-      (let ((mapping (nth (if f-mode-p 2 1) mapping-entry)))
@@ -280 +353 @@
-  (setf (aref map symbolics-scancode) (car ps2-keycode))))
-
+(defun map-symbolics-key (symbolics-keyname &optional f-mode)
+  "Given the name of a symbolics key, return the corresponding PS/2 scan code(s) as a list."
+  (cdr (or (when f-mode
+             (find-explicit-mapping symbolics-keyname t))
+           (find-explicit-mapping symbolics-keyname)
+           (find-direct-mapping symbolics-keyname))))
+
+(defun f-mode-key-p (symbolics-key-entry)
+  "Return a true value if the key desribed by SYMBOLICS-KEY-ENTRY is a F-mode switch."
+  (member (key-name symbolics-key-entry) '("Local" "ModeLock") :test #'equal))
+
-(defun make-keymap ()
+  "Print mapping definition arrays in assembler format to
+  *standard-output*.  The labels are chosen so that the tables can be
+  copied into the kbdlabel assembler source."
-  (let ((normal-map (make-array 128 :initial-element 0))
-        (f-mode-map (make-array 128 :initial-element 0))
@@ -290 +377 @@
-        (declare (ignore geometry-info))
-        (cond
-member symbolics-keyname '("Local" "ModeLock") :test #'equal
+f-mode-key-p symbolics-key-entry
-           (setf (aref flag-map symbolics-scancode) +f-mode-switch+))
-          (t
-
-
-
-
+
+
-             (cond
-               ((or ps2-keycode f-mode-ps2-keycode)
@@ -314 +399 @@
-    (when unmapped-ps2-keys
-      (format t "Unmapped PS/2 keys: ~S~%" (mapcar #'car unmapped-ps2-keys)))))
+
+(defun draw-keyboard (&optional (label-function #'key-name))
+  (pdf:with-saved-state
+    (pdf:translate 70 0)
+    (pdf:scale 25 25)
+    (pdf:set-line-width .05)
+    (pdf:set-rgb-stroke 0.2 0.2 0.2)
+    (let ((keys (sort (group-on *symbolics-map*
+                                :test #'eql
+                                :key #'key-y
+                                :include-key nil)
+                      #'> :key (compose #'key-y #'car)))
+          (helvetica (pdf:get-font "Helvetica")))
+      (do* ((y 0 (incf y)))
+           ((> y 5))
+        (let ((row (nth (- 5 y) keys)))
+          (pdf:move-to 0 y)
+          (pdf:line-to 20 y)
+          (do* ((i 0 (incf i))
+                (entry (nth i row) (nth i row))
+                (x 0))
+               ((null (nth i row)))
+            (pdf:move-to x y)
+            (pdf:line-to x (+ y 1))
+            (pdf:stroke)
+            (pdf:in-text-mode
+              (pdf:set-font helvetica 0.3)
+              (pdf:move-text (+ x 0.1) (+ y 0.6))
+              (let ((label-text (funcall label-function entry)))
+                (cond
+                  ((null label-text))
+                  ((= 1 (length label-text))
+                   (pdf:move-text 0 -0.4)
+                   (pdf:draw-text (first label-text)))
+                  ((= 2 (length label-text))
+                   (pdf:draw-text (first label-text))
+                   (pdf:move-text 0 -0.4)
+                   (pdf:draw-text (second label-text)))
+                  (t
+                   (error "unexpected number of elements in labels list ~S returned by label function for entry ~S"
+                          label-text entry)))))
+            (incf x (key-width entry)))))
+      (pdf:move-to 0 6)
+      (pdf:line-to 20 6)
+      (pdf:stroke)
+      (pdf:move-to 20 6)
+      (pdf:line-to 20 0)
+      (pdf:stroke))))
+
+(defun split-label (string)
+  "Split camel case label into multiple words."
+  (cl-ppcre:split "(?<=[a-z])(?=[A-Z])" string))
+
+(defun format-key-name (entry)
+  "Given a Symbolics key definition entry, return one or two strings
+to be used as label for the key."
+  (if (= 1 (length (key-labels entry)))
+      (split-label (key-name entry))
+      (reverse (key-labels entry))))
+
+(defun format-key-scancodes (entry)
+  "Given a Symbolics key definition entry, return one or two strings
+representing the PS/2 scan code of the key."
+  (list (format nil "~{~2,'0X~^ ~}" (map-symbolics-key (key-name entry)))
+        (format nil "~{~2,'0X~^ ~}" (map-symbolics-key (key-name entry) t))))
+
+(defun format-key-ps2-name (entry &optional f-mode)
+  (cond
+    ((equal "ModeLock" (car entry))
+     '("F-Mode" "Lock"))
+    ((equal "Local" (car entry))
+     '("F-Mode"))
+    (t
+     (let ((scan-codes (map-symbolics-key (key-name entry) f-mode)))
+       (split-label (or (car (find scan-codes *ps2-map* :key #'cdr :test #'equal))
+                        ""))))))
+
+(defun draw-label (x y text &key (size 12) (font-name "Helvetica-Bold"))
+  (let ((helvetica (pdf:get-font font-name)))
+    (pdf:in-text-mode
+      (pdf:set-font helvetica size)
+      (pdf:move-text x y)
+      (pdf:draw-text text))))
+
+(defun draw-layout (&optional (pathname #P"layout.pdf"))
+  (pdf:with-document ()
+    (pdf:with-page ()
+      (pdf:with-outline-level ("Symbolics keyboard layout" (pdf:register-page-reference))
+        (draw-label 70 800 "kbdbabel-symbolics Symbolics to PS/2 Adapter key code mapping" :size 14)
+        (draw-label 240 10 "kbdbabel for Symbolics keyboard - by Alexander Kurz and Hans Hübner - http://kbdbabel.net/"
+                    :size 8 :font-name "Helvetica")
+        (draw-label 70 35 "PS/2 scan codes (top: standard, bottom: F-mode)")
+        (pdf:translate 0 50)
+        (draw-keyboard #'format-key-scancodes)
+        (draw-label 70 175 "F-Mode mapping")
+        (pdf:translate 0 190)
+        (draw-keyboard (rcurry #'format-key-ps2-name t))
+        (draw-label 70 175 "Standard mapping")
+        (pdf:translate 0 190)
+        (draw-keyboard #'format-key-ps2-name)
+        (draw-label 70 175 "Key caps")
+        (pdf:translate 0 190)
+        (draw-keyboard #'format-key-name)))
+    (pdf:write-document pathname)))