diff --git a/fcore/pointer-quad-tree-fold.sml b/fcore/pointer-quad-tree-fold.sml new file mode 100644 index 0000000..c8c9934 --- /dev/null +++ b/fcore/pointer-quad-tree-fold.sml @@ -0,0 +1,92 @@ +signature POINTER_QUAD_FOLDER = +sig + type env + type state + + val fold: int * env * state -> state +end + +signature MAKE_POINTER_QUAD_TREE_FOLD = +sig + structure Fn: POINTER_QUAD_FOLDER + + val foldRegion: int * int * int * int * + Fn.env * Fn.state * {tree: PointerQuadTreeType.t, width: int, height: int} + -> Fn.state +end + +functor MakePointerQuadTreeFold(Fn: POINTER_QUAD_FOLDER): MAKE_POINTER_QUAD_TREE_FOLD = +struct + structure Fn = Fn + + open PointerQuadTreeType + + fun foldRegionList (rx, ry, rw, rh, env, state, lst) = + case lst of + item :: tl => + let + val state = + if isCollidingItem (rx, ry, rw, rh, ~1, item) then + Fn.fold (#itemID item, env, state) + else + state + in + foldRegionList (rx, ry, rw, rh, env, state, tl) + end + | [] => state + + fun helpFoldRegion (rx, ry, rw, rh, env, state, qx, qy, qw, qh, tree) = + case tree of + NODE {tl, tr, bl, br} => + let + val vtl = visitTopLeft (rx, ry, rw, rh, qx, qy, qw, qh) + val vtr = visitTopRight (rx, ry, rw, rh, qx, qy, qw, qh) + val vbl = visitBottomLeft (rx, ry, rw, rh, qx, qy, qw, qh) + val vbr = visitBottomRight (rx, ry, rw, rh, qx, qy, qw, qh) + + val hw = qw div 2 + val hh = qh div 2 + + val state = + if vtl then + helpFoldRegion + (rx, ry, rw, rh, env, state, qx, qy, hw, hh, tl) + else + state + + val state = + if vtr then + helpFoldRegion + (rx, ry, rw, rh, env, state, qx + hw, qy, hw, hh, tr) + else + state + + val state = + if vbl then + helpFoldRegion + (rx, ry, rw, rh, env, state, qx, qy + hh, hw, hh, bl) + else + state + in + if vbr then + helpFoldRegion + (rx, ry, rw, rh, env, state, qw + hw, qy + hh, hw, hh, br) + else + state + end + | LEAF item => + if isCollidingItem (rx, ry, rw, rh, ~1, item) then + Fn.fold (#itemID item, env, state) + else + state + | EMPTY => state + | SHARE_LEAF items => foldRegionList (rx, ry, rw, rh, env, state, items) + + fun foldRegion (rx, ry, rw, rh, env, state, tree) = + let + val {width, height, tree} = tree + in + helpFoldRegion (rx, ry, rw, rh, env, state, 0, 0, width, height, tree) + end +end + diff --git a/fcore/pointer-quad-tree.sml b/fcore/pointer-quad-tree.sml index bc8ca5f..4693521 100644 --- a/fcore/pointer-quad-tree.sml +++ b/fcore/pointer-quad-tree.sml @@ -1,4 +1,19 @@ -structure PointerQuadTree = +signature POINTER_QUAD_TREE = +sig + type t + + val insert: int * int * int * int * int * t -> t + + val getCollisions: int * int * int * int * int * t -> int list + + val hasCollisionAt: int * int * int * int * int * t -> bool + + val getItemID: int * int * int * int * t -> int + + val create: int * int -> t +end + +structure PointerQuadTree: POINTER_QUAD_TREE = struct open PointerQuadTreeType @@ -195,4 +210,40 @@ struct let val newItem = mkItem (itemID, ix, iy, iw, ih) in splitShareLeaf (qx, qy, qw, qh, oldItems, newItem) end + + fun insert (iX, iY, iW, iH, itemID, tree: t) = + let + val {width, height, tree} = tree + val tree = + helpInsert (iX, iY, iW, iH, itemID, 0, 0, width, height, tree) + in + {width = width, height = height, tree = tree} + end + + structure GetCollisions = MakePointerQuadTreeFold (struct + type env = unit + type state = int list + fun fold (itemID, (), lst) = itemID :: lst + end) + + fun getCollisions (itemX, itemY, itemWidth, itemHeight, _, tree) = + GetCollisions.foldRegion (itemX, itemY, itemWidth, itemHeight, (), [], tree) + + structure HasCollisionAt = MakePointerQuadTreeFold (struct + type env = unit + type state = bool + fun fold _ = true + end) + + fun hasCollisionAt (ix, iy, iw, ih, _, tree) = + HasCollisionAt.foldRegion (ix, iy, iw, ih, (), false, tree) + + structure GetItemID = MakePointerQuadTreeFold (struct + type env = unit + type state = int + fun fold (itemID, (), curID) = Int.max (itemID, curID) + end) + + fun getItemID (ix, iy, iw, ih, tree) = + GetItemID.foldRegion (ix, iy, iw, ih, (), ~1, tree) end diff --git a/oms.mlb b/oms.mlb index 5a81a6b..17e96f1 100644 --- a/oms.mlb +++ b/oms.mlb @@ -7,6 +7,10 @@ fcore/quad-tree-type.sml fcore/quad-tree-fold.sml fcore/quad-tree.sml +fcore/pointer-quad-tree-type.sml +fcore/pointer-quad-tree-fold.sml +fcore/pointer-quad-tree.sml + fcore/bin-search.sml fcore/bin-vec.sml @@ -39,9 +43,6 @@ fcore/projectile.sml fcore/player-enemy.sml fcore/game-update.sml -fcore/pointer-quad-tree-type.sml -fcore/pointer-quad-tree.sml - (* shell *) $(SML_LIB)/basis/mlton.mlb