get player to react to wall quad tree
This commit is contained in:
109
fcore/player.sml
109
fcore/player.sml
@@ -5,53 +5,100 @@ struct
|
||||
|
||||
(* width/height *)
|
||||
val size = 35
|
||||
val realSize = 35.0
|
||||
|
||||
val moveBy = 5
|
||||
val jumpLimit = 55
|
||||
val jumpLimit = 150
|
||||
|
||||
type t = {yAxis: y_axis, xAxis: x_axis, health: int, x: int, y: int}
|
||||
|
||||
(* placeholder *)
|
||||
val initial: t =
|
||||
{yAxis = JUMPING 0, xAxis = STAY_STILL, health = 3, x = 500, y = 500}
|
||||
|
||||
(* placeholder *)
|
||||
fun getVec ({x, y, ...}: t) =
|
||||
Block.lerp (x, y, realSize, realSize, 1920.0, 1080.0, 0.5, 0.5, 0.5)
|
||||
|
||||
fun mkPlayer (health, xAxis, yAxis, x, y) =
|
||||
{yAxis = yAxis, xAxis = xAxis, health = health, x = x, y = y}
|
||||
|
||||
fun move (player: t) =
|
||||
fun checkWalls (yAxis, xAxis, x, y, health, lst) =
|
||||
let
|
||||
val {yAxis, xAxis, x, y, health} = player
|
||||
open QuadTree
|
||||
in
|
||||
case lst of
|
||||
(QUERY_ON_LEFT_SIDE, wallID) :: tl =>
|
||||
let
|
||||
val {x = wallX, width = wallWidth, ...} = Wall.getID wallID
|
||||
val newX = wallX + wallWidth
|
||||
in
|
||||
checkWalls (yAxis, xAxis, newX, y, health, tl)
|
||||
end
|
||||
| (QUERY_ON_RIGHT_SIDE, wallID) :: tl =>
|
||||
let
|
||||
val {x = wallX, width = wallWidth, ...} = Wall.getID wallID
|
||||
val newX = wallX - size
|
||||
in
|
||||
checkWalls (yAxis, xAxis, newX, y, health, tl)
|
||||
end
|
||||
| (QUERY_ON_BOTTOM_SIDE, wallID) :: tl =>
|
||||
let
|
||||
val {y = wallY, ...} = Wall.getID wallID
|
||||
val newY = wallY - size
|
||||
in
|
||||
checkWalls (yAxis, 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
|
||||
|
||||
(* todo: check for wall and platform collisions
|
||||
* in case analysis for both axis
|
||||
* *)
|
||||
val x =
|
||||
fun move ({x, y, xAxis, yAxis, health}: t) =
|
||||
let
|
||||
(* check against wall quad tree *)
|
||||
val desiredX =
|
||||
case xAxis of
|
||||
MOVE_LEFT =>
|
||||
(* todo: check if we are trying to move left
|
||||
* even though player is against wall.
|
||||
* In that case, keep same action (it is a sign for us to animate),
|
||||
* but don't actually move leftwards. *)
|
||||
x - moveBy
|
||||
| MOVE_RIGHT => (* todo: check against wall *) x + moveBy
|
||||
| STAY_STILL => x
|
||||
STAY_STILL => x
|
||||
| MOVE_LEFT => x - moveBy
|
||||
| MOVE_RIGHT => x + moveBy
|
||||
in
|
||||
case yAxis of
|
||||
JUMPING jumped =>
|
||||
(* check if we hit jump limit;
|
||||
* if we did, change to falling case.
|
||||
* *)
|
||||
if jumped + moveBy <= jumpLimit then
|
||||
ON_GROUND =>
|
||||
let
|
||||
val jumped = jumped + moveBy
|
||||
val yAxis = JUMPING jumped
|
||||
val y = y + moveBy
|
||||
val collisions = QuadTree.getCollisionSides
|
||||
(desiredX, y, size, size, 0, 0, 1920, 1080, 0, Wall.tree)
|
||||
in
|
||||
mkPlayer (health, xAxis, yAxis, x, y)
|
||||
checkWalls (yAxis, xAxis, desiredX, y, health, collisions)
|
||||
end
|
||||
| FALLING =>
|
||||
let
|
||||
val desiredY = y + moveBy
|
||||
val collisions = QuadTree.getCollisionSides
|
||||
(desiredX, desiredY, size, size, 0, 0, 1920, 1080, 0, Wall.tree)
|
||||
in
|
||||
checkWalls (yAxis, xAxis, desiredX, desiredY, health, collisions)
|
||||
end
|
||||
| JUMPING jumped =>
|
||||
if jumped + moveBy > jumpLimit then
|
||||
(* if we are above the jump limit, trigger a fall *)
|
||||
let
|
||||
val collisions = QuadTree.getCollisionSides
|
||||
(desiredX, y, size, size, 0, 0, 1920, 1080, 0, Wall.tree)
|
||||
in
|
||||
checkWalls (FALLING, xAxis, desiredX, y, health, collisions)
|
||||
end
|
||||
else
|
||||
mkPlayer (health, xAxis, FALLING, x, y)
|
||||
| FALLING =>
|
||||
(* todo: keep decrementing and falling down
|
||||
* until we hit ground or platform
|
||||
* *)
|
||||
mkPlayer (health, xAxis, yAxis, x, y - moveBy)
|
||||
| ON_GROUND => mkPlayer (health, xAxis, yAxis, x, y)
|
||||
(* jump *)
|
||||
let
|
||||
val newJumped = jumped + moveBy
|
||||
val yAxis = JUMPING newJumped
|
||||
val desiredY = y - moveBy
|
||||
|
||||
val collisions = QuadTree.getCollisionSides
|
||||
(desiredX, desiredY, size, size, 0, 0, 1920, 1080, 0, Wall.tree)
|
||||
in
|
||||
checkWalls (yAxis, xAxis, desiredX, desiredY, health, collisions)
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
@@ -8,20 +8,18 @@ sig
|
||||
| QUERY_ON_RIGHT_SIDE
|
||||
| QUERY_ON_BOTTOM_SIDE
|
||||
|
||||
val insert : int * int * int * int *
|
||||
int * int * int * int *
|
||||
int * t -> t
|
||||
val insert: int * int * int * int * int * int * int * int * int * t -> t
|
||||
|
||||
val getCollisions : int * int * int * int *
|
||||
int * int * int * int *
|
||||
int * t -> int list
|
||||
val fromItem: int * int * int * int * int -> t
|
||||
|
||||
val getCollisionSides : int * int * int * int *
|
||||
int * int * int * int *
|
||||
int * t -> (collision_side * int) list
|
||||
val getCollisions: int * int * int * int * int * int * int * int * int * t
|
||||
-> int list
|
||||
|
||||
val getCollisionSides: int * int * int * int * int * int * int * int * int * t
|
||||
-> (collision_side * int) list
|
||||
end
|
||||
|
||||
structure QuadTree : QUAD_TREE =
|
||||
structure QuadTree: QUAD_TREE =
|
||||
struct
|
||||
type item = {itemID: int, startX: int, startY: int, width: int, height: int}
|
||||
|
||||
@@ -43,6 +41,14 @@ struct
|
||||
}
|
||||
| LEAF of item vector
|
||||
|
||||
fun fromItem (itemID, startX, startY, width, height) =
|
||||
let
|
||||
val item = mkItem (itemID, startX, startY, width, height)
|
||||
val elements = Vector.fromList [item]
|
||||
in
|
||||
LEAF elements
|
||||
end
|
||||
|
||||
(* max size of vector before we split it further *)
|
||||
val maxSize = 3
|
||||
|
||||
@@ -68,23 +74,47 @@ struct
|
||||
val middleY = quadY + halfHeight
|
||||
|
||||
val isInTopLeft = isItemInQuad
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, halfWidth, halfHeight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
)
|
||||
|
||||
val isInTopRight = isItemInQuad
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, middleX, quadY, halfWidth, halfHeight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, middleX
|
||||
, quadY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
)
|
||||
|
||||
val isInBottomLeft = isItemInQuad
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, middleY, halfWidth, halfHeight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, middleY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
)
|
||||
|
||||
val isInBottomRight = isItemInQuad
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, middleX, middleY, halfWidth, halfHeight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, middleX
|
||||
, middleY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
)
|
||||
in
|
||||
if isInTopLeft then TOP_LEFT
|
||||
@@ -135,9 +165,16 @@ struct
|
||||
end
|
||||
|
||||
fun insert
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
, itemID, tree: t
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, itemID
|
||||
, tree: t
|
||||
) =
|
||||
case tree of
|
||||
NODE {topLeft, topRight, bottomLeft, bottomRight, elements} =>
|
||||
@@ -146,8 +183,14 @@ struct
|
||||
* Else, add to elements vector in current node. *)
|
||||
(case
|
||||
whichQuadrant
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
)
|
||||
of
|
||||
TOP_LEFT =>
|
||||
@@ -160,9 +203,16 @@ struct
|
||||
val halfHeight = quadHeight div 2
|
||||
|
||||
val newTopLeft = insert
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, halfWidth, halfHeight
|
||||
, itemID, topLeft
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, topLeft
|
||||
)
|
||||
in
|
||||
NODE
|
||||
@@ -180,9 +230,16 @@ struct
|
||||
val middleX = quadX + halfWidth
|
||||
|
||||
val newTopRight = insert
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, middleX, quadY, halfWidth, halfHeight
|
||||
, itemID, topRight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, middleX
|
||||
, quadY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, topRight
|
||||
)
|
||||
in
|
||||
NODE
|
||||
@@ -200,9 +257,16 @@ struct
|
||||
val middleY = quadY + halfHeight
|
||||
|
||||
val newBottomLeft = insert
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, middleY, halfWidth, halfHeight
|
||||
, itemID, bottomLeft
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, middleY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, bottomLeft
|
||||
)
|
||||
in
|
||||
NODE
|
||||
@@ -221,9 +285,16 @@ struct
|
||||
val middleY = quadY + halfHeight
|
||||
|
||||
val newBottomRight = insert
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, middleX, middleY, halfWidth, halfHeight
|
||||
, itemID, bottomRight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, middleX
|
||||
, middleY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, bottomRight
|
||||
)
|
||||
in
|
||||
NODE
|
||||
@@ -258,39 +329,85 @@ struct
|
||||
in
|
||||
(case
|
||||
whichQuadrant
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
)
|
||||
of
|
||||
TOP_LEFT =>
|
||||
splitLeaf
|
||||
( quadX, quadY, quadWidth, quadHeight
|
||||
, [item], [], [], [], []
|
||||
, elements, pos
|
||||
( quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, [item]
|
||||
, []
|
||||
, []
|
||||
, []
|
||||
, []
|
||||
, elements
|
||||
, pos
|
||||
)
|
||||
| TOP_RIGHT =>
|
||||
splitLeaf
|
||||
( quadX, quadY, quadWidth, quadHeight
|
||||
, [], [item], [], [], []
|
||||
, elements, pos
|
||||
( quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, []
|
||||
, [item]
|
||||
, []
|
||||
, []
|
||||
, []
|
||||
, elements
|
||||
, pos
|
||||
)
|
||||
| BOTTOM_LEFT =>
|
||||
splitLeaf
|
||||
( quadX, quadY, quadWidth, quadHeight
|
||||
, [], [], [item], [], []
|
||||
, elements, pos
|
||||
( quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, []
|
||||
, []
|
||||
, [item]
|
||||
, []
|
||||
, []
|
||||
, elements
|
||||
, pos
|
||||
)
|
||||
| BOTTOM_RIGHT =>
|
||||
splitLeaf
|
||||
( quadX, quadY, quadWidth, quadHeight
|
||||
, [], [], [], [item], []
|
||||
, elements, pos
|
||||
( quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, []
|
||||
, []
|
||||
, []
|
||||
, [item]
|
||||
, []
|
||||
, elements
|
||||
, pos
|
||||
)
|
||||
| PARENT_QUADRANT =>
|
||||
splitLeaf
|
||||
( quadX, quadY, quadWidth, quadHeight
|
||||
, [], [], [], [], [item]
|
||||
, elements, pos
|
||||
( quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, []
|
||||
, []
|
||||
, []
|
||||
, []
|
||||
, [item]
|
||||
, elements
|
||||
, pos
|
||||
))
|
||||
end
|
||||
else
|
||||
@@ -310,11 +427,8 @@ struct
|
||||
val endX = startX + width
|
||||
val endY = startY + height
|
||||
in
|
||||
iX < endX
|
||||
andalso itemEndX > startX
|
||||
andalso iY < endY
|
||||
andalso itemEndY > startY
|
||||
andalso itemID <> checkID
|
||||
iX < endX andalso itemEndX > startX andalso iY < endY
|
||||
andalso itemEndY > startY andalso itemID <> checkID
|
||||
end
|
||||
|
||||
fun getCollisionsVec (iX, iY, iW, iH, itemID, pos, elements, acc) =
|
||||
@@ -324,97 +438,124 @@ struct
|
||||
let
|
||||
val item = Vector.sub (elements, pos)
|
||||
val acc =
|
||||
if isColliding (iX, iY, iW, iH, itemID, item)
|
||||
then #itemID item :: acc
|
||||
if isColliding (iX, iY, iW, iH, itemID, item) then #itemID item :: acc
|
||||
else acc
|
||||
in
|
||||
getCollisionsVec (iX, iY, iW, iH, itemID, pos + 1, elements, acc)
|
||||
end
|
||||
|
||||
fun getCollisionsAll
|
||||
( iX, iY, iW, iH, qW, qH
|
||||
, itemID, acc, tree
|
||||
) =
|
||||
fun getCollisionsAll (iX, iY, iW, iH, qW, qH, itemID, acc, tree) =
|
||||
case tree of
|
||||
NODE {topLeft, topRight, bottomLeft, bottomRight, elements} =>
|
||||
let
|
||||
val acc =
|
||||
getCollisionsVec (iX, iY, iW, iH, itemID, 0, elements, acc)
|
||||
val acc = getCollisionsVec (iX, iY, iW, iH, itemID, 0, elements, acc)
|
||||
val halfWidth = qW div 2
|
||||
val halfHeight = qH div 2
|
||||
|
||||
val acc =
|
||||
getCollisionsAll
|
||||
( iX, iY, iW, iH, halfWidth, halfHeight
|
||||
, itemID, acc, topLeft
|
||||
)
|
||||
val acc = getCollisionsAll
|
||||
(iX, iY, iW, iH, halfWidth, halfHeight, itemID, acc, topLeft)
|
||||
|
||||
val acc =
|
||||
getCollisionsAll
|
||||
( iX, iY, iW, iH, halfWidth, halfHeight
|
||||
, itemID, acc, topRight
|
||||
)
|
||||
val acc = getCollisionsAll
|
||||
(iX, iY, iW, iH, halfWidth, halfHeight, itemID, acc, topRight)
|
||||
|
||||
val acc =
|
||||
getCollisionsAll
|
||||
( iX, iY, iW, iH, halfWidth, halfHeight
|
||||
, itemID, acc, bottomLeft
|
||||
)
|
||||
val acc = getCollisionsAll
|
||||
(iX, iY, iW, iH, halfWidth, halfHeight, itemID, acc, bottomLeft)
|
||||
in
|
||||
getCollisionsAll
|
||||
( iX, iY, iW, iH, halfWidth, halfWidth
|
||||
, itemID, acc, bottomRight
|
||||
)
|
||||
(iX, iY, iW, iH, halfWidth, halfWidth, itemID, acc, bottomRight)
|
||||
end
|
||||
| LEAF elements =>
|
||||
getCollisionsVec (iX, iY, iW, iH, itemID, 0, elements, acc)
|
||||
|
||||
fun helpGetCollisions
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
, itemID, acc, tree: t
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, itemID
|
||||
, acc
|
||||
, tree: t
|
||||
) =
|
||||
case tree of
|
||||
NODE {topLeft, topRight, bottomLeft, bottomRight, elements} =>
|
||||
let
|
||||
(* get colliding elements in this node first *)
|
||||
val acc =
|
||||
getCollisionsVec
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, itemID, 0, elements, acc
|
||||
)
|
||||
val acc = getCollisionsVec
|
||||
(itemX, itemY, itemWidth, itemHeight, itemID, 0, elements, acc)
|
||||
val halfWidth = quadWidth div 2
|
||||
val halfHeight = quadHeight div 2
|
||||
in
|
||||
(case whichQuadrant
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
(case
|
||||
whichQuadrant
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
)
|
||||
of
|
||||
TOP_LEFT =>
|
||||
helpGetCollisions
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, halfWidth, halfHeight
|
||||
, itemID, acc, topLeft
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, topLeft
|
||||
)
|
||||
| TOP_RIGHT =>
|
||||
helpGetCollisions
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX + halfWidth, quadY, halfWidth, halfHeight
|
||||
, itemID, acc, topRight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX + halfWidth
|
||||
, quadY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, topRight
|
||||
)
|
||||
| BOTTOM_LEFT =>
|
||||
helpGetCollisions
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY + halfHeight, halfWidth, halfHeight
|
||||
, itemID, acc, bottomLeft
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY + halfHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, bottomLeft
|
||||
)
|
||||
| BOTTOM_RIGHT =>
|
||||
helpGetCollisions
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX + halfWidth, quadY + halfHeight
|
||||
, halfWidth, halfHeight
|
||||
, itemID, acc, bottomRight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX + halfWidth
|
||||
, quadY + halfHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, bottomRight
|
||||
)
|
||||
| PARENT_QUADRANT =>
|
||||
(* In this function, PARENT_QUADRANT means
|
||||
@@ -424,49 +565,83 @@ struct
|
||||
* So descend down on all the children, accumulating acc.
|
||||
* *)
|
||||
let
|
||||
val acc =
|
||||
getCollisionsAll
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, halfWidth, halfHeight
|
||||
, itemID, acc, topLeft
|
||||
val acc = getCollisionsAll
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, topLeft
|
||||
)
|
||||
|
||||
val acc =
|
||||
getCollisionsAll
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, halfWidth, halfHeight
|
||||
, itemID, acc, topRight
|
||||
val acc = getCollisionsAll
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, topRight
|
||||
)
|
||||
|
||||
val acc =
|
||||
getCollisionsAll
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, halfWidth, halfHeight
|
||||
, itemID, acc, bottomLeft
|
||||
val acc = getCollisionsAll
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, bottomLeft
|
||||
)
|
||||
in
|
||||
getCollisionsAll
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, halfWidth, halfHeight
|
||||
, itemID, acc, bottomRight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, bottomRight
|
||||
)
|
||||
end)
|
||||
end
|
||||
| LEAF elements =>
|
||||
getCollisionsVec
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, itemID, 0, elements, acc
|
||||
)
|
||||
(itemX, itemY, itemWidth, itemHeight, itemID, 0, elements, acc)
|
||||
|
||||
fun getCollisions
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
, itemID, tree
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, itemID
|
||||
, tree
|
||||
) =
|
||||
helpGetCollisions
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
, itemID, [], tree
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, itemID
|
||||
, []
|
||||
, tree
|
||||
)
|
||||
|
||||
(* no variant to represent 'no collision' case
|
||||
@@ -505,23 +680,13 @@ struct
|
||||
val minXDist = iHalfW + cHalfW
|
||||
val minYDist = iHalfH + cHalfH
|
||||
|
||||
val depthX =
|
||||
if diffX > 0
|
||||
then minXDist - diffX
|
||||
else (~minXDist) - diffX
|
||||
val depthX = if diffX > 0 then minXDist - diffX else (~minXDist) - diffX
|
||||
|
||||
val depthY =
|
||||
if diffY > 0
|
||||
then minYDist - diffY
|
||||
else (~minYDist) - diffY
|
||||
val depthY = if diffY > 0 then minYDist - diffY else (~minYDist) - diffY
|
||||
in
|
||||
if abs depthX < abs depthY then
|
||||
if depthX > 0 then
|
||||
QUERY_ON_LEFT_SIDE
|
||||
else
|
||||
QUERY_ON_RIGHT_SIDE
|
||||
else
|
||||
if depthY > 0 then
|
||||
if depthX > 0 then QUERY_ON_LEFT_SIDE else QUERY_ON_RIGHT_SIDE
|
||||
else if depthY > 0 then
|
||||
QUERY_ON_TOP_SIDE
|
||||
else
|
||||
QUERY_ON_BOTTOM_SIDE
|
||||
@@ -538,100 +703,128 @@ struct
|
||||
val item = Vector.sub (elements, pos)
|
||||
val acc =
|
||||
if isColliding (iX, iY, iW, iH, itemID, item) then
|
||||
let
|
||||
val side = getCollisionSide (iX, iY, iW, iH, item)
|
||||
in
|
||||
(side, #itemID item) :: acc
|
||||
let val side = getCollisionSide (iX, iY, iW, iH, item)
|
||||
in (side, #itemID item) :: acc
|
||||
end
|
||||
else acc
|
||||
else
|
||||
acc
|
||||
in
|
||||
getCollisionSideVec (iX, iY, iW, iH, itemID, pos + 1, elements, acc)
|
||||
end
|
||||
|
||||
fun getCollisionSidesAll
|
||||
( iX, iY, iW, iH, qW, qH
|
||||
, itemID, acc, tree
|
||||
) =
|
||||
fun getCollisionSidesAll (iX, iY, iW, iH, qW, qH, itemID, acc, tree) =
|
||||
case tree of
|
||||
NODE {topLeft, topRight, bottomLeft, bottomRight, elements} =>
|
||||
let
|
||||
val acc =
|
||||
getCollisionSideVec (iX, iY, iW, iH, itemID, 0, elements, acc)
|
||||
val acc = getCollisionSideVec
|
||||
(iX, iY, iW, iH, itemID, 0, elements, acc)
|
||||
val halfWidth = qW div 2
|
||||
val halfHeight = qH div 2
|
||||
|
||||
val acc =
|
||||
getCollisionSidesAll
|
||||
( iX, iY, iW, iH, halfWidth, halfHeight
|
||||
, itemID, acc, topLeft
|
||||
)
|
||||
val acc = getCollisionSidesAll
|
||||
(iX, iY, iW, iH, halfWidth, halfHeight, itemID, acc, topLeft)
|
||||
|
||||
val acc =
|
||||
getCollisionSidesAll
|
||||
( iX, iY, iW, iH, halfWidth, halfHeight
|
||||
, itemID, acc, topRight
|
||||
)
|
||||
val acc = getCollisionSidesAll
|
||||
(iX, iY, iW, iH, halfWidth, halfHeight, itemID, acc, topRight)
|
||||
|
||||
val acc =
|
||||
getCollisionSidesAll
|
||||
( iX, iY, iW, iH, halfWidth, halfHeight
|
||||
, itemID, acc, bottomLeft
|
||||
)
|
||||
val acc = getCollisionSidesAll
|
||||
(iX, iY, iW, iH, halfWidth, halfHeight, itemID, acc, bottomLeft)
|
||||
in
|
||||
getCollisionSidesAll
|
||||
( iX, iY, iW, iH, halfWidth, halfWidth
|
||||
, itemID, acc, bottomRight
|
||||
)
|
||||
(iX, iY, iW, iH, halfWidth, halfWidth, itemID, acc, bottomRight)
|
||||
end
|
||||
| LEAF elements =>
|
||||
getCollisionSideVec (iX, iY, iW, iH, itemID, 0, elements, acc)
|
||||
|
||||
fun helpGetCollisionSides
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
, itemID, acc, tree: t
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, itemID
|
||||
, acc
|
||||
, tree: t
|
||||
) =
|
||||
case tree of
|
||||
NODE {topLeft, topRight, bottomLeft, bottomRight, elements} =>
|
||||
let
|
||||
(* get colliding elements in this node first *)
|
||||
val acc =
|
||||
getCollisionSideVec
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, itemID, 0, elements, acc
|
||||
)
|
||||
val acc = getCollisionSideVec
|
||||
(itemX, itemY, itemWidth, itemHeight, itemID, 0, elements, acc)
|
||||
val halfWidth = quadWidth div 2
|
||||
val halfHeight = quadHeight div 2
|
||||
in
|
||||
(case whichQuadrant
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
(case
|
||||
whichQuadrant
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
)
|
||||
of
|
||||
TOP_LEFT =>
|
||||
helpGetCollisionSides
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, halfWidth, halfHeight
|
||||
, itemID, acc, topLeft
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, topLeft
|
||||
)
|
||||
| TOP_RIGHT =>
|
||||
helpGetCollisionSides
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX + halfWidth, quadY, halfWidth, halfHeight
|
||||
, itemID, acc, topRight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX + halfWidth
|
||||
, quadY
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, topRight
|
||||
)
|
||||
| BOTTOM_LEFT =>
|
||||
helpGetCollisionSides
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY + halfHeight, halfWidth, halfHeight
|
||||
, itemID, acc, bottomLeft
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY + halfHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, bottomLeft
|
||||
)
|
||||
| BOTTOM_RIGHT =>
|
||||
helpGetCollisionSides
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX + halfWidth, quadY + halfHeight
|
||||
, halfWidth, halfHeight
|
||||
, itemID, acc, bottomRight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX + halfWidth
|
||||
, quadY + halfHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, bottomRight
|
||||
)
|
||||
| PARENT_QUADRANT =>
|
||||
(* In this function, PARENT_QUADRANT means
|
||||
@@ -641,48 +834,82 @@ struct
|
||||
* So descend down on all the children, accumulating acc.
|
||||
* *)
|
||||
let
|
||||
val acc =
|
||||
getCollisionSidesAll
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, halfWidth, halfHeight
|
||||
, itemID, acc, topLeft
|
||||
val acc = getCollisionSidesAll
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, topLeft
|
||||
)
|
||||
|
||||
val acc =
|
||||
getCollisionSidesAll
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, halfWidth, halfHeight
|
||||
, itemID, acc, topRight
|
||||
val acc = getCollisionSidesAll
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, topRight
|
||||
)
|
||||
|
||||
val acc =
|
||||
getCollisionSidesAll
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, halfWidth, halfHeight
|
||||
, itemID, acc, bottomLeft
|
||||
val acc = getCollisionSidesAll
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, bottomLeft
|
||||
)
|
||||
in
|
||||
getCollisionSidesAll
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, halfWidth, halfHeight
|
||||
, itemID, acc, bottomRight
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, halfWidth
|
||||
, halfHeight
|
||||
, itemID
|
||||
, acc
|
||||
, bottomRight
|
||||
)
|
||||
end)
|
||||
end
|
||||
| LEAF elements =>
|
||||
getCollisionSideVec
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, itemID, 0, elements, acc
|
||||
)
|
||||
(itemX, itemY, itemWidth, itemHeight, itemID, 0, elements, acc)
|
||||
|
||||
fun getCollisionSides
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
, itemID, tree
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, itemID
|
||||
, tree
|
||||
) =
|
||||
helpGetCollisionSides
|
||||
( itemX, itemY, itemWidth, itemHeight
|
||||
, quadX, quadY, quadWidth, quadHeight
|
||||
, itemID, [], tree
|
||||
( itemX
|
||||
, itemY
|
||||
, itemWidth
|
||||
, itemHeight
|
||||
, quadX
|
||||
, quadY
|
||||
, quadWidth
|
||||
, quadHeight
|
||||
, itemID
|
||||
, []
|
||||
, tree
|
||||
)
|
||||
end
|
||||
|
||||
@@ -1,9 +1,52 @@
|
||||
structure Wall =
|
||||
struct
|
||||
(* Wall or platform, where player can land after falling.
|
||||
* Difference between wall and platform is that one can jump to a platform
|
||||
* and go below it, but wall is completely opaque. *)
|
||||
datatype wall_type = WALL | PLATFORM
|
||||
type t = {id: int, x: int, y: int, width: int, height: int}
|
||||
|
||||
val wall1 = {id = 1, x = 0, y = 0, width = 100, height = 1080}
|
||||
val wall2 = {id = 2, x = 1820, y = 0, width = 100, height = 1080}
|
||||
val wall3 = {id = 3, x = 0, y = 980, width = 1920, height = 108}
|
||||
|
||||
val wallVec = Vector.fromList [wall1, wall2, wall3]
|
||||
|
||||
fun getID n =
|
||||
Vector.sub (wallVec, n - 1)
|
||||
|
||||
fun generateTree (pos, wallVec, acc) =
|
||||
if pos = Vector.length wallVec then
|
||||
acc
|
||||
else
|
||||
let
|
||||
val {id, x, y, width, height} = Vector.sub (wallVec, pos)
|
||||
val acc = QuadTree.insert
|
||||
(x, y, width, height, 0, 0, 1920, 1080, id, acc)
|
||||
in
|
||||
generateTree (pos + 1, wallVec, acc)
|
||||
end
|
||||
|
||||
val tree =
|
||||
let
|
||||
val {id, x, y, width, height} = Vector.sub (wallVec, 0)
|
||||
val acc = QuadTree.fromItem (id, x, y, width, height)
|
||||
in
|
||||
generateTree (1, wallVec, acc)
|
||||
end
|
||||
|
||||
fun helpGenerateWalls (pos, wallVec, acc, winWidth, winHeight) =
|
||||
if pos = Vector.length wallVec then
|
||||
Vector.concat acc
|
||||
else
|
||||
let
|
||||
val wall = Vector.sub (wallVec, pos)
|
||||
val {x, y, width, height, ...} = wall
|
||||
val width = Real32.fromInt width
|
||||
val height = Real32.fromInt height
|
||||
val block = Block.lerp
|
||||
(x, y, width, height, winWidth, winHeight, 0.0, 0.0, 0.0)
|
||||
val acc = block :: acc
|
||||
in
|
||||
helpGenerateWalls (pos + 1, wallVec, acc, winWidth, winHeight)
|
||||
end
|
||||
|
||||
fun generateWalls () =
|
||||
helpGenerateWalls (0, wallVec, [], 1920.0, 1080.0)
|
||||
end
|
||||
|
||||
11
message-types/input-msg.sml
Normal file
11
message-types/input-msg.sml
Normal file
@@ -0,0 +1,11 @@
|
||||
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
|
||||
4
oms.mlb
4
oms.mlb
@@ -1,6 +1,8 @@
|
||||
$(SML_LIB)/basis/basis.mlb
|
||||
|
||||
(* fcore *)
|
||||
message-types/input-msg.sml
|
||||
|
||||
ann
|
||||
"allowVectorExps true"
|
||||
in
|
||||
@@ -8,8 +10,8 @@ in
|
||||
end
|
||||
|
||||
fcore/quad-tree.sml
|
||||
fcore/player.sml
|
||||
fcore/wall.sml
|
||||
fcore/player.sml
|
||||
|
||||
(* shell *)
|
||||
$(SML_LIB)/basis/mlton.mlb
|
||||
|
||||
@@ -2,7 +2,16 @@ structure GlDraw =
|
||||
struct
|
||||
open CML
|
||||
|
||||
type t = { window: MLton.Pointer.t }
|
||||
type t =
|
||||
{ window: MLton.Pointer.t
|
||||
, mbox: InputMsg.t Mailbox.mbox
|
||||
, wallVertexBuffer: Word32.word
|
||||
, wallProgram: Word32.word
|
||||
, wallLength: int
|
||||
, playerVertexBuffer: Word32.word
|
||||
, playerProgram: Word32.word
|
||||
, playerLength: int
|
||||
}
|
||||
|
||||
fun createShader (shaderType, shaderString) =
|
||||
let
|
||||
@@ -25,17 +34,86 @@ struct
|
||||
|
||||
fun create window =
|
||||
let
|
||||
val mbox = Mailbox.mailbox ()
|
||||
(* create vertex buffer, program, etc. *)
|
||||
val textVertexBuffer = Gles3.createBuffer ()
|
||||
val xyrgbVertexShader = createShader
|
||||
(Gles3.VERTEX_SHADER, GlShaders.xyrgbVertexShaderString)
|
||||
|
||||
val rgbFragmentShader = createShader
|
||||
(Gles3.FRAGMENT_SHADER, GlShaders.rgbFragmentShaderString)
|
||||
|
||||
val placeholderProgram = createProgram (xyrgbVertexShader, rgbFragmentShader)
|
||||
(* wall here includes both walls and platforms *)
|
||||
val wallVertexBuffer = Gles3.createBuffer ()
|
||||
val wallProgram = createProgram (xyrgbVertexShader, rgbFragmentShader)
|
||||
|
||||
val playerVertexBuffer = Gles3.createBuffer ()
|
||||
val playerProgram = createProgram (xyrgbVertexShader, rgbFragmentShader)
|
||||
in
|
||||
{window = window}
|
||||
{ window = window
|
||||
, mbox = mbox
|
||||
, wallVertexBuffer = wallVertexBuffer
|
||||
, wallProgram = wallProgram
|
||||
, wallLength = 0
|
||||
, playerVertexBuffer = playerVertexBuffer
|
||||
, playerProgram = playerProgram
|
||||
, playerLength = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun uploadWall (shellState: t, vec) =
|
||||
let
|
||||
val
|
||||
{ window
|
||||
, mbox
|
||||
, playerVertexBuffer
|
||||
, playerProgram
|
||||
, playerLength
|
||||
, wallVertexBuffer
|
||||
, wallProgram
|
||||
, wallLength = _
|
||||
} = shellState
|
||||
|
||||
val _ = Gles3.bindBuffer wallVertexBuffer
|
||||
val _ = Gles3.bufferData (vec, Vector.length vec, Gles3.STATIC_DRAW)
|
||||
val newWallLength = Vector.length vec div 5
|
||||
in
|
||||
{ window = window
|
||||
, mbox = mbox
|
||||
, playerVertexBuffer = playerVertexBuffer
|
||||
, playerProgram = playerProgram
|
||||
, playerLength = playerLength
|
||||
, wallVertexBuffer = wallVertexBuffer
|
||||
, wallProgram = wallProgram
|
||||
, wallLength = newWallLength
|
||||
}
|
||||
end
|
||||
|
||||
fun uploadPlayer (shellState: t, vec) =
|
||||
let
|
||||
val
|
||||
{ window
|
||||
, mbox
|
||||
, wallVertexBuffer
|
||||
, wallProgram
|
||||
, wallLength
|
||||
, playerVertexBuffer
|
||||
, playerProgram
|
||||
, playerLength = _
|
||||
} = shellState
|
||||
|
||||
val _ = Gles3.bindBuffer playerVertexBuffer
|
||||
val _ = Gles3.bufferData (vec, Vector.length vec, Gles3.STATIC_DRAW)
|
||||
val newPlayerLength = Vector.length vec div 5
|
||||
in
|
||||
{ window = window
|
||||
, mbox = mbox
|
||||
, wallVertexBuffer = wallVertexBuffer
|
||||
, wallProgram = wallProgram
|
||||
, wallLength = wallLength
|
||||
, playerVertexBuffer = playerVertexBuffer
|
||||
, playerProgram = playerProgram
|
||||
, playerLength = newPlayerLength
|
||||
}
|
||||
end
|
||||
|
||||
fun drawXyrgb (vertexBuffer, program, drawLength) =
|
||||
@@ -57,7 +135,21 @@ struct
|
||||
else
|
||||
()
|
||||
|
||||
fun helpLoop (shellState as {window, ...}: t) =
|
||||
fun drawWall ({wallVertexBuffer, wallProgram, wallLength, ...}: t) =
|
||||
drawXyrgb (wallVertexBuffer, wallProgram, wallLength)
|
||||
|
||||
fun drawPlayer ({playerVertexBuffer, playerProgram, playerLength, ...}: t) =
|
||||
drawXyrgb (playerVertexBuffer, playerProgram, playerLength)
|
||||
|
||||
fun draw (shellState: t) =
|
||||
let
|
||||
val _ = drawWall shellState
|
||||
val _ = drawPlayer shellState
|
||||
in
|
||||
()
|
||||
end
|
||||
|
||||
fun helpLoop (shellState as {window, ...}: t, player) =
|
||||
case Glfw.windowShouldClose window of
|
||||
false =>
|
||||
let
|
||||
@@ -69,15 +161,26 @@ struct
|
||||
* - consume draw messages
|
||||
* - finally, draw
|
||||
* *)
|
||||
|
||||
val wallVec = Wall.generateWalls ()
|
||||
val shellState = uploadWall (shellState, wallVec)
|
||||
|
||||
val player = Player.move player
|
||||
val playerVec = Player.getVec player
|
||||
val shellState = uploadWall (shellState, wallVec)
|
||||
val shellState = uploadPlayer (shellState, playerVec)
|
||||
|
||||
val _ = draw shellState
|
||||
|
||||
val _ = Glfw.swapBuffers window
|
||||
val _ = Glfw.waitEvents ()
|
||||
in
|
||||
helpLoop shellState
|
||||
helpLoop (shellState, player)
|
||||
end
|
||||
| true => Glfw.terminate ()
|
||||
|
||||
fun loop window =
|
||||
let val shellState = create window
|
||||
in helpLoop shellState
|
||||
in helpLoop (shellState, Player.initial)
|
||||
end
|
||||
end
|
||||
|
||||
Reference in New Issue
Block a user