1 files changed, 175 insertions, 0 deletions
diff --git a/catbird/input-map.scm b/catbird/input-map.scm
new file mode 100644
index 0000000..43ba57a
--- /dev/null
+++ b/catbird/input-map.scm
@@ -0,0 +1,175 @@
+(define-module (catbird input-map)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (make-input-map
+            add-input
+            remove-input
+            key-press
+            key-release
+            text-input
+            mouse-press
+            mouse-release
+            mouse-move
+            mouse-wheel
+            controller-press
+            controller-release
+            controller-move
+            key-press-handler
+            key-release-handler
+            text-input-handler
+            mouse-press-handler
+            mouse-release-handler
+            mouse-move-handler
+            mouse-wheel-handler
+            controller-press-handler
+            controller-release-handler
+            controller-move-handler))
+
+(define (make-input-map)
+  '())
+
+(define (add-input input-map spec handler)
+  (cons (cons spec handler)
+        input-map))
+
+(define (remove-input input-map spec)
+  (delete spec input-map
+          (match-lambda
+            ((s . _) (equal? s spec)))))
+
+(define* (key-press key #:optional (modifiers '()))
+  `(keyboard ,key ,modifiers down))
+
+(define* (key-release key #:optional (modifiers '()))
+  `(keyboard ,key ,modifiers up))
+
+(define (text-input)
+  '(text-input))
+
+(define (mouse-press button)
+  `(mouse button ,button down))
+
+(define (mouse-release button)
+  `(mouse button ,button up))
+
+(define* (mouse-move #:optional (buttons '()))
+  `(mouse move ,buttons))
+
+(define* (mouse-wheel)
+  '(mouse wheel))
+
+(define (controller-press id button)
+  `(controller button ,id ,button down))
+
+(define (controller-release id button)
+  `(controller button ,id ,button up))
+
+(define (controller-move id axis)
+  `(controller axis ,id ,axis))
+
+;; Chickadee is specific about which modifier keys are pressed and
+;; makes distinctions between left and right ctrl, for example.  For
+;; convenience, we want users to be able to specify simply 'ctrl' and
+;; it will match both left and right.
+(define (modifiers-match? spec-modifiers modifiers)
+  (every (lambda (k)
+           (case k
+             ;; The specification is looking for a specific modifier
+             ;; key.
+             ((left-ctrl right-ctrl left-alt right-alt left-shift right-shift)
+              (memq k modifiers))
+             ;; The specification is looking for either left/right
+             ;; modifier key.
+             ((ctrl)
+              (or (memq 'left-control modifiers)
+                  (memq 'right-control modifiers)))
+             ((alt)
+              (or (memq 'left-alt modifiers)
+                  (memq 'right-alt modifiers)))
+             ((shift)
+              (or (memq 'left-shift modifiers)
+                  (memq 'right-shift modifiers)))))
+         spec-modifiers))
+
+(define (key-press-handler input-map key modifiers)
+  (any (match-lambda
+         ((('keyboard key* modifiers* 'down) . handler)
+          (and (eq? key key*)
+               (modifiers-match? modifiers* modifiers)
+               handler))
+         (_ #f))
+       input-map))
+
+(define (key-release-handler input-map key modifiers)
+  (any (match-lambda
+         ((('keyboard key* modifiers* 'up) . handler)
+          (and (eq? key key*)
+               (modifiers-match? modifiers modifiers*)
+               handler))
+         (_ #f))
+       input-map))
+
+(define (text-input-handler input-map)
+  (any (match-lambda
+         ((('text-input) . handler) handler)
+         (_ #f))
+       input-map))
+
+(define (mouse-press-handler input-map button)
+  (any (match-lambda
+         ((('mouse 'button button* 'down) . handler)
+          (and (eq? button button*)
+               handler))
+         (_ #f))
+       input-map))
+
+(define (mouse-release-handler input-map button)
+  (any (match-lambda
+         ((('mouse 'button button* 'up) . handler)
+          (and (eq? button button*)
+               handler))
+         (_ #f))
+       input-map))
+
+(define (mouse-move-handler input-map buttons)
+  (any (match-lambda
+         ((('mouse 'move buttons*) . handler)
+          (and (= (length buttons) (length buttons*))
+               (every (lambda (b) (memq b buttons*)) buttons)
+               handler))
+         (_ #f))
+       input-map))
+
+(define (mouse-wheel-handler input-map)
+  (any (match-lambda
+         ((('mouse 'wheel) . handler)
+          handler)
+         (_ #f))
+       input-map))
+
+(define (controller-press-handler input-map controller-id button)
+  (any (match-lambda
+         ((('controller 'button controller-id* button* 'down) . handler)
+          (and (= controller-id controller-id*)
+               (eq? button button*)
+               handler))
+         (_ #f))
+       input-map))
+
+(define (controller-release-handler input-map controller-id button)
+  (any (match-lambda
+         ((('controller 'button controller-id* button* 'up) . handler)
+          (and (= controller-id controller-id*)
+               (eq? button button*)
+               handler))
+         (_ #f))
+       input-map))
+
+(define (controller-move-handler input-map controller-id axis)
+  (any (match-lambda
+         ((('controller 'axis controller-id* axis*) . handler)
+          (and (= controller-id controller-id*)
+               (eq? axis axis*)
+               handler))
+         (_ #f))
+       input-map))