From 4a59f0df2305652d72dde6573574482c21d74637 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 10 Dec 2024 11:32:14 -0500
Subject: [PATCH] Attempt to add gamepad support.

---
 Makefile              |  1 +
 game.js               |  8 ++++-
 game.scm              | 68 +++++++++++++++++++++++++++++++++++++++++++
 modules/dom/event.scm |  8 ++++-
 4 files changed, 83 insertions(+), 2 deletions(-)

diff --git a/Makefile b/Makefile
index 9ef20c1..91f55d6 100644
--- a/Makefile
+++ b/Makefile
@@ -3,6 +3,7 @@ modules = \
   modules/dom/document.scm \
   modules/dom/element.scm \
   modules/dom/event.scm \
+  modules/dom/gamepad.scm \
   modules/dom/image.scm \
   modules/dom/media.scm \
   modules/dom/window.scm \
diff --git a/game.js b/game.js
index bdd4152..616e5f0 100644
--- a/game.js
+++ b/game.js
@@ -34,7 +34,13 @@ window.addEventListener("load", async () => {
           addEventListener: (target, type, listener) => target.addEventListener(type, listener),
           removeEventListener: (target, type, listener) => target.removeEventListener(type, listener),
           preventDefault: (event) => event.preventDefault(),
-          keyboardCode: (event) => event.code
+          keyboardCode: (event) => event.code,
+          gamepad: (event) => event.gamepad
+        },
+        gamepad: {
+          index: (gp) => gp.index,
+          button: (gp, i) => gp.buttons[i] || null,
+          buttonPressed: (b) => b.pressed
         },
         image: {
           new: (src) => {
diff --git a/game.scm b/game.scm
index 31a38ed..1fbaba7 100644
--- a/game.scm
+++ b/game.scm
@@ -23,6 +23,7 @@
              (dom document)
              (dom element)
              (dom event)
+             (dom gamepad)
              (dom image)
              (dom media)
              (dom window)
@@ -402,6 +403,7 @@
 
 (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
 (define (update)
+  (maybe-poll-gamepad)
   (scheduler-tick! (current-scheduler))
   (particle-pool-update! particles)
   (timeout update-callback dt))
@@ -776,6 +778,64 @@
      ((string=? key key:confirm)
       (on-input-down 'confirm)))))
 
+(define *gamepad* #f)
+(define *button:left* #f)
+(define *button:right* #f)
+(define *button:up* #f)
+(define *button:down* #f)
+(define *button:undo* #f)
+(define *button-state* #f)
+
+(define (connect-gamepad! gamepad)
+  (when (zero? (gamepad-index gamepad))
+    (set! *gamepad* gamepad)
+    ;; These indices correspond to the "standard" gamepad mapping:
+    ;; https://w3c.github.io/gamepad/#remapping
+    (set! *button:left* (gamepad-button-ref gamepad 14))
+    (set! *button:right* (gamepad-button-ref gamepad 15))
+    (set! *button:up* (gamepad-button-ref gamepad 12))
+    (set! *button:down* (gamepad-button-ref gamepad 13))
+    (set! *button:undo* (gamepad-button-ref gamepad 0))
+    (set! *button-state* (vector #f #f #f #f #f))))
+
+(define (disconnect-gamepad! gamepad)
+  (when (zero? (gamepad-index gamepad))
+    (set! *gamepad* #f)
+    (set! *button:left* #f)
+    (set! *button:right* #f)
+    (set! *button:up* #f)
+    (set! *button:down* #f)
+    (set! *button:undo* #f)
+    (set! *button-state* #f)))
+
+(define (maybe-poll-gamepad)
+  (define (press? old new)
+    (and (not old) new))
+  (when *gamepad*
+    (let ((state *button-state*))
+      (match *button-state*
+        (#(prev-left prev-right prev-up prev-down prev-undo)
+         (let ((left (gamepad-button-pressed? *button:left*))
+               (right (gamepad-button-pressed? *button:right*))
+               (up (gamepad-button-pressed? *button:up*))
+               (down (gamepad-button-pressed? *button:down*))
+               (undo (gamepad-button-pressed? *button:undo*)))
+           (vector-set! *button-state* 0 left)
+           (vector-set! *button-state* 1 right)
+           (vector-set! *button-state* 2 up)
+           (vector-set! *button-state* 3 down)
+           (vector-set! *button-state* 4 undo)
+           (when (press? prev-left left)
+             (on-input-down 'left))
+           (when (press? prev-right right)
+             (on-input-down 'right))
+           (when (press? prev-up up)
+             (on-input-down 'up))
+           (when (press? prev-down down)
+             (on-input-down 'down))
+           (when (press? prev-undo undo)
+             (on-input-down 'undo))))))))
+
 (define (on-input-down input)
   (match *state*
     ('play
@@ -817,6 +877,14 @@
 (set-element-height! canvas (inexact->exact game-height))
 (add-event-listener! (current-window) "resize"
                      (procedure->external (lambda (_) (resize-canvas))))
+(add-event-listener! (current-window) "gamepadconnected"
+                     (procedure->external
+                      (lambda (e)
+                        (connect-gamepad! (gamepad-event-gamepad e)))))
+(add-event-listener! (current-window) "gamepaddisconnected"
+                     (procedure->external
+                      (lambda (e)
+                        (disconnect-gamepad! (gamepad-event-gamepad e)))))
 (add-event-listener! (current-document) "keydown"
                      (procedure->external on-key-down))
 (define (register-touch-control elem-id input-id)
diff --git a/modules/dom/event.scm b/modules/dom/event.scm
index 65594fb..8a6494c 100644
--- a/modules/dom/event.scm
+++ b/modules/dom/event.scm
@@ -25,7 +25,8 @@
   #:export (add-event-listener!
             remove-event-listener!
             prevent-default!
-            keyboard-event-code))
+            keyboard-event-code
+            gamepad-event-gamepad))
 
 ;; EventTarget
 (define-foreign add-event-listener!
@@ -44,3 +45,8 @@
 (define-foreign keyboard-event-code
   "event" "keyboardCode"
   (ref extern) -> (ref string))
+
+;; GamepadEvent
+(define-foreign gamepad-event-gamepad
+  "event" "gamepad"
+  (ref extern) -> (ref extern))