functorise environment collision patches

fcore/enemy.sml

@@ -29,7 +29,7 @@ struct
           acc
         else
           let
-            val patches = EnemyPhysics.getPatches enemy
+            val patches = EnemyPhysics.getPhysicsPatches enemy
             val patches = EnemyPatch.W_HEALTH (health - 1) :: patches
             val enemy = EnemyPatch.withPatches (enemy, patches)
           in
@@ -37,7 +37,7 @@ struct
           end
       else
         let
-          val patches = EnemyPhysics.getPatches enemy
+          val patches = EnemyPhysics.getPhysicsPatches enemy
           val enemy = EnemyPatch.withPatches (enemy, patches)
         in
           enemy :: acc

fcore/physics.sml

@@ -3,6 +3,8 @@ sig
   type t
   type patch
 
+  val entitySize: int
+
   (* constants for physics *)
   val moveBy: int
   val floatLimit: int
@@ -23,7 +25,7 @@ functor MakePhysics(Fn: PHYSICS_INPUT) =
 struct
   open GameType
 
-  fun getPatches input =
+  fun getPhysicsPatches input =
     let
       val x = Fn.getX input
       val y = Fn.getY input
@@ -70,6 +72,94 @@ struct
               [Fn.W_X desiredX, Fn.W_Y desiredY, Fn.W_Y_AXIS newYAxis]
             end
     end
+
+  fun getPlatformPatches (yAxis, platforms: platform vector, lst, acc) =
+    let
+      open QuadTree
+    in
+      case lst of
+        platID :: tl =>
+          (case yAxis of
+             DROP_BELOW_PLATFORM =>
+               (* pass through, allowing player to drop below the platform *)
+               getPlatformPatches (yAxis, platforms, tl, acc)
+           | JUMPING _ =>
+               (* pass through, allowing player to jump above the platform *)
+               getPlatformPatches (yAxis, platforms, tl, acc)
+           | _ =>
+               let
+                 (* default case: 
+                  * player will land on platform and stay on the ground there. *)
+                 val {y = platY, ...} = Vector.sub (platforms, platID - 1)
+
+                 val newY = platY - Fn.entitySize
+                 val acc = Fn.W_Y_AXIS ON_GROUND :: Fn.W_Y newY :: acc
+               in
+                 getPlatformPatches (yAxis, platforms, tl, acc)
+               end)
+      | [] => acc
+    end
+
+  fun getWallPatches (walls: wall vector, lst, acc) =
+    let
+      open QuadTree
+    in
+      case lst of
+        (QUERY_ON_LEFT_SIDE, wallID) :: tl =>
+          let
+            val {x = wallX, width = wallWidth, ...} =
+              Vector.sub (walls, wallID - 1)
+
+            val newX = wallX + wallWidth
+            val acc = Fn.W_X newX :: acc
+          in
+            getWallPatches (walls, tl, acc)
+          end
+      | (QUERY_ON_RIGHT_SIDE, wallID) :: tl =>
+          let
+            val {x = wallX, width = wallWidth, ...} =
+              Vector.sub (walls, wallID - 1)
+
+            val newX = wallX - Fn.entitySize
+            val acc = Fn.W_X newX :: acc
+          in
+            getWallPatches (walls, tl, acc)
+          end
+      | (QUERY_ON_BOTTOM_SIDE, wallID) :: tl =>
+          let
+            val {y = wallY, ...} = Vector.sub (walls, wallID - 1)
+
+            val newY = wallY - Fn.entitySize
+            val acc = Fn.W_Y_AXIS ON_GROUND :: Fn.W_Y newY :: acc
+          in
+            getWallPatches (walls, tl, acc)
+          end
+      | (QUERY_ON_TOP_SIDE, wallID) :: tl => getWallPatches (walls, tl, acc)
+      | [] => acc
+    end
+
+  fun getEnvironmentPatches (input, walls, wallTree, platforms, platformTree) =
+    let
+      (* first apply physics *)
+
+      (* then react to platform and environment collisions  *)
+      val x = Fn.getX input
+      val y = Fn.getY input
+      val yAxis = Fn.getYAxis input
+
+      val size = Fn.entitySize
+      val ww = Constants.worldWidth
+      val wh = Constants.worldHeight
+
+      val platCollisions = QuadTree.getCollisionsBelow
+        (x, y, size, size, 0, 0, ww, wh, 0, platformTree)
+      val acc = getPlatformPatches (yAxis, platforms, platCollisions, [])
+
+      val wallCollisions = QuadTree.getCollisionSides
+        (x, y, size, size, 0, 0, ww, wh, 0, wallTree)
+    in
+      getWallPatches (walls, wallCollisions, acc)
+    end
 end
 
 structure PlayerPhysics =
@@ -78,6 +168,8 @@ structure PlayerPhysics =
        type t = GameType.player
        type patch = PlayerPatch.player_patch
 
+       val entitySize = Constants.playerSize
+
        (* constants for physics *)
        val moveBy = Constants.movePlayerBy
        val floatLimit = Constants.floatLimit
@@ -101,6 +193,8 @@ structure EnemyPhysics =
        type t = GameType.enemy
        type patch = EnemyPatch.enemy_patch
 
+       val entitySize = Constants.enemySize
+
        (* constants for physics *)
        val moveBy = Constants.moveEnemyBy
        val floatLimit = Constants.floatLimit

fcore/player.sml

@@ -49,92 +49,6 @@ struct
         if jumpPressed then (* apply gravity *) FALLING else JUMPING 0
     | _ => prevAxis
 
-  fun checkWalls (player, walls, lst, acc) =
-    let
-      open QuadTree
-    in
-      case lst of
-        (QUERY_ON_LEFT_SIDE, wallID) :: tl =>
-          let
-            val {x = wallX, width = wallWidth, ...} =
-              Vector.sub (walls, wallID - 1)
-
-            val newX = wallX + wallWidth
-            val acc = W_X newX :: acc
-          in
-            checkWalls (player, walls, tl, acc)
-          end
-      | (QUERY_ON_RIGHT_SIDE, wallID) :: tl =>
-          let
-            val {x = wallX, width = wallWidth, ...} =
-              Vector.sub (walls, wallID - 1)
-
-            val newX = wallX - Constants.playerSize
-            val acc = W_X newX :: acc
-          in
-            checkWalls (player, walls, tl, acc)
-          end
-      | (QUERY_ON_BOTTOM_SIDE, wallID) :: tl =>
-          let
-            val {y = wallY, ...} = Vector.sub (walls, wallID - 1)
-
-            val newY = wallY - Constants.playerSize
-            val acc = W_Y_AXIS ON_GROUND :: W_Y newY :: acc
-          in
-            checkWalls (player, walls, tl, acc)
-          end
-      | (QUERY_ON_TOP_SIDE, wallID) :: tl => checkWalls (player, walls, tl, acc)
-      | [] => acc
-    end
-
-  fun checkPlatforms (player, platforms, lst, acc) =
-    let
-      open QuadTree
-    in
-      case lst of
-        platID :: tl =>
-          (case #yAxis player of
-             DROP_BELOW_PLATFORM =>
-               (* pass through, allowing player to drop below the platform *)
-               checkPlatforms (player, platforms, tl, acc)
-           | JUMPING _ =>
-               (* pass through, allowing player to jump above the platform *)
-               checkPlatforms (player, platforms, tl, acc)
-           | _ =>
-               let
-                 (* default case: 
-                  * player will land on platform and stay on the ground there. *)
-                 val {y = platY, ...} = Vector.sub (platforms, platID - 1)
-
-                 val newY = platY - Constants.playerSize
-                 val acc = W_Y_AXIS ON_GROUND :: W_Y newY :: acc
-               in
-                 checkPlatforms (player, platforms, tl, acc)
-               end)
-      | [] => acc
-    end
-
-  (* only checks for collisions with environment (walls and platforms) *)
-  fun getEnvironmentPatches (player, game) =
-    let
-      val {walls, wallTree, platformTree, platforms, ...} = game
-
-      val {x, y, ...} = player
-
-      val size = Constants.playerSize
-      val ww = Constants.worldWidth
-      val wh = Constants.worldHeight
-
-      val platCollisions = QuadTree.getCollisionsBelow
-        (x, y, size, size, 0, 0, ww, wh, 0, platformTree)
-      val acc = checkPlatforms (player, platforms, platCollisions, [])
-
-      val wallCollisions = QuadTree.getCollisionSides
-        (x, y, size, size, 0, 0, ww, wh, 0, wallTree)
-    in
-      checkWalls (player, walls, wallCollisions, acc)
-    end
-
   fun getJumpPatches (player, upHeld, downHeld, acc) =
     let
       val {yAxis, jumpPressed, ...} = player
@@ -432,10 +346,12 @@ struct
           PlayerPatch.withPatches (player, patches)
         end
 
-      val patches = PlayerPhysics.getPatches player
+      val patches = PlayerPhysics.getPhysicsPatches player
       val player = PlayerPatch.withPatches (player, patches)
 
-      val patches = getEnvironmentPatches (player, game)
+      val {walls, wallTree, platforms, platformTree, ...} = game
+      val patches = PlayerPhysics.getEnvironmentPatches
+        (player, walls, wallTree, platforms, platformTree)
     in
       PlayerPatch.withPatches (player, patches)
     end