;;; x-kbgrunge.scm

;; Copyright (C) 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Code:

(define-module (ttn-do zzz x-kbgrunge)
  #:export (mk-key
            key-sym
            key-mod
            symbol<-keysym
            keysym<-symbol
            kthx-core)
  #:use-module ((ice-9 optargs-kw) #:select (lambda*
                                             define*
                                             let-optional*
                                             let-keywords*))
  #:use-module ((srfi srfi-1) #:select (remove!
                                        any))
  #:use-module ((ttn-do zzz x-protocol) #:select ((-x . zx)
                                                  (-event-data . key-ev-data)
                                                  (-internal-data . zxint)))
  #:use-module ((ttn-do zzz personally) #:select (FE whatever)))

(define K2S (make-hash-table 71))
(define S2K (make-hash-table 71))

;; Return a @dfn{key object}, basically a pair of integers
;; representing the key's @var{keysym} and @var{modifier}.
;;
(define (mk-key keysym modifier)
  (cons keysym modifier))

;; Return the keysym portion of @var{key}.
;;
(define (key-sym key)
  (car key))

;; Return the modifier portion of @var{key}.
;;
(define (key-mod key)
  (cdr key))

;; Return the symbol associated with @var{keysym} (an integer).
;;
(define (symbol<-keysym keysym)
  (hashq-ref K2S keysym))

;; Return the keysym (integer) associated with @var{symbol}.
;;
(define (keysym<-symbol symbol)
  (hashq-ref S2K symbol))

;;;---------------------------------------------------------------------------
;;; kthx

(define upper-of                        ; WARNING: ASCII ONLY!
  (let* ((a (char->integer #\a))
         (z (char->integer #\z))
         (diff (- (char->integer #\A) a)))
    (lambda (keysym)
      (and (<= a keysym z)
           (+ diff keysym)))))

(define (upcased-maybe keysym)
  (or (upper-of keysym)
      keysym))

(define symbolic-modifiers
  (let ((masks (map (lambda (pair)
                      (cons (ash 1 (cdr pair)) (car pair)))
                    (reverse (hash-ref (zxint 'ENUMS) 'MapIndex)))))
    (lambda (n)
      (let loop ((ls masks) (rv '()))
        (if (null? ls)
            rv
            (let ((pair (car ls)))
              (loop (cdr ls)
                    (if (positive? (logand n (car pair)))
                        (cons (cdr pair) rv)
                        rv))))))))

(define (latin1<-keysym keysym control?) ; => 1-byte string, or #f
  (let ((hi (ash keysym -8))
        (lo (logand keysym #xff)))
    (cond ((zero? keysym)
           #f)
          ((not (or (zero? hi)
                    (and (= #xff hi)
                         (let ((sym (symbol<-keysym keysym)))

                           (define (in-range? bot top)
                             (<= (keysym<-symbol bot)
                                 keysym
                                 (keysym<-symbol top)))

                           (define (one-of? . list)
                             (memq sym list))

                           (or (in-range? 'BackSpace 'Clear)
                               (one-of? 'Return
                                        'Escape
                                        'KP_Space
                                        'KP_Tab
                                        'KP_Enter)
                               (in-range? 'KP_Multiply 'KP_9)
                               (one-of? 'KP_Equal
                                        'Delete))))))
           #f)
          (else
           ;; If X keysym, convert to ASCII by grabbing low 7 bits.
           (and (or (eq? 'KP_Space (symbol<-keysym keysym)) ; encoding botch
                    (= hi #xff))
                (set! lo (logand lo #x7f)))
           ;; Only apply Control key if it makes sense, else ignore it.
           (set! lo (cond ((not control?)
                           lo)
                          ((or (and (<= (char->integer #\@) lo)
                                    (> #o177 lo))
                               (= (char->integer #\space) lo))
                           (logand #x1f lo))
                          ((= (char->integer #\2) lo)
                           0)
                          ((<= (char->integer #\3) lo (char->integer #\7))
                           (- lo (- (char->integer #\3) #o33)))
                          ((= (char->integer #\8) lo)
                           #o177)
                          ((= (char->integer #\/) lo)
                           (logand (char->integer #\_) #x1f))
                          (else
                           lo)))
           (string (integer->char lo))))))

(define ALL-MODIFIERS '(Hyper_R
                        Hyper_L
                        Super_R
                        Super_L
                        Alt_R
                        Alt_L
                        Meta_R
                        Meta_L
                        Shift_Lock
                        Caps_Lock
                        Control_R
                        Control_L
                        Shift_R
                        Shift_L
                        ISO_Last_Group_Lock
                        ISO_Last_Group
                        ISO_First_Group_Lock
                        ISO_First_Group
                        ISO_Prev_Group_Lock
                        ISO_Prev_Group
                        ISO_Next_Group_Lock
                        ISO_Next_Group
                        ISO_Group_Lock
                        ISO_Group_Latch
                        ISO_Group_Shift
                        ISO_Level3_Lock
                        ISO_Level3_Latch
                        ISO_Level3_Shift
                        ISO_Level2_Latch
                        ISO_Lock
                        Mode_switch
                        Num_Lock))

;; Query @var{conn} for the current keysyms and modifiers mappings,
;; massage the raw info --- influenced by the keyword args
;; @code{#:finangle-meta?} and @code{#:additional-modifiers} --- into an
;; internal representation, and return a procedure @var{p} that
;; provides ``core'' translation facilities.
;;
;; The procedure @var{p} takes two args @var{command} and @var{arg},
;; where @var{command} is a keyword.  Valid invocations are:
;;
;; @table @code
;; @item #:info @var{detail}
;; Return information on @var{detail} (a symbol), one of:
;;
;; @table @code
;; @item mode-switch-mod
;; @itemx num-lock-mod
;; A @code{MapIndex} enum, one of: @code{Shift}, @code{Lock},
;; @code{Control}, 1, 2, 3, 4 or 5, which means that the
;; @code{Mode_switch} (or @code{Num_Lock}) keysym is ``bound'' to that
;; modifier; or @code{#f}, which means ``not bound to any modifier''.
;; @item lock-mod
;; One of: @code{#f}, @code{Caps_Lock}, @code{Shift_Lock}.
;; @item meta-finangled?
;; @code{#t} if @code{meta} has been finangled (see below), else @code{#f}.
;; @item valid-modifiers
;; A list of nice names of the available recognized modifiers.
;; @end table
;;
;; @item #:modifier-mask @var{nice-name}
;; If @var{nice-name} is an available recognized modifier,
;; return its 1-bit-set value (i.e., the @dfn{mask}), one of:
;; 1, 2, 4, 8, 16, 32, 64, 128.  Otherwise, return @code{#f}.
;;
;; @item #:keypress<-event @var{event}
;; Translate an event object of type @code{KeyPress} or
;; @code{KeyRelease} into a @dfn{keypress object}, which has
;; the form @code{(@var{name} . @var{press})}.
;;
;; If the event is a modifier key, @var{name} is the nice name or
;; @code{#f}, and @var{press} is the X symbol.
;;
;; If the event is not a modifier key, @var{name} is a string (one byte
;; from the Latin 1 charset) or @code{#f}, and @var{press} has the form
;; @code{(@var{base} [@var{modifier}@dots{}])}, where @var{base} is an X
;; symbol, and @var{modifier} is the nice name.
;;
;; @item #:code/modmask<-keypress @var{press}
;; Translate a @var{press} into @code{(@var{keycode} . @var{modmask})}.
;; If @var{press} is a symbol, it must be either a modifier nice name or
;; (one of) its X symbol(s).  Otherwise @var{press} should be of the
;; form returned by @code{#:keypress<-event} (in which case modifiers
;; must be nice names).
;;
;; This may throw @code{invalid-symbol}, @code{symbol-not-mapped},
;; @code{invalid-modifier} or @code{modifier-not-mapped}, along with
;; the respective (base) symbol or modifier.
;; @end table
;;
;; If you specify non-@code{#f} @var{finangle-meta?}, and @code{alt} is
;; ``bound'', and @code{meta} is ``not bound'', then you will see
;; @code{meta} everywhere @code{alt} should appear, and specifying
;; @code{alt} as a modifier in a (non modifier) arg to
;; @code{#:code/modmask<-keypress} will result in a
;; @code{modifier-not-mapped} error.
;;
(define* (kthx-core conn #:key
                    (finangle-meta? #f)
                    (additional-modifiers '()))
  (let ((keysyms-ra (whatever))
        (look (append
               additional-modifiers
               '((mode-switch Mode_switch)
                 (shift-lock Shift_Lock)
                 (caps-lock Caps_Lock)
                 (num-lock Num_Lock))
               (map (lambda (x)
                      (let ((base (string-capitalize (symbol->string x))))
                        (define (with suffix)
                          (string->symbol (string-append base suffix)))
                        (list x (with "_L") (with "_R"))))
                    '(shift
                      control
                      meta
                      alt
                      super
                      hyper))))
        (canon-mods (whatever))
        (misc (map (lambda (x)
                     (cons x #f))
                   '(mode-switch-mod
                     num-lock-mod
                     lock-mod
                     meta-finangled?))))

    (define (q . x)
      (apply (conn #:q) x))

    (define (keysyms-ref keycode j)
      (array-ref keysyms-ra keycode j))

    (define (nice-name ugly)
      (let loop ((ls look))
        (cond ((null? ls) #f)
              ((memq ugly (cdar ls)) (caar ls))
              (else (loop (cdr ls))))))

    (define (misc! name value)
      (assq-set! misc name value))

    (define (misc: name)
      (assq-ref misc name))

    (define (grok-keysyms!)
      ;; In the following, "per spec" means "per the X Window System Protocol",
      ;; section "5. Keyboards".
      (let* ((setup (conn #:setup))
             (void (keysym<-symbol 'VoidSymbol))
             (min-keycode (zx 'min-keycode setup))
             (max-keycode (zx 'max-keycode setup))
             (count (- max-keycode min-keycode -1))
             ;; The array is hardcoded to width 4, per spec:
             ;;
             ;;   The standard rules for obtaining a KEYSYM from a
             ;;   KeyPress event make use of only the Group 1 and Group 2
             ;;   KEYSYMs; no interpretation of other KEYSYMs in the list
             ;;   is defined.
             ;;
             ;; Thus, if ‘keysyms-per-keycode’ is more than 4, the code
             ;; silently discards the trailing entries.
             (ra (make-uniform-array 1 (+ min-keycode count) 4))
             (kmapping (q 'GetKeyboardMapping
                          #:first-keycode min-keycode
                          #:count count))
             (keysyms-per-keycode (zx 'keysyms-per-keycode kmapping))
             (keysyms (zx 'keysyms kmapping))
             (k0 #f) (k1 #f) (k2 #f) (k3 #f))

        (define (pop)
          (let ((rv (car keysyms)))
            (set! keysyms (cdr keysyms))
            rv))

        (define (take-4!)
          (set! k0 (pop))
          (set! k1 (pop))
          (set! k2 (pop))
          (set! k3 (pop)))

        (define more!
          (case keysyms-per-keycode
            ((1) (lambda ()
                   (set! k0 (pop))
                   (set! k1 void)
                   (set! k2 void)
                   (set! k3 void)))
            ((2) (lambda ()
                   (set! k0 (pop))
                   (set! k1 (pop))
                   (set! k2 void)
                   (set! k3 void)))
            ((3) (lambda ()
                   (set! k0 (pop))
                   (set! k1 (pop))
                   (set! k2 (pop))
                   (set! k3 void)))
            ((4) take-4!)
            (else (let ((dead (- keysyms-per-keycode 4)))
                    (lambda ()
                      (take-4!)
                      (let ignore ((dead dead))
                        (cond ((zero? dead))
                              (else (pop) (ignore (1- dead))))))))))

        (do ((i min-keycode (1+ i)))
            ((= (1+ max-keycode) i))
          (more!)

          ;; FIXME: Presently, the symbol database (see x-kbgrunge.LEARNINGS)
          ;; is not comprehensive.  To ensure that ‘symbol<-keysym’ never
          ;; returns #f, we preemptively jam those positions to 0 (NoSymbol),
          ;; with expectation that the next normalization pass (below) will
          ;; DTRT.  If/when x-kbgrunge.learn becomes comprehensive, this
          ;; step can be dropped.
          (or (symbol<-keysym k0) (set! k0 0))
          (or (symbol<-keysym k1) (set! k1 0))
          (or (symbol<-keysym k2) (set! k2 0))
          (or (symbol<-keysym k3) (set! k3 0))

          ;; Per spec:
          ;;
          ;;   If the list is FOO, then the list is treated as if BAR.
          ;;
          ;; Although this describes a runtime invariant, we choose to
          ;; codify this directly in the data structure, once (here).
          (cond ((and (zero? k3)
                      (zero? k2))
                 (cond ((zero? k1)
                        (set! k2 k0))
                       (else
                        (set! k2 k0)
                        (set! k3 k1))))
                ((zero? k3)
                 (set! k3 void)))

          ;; Likewise (in "should be treated as if" interpretation),
          ;; per spec:
          ;;
          ;;   The first four elements of the list are split into two
          ;;   groups of KEYSYMs.  Group 1 contains the first and second
          ;;   KEYSYMs, Group 2 contains the third and fourth KEYSYMs.
          ;;   Within each group, if the second element of the group is
          ;;   NoSymbol, then the group should be treated as if the second
          ;;   element were the same as the first element, except when the
          ;;   first element is an alphabetic KEYSYM “K” for which both
          ;;   lowercase and uppercase forms are defined.  In that case,
          ;;   the group should be treated as if the first element were
          ;;   the lowercase form of “K” and the second element were the
          ;;   uppercase form of “K”.
          ;;
          ;; For "alphabetic", we limit to ASCII only.  Is this a problem?
          (and (zero? k1) (positive? k0) (set! k1 (upcased-maybe k0)))
          (and (zero? k3) (positive? k2) (set! k3 (upcased-maybe k2)))

          ;; OK, done mangling the set; save it.
          (array-set! ra k0 i 0)
          (array-set! ra k1 i 1)
          (array-set! ra k2 i 2)
          (array-set! ra k3 i 3))

        ;; !!!
        (set! keysyms-ra ra)))

    (define (grok-modifiers!)
      (let* ((mmapping (q 'GetModifierMapping))
             (keycodes-per-modifier (zx 'keycodes-per-modifier mmapping))
             (all-j (iota keycodes-per-modifier))
             (all-keysyms-j (iota 4))
             (keycodes (zx 'keycodes mmapping))
             (canon (map list (map car look))))

        (define (extract i)
          (char->integer (string-ref keycodes i)))

        (FE (iota (/ (string-length keycodes)
                     keycodes-per-modifier))
            (lambda (i)
              (let ((mask (ash 1 i)))
                (define (grok-binding n)

                  (define (msym j)
                    (let ((keysym (keysyms-ref n j)))
                      (and (positive? keysym)
                           (symbol<-keysym keysym))))

                  (let ((name (and (positive? n) (any msym all-keysyms-j))))
                    (define (symbolic-xmod)
                      (car (symbolic-modifiers mask)))
                    (case name
                      ((Mode_switch)
                       (misc! 'mode-switch-mod (symbolic-xmod)))
                      ((Num_Lock)
                       (misc! 'num-lock-mod (symbolic-xmod)))
                      ((Shift_Lock Caps_Lock)
                       (misc! 'lock-mod name)))
                    (cond ((and name (nice-name name))
                           => (lambda (nice)
                                (let ((pair (assq nice canon)))
                                  (and (null? (cdr pair))
                                       (set-cdr! pair mask)))
                                #t))
                          (else #f))))

                (any grok-binding
                     (map (lambda (j)
                            (extract (+ (* i keycodes-per-modifier) j)))
                          all-j)))))

        ;; If requested, when there are no meta keys but there are alt keys,
        ;; arrange for alt keys to be considered as meta keys.
        (and finangle-meta?
             (let ((alt  (assq 'alt  canon))
                   (meta (assq 'meta canon)))
               (and (null? (cdr meta))
                    (not (null? (cdr alt)))
                    (begin (misc! 'meta-finangled? #t)
                           (set-cdr! meta (cdr alt))
                           (set-cdr! alt '())))))

        ;; !!!
        (set! canon-mods (remove! (lambda (x)
                                    (null? (cdr x)))
                                  canon))))

    (define (symbolic-keypress keycode state)

      (define mod?
        (let ((mods (symbolic-modifiers state)))
          (lambda (x) (memq x mods))))

      (define (group-sel a b)
        (if (and=> (misc: 'mode-switch-mod) mod?)
            b
            a))

      (define (lock-is? symbol)
        (eq? symbol (misc: 'lock-mod)))

      (let* ((plain (keysyms-ref keycode (group-sel 0 2)))
             (shift (keysyms-ref keycode (group-sel 1 3)))
             (same? (eq? plain shift))
             (base (symbol<-keysym
                    (let ((shift? (mod? 'Shift))
                          (lock? (mod? 'Lock)))
                      (cond ((and (and=> (misc: 'num-lock-mod) mod?)
                                  (or (<=     #xff80 shift     #xffbd)
                                      (<= #x11000000 shift #x1100ffff)))
                             (if (or shift?
                                     (and lock? (lock-is? 'Shift_Lock)))
                                 plain
                                 shift))
                            ((and (not shift?)
                                  (not lock?))
                             plain)
                            ((and (not shift?)
                                  (lock-is? 'Caps_Lock))
                             (if (upper-of plain)
                                 shift
                                 plain))
                            ((and shift?
                                  (lock-is? 'Caps_Lock))
                             (upcased-maybe shift))
                            ((or shift?
                                 (lock-is? 'Shift_Lock))
                             shift)
                            (else
                             plain))))))
        (if (memq base ALL-MODIFIERS)
            base
            (let ((mods '()))
              (FE canon-mods (lambda (cmod)
                               (or (null? (cdr cmod))
                                   (zero? (logand (cdr cmod) state))
                                   (and (eq? 'shift (car cmod))
                                        (not same?))
                                   (set! mods (cons (car cmod) mods)))))
              (cons base mods)))))

    (define (keypress<-event ev)
      (let* ((alist (key-ev-data ev))
             (detail (zx 'detail alist))
             (state (zx 'state alist))
             (tail (symbolic-keypress detail state)))
        (cons (if (pair? tail)
                  (let ((keysym (keysym<-symbol (car tail)))
                        (control? (memq 'control (cdr tail))))
                    (and keysym (latin1<-keysym keysym control?)))
                  (and=> (nice-name tail)
                         (lambda (nice)
                           (if (and (eq? 'alt nice)
                                    (misc: 'meta-finangled?))
                               'meta
                               nice))))
              tail)))

    (define (!!-invalid-modifier x)
      (throw 'invalid-modifier x))

    (define (!!-modifier-not-mapped x)
      (throw 'modifier-not-mapped x))

    (define (code/modmask<-keypress ls)

      (define (keycode<-keysym keysym)  ; => keycode, or #f
        (let* ((dims (array-dimensions keysyms-ra))
               (max-j (cadr dims))
               (max-keycode (car dims)))
          (call-with-current-continuation
           (lambda (return)
             (do ((j 0 (1+ j)))
                 ((= j max-j))
               (do ((code 0 (1+ code)))
                   ((= max-keycode code))
                 (and (= keysym (keysyms-ref code j))
                      (return code))))
             #f))))

      (cond ((not (pair? ls))
             (cons (or (cond ((assq-ref look ls)
                              => (lambda (maybe)
                                   (any keycode<-keysym
                                        (map keysym<-symbol maybe))))
                             ((keysym<-symbol ls)
                              => keycode<-keysym)
                             (else
                              (!!-invalid-modifier ls)))
                       (!!-modifier-not-mapped ls))
                   0))
            ((keysym<-symbol (car ls))
             => (lambda (keysym)
                  (let* ((c (or (keycode<-keysym keysym)
                                (throw 'symbol-not-mapped (car ls))))
                         (modsyms (cdr ls))
                         (plain (keysyms-ref c 0))
                         (shift (keysyms-ref c 1)))
                    (and (= keysym shift)
                         (or (= plain shift)
                             (set! modsyms (cons 'shift modsyms))))
                    (cons c (apply logior
                                   (map (lambda (sym)
                                          (or (assq sym look)
                                              (!!-invalid-modifier sym))
                                          (or (assq-ref canon-mods sym)
                                              (!!-modifier-not-mapped sym)))
                                        modsyms))))))
            (else
             (throw 'invalid-symbol (car ls)))))

    (define (info what)
      (case what
        ((mode-switch-mod num-lock-mod lock-mod meta-finangled?)
         (misc: what))
        ((valid-modifiers) (map car canon-mods))
        (else (error "bad info request:" what))))

    (define (modifier-mask nice)
      (assq-ref canon-mods nice))

    ;; do it!
    (grok-keysyms!)
    (grok-modifiers!)
    ;; rv
    (lambda (command arg)
      ((case command
         ((#:info) info)
         ((#:modifier-mask) modifier-mask)
         ((#:keypress<-event) keypress<-event)
         ((#:code/modmask<-keypress) code/modmask<-keypress)
         (else (error "bad command:" command)))
       arg))))

;;; bloat, sigh...
(load (in-vicinity (dirname (port-filename (current-load-port)))
                   "x-kbgrunge.LEARNINGS"))

;;; x-kbgrunge.scm ends here