1 files changed, 184 insertions, 0 deletions
diff --git a/input.scm b/input.scm
new file mode 100644
index 0000000..db581f0
--- /dev/null
+++ b/input.scm
@@ -0,0 +1,184 @@
+(module input
+    *
+
+(import scheme
+        (chicken base)
+        (chicken format)
+        (only srfi-1 any filter fold alist-delete)
+        (only srfi-13 string-join)
+        (only srfi-197 chain)
+        (prefix sdl2 sdl2:)
+	simple-logger
+	entity
+	defstruct)
+
+;; Input configuration record
+(defstruct input-config
+  actions                    ; list of action symbols
+  keyboard-map               ; alist: (sdl2-key-sym . action)
+  joy-button-map             ; alist: (button-id . action)
+  controller-button-map      ; alist: (button-sym . action)
+  joy-axis-bindings          ; list of (axis-id positive-action negative-action)
+  controller-axis-bindings   ; list of (axis-sym positive-action negative-action)
+  deadzone)                  ; integer threshold for analog sticks
+
+;; Default input configuration (capture current hardcoded values)
+(define *default-input-config*
+  (make-input-config
+    actions: '(up down left right a b start select quit)
+    keyboard-map: '((w . up) (up . up)
+                    (s . down) (down . down)
+                    (a . left) (left . left)
+                    (d . right) (right . right)
+                    (j . a) (z . a)
+                    (k . b) (x . b)
+                    (return . start)
+                    (escape . quit))
+    joy-button-map: '((0 . a) (1 . b) (7 . start) (6 . select))
+    controller-button-map: '((a . a) (b . b) (start . start) (back . select)
+                             (dpad-up . up) (dpad-down . down)
+                             (dpad-left . left) (dpad-right . right))
+    joy-axis-bindings: '((0 right left) (1 down up))
+    controller-axis-bindings: '((left-x right left) (left-y down up))
+    deadzone: 8000))
+
+(define-record input-state
+  current   ; Alist: (action . bool)
+  previous) ; Alist: (action . bool)
+
+;; Create empty input state from config
+(define (create-input-state config)
+  (let ((initial (map (lambda (a) (cons a #f)) (input-config-actions config))))
+    (make-input-state initial initial)))
+
+;; Helper to update the Alist
+(define (set-action state action value)
+  (let* ((curr (input-state-current state))
+         (new-curr (cons (cons action value) (alist-delete action curr eq?))))
+    (make-input-state new-curr (input-state-previous state))))
+
+(define (input-state-diff state)
+  "Retrieve the difference between current and previous input state maps"
+  (fold (lambda (item agg)
+	  (unless (eq? (alist-ref item (input-state-previous state)) item)
+	    (cons item agg)))
+	'()
+	(input-state-current state)))
+
+(define (handle-noop state event type config)
+  state)
+
+(define (handle-keyboard state event type config)
+  (let* ((pressed? (eq? type 'key-down))
+         (sym (sdl2:keyboard-event-sym event))
+         (action (alist-ref sym (input-config-keyboard-map config) eq? #f)))
+    (if action (set-action state action pressed?) state)))
+
+(define (apply-axis-to-state state val positive-action negative-action deadzone)
+  (chain state
+         (set-action _ positive-action (> val deadzone))
+         (set-action _ negative-action (< val (- deadzone)))))
+
+(define (handle-joy-button state event type config)
+  (let* ((pressed? (eq? type 'joy-button-down))
+         (btn (sdl2:joy-button-event-button event))
+         (action (alist-ref btn (input-config-joy-button-map config) eqv? #f)))
+    (if action (set-action state action pressed?) state)))
+
+(define (handle-joy-axis state event type config)
+  (let ((axis (sdl2:joy-axis-event-axis event))
+        (val  (sdl2:joy-axis-event-value event))
+        (dz   (input-config-deadzone config)))
+    (let ((binding (assv axis (input-config-joy-axis-bindings config))))
+      (if binding
+          (apply-axis-to-state state val (cadr binding) (caddr binding) dz)
+          state))))
+
+(define (handle-controller-button state event type config)
+  (let* ((pressed? (eq? type 'controller-button-down))
+         (btn (sdl2:controller-button-event-button event))
+         (action (alist-ref btn (input-config-controller-button-map config) eq? #f)))
+    (if action (set-action state action pressed?) state)))
+
+(define (handle-controller-axis state event type config)
+  (let ((axis (sdl2:controller-axis-event-axis event))
+        (val  (sdl2:controller-axis-event-value event))
+        (dz   (input-config-deadzone config)))
+    (let ((binding (assv axis (input-config-controller-axis-bindings config))))
+      (if binding
+          (apply-axis-to-state state val (cadr binding) (caddr binding) dz)
+          state))))
+
+(define (handle-controller-device state event type config)
+  (when (eq? type 'controller-device-added)
+    (sdl2:game-controller-open! (sdl2:controller-device-event-which event)))
+  state)
+
+(define (handle-event state event config)
+  (let* ((type (sdl2:event-type event))
+	 (handler (case type
+		    ((key-down key-up)                          handle-keyboard)
+		    ((joy-button-down joy-button-up)            handle-joy-button)
+		    ((joy-axis-motion)                          handle-joy-axis)
+		    ((controller-button-down
+		      controller-button-up)                     handle-controller-button)
+		    ((controller-axis-motion)                   handle-controller-axis)
+		    ((controller-device-added
+		      controller-device-removed)                handle-controller-device)
+		    (else handle-noop))))
+    (handler state event type config)))
+
+(define (input-state-update state events config)
+  (let ((rolled (make-input-state (input-state-current state)
+                                  (input-state-current state))))
+    (let* ((new-state (fold (lambda (ev st) (handle-event st ev config)) rolled events))
+	   (state-diff (input-state-diff new-state)))
+      (unless (eq? state-diff '())
+	(log-debug "input-state change: ~a" state-diff))
+      new-state)))
+
+;; 5. Simple Getters
+(define (input-held? state action)
+  (alist-ref action (input-state-current state) eq? #f))
+
+(define (input-pressed? state action)
+  (and (input-held? state action)
+       (not (alist-ref action (input-state-previous state) eq? #f))))
+
+(define (input-released? state action)
+  (and (not (input-held? state action))
+       (alist-ref action (input-state-previous state) eq? #f)))
+
+(define (input-any-pressed? state config)
+  (any (lambda (a) (input-pressed? state a)) (input-config-actions config)))
+
+(define (input-state->string state config)
+  (let ((active (filter (lambda (a) (input-held? state a)) (input-config-actions config))))
+    (format #f "[Input: ~a]" (string-join (map symbol->string active) " "))))
+
+(define (set-facing-from-vx entity vx)
+  (cond
+    ((> vx 0) (entity-set entity #:facing  1))
+    ((< vx 0) (entity-set entity #:facing -1))
+    (else entity)))
+
+(define (apply-input-to-entity entity held?)
+  (let ((input-map (entity-ref entity #:input-map #f)))
+    (if (not input-map)
+        entity
+        (let* ((delta (fold (lambda (entry acc)
+                              (let* ((action (car entry))
+                                     (d      (cdr entry))
+                                     (dvx    (car d))
+                                     (dvy    (cdr d)))
+                                (if (held? action)
+                                    (cons (+ (car acc) dvx)
+                                          (+ (cdr acc) dvy))
+                                    acc)))
+                            '(0 . 0)
+                            input-map))
+               (speed (entity-ref entity #:move-speed 1))
+               (vx    (* speed (car delta))))
+          (set-facing-from-vx (entity-set entity #:vx vx) vx)))))
+
+) ;; end module