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

Last change on this file since 25842 was 25842, checked in by felix winkelmann, 9 years ago

added kitaaba (work in progress, far from finished)

  • Property svn:executable set to *
File size: 2.0 KB
Line 
1;;;; keybd.scm
2
3
4(define scancode-map (make-hash-table eq?)) ; SCANCODE -> KEYCODE
5(define keycode-map (make-hash-table eq?))  ; KEYCODE+MODIFIERS -> (KEYCODE -> _) | CHARCODE
6(define overstrike-map (make-hash-table eq?)) ; CHARCODE -> ((CHARCODE . CHARCODE) ...)
7
8(define (decode-key-event)
9  (let* ((sc (event-key-scancode))
10         (kc (fxior (or (hash-table-ref/default scancode-map sc #f)
11                        (event-key-code))
12                    (fxshl (event-modifier-keys) 16)))
13         (h (hash-table-ref/default keycode-map kc #f)))
14    #;(##sys#message
15     (sprintf "mod: ~x, kc: ~x -> ~x"
16       (event-modifier-keys)
17       (event-key-code)
18       kc))
19    (define (add c)
20      (let* ((cc (current-char))
21             (os (or (and cc
22                          (hash-table-ref/default overstrike-map cc #f))
23                     '())))
24        (cond ((assq c os) =>
25               (lambda (a)
26                 (replace-char (cdr a))))
27              (else (insert-char c)))))
28    ;(##sys#message (sprintf "#x~x #x~x ~s~%" sc kc h)) ;XXX
29    (cond ((not h)
30           (let ((c (event-key-unicode)))
31             (when (>= c 32) 
32               (add c))))
33          ((number? h) (add h))
34          ((procedure? h)
35           (h kc))      ;XXX does not handle overstrike
36          (else (error "invalid keycode handler" kc h)))))
37
38(define (map-key spec mapping)
39  (let ((kc (let loop ((spec (if (number? spec) (list spec) spec)))
40              (if (null? spec) 
41                  0
42                  (let ((x (car spec))
43                        (r (cdr spec)))
44                    (fxior 
45                     (cond ((number? x) x)
46                           ((symbol? x) (fxshl (modifier-key-code x) 16))
47                           ((char? x) (char->integer x))
48                           (else (error "invalid key specifier" spec)))
49                     (loop r)))))))
50    ;(##sys#message (sprintf "map #x~x -> ~s~%" kc mapping)) ;XXX
51    (hash-table-set! keycode-map kc mapping)))
52
53(define (overstrike lst)
54  (for-each
55   (match-lambda
56     ((code parts ...)
57      (for-each
58       (lambda (cp)
59         (hash-table-set!
60          overstrike-map cp
61          (append
62           (hash-table-ref/default overstrike-map cp '())
63           (filter-map
64            (lambda (cp2)
65              (and (not (eq? cp cp2))
66                   (cons cp2 code)))
67            parts))))
68       parts)))
69   lst))
70
71
72(include "defkeys")
Note: See TracBrowser for help on using the repository browser.