Update of /project/mcclim/cvsroot/mcclim/ESA
In directory clnet:/tmp/cvs-serv10422/ESA
Modified Files:
esa.lisp packages.lisp utils.lisp
Added Files:
dead-keys.lisp
Log Message:
Improved dead key handling for ESAs (well, some of them).
Now uses a clever state machine to merge dead keys, rather than the
old command table hack.
--- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/02/03 08:38:26 1.19
+++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/04/29 16:27:42 1.20
@@ -550,21 +550,25 @@
(end-command-loop (overriding-handler command-processor)))
(setf (overriding-handler (super-command-processor command-processor)) nil))
-(defmethod process-gesture :around ((command-processor command-loop-command-processor) gesture)
- (cond ((find gesture *abort-gestures*
- :test #'gesture-matches-gesture-name-p)
- ;; It is to be expected that the abort function might signal
- ;; `abort-gesture'. If that happens, we must end the command
- ;; loop, but ONLY if this is signalled.
- (handler-case (funcall (abort-function command-processor))
- (abort-gesture (c)
- (end-command-loop command-processor)
- (signal c))))
- (t
- (call-next-method)
- (when (funcall (end-condition command-processor))
- (funcall (end-function command-processor))
- (end-command-loop command-processor)))))
+(defmethod process-gesture ((command-processor command-loop-command-processor) gesture)
+ (handling-dead-keys (gesture)
+ (cond ((find gesture *abort-gestures*
+ :test #'gesture-matches-gesture-name-p)
+ ;; It is to be expected that the abort function might signal
+ ;; `abort-gesture'. If that happens, we must end the command
+ ;; loop, but ONLY if this is signalled.
+ (handler-case (funcall (abort-function command-processor))
+ (abort-gesture (c)
+ (end-command-loop command-processor)
+ (signal c))))
+ (t
+ (setf (accumulated-gestures command-processor)
+ (nconc (accumulated-gestures command-processor)
+ (list gesture)))
+ (process-gestures command-processor)
+ (when (funcall (end-condition command-processor))
+ (funcall (end-function command-processor))
+ (end-command-loop command-processor))))))
(defun process-gestures-for-numeric-argument (gestures)
"Processes a list of gestures for numeric argument
--- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/02/03 08:38:26 1.17
+++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/04/29 16:27:42 1.18
@@ -46,6 +46,7 @@
#:capitalize
#:ensure-array-size
#:values-max-min
+ #:retaining-value
#:build-menu #:define-menu-table
#:observable-mixin
#:add-observer #:remove-observer
--- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/29 22:59:30 1.11
+++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/04/29 16:27:42 1.12
@@ -261,6 +261,18 @@
`(call-method ,(first around) (,@(rest around) (make-method ,form)))
form))))
+(defmacro retaining-value ((bound-symbol &optional initial-value) &body body)
+ "Evaluate `body' with `bound-symbol' bound to
+`initial-value' (default NIL). Th next time `body' is evaluated,
+`bound-symbol' will be bound to whatever its value was the last
+time evaluation of `body' ended."
+ (let ((symbol (gensym)))
+ `(progn (unless (boundp ',symbol)
+ (setf (symbol-value ',symbol) ,initial-value))
+ (let ((,bound-symbol (symbol-value ',symbol)))
+ (unwind-protect (progn ,@body)
+ (setf (symbol-value ',symbol) ,bound-symbol))))))
+
(defun build-menu (command-tables &rest commands)
"Create a command table inheriting commands from
`command-tables', which must be a list of command table
--- /project/mcclim/cvsroot/mcclim/ESA/dead-keys.lisp 2008/04/29 16:27:42 NONE
+++ /project/mcclim/cvsroot/mcclim/ESA/dead-keys.lisp 2008/04/29 16:27:42 1.1
;;; -*- Mode: Lisp; Package: ESA -*-
;;; (c) copyright 2008 by
;;; Troels Henriksen (athas(a)sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;; Elegantly handle dead keys by collapsing into single characters.
(in-package :esa)
(defvar *dead-key-table* (make-hash-table :test 'equal)
"A hash table mapping keyboard event names and characters to
either a similar hash table or characters.")
(defun set-dead-key-combination (character gestures table)
"Set `gestures' to result in `character' in the hash table
`table' (see `*dead-key-table*' for the format of the hash
table)."
(assert (not (null gestures)))
(if (null (rest gestures))
;; Just add it directly to this table.
(setf (gethash (first gestures) table) character)
;; Ensure that the subtable exists.
(let ((new-table (setf (gethash (first gestures) table)
(gethash (first gestures) table
(make-hash-table :test 'equal)))))
(set-dead-key-combination character (rest gestures) new-table))))
(defmacro define-dead-key-combination (character (&rest gestures))
"Define a dead key combination that results in `character' when
`gestures' (either characters or key names) is entered."
(assert (>= (length gestures) 2))
`(set-dead-key-combination ,character ',gestures *dead-key-table*))
(define-dead-key-combination (code-char 193) (:dead-acute #\a))
(define-dead-key-combination (code-char 201) (:dead-acute #\e))
(define-dead-key-combination (code-char 205) (:dead-acute #\i))
(define-dead-key-combination (code-char 211) (:dead-acute #\o))
(define-dead-key-combination (code-char 218) (:dead-acute #\u))
(define-dead-key-combination (code-char 221) (:dead-acute #\y))
(define-dead-key-combination (code-char 225) (:dead-acute #\a))
(define-dead-key-combination (code-char 233) (:dead-acute #\e))
(define-dead-key-combination (code-char 237) (:dead-acute #\i))
(define-dead-key-combination (code-char 243) (:dead-acute #\o))
(define-dead-key-combination (code-char 250) (:dead-acute #\u))
(define-dead-key-combination (code-char 253) (:dead-acute #\y))
(define-dead-key-combination (code-char 199) (:dead-acute #\c))
(define-dead-key-combination (code-char 231) (:dead-acute #\c))
(define-dead-key-combination (code-char 215) (:dead-acute #\x))
(define-dead-key-combination (code-char 247) (:dead-acute #\-))
(define-dead-key-combination (code-char 222) (:dead-acute #\t))
(define-dead-key-combination (code-char 254) (:dead-acute #\t))
(define-dead-key-combination (code-char 223) (:dead-acute #\s))
(define-dead-key-combination (code-char 39) (:dead-acute #\space))
(define-dead-key-combination (code-char 197) (:dead-acute :dead-acute #\a))
(define-dead-key-combination (code-char 229) (:dead-acute :dead-acute #\a))
(define-dead-key-combination (code-char 192) (:dead-grave #\a))
(define-dead-key-combination (code-char 200) (:dead-grave #\e))
(define-dead-key-combination (code-char 204) (:dead-grave #\i))
(define-dead-key-combination (code-char 210) (:dead-grave #\o))
(define-dead-key-combination (code-char 217) (:dead-grave #\u))
(define-dead-key-combination (code-char 224) (:dead-grave #\a))
(define-dead-key-combination (code-char 232) (:dead-grave #\e))
(define-dead-key-combination (code-char 236) (:dead-grave #\i))
(define-dead-key-combination (code-char 242) (:dead-grave #\o))
(define-dead-key-combination (code-char 249) (:dead-grave #\u))
(define-dead-key-combination (code-char 96) (:dead-grave #\space))
(define-dead-key-combination (code-char 196) (:dead-diaeresis #\a))
(define-dead-key-combination (code-char 203) (:dead-diaeresis #\e))
(define-dead-key-combination (code-char 207) (:dead-diaeresis #\i))
(define-dead-key-combination (code-char 214) (:dead-diaeresis #\o))
(define-dead-key-combination (code-char 220) (:dead-diaeresis #\u))
(define-dead-key-combination (code-char 228) (:dead-diaeresis #\a))
(define-dead-key-combination (code-char 235) (:dead-diaeresis #\e))
(define-dead-key-combination (code-char 239) (:dead-diaeresis #\i))
(define-dead-key-combination (code-char 246) (:dead-diaeresis #\o))
(define-dead-key-combination (code-char 252) (:dead-diaeresis #\u))
(define-dead-key-combination (code-char 255) (:dead-diaeresis #\y))
(define-dead-key-combination (code-char 34) (:dead-diaeresis #\space))
(define-dead-key-combination (code-char 195) (:dead-tilde #\a))
(define-dead-key-combination (code-char 209) (:dead-tilde #\n))
(define-dead-key-combination (code-char 227) (:dead-tilde #\a))
(define-dead-key-combination (code-char 241) (:dead-tilde #\n))
(define-dead-key-combination (code-char 198) (:dead-tilde #\e))
(define-dead-key-combination (code-char 230) (:dead-tilde #\e))
(define-dead-key-combination (code-char 208) (:dead-tilde #\d))
(define-dead-key-combination (code-char 240) (:dead-tilde #\d))
(define-dead-key-combination (code-char 245) (:dead-tilde #\o))
(define-dead-key-combination (code-char 126) (:dead-tilde #\space))
(define-dead-key-combination (code-char 194) (:dead-circumflex #\a))
(define-dead-key-combination (code-char 202) (:dead-circumflex #\e))
(define-dead-key-combination (code-char 206) (:dead-circumflex #\i))
(define-dead-key-combination (code-char 212) (:dead-circumflex #\o))
(define-dead-key-combination (code-char 219) (:dead-circumflex #\u))
(define-dead-key-combination (code-char 226) (:dead-circumflex #\a))
(define-dead-key-combination (code-char 234) (:dead-circumflex #\e))
(define-dead-key-combination (code-char 238) (:dead-circumflex #\i))
(define-dead-key-combination (code-char 244) (:dead-circumflex #\o))
(define-dead-key-combination (code-char 251) (:dead-circumflex #\u))
(define-dead-key-combination (code-char 94) (:dead-circumflex #\space))
(defmacro handling-dead-keys ((gesture) &body body)
"Accumulate dead keys and subsequent characters. `Gesture'
should be a symbol bound to either a gesture or an input
event. When it has been determined that a sequence of `gesture's
either does or doesn't result in a full gesture, `body' will be
evaluated with `gesture' bound to that gesture."
(with-gensyms (state-sym)
`(retaining-value (,state-sym *dead-key-table*)
(flet ((invoke-body (,gesture)
(setf ,state-sym *dead-key-table*)
,@body))
(if (typep gesture '(or keyboard-event character))
(let ((value (gethash (if (characterp ,gesture)
,gesture
(keyboard-event-key-name ,gesture))
,state-sym)))
(etypecase value
(null
(if (eq ,state-sym *dead-key-table*)
(invoke-body ,gesture)
(setf ,state-sym *dead-key-table*)))
(character
(invoke-body value))
(hash-table
(setf ,state-sym value))))
(invoke-body ,gesture))))))
