add functionality to move player by using arrow keys

fcore/player.sml

@@ -47,14 +47,14 @@ struct
             val {y = wallY, ...} = Wall.getID wallID
             val newY = wallY - size
           in
-            checkWalls (yAxis, xAxis, x, newY, health, tl)
+            checkWalls (ON_GROUND, xAxis, x, newY, health, tl)
           end
       | (QUERY_ON_TOP_SIDE, wallID) :: tl =>
           checkWalls (yAxis, xAxis, x, y, health, tl)
       | [] => mkPlayer (health, xAxis, yAxis, x, y)
     end
 
-  fun move ({x, y, xAxis, yAxis, health}: t) =
+  fun helpMove (x, y, xAxis, yAxis, health) =
     let
       (* check against wall quad tree *)
       val desiredX =
@@ -101,4 +101,32 @@ struct
               checkWalls (yAxis, xAxis, desiredX, desiredY, health, collisions)
             end
     end
+
+  fun getXAxis (lh, rh) =
+    case (lh, rh) of
+      (false, false) => STAY_STILL
+    | (false, true) => MOVE_RIGHT
+    | (true, false) => MOVE_LEFT
+    | (true, true) => STAY_STILL
+
+  fun getYAxis (uh, dh, yAxis) =
+    case (uh, dh) of
+      (false, false) => yAxis
+    | (true, false) =>
+        (case yAxis of
+           ON_GROUND => JUMPING 0
+         | _ => yAxis)
+    | (false, true) => 
+        (* todo: should move down if on platform *) 
+        yAxis
+    | (true, true) => yAxis
+
+  fun move
+    ({x, y, yAxis, health, ...}: t, {leftHeld, rightHeld, upHeld, downHeld}) =
+    let
+      val xAxis = getXAxis (leftHeld, rightHeld)
+      val yAxis = getYAxis (upHeld, downHeld, yAxis)
+    in
+      helpMove (x, y, xAxis, yAxis, health)
+    end
 end

ffi/export.h

@@ -157,6 +157,7 @@ typedef Pointer Objptr;
 extern "C" {
 #endif
 
+MLLIB_PUBLIC(void mltonKeyCallback (Int32 x0, Int32 x1, Int32 x2, Int32 x3);)
 
 #undef MLLIB_PRIVATE
 #undef MLLIB_PUBLIC

ffi/glfw-input.c

@@ -4,6 +4,17 @@
 #include <GLFW/glfw3.h>
 
 int PRESS = GLFW_PRESS;
-int REPEAT = GLFW_REPEAT;
 int RELEASE = GLFW_RELEASE;
 
+int ARROW_UP = GLFW_KEY_UP;
+int ARROW_DOWN = GLFW_KEY_DOWN;
+int ARROW_LEFT = GLFW_KEY_LEFT;
+int ARROW_RIGHT = GLFW_KEY_RIGHT;
+
+void keyCallback(GLFWwindow* window, int key, int scancode, int action, int mods) {
+  mltonKeyCallback(key, scancode, action, mods);
+}
+
+void setKeyCallback(GLFWwindow* window) {
+  glfwSetKeyCallback(window, keyCallback);
+}

ffi/glfw-input.sml

@@ -7,13 +7,28 @@ struct
     _symbol "PRESS" public : ( unit -> int ) * ( int -> unit );
   val PRESS = PRESS ()
 
-  val (REPEAT, _) =
-    _symbol "REPEAT" public : ( unit -> int ) * ( int -> unit );
-  val REPEAT = REPEAT ()
-
   val (RELEASE, _) =
     _symbol "RELEASE" public : ( unit -> int ) * ( int -> unit );
   val RELEASE = RELEASE ()
 
+  val (ARROW_UP, _) =
+    _symbol "ARROW_UP" public : ( unit -> int ) * ( int -> unit );
+  val ARROW_UP = ARROW_UP ()
 
+  val (ARROW_DOWN, _) =
+    _symbol "ARROW_DOWN" public : ( unit -> int ) * ( int -> unit );
+  val ARROW_DOWN = ARROW_DOWN ()
+
+  val (ARROW_LEFT, _) =
+    _symbol "ARROW_LEFT" public : ( unit -> int ) * ( int -> unit );
+  val ARROW_LEFT = ARROW_LEFT ()
+
+  val (ARROW_RIGHT, _) =
+    _symbol "ARROW_RIGHT" public : ( unit -> int ) * ( int -> unit );
+  val ARROW_RIGHT = ARROW_RIGHT ()
+
+  val exportKeyCallback =
+    _export "mltonKeyCallback" public : (int * int * int * int -> unit) -> unit;
+  val setKeyCallback =
+    _import "setKeyCallback" public : window -> unit;
 end

message-types/input-msg.sml

@@ -1,11 +0,0 @@
-signature INPUT_MSG =
-sig
-  datatype t =
-    RESIZE_WINDOW of {width: int, height: int}
-end
-
-structure InputMsg =
-struct
-  datatype t =
-    RESIZE_WINDOW of {width: int, height: int}
-end

oms.mlb

@@ -1,8 +1,6 @@
 $(SML_LIB)/basis/basis.mlb
 
 (* fcore *)
-message-types/input-msg.sml
-
 ann
   "allowVectorExps true"
 in
@@ -15,7 +13,6 @@ fcore/player.sml
 
 (* shell *)
 $(SML_LIB)/basis/mlton.mlb
-$(SML_LIB)/cml/cml.mlb
 
 ann
   "allowFFI true"
@@ -25,6 +22,7 @@ in
   ffi/glfw-input.sml
 end
 
+shell/input-state.sml
 shell/gl-shaders.sml
 shell/gl-draw.sml
 shell/shell.sml

shell/gl-draw.sml

@@ -1,10 +1,7 @@
 structure GlDraw =
 struct
-  open CML
-
   type t =
     { window: MLton.Pointer.t
-    , mbox: InputMsg.t Mailbox.mbox
     , wallVertexBuffer: Word32.word
     , wallProgram: Word32.word
     , wallLength: int
@@ -34,7 +31,6 @@ struct
 
   fun create window =
     let
-      val mbox = Mailbox.mailbox ()
       (* create vertex buffer, program, etc. *)
       val xyrgbVertexShader = createShader
         (Gles3.VERTEX_SHADER, GlShaders.xyrgbVertexShaderString)
@@ -50,7 +46,6 @@ struct
       val playerProgram = createProgram (xyrgbVertexShader, rgbFragmentShader)
     in
       { window = window
-      , mbox = mbox
       , wallVertexBuffer = wallVertexBuffer
       , wallProgram = wallProgram
       , wallLength = 0
@@ -64,7 +59,6 @@ struct
     let
       val
         { window
-        , mbox
         , playerVertexBuffer
         , playerProgram
         , playerLength
@@ -78,7 +72,6 @@ struct
       val newWallLength = Vector.length vec div 5
     in
       { window = window
-      , mbox = mbox
       , playerVertexBuffer = playerVertexBuffer
       , playerProgram = playerProgram
       , playerLength = playerLength
@@ -92,7 +85,6 @@ struct
     let
       val
         { window
-        , mbox
         , wallVertexBuffer
         , wallProgram
         , wallLength
@@ -106,7 +98,6 @@ struct
       val newPlayerLength = Vector.length vec div 5
     in
       { window = window
-      , mbox = mbox
       , wallVertexBuffer = wallVertexBuffer
       , wallProgram = wallProgram
       , wallLength = wallLength
@@ -163,10 +154,11 @@ struct
            * *)
 
           val wallVec = Wall.generateWalls ()
-          val shellState = uploadWall (shellState, wallVec)
 
-          val player = Player.move player
+          val input = InputState.getSnapshot ()
+          val player = Player.move (player, input)
           val playerVec = Player.getVec player
+
           val shellState = uploadWall (shellState, wallVec)
           val shellState = uploadPlayer (shellState, playerVec)
 

shell/input-state.sml

@@ -0,0 +1,66 @@
+structure InputState =
+struct
+  (* global state detecting button inputs *)
+  val state =
+    { leftHeld = ref false
+    , rightHeld = ref false
+    , upHeld = ref false
+    , downHeld = ref false
+    }
+
+  fun getSnapshot () =
+    { leftHeld = !(#leftHeld state)
+    , rightHeld = !(#rightHeld state)
+    , upHeld = !(#upHeld state)
+    , downHeld = !(#downHeld state)
+    }
+
+  fun getPlayerXAxis () =
+    let
+      val lh = #leftHeld state
+      val rh = #rightHeld state
+
+      open Player
+    in
+      case (!lh, !rh) of
+        (false, false) => STAY_STILL
+      | (false, true) => MOVE_RIGHT
+      | (true, false) => MOVE_LEFT
+      | (true, true) => STAY_STILL
+    end
+
+  open Input
+
+  fun handleKey (key, action) =
+    if key = ARROW_UP then
+      if action = PRESS then (#upHeld state) := true
+      else if action = RELEASE then (#upHeld state) := false
+      else ()
+    else if key = ARROW_DOWN then
+      if action = PRESS then (#downHeld state) := true
+      else if action = RELEASE then (#downHeld state) := false
+      else ()
+    else if key = ARROW_LEFT then
+      if action = PRESS then (#leftHeld state) := true
+      else if action = RELEASE then (#leftHeld state) := false
+      else ()
+    else if key = ARROW_RIGHT then
+      if action = PRESS then (#rightHeld state) := true
+      else if action = RELEASE then (#rightHeld state) := false
+      else ()
+    else
+      ()
+
+  fun keyCallback (key, scancode, action, mods) =
+    let open Input
+    in if mods = 0 then handleKey (key, action) else ()
+    end
+
+  fun registerCallbacks window =
+    let
+      val () = Input.exportKeyCallback keyCallback
+      val () = Input.setKeyCallback window
+    in
+      ()
+    end
+end

shell/shell.sml

@@ -1,7 +1,5 @@
 structure Shell =
 struct
-  open CML
-
   fun main () =
     let
       (* Set up GLFW. *)
@@ -13,6 +11,8 @@ struct
       val window = Glfw.createWindow (1920, 1080, "shf")
       val _ = Glfw.makeContextCurrent window
       val _ = Gles3.loadGlad ()
+
+      val _ = InputState.registerCallbacks window
     in
       GlDraw.loop window
     end