#lang scheme/base
(require scheme/class
         "../syntax.ss"
         "wx.ss")

(provide keymap%
         map-command-as-meta-key)

(define map-command-as-meta? #f)

(define/top (map-command-as-meta-key [bool? v])
  (set! map-command-as-meta? v))

(define (as-meta-key k)
  (case (system-type)
    [(macosx) (if map-command-as-meta?
                  k
                  #f)]
    [else k]))

(define (as-cmd-key k)
  (case (system-type)
    [(macosx) k]
    [else #f]))

(define keylist
  #hash(("leftbutton" . mouse-left)
        ("rightbutton" . mouse-right)
        ("middlebutton" . mouse-middle)
        ("leftbuttondouble" . mouse-left-double)
        ("rightbuttondouble" . mouse-right-double)
        ("middlebuttondouble" . mouse-middle-double)
        ("leftbuttontriple" . mouse-left-triple)
        ("rightbuttontriple" . mouse-right-triple)
        ("middlebuttontriple" . mouse-middle-triple)
        ("leftbuttonseq" . mouse-left)
        ("rightbuttonseq" . mouse-right)
        ("middlebuttonseq" . mouse-middle)
        ("wheelup" . wheel-up)
        ("wheeldown" . wheel-down)
        ("wheelleft" . wheel-left)
        ("wheelright" . wheel-right)
        ("esc" . escape) 
        ("delete" . #\rubout)
        ("del" . #\rubout)
        ("insert" . insert)
        ("ins" . insert)
        ("add" . add)
        ("subtract" . subtract)
        ("multiply" . multiply)
        ("divide" . divide)
        ("backspace" . #\backspace)
        ("back" . #\backspace)
        ("return" . #\return)
        ("enter" . #\return)
        ("tab" . #\tab)
        ("space" . #\space)
        ("right" . right)
        ("left" . left)
        ("up" . up)
        ("down" . down)
        ("home" . home)
        ("end" . end)
        ("pageup" . prior)
        ("pagedown" . next)
        ("semicolon" . #\;)
        ("colon" . #\:)
        ("numpad0" . numpad0)
        ("numpad1" . numpad1)
        ("numpad2" . numpad2)
        ("numpad3" . numpad3)
        ("numpad4" . numpad4)
        ("numpad5" . numpad5)
        ("numpad6" . numpad6)
        ("numpad7" . numpad7)
        ("numpad8" . numpad8)
        ("numpad9" . numpad9)
        ("numpadenter" . #\u3)
        ("f1" . f1)
        ("f2" . f2)
        ("f3" . f3)
        ("f4" . f4)
        ("f5" . f5)
        ("f6" . f6)
        ("f7" . f7)
        ("f8" . f8)
        ("f9" . f9)
        ("f10" . f10)
        ("f11" . f11)
        ("f12" . f12)
        ("f13" . f13)
        ("f14" . f14)
        ("f15" . f15)
        ("f16" . f16)
        ("f17" . f17)
        ("f18" . f18)
        ("f19" . f19)
        ("f20" . f20)
        ("f21" . f21)
        ("f22" . f22)
        ("f23" . f23)
        ("f24" . f24)))
(define rev-keylist
  (make-immutable-hash
   (hash-map keylist (lambda (k v) (cons v k)))))

(define-struct kmfunc (name f))

(define-struct key (code

                    shift-on?
                    shift-off?
                    ctrl-on?
                    ctrl-off?
                    alt-on?
                    alt-off?
                    meta-on?
                    meta-off?
                    cmd-on?
                    cmd-off?
                    caps-on?
                    caps-off?

                    score

                    check-other?
                    fullset?

                    [fname #:mutable]

                    isprefix?
                    seqprefix))

(define-local-member-name 
  chain-handle-key-event
  get-best-score
  chain-handle-mouse-event
  get-best-mouse-score
  cycle-check)

(defclass keymap% object%
  
  (super-new)

  (define functions (make-hash))
  (define keys (make-hash))

  (define prefix #f)
  (define prefixed? #f)

  (define active-mouse-function #f)

  (define grab-key-function #f)
  (define grab-mouse-function #f)
  (define on-break #f)

  (define chain-to null)

  (define last-time 0)
  (define last-x 0)
  (define last-y 0)
  (define click-count 0)
  (define last-code #f)
  (define last-button #f)

  (define double-interval (get-double-click-threshold))

  (def/public (reset)
    (set! prefix #f)
    (set! prefixed? #f)

    (for-each (lambda (c)
                (send c reset))
              chain-to))

  (def/public (break-sequence)
    (set! prefix #f)

    (when on-break
      (let ([f on-break])
        (set! on-break #f)
        (f)))
    
    (for-each (lambda (c)
                (send c break-sequence))
              chain-to))

  (def/public (set-break-sequence-callback [(make-procedure 0) f])
    (let ([old on-break])
      (set! on-break f)
      (when old (old))))

  (define/private (find-key code other-code alt-code other-alt-code caps-code
                            shift? ctrl? alt? meta? cmd? caps?
                            prefix)
    (for*/fold ([best-key #f]
                [best-score -1])
        ([findk (in-list (list code other-code alt-code other-alt-code caps-code))]
         [key (in-list (hash-ref keys findk null))])
      (if (and (or (eqv? (key-code key) code)
                   (and (key-check-other? key)
                        (or (eqv? (key-code key) other-code)
                            (eqv? (key-code key) alt-code)
                            (eqv? (key-code key) other-alt-code)
                            (eqv? (key-code key) caps-code))))
               (or (and (key-shift-on? key) shift?)
                   (and (key-shift-off? key) (not shift?))
                   (and (not (key-shift-on? key)) (not (key-shift-off? key))))
               (or (and (key-ctrl-on? key) ctrl?)
                   (and (key-ctrl-off? key) (not ctrl?))
                   (and (not (key-ctrl-on? key)) (not (key-ctrl-off? key))))
               (or (and (key-alt-on? key) alt?)
                   (and (key-alt-off? key) (not alt?))
                   (and (not (key-alt-on? key)) (not (key-alt-off? key))))
               (or (and (key-meta-on? key) meta?)
                   (and (key-meta-off? key) (not meta?))
                   (and (not (key-meta-on? key)) (not (key-meta-off? key))))
               (or (and (key-cmd-on? key) cmd?)
                   (and (key-cmd-off? key) (not cmd?))
                   (and (not (key-cmd-on? key)) (not (key-cmd-off? key))))
               (or (and (key-caps-on? key) caps?)
                   (and (key-caps-off? key) (not caps?))
                   (and (not (key-caps-on? key)) (not (key-caps-off? key))))
               (eq? (key-seqprefix key) prefix))
          (let ([score (+ (key-score key)
                          (if (eqv? (key-code key) code)
                              0
                              (if (eqv? (key-code key) other-alt-code)
                                  -4
                                  -2)))])
            (if (score . > . best-score)
                (values key score)
                (values best-key best-score)))
          (values best-key best-score))))

  (define/private (do-map-function code shift ctrl alt meta cmd caps check-other?
                                   fname prev isprefix? fullset?)
    ;; look for existing key mapping:
    (let ([key
           (ormap (lambda (key)
                    (and (eqv? (key-code key) code)
                         (eq? (key-shift-on? key) (shift . > . 0))
                         (eq? (key-shift-off? key) (shift . < . 0))
                         (eq? (key-ctrl-on? key) (ctrl . > . 0))
                         (eq? (key-ctrl-off? key) (ctrl . < . 0))
                         (eq? (key-alt-on? key) (alt . > . 0))
                         (eq? (key-alt-off? key) (alt . < . 0))
                         (eq? (key-meta-on? key) (meta . > . 0))
                         (eq? (key-meta-off? key) (meta . < . 0))
                         (eq? (key-cmd-on? key) (cmd . > . 0))
                         (eq? (key-cmd-off? key) (cmd . < . 0))
                         (eq? (key-caps-on? key) (caps . > . 0))
                         (eq? (key-caps-off? key) (caps . < . 0))
                         (eq? (key-check-other? key) check-other?)
                         (eq? (key-seqprefix key) prev)
                         key))
                  (hash-ref keys code null))])

      (if key
          ;; Found existing
          (if (not (eq? isprefix? (key-isprefix? key)))
              ;; prefix vs no-prefix mismatch:
              (let ([s
                     (string-append
                      (if (meta . > . 0) "m:" "")
                      (if (meta . < . 0) "~m:" "")
                      (if (cmd . > . 0) "d:" "")
                      (if (cmd . < . 0) "~d:" "")
                      (if (alt . > . 0) "a:" "")
                      (if (alt . < . 0) "~a:" "")
                      (if (ctrl . > . 0) "c:" "")
                      (if (ctrl . < . 0) "~c:" "")
                      (if (shift . > . 0) "s:" "")
                      (if (shift . < . 0) "~s:" "")
                      (or (hash-ref rev-keylist code)
                          (format "~c" code)))])
                (error (method-name 'keymap% 'map-function)
                       "~s is already mapped as a ~aprefix key"
                       s (if isprefix? "non-" "")))
              (begin
                (set-key-fname! key (string->immutable-string fname))
                key))
          ;; Create new
          (let ([newkey (make-key
                         code
                         (shift . > . 0) (shift . < . 0)
                         (ctrl . > . 0) (ctrl . < . 0)
                         (alt . > . 0) (alt . < . 0)
                         (meta . > . 0) (meta . < . 0)
                         (cmd . > . 0) (cmd . < . 0)
                         (caps . > . 0) (caps . < . 0)
                         (+ (if (shift . > . 0) 1 0)
                            (if (shift . < . 0) 5 0)
                            (if (ctrl . > . 0) 1 0)
                            (if (ctrl . < . 0) 5 0)
                            (if (alt . > . 0) 1 0)
                            (if (alt . < . 0) 5 0)
                            (if (meta . > . 0) 1 0)
                            (if (meta . < . 0) 5 0)
                            (if (cmd . > . 0) 1 0)
                            (if (cmd . < . 0) 5 0)
                            (if (caps . > . 0) 1 0)
                            (if (caps . < . 0) 5 0)
                            (if check-other? 6 30))
                         check-other?
                         fullset?
                         (string->immutable-string fname)
                         isprefix?
                         prev)])
            (hash-set! keys code (cons newkey (hash-ref keys code null)))
            newkey))))

  (define/private (get-code str)
    (let ([code (hash-ref keylist (string-downcase str) #f)])
      (if code
          (values code (member str '("leftbuttonseq"
                                     "middlebuttonseq"
                                     "rightbuttonseq")))
          (if (= 1 (string-length str))
              (values (string-ref str 0)
                      #f)
              (values #f #f)))))

  (def/public (map-function [string? keys]
                            [string? fname])
    (if (string=? keys "")
        (error (method-name 'keymap% 'map-function)
               "bad key string: ~e"
               keys)
        (let loop ([seq (regexp-split #rx";" keys)]
                   [prev-key #f])
          (let ([str (car seq)])
            (define (bad-string msg)
              (error (method-name 'keymap% 'map-function)
                     "bad keymap string: ~e~a: ~a"
                     str
                     (if (equal? str keys)
                         ""
                         (format " within ~e" keys))
                     msg))
            (let-values ([(str default-off?)
                          (if (regexp-match? #rx"^:" str)
                              (values (substring str 1) #t)
                              (values str #f))])
              (let sloop ([str str]
                          [downs null]
                          [ups null]
                          [others? #f])
                (cond
                 [(regexp-match? #rx"^[?]:" str)
                  (sloop (substring str 2) downs ups #t)]
                 [(regexp-match? #rx"^~[SsCcAaMmDdLl]:" str)
                  (let ([c (char-downcase (string-ref str 1))])
                    (if (memv c downs)
                        (bad-string (format "inconsistent ~a: modifier state" c))
                        (sloop (substring str 3) downs (cons c ups) others?)))]
                 [(regexp-match? #rx"^[SsCcAaMmDdLl]:" str)
                  (let ([c (char-downcase (string-ref str 0))])
                    (if (memv c ups)
                        (bad-string (format "inconsistent ~a: modifier state" c))
                        (sloop (substring str 2) (cons c downs) ups others?)))]
                 [else
                  (let-values ([(code fullset?) (get-code str)])
                    (if (not code)
                        (bad-string "unrecognized key name")
                        (let-values ([(downs code)
                                      (if (and (char? code)
                                               ((char->integer code) . > . 0)
                                               ((char->integer code) . < . 127)
                                               (char-alphabetic? code))
                                          (cond
                                           [(memq #\s downs)
                                            (if (or (and (eq? (system-type) 'macosx)
                                                         (not (memq #\m downs))
                                                         (not (memq #\d downs)))
                                                    (and (eq? (system-type) 'windows)
                                                         (or (not (memq #\c downs))
                                                             (memq #\m downs))))
                                                (values downs (char-upcase code))
                                                (values downs code))]
                                           [(char-upper-case? code)
                                            (values (cons #\s downs) code)]
                                           [else
                                            (values downs code)])
                                          (values downs code))])
                          (let ([newkey
                                 (let ([modval (lambda (c)
                                                 (cond
                                                  [(memq c downs) 1]
                                                  [(memq c ups) -1]
                                                  [else (if default-off? -1 0)]))])
                                   (do-map-function code
                                                    (modval #\s)
                                                    (modval #\c)
                                                    (modval #\a)
                                                    (modval #\m)
                                                    (modval #\d)
                                                    (modval #\l)
                                                    others?
                                                    fname
                                                    prev-key
                                                    (not (null? (cdr seq)))
                                                    fullset?))])
                            (if (null? (cdr seq))
                                (void)
                                (loop (cdr seq) newkey))))))])))))))

  (define/private (handle-event code other-code alt-code other-alt-code caps-code
                                shift? ctrl? alt? meta? cmd? caps?
                                score)
    (let-values ([(key found-score)
                  (find-key code other-code alt-code other-alt-code caps-code
                            shift? ctrl? alt? meta? cmd? caps? prefix)])
      (set! prefix #f)

      (if (and key (found-score . >= . score))
          (if (key-isprefix? key)
              (begin
                (set! prefix key)
                (values #t #f #f))
              (values #t
                      (key-fname key)
                      (key-fullset? key)))
          (values #f #f #f))))

  (define/public (get-best-score code other-code alt-code other-alt-code caps-code
                                 shift? ctrl? alt? meta? cmd? caps?)
    (let-values ([(key score)
                  (find-key code other-code alt-code other-alt-code caps-code
                            shift? ctrl? alt? meta? cmd? caps? prefix)])
      (for/fold ([s (if key score -1)])
          ([c (in-list chain-to)])
        (max s
             (send c get-best-score code other-code alt-code other-alt-code caps-code
                   shift? ctrl? alt? meta? cmd? caps?)))))

  (def/public (set-grab-key-function [(make-procedure 4) grab])
    (set! grab-key-function grab))
  
  (def/public (remove-grab-key-function)
    (set! grab-key-function #f))

  (def/public (handle-key-event [any? obj] [key-event% event])
    (let ([code (send event get-key-code)])
      (or (eq? code 'shift)
          (eq? code 'control)
          (eq? code 'release)
          (let ([score (get-best-score 
                        code
                        (send event get-other-shift-key-code)
                        (send event get-other-altgr-key-code)
                        (send event get-other-shift-altgr-key-code)
                        (send event get-other-caps-key-code)
                        (send event get-shift-down)
                        (send event get-control-down)
                        (send event get-alt-down)
                        (as-meta-key (send event get-meta-down))
                        (as-cmd-key (send event get-meta-down))
                        (send event get-caps-down))])
            (let ([was-prefixed? prefixed?])
              
              (let* ([r (chain-handle-key-event obj event #f prefixed? score)]
                     [r (if (and (zero? r)
                                 was-prefixed?)
                            (begin
                              (reset)
                              ;; try again without prefix:
                              (chain-handle-key-event obj event #f #f score))
                            r)])
                (when (r . >= . 0)
                  (reset))
                (not (zero? r))))))))

  (define/private (other-handle-key-event obj event grab try-prefixed? score)
    (for/fold ([r 0])
        ([c (in-list chain-to)]
         #:when (r . <= . 0))
      (let ([r2 (send c chain-handle-key-event obj event grab try-prefixed? score)])
        (if (r2 . > . 0)
            (begin
              (reset)
              r2)
            (if (r2 . < . 0)
                r2
                r)))))

  (define/public (chain-handle-key-event obj event grab only-prefixed? score)
    ;; results: 0 = no match, 1 = match, -1 = matched prefix
    (set! last-time (send event get-time-stamp))
    (set! last-button #f)
    (let ([grab (or grab-key-function
                    grab)])
      (if (and only-prefixed? (not prefixed?))
          0
          (let ([sub-result (other-handle-key-event obj event grab only-prefixed? score)])
            (if (sub-result . > . 0)
                sub-result
                (let-values ([(h? fname fullset?)
                              (handle-event (send event get-key-code)
                                            (send event get-other-shift-key-code)
                                            (send event get-other-altgr-key-code)
                                            (send event get-other-shift-altgr-key-code)
                                            (send event get-other-caps-key-code)
                                            (send event get-shift-down)
                                            (send event get-control-down)
                                            (send event get-alt-down)
                                            (as-meta-key (send event get-meta-down))
                                            (as-cmd-key (send event get-meta-down))
                                            (send event get-caps-down)
                                            score)])
                  (if h?
                      (if fname
                          (begin
                            (reset)
                            (if (and grab
                                     (grab fname this obj event))
                                1
                                (if (call-function fname obj event)
                                    1
                                    0)))
                          (if prefix
                              (begin
                                (set! prefixed? #t)
                                -1)
                              ;; shouldn't get here
                              0))
                      (let ([result
                             (if (sub-result . < . 0)
                                 (begin
                                   (set! prefixed? #t)
                                   -1)
                                 0)])
                        (if (and (zero? result)
                                 grab-key-function
                                 (grab-key-function #f this obj event))
                            1
                            result)))))))))

  (def/public (set-grab-mouse-function [(make-procedure 4) grab])
    (set! grab-mouse-function grab))

  (def/public (remove-grab-mouse-function)
    (set! grab-mouse-function #f))

  (define/private (adjust-button-code code click-count)
    (case click-count
      [(0) code]
      [(1) (case code
             [(mouse-right) 'mouse-right-double]
             [(mouse-left) 'mouse-left-double]
             [(mouse-middle) 'mouse-middle-double])]
      [else (case code
              [(mouse-right) 'mouse-right-triple]
              [(mouse-left) 'mouse-left-triple]
              [(mouse-middle) 'mouse-middle-triple])]))

  (def/public (handle-mouse-event [any? obj][mouse-event% event])
    (let ([score (get-best-mouse-score event)])
      (not (zero? (chain-handle-mouse-event obj event #f 0 score)))))

  (define/public (get-best-mouse-score event)
    (cond
     [(not (send event button-down?))
      (if active-mouse-function
          100
          (or (ormap (lambda (c)
                       (and (not (zero? (send c get-best-mouse-score event)))
                            100))
                     chain-to)
              -1))]
     [else
      (let ([code (cond
                   [(send event get-right-down) 'mouse-right]
                   [(send event get-left-down) 'mouse-left]
                   [(send event get-middle-down) 'mouse-middle]
                   [else #f])])
        (if (not code)
            -1
            (let ([code
                   (if (and (eq? code last-button)
                            (= (send event get-x) last-x)
                            (= (send event get-y) last-y)
                            ((abs (- (send event get-time-stamp) last-time)) . < . double-interval))
                       (adjust-button-code code click-count)
                       code)])
              (get-best-score code #f #f #f #f
                              (send event get-shift-down)
                              (send event get-control-down)
                              (send event get-alt-down)
                              (as-meta-key (send event get-meta-down))
                              (as-cmd-key (send event get-meta-down))
                              (send event get-caps-down)))))]))

  (define/private (other-handle-mouse-event obj event grab try-state score)
    (for/fold ([result 0])
        ([c (in-list chain-to)]
         #:when (result . <= . 0))
      (let ([r (send c chain-handle-mouse-event obj event grab try-state score)])
        (cond
         [(r . > . 0)
          (reset)
          r]
         [(zero? r) result]
         [else r]))))

  (define/public (chain-handle-mouse-event obj event grab try-state score)
    (let ([grab (or grab-mouse-function grab)])
      (define (step1)
        (cond
         [(and (not prefix)
               (try-state . >= . 0))
          (let ([r (other-handle-mouse-event obj event grab 1 score)])
            (cond
             [(r . > . 0) r]
             [(try-state . > . 0) r]
             [else (step2 -1)]))]
         [(and prefix (try-state . < . 0))
          (other-handle-mouse-event obj event grab -1 score)]
         [else (step2 try-state)]))
      (define (step2 try-state)
        (cond
         [(not (send event button-down?))
          (when (and (not (send event dragging?))
                     (not (send event button-up?)))
            ;; we must have missed the button-up
            (set! active-mouse-function #f))
          (if (not active-mouse-function)
              (other-handle-mouse-event obj event grab -1 score)
              (let ([v (if (and grab 
                                (grab active-mouse-function this obj event))
                           1
                           (if (call-function active-mouse-function obj event)
                               1
                               0))])
                (when (send event button-up?)
                  (set! active-mouse-function #f))
                v))]
         [else
          (let ([code (cond
                       [(send event get-right-down) 'mouse-right]
                       [(send event get-left-down) 'mouse-left]
                       [(send event get-middle-down) 'mouse-middle]
                       [else #f])])
            (if (not code)
                0 ;; FIXME: should we call grab here?
                (let ([orig-code code]
                      [code
                       (if (and (eq? code last-button)
                                (= (send event get-x) last-x)
                                (= (send event get-y) last-y))
                           (if ((abs (- (send event get-time-stamp) last-time)) . < . double-interval)
                               (begin0
                                (adjust-button-code code click-count)
                                (set! click-count (add1 click-count)))
                               (begin
                                 (set! click-count 1)
                                 code))
                           (begin
                             (set! last-button code)
                             (set! click-count 1)
                             code))])
                  (set! last-time (send event get-time-stamp))
                  (set! last-x (send event get-x))
                  (set! last-y (send event get-y))

                  (let loop ([code code])
                    (let-values ([(h? fname fullset?) (handle-event code
                                                                    #f #f #f #f
                                                                    (send event get-shift-down)
                                                                    (send event get-control-down)
                                                                    (send event get-alt-down)
                                                                    (as-meta-key (send event get-meta-down))
                                                                    (as-cmd-key (send event get-meta-down))
                                                                    (send event get-caps-down)
                                                                    score)])
                      (cond
                       [(and h? fname)
                        (reset)
                        (when fullset?
                          (set! active-mouse-function fname))
                        (cond
                         [(and grab (grab fname this obj event)) 1]
                         [(call-function fname obj event) 1]
                         [else 0])]
                       [h?
                        (let ([r (other-handle-mouse-event obj event grab try-state score)])
                          (if (r . > . 0)
                              r
                              -1))]
                       [else
                        (set! last-code code)
                        (if (not (eqv? last-code orig-code))
                            (loop orig-code)
                            (let ([result (other-handle-mouse-event obj event grab try-state score)])
                              (if (and (zero? result)
                                       grab-mouse-function
                                       (grab-mouse-function #f this obj event))
                                  1
                                  result)))]))))))]))
      (step1)))

  (def/public (add-function [string? name] [(make-procedure 2) f])
    (hash-set! functions
               (string->immutable-string name)
               f))

  (def/public (call-function [string? name] [any? obj] [event% event] [any? [try-chained? #f]])
    (let ([f (hash-ref functions name #f)])
      (cond
       [f 
        (f obj event)
        #t]
       [try-chained?
        (ormap (lambda (c)
                 (send c call-function name obj event #t))
               chain-to)]
       [else
        (error 'keymap "no function ~e" name)])))

  (def/public (get-double-click-interval)
    double-interval)

  (def/public (set-double-click-interval [exact-positive-integer? d])
    (set! double-interval d))

  (define/public (cycle-check km)
    (ormap (lambda (c)
             (or (eq? km c)
                 (send c cycle-check km)))
           chain-to))

  (def/public (chain-to-keymap [keymap% km] [any? prefix?])
    (unless (or (eq? km this)
                (cycle-check km)
                (send km cycle-check this))
      (set! chain-to (if prefix?
                         (cons km chain-to)
                         (append chain-to (list km))))))

  (def/public (remove-chained-keymap [keymap% km])
    (set! chain-to (remq km chain-to))))
