[movitz-cvs] CVS update: movitz/losp/x86-pc/keyboard.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv26225

Modified Files:
	keyboard.lisp 
Log Message:
Make poll-key similar to poll-char. A key is a character or a symbolic
key name.

Date: Wed Nov 24 17:20:15 2004
Author: ffjeld

Index: movitz/losp/x86-pc/keyboard.lisp
diff -u movitz/losp/x86-pc/keyboard.lisp:1.3 movitz/losp/x86-pc/keyboard.lisp:1.4
--- movitz/losp/x86-pc/keyboard.lisp:1.3	Thu Oct  7 14:45:07 2004
+++ movitz/losp/x86-pc/keyboard.lisp	Wed Nov 24 17:20:14 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Sep 24 16:04:12 2001
 ;;;;                
-;;;; $Id: keyboard.lisp,v 1.3 2004/10/07 12:45:07 ffjeld Exp $
+;;;; $Id: keyboard.lisp,v 1.4 2004/11/24 16:20:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -23,6 +23,7 @@
 	   ;; read-char
 	   poll-keypress
 	   read-keypress
+	   poll-key
 	   set-leds
 	   cpu-reset))
 
@@ -155,7 +156,7 @@
 	   (aref *scan-codes* key-code))))
 ;;;  (< -1 key-code (length *scan-codes*)))
 
-(defun read-key ()
+(defun get-key ()
   (when (lowlevel-event-p)
     (multiple-value-bind (key-code release-p)
 	(lowlevel-read)
@@ -175,7 +176,7 @@
 
 (defun poll-keypress ()
   (multiple-value-bind (key release-p)
-      (read-key)
+      (get-key)
     (unless release-p
       (values key *qualifier-state*))))
 
@@ -189,6 +190,7 @@
   (multiple-value-bind (key qualifiers)
       (poll-keypress)
     (cond
+     ((not key) nil)
      ((symbolp key)
       (case key
 	(:up #\^p)
@@ -204,8 +206,16 @@
 		    (- (char-code #\a)))))
      (t key))))
 
-;;;(defun read-char ()
-;;;  (loop when (poll-char) return it))
+(defun poll-key ()
+  (multiple-value-bind (key qualifiers)
+      (poll-keypress)
+    (if (and (characterp key)
+	     (qualifier-p :ctrl qualifiers)
+	     (char<= #\a (char-downcase key) #\z))
+	(code-char (+ (char-code #\^a)
+		      (char-code (char-downcase key))
+		      (- (char-code #\a))))
+      key)))
 
 (defun set-leds (led0 led1 led2)
   (loop while (logbitp 1 (io-port #x64 :unsigned-byte8)))