diff --git a/fcore/quad-tree-fold.sml b/fcore/quad-tree-fold.sml index 8b13789..ca15a66 100644 --- a/fcore/quad-tree-fold.sml +++ b/fcore/quad-tree-fold.sml @@ -1 +1,57 @@ +signature QUAD_FOLDER = +sig + type env + type state + val fold: int * env * state -> state +end + +signature MAKE_QUAD_TREE_FOLD = +sig + structure Fn: QUAD_FOLDER + + val foldRegion: int * int * int * int * + Fn.env * Fn.state * QuadTreeType.t + -> Fn.state +end + +functor MakeQuadTreeFold(Fn: QUAD_FOLDER): MAKE_QUAD_TREE_FOLD = +struct + structure Fn = Fn + + open QuadTreeType + + fun foldRegionVec (rx, ry, rw, rh, env, state, pos, elements) = + if pos = Vector.length elements then + state + else + let + val item = Vector.sub (elements, pos) + val state = + if isCollidingItem (rx, ry, rw, rh, ~1, item) then + Fn.fold (#itemID item, env, state) + else + state + in + foldRegionVec (rx, ry, rh, rh, env, state, pos + 1, elements) + end + + fun foldRegion (rx, ry, rw, rh, env, state, tree) = + case tree of + NODE {topLeft, topRight, bottomLeft, bottomRight, x, y, w, h} => + if isCollidingPlus (rx, ry, rw, rh, x, y, w, h) then + let + val state = foldRegion (rx, ry, rw, rh, env, state, topLeft) + val state = foldRegion (rx, ry, rw, rh, env, state, topRight) + val state = foldRegion (rx, ry, rw, rh, env, state, bottomLeft) + in + foldRegion (rx, ry, rw, rh, env, state, bottomRight) + end + else + state + | LEAF {items, x, y, w, h} => + if isCollidingPlus (rx, ry, rw, rh, x, y, w, h) then + foldRegionVec (rx, ry, rw, rh, env, state, 0, items) + else + state +end diff --git a/fcore/quad-tree-type.sml b/fcore/quad-tree-type.sml index 5be770f..fc8cca5 100644 --- a/fcore/quad-tree-type.sml +++ b/fcore/quad-tree-type.sml @@ -15,17 +15,33 @@ sig } | LEAF of {items: item vector, x: int, y: int, w: int, h: int} - val isColliding: int * int * int * int * int * int * int * int -> bool + val isColliding: int * int * int * int * + int * int * int * int + -> bool - val isCollidingPlus: int * int * int * int * int * int * int * int -> bool + val isCollidingPlus: int * int * int * int * + int * int * int * int + -> bool - val visitTopLeft: int * int * int * int * int * int * int * int -> bool + val isCollidingItem: int * int * int * int * + int * item + -> bool - val visitTopRight: int * int * int * int * int * int * int * int -> bool + val visitTopLeft: int * int * int * int * + int * int * int * int + -> bool - val visitBottomLeft: int * int * int * int * int * int * int * int -> bool + val visitTopRight: int * int * int * int * + int * int * int * int + -> bool - val visitBottomRight: int * int * int * int * int * int * int * int -> bool + val visitBottomLeft: int * int * int * int * + int * int * int * int + -> bool + + val visitBottomRight: int * int * int * int * + int * int * int * int + -> bool end structure QuadTreeType :> QUAD_TREE_TYPE = @@ -58,6 +74,20 @@ struct isColliding (ix, iy, ifx, ify, cx, cy, cfx, cfy) end + fun isCollidingItem (iX, iY, iW, iH, itemID, checkWith: item) = + let + val + { itemID = checkID + , startX = cX + , startY = cY + , width = cW + , height = cH + , ... + } = checkWith + in + isCollidingPlus (iX, iY, iW, iH, cX, cY, cW, cH) andalso itemID <> checkID + end + fun visitTopLeft (iX, iY, iW, iH, qX, qY, qW, qH) = let val hw = qW div 2 diff --git a/fcore/quad-tree.sml b/fcore/quad-tree.sml index 9ff2232..e4941da 100644 --- a/fcore/quad-tree.sml +++ b/fcore/quad-tree.sml @@ -189,21 +189,6 @@ struct (* bounds of new item don't fit inside leaf so return old tree *) tree - fun isColliding (iX, iY, iW, iH, itemID, checkWith: item) = - let - val - { itemID = checkID - , startX = cX - , startY = cY - , width = cW - , height = cH - , ... - } = checkWith - in - iX < cX + cW andalso iX + iW > cX andalso iY < cY + cH - andalso iY + iH > cY andalso itemID <> checkID - end - fun getCollisionsVec (iX, iY, iW, iH, itemID, pos, elements, acc) = if pos = Vector.length elements then acc @@ -211,8 +196,10 @@ struct let val item = Vector.sub (elements, pos) val acc = - if isColliding (iX, iY, iW, iH, itemID, item) then #itemID item :: acc - else acc + if isCollidingItem (iX, iY, iW, iH, itemID, item) then + #itemID item :: acc + else + acc in getCollisionsVec (iX, iY, iW, iH, itemID, pos + 1, elements, acc) end @@ -270,7 +257,7 @@ struct let val item = Vector.sub (elements, pos) in - isColliding (iX, iY, iW, iH, itemID, item) + isCollidingItem (iX, iY, iW, iH, itemID, item) orelse hasCollisionAtVec (iX, iY, iW, iH, itemID, pos + 1, elements) end @@ -297,7 +284,7 @@ struct let val item = Vector.sub (elements, pos) in - if isColliding (iX, iY, iW, iH, ~1, item) then #itemID item + if isCollidingItem (iX, iY, iW, iH, ~1, item) then #itemID item else getItemIDVec (iX, iY, iW, iH, pos + 1, elements) end