source: project/release/4/kitaaba/trunk/keybd.scm @ 25842

;;;; keybd.scm


(define scancode-map (make-hash-table eq?)) ; SCANCODE -> KEYCODE
(define keycode-map (make-hash-table eq?))  ; KEYCODE+MODIFIERS -> (KEYCODE -> _) | CHARCODE
(define overstrike-map (make-hash-table eq?)) ; CHARCODE -> ((CHARCODE . CHARCODE) ...)

(define (decode-key-event)
  (let* ((sc (event-key-scancode))
         (kc (fxior (or (hash-table-ref/default scancode-map sc #f)
                        (event-key-code))
                    (fxshl (event-modifier-keys) 16)))
         (h (hash-table-ref/default keycode-map kc #f)))
    #;(##sys#message
     (sprintf "mod: ~x, kc: ~x -> ~x"
       (event-modifier-keys)
       (event-key-code)
       kc))
    (define (add c)
      (let* ((cc (current-char))
             (os (or (and cc
                          (hash-table-ref/default overstrike-map cc #f))
                     '())))
        (cond ((assq c os) =>
               (lambda (a)
                 (replace-char (cdr a))))
              (else (insert-char c)))))
    ;(##sys#message (sprintf "#x~x #x~x ~s~%" sc kc h)) ;XXX
    (cond ((not h)
           (let ((c (event-key-unicode)))
             (when (>= c 32) 
               (add c))))
          ((number? h) (add h))
          ((procedure? h)
           (h kc))      ;XXX does not handle overstrike
          (else (error "invalid keycode handler" kc h)))))

(define (map-key spec mapping)
  (let ((kc (let loop ((spec (if (number? spec) (list spec) spec)))
              (if (null? spec) 
                  0
                  (let ((x (car spec))
                        (r (cdr spec)))
                    (fxior 
                     (cond ((number? x) x)
                           ((symbol? x) (fxshl (modifier-key-code x) 16))
                           ((char? x) (char->integer x))
                           (else (error "invalid key specifier" spec)))
                     (loop r)))))))
    ;(##sys#message (sprintf "map #x~x -> ~s~%" kc mapping)) ;XXX
    (hash-table-set! keycode-map kc mapping)))

(define (overstrike lst)
  (for-each
   (match-lambda
     ((code parts ...)
      (for-each
       (lambda (cp)
         (hash-table-set!
          overstrike-map cp
          (append
           (hash-table-ref/default overstrike-map cp '())
           (filter-map
            (lambda (cp2)
              (and (not (eq? cp cp2))
                   (cons cp2 code)))
            parts))))
       parts)))
   lst))


(include "defkeys")