From e1e1228983ac9a06aaf3f505739c52797aefbe72 Mon Sep 17 00:00:00 2001 From: Humza Shahid Date: Sat, 1 Feb 2025 10:11:32 +0000 Subject: [PATCH] delete pointer quad tree because it is twice as slow to construct as the vector-based implementation --- fcore/pointer-quad-tree-fold.sml | 92 ------------ fcore/pointer-quad-tree-type.sml | 130 ---------------- fcore/pointer-quad-tree.sml | 249 ------------------------------- oms.mlb | 4 - 4 files changed, 475 deletions(-) delete mode 100644 fcore/pointer-quad-tree-fold.sml delete mode 100644 fcore/pointer-quad-tree-type.sml delete mode 100644 fcore/pointer-quad-tree.sml diff --git a/fcore/pointer-quad-tree-fold.sml b/fcore/pointer-quad-tree-fold.sml deleted file mode 100644 index c8c9934..0000000 --- a/fcore/pointer-quad-tree-fold.sml +++ /dev/null @@ -1,92 +0,0 @@ -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-type.sml b/fcore/pointer-quad-tree-type.sml deleted file mode 100644 index c1c089f..0000000 --- a/fcore/pointer-quad-tree-type.sml +++ /dev/null @@ -1,130 +0,0 @@ -signature POINTER_QUAD_TREE_TYPE = -sig - type item = {itemID: int, startX: int, startY: int, width: int, height: int} - - datatype t = - NODE of {tl: t, tr: t, bl: t, br: t} - | LEAF of item - | SHARE_LEAF of item list - | EMPTY - - val isColliding: int * int * int * int * int * int * int * int -> bool - - val isCollidingPlus: int * int * int * int * int * int * int * int -> bool - - val isCollidingItem: int * int * int * int * int * item -> bool - - val visitTopLeft: int * int * int * int * int * int * int * int -> bool - - val visitTopRight: 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 PointerQuadTreeType :> POINTER_QUAD_TREE_TYPE = -struct - type item = {itemID: int, startX: int, startY: int, width: int, height: int} - - datatype t = - NODE of {tl: t, tr: t, bl: t, br: t} - | LEAF of item - | SHARE_LEAF of item list - | EMPTY - - fun isColliding (ix, iy, ifx, ify, cx, cy, cfx, cfy) = - ix < cfx andalso ifx > cx andalso iy < cfy andalso ify > cy - - fun isCollidingPlus (ix, iy, iw, ih, cx, cy, cw, ch) = - let - val ifx = ix + iw - val ify = iy + ih - val cfx = cx + cw - val cfy = cy + ch - in - 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 - val hh = qH div 2 - - val ifx = iX + iW - val ify = iY + iH - - val qmx = qX + hw - val qmy = qY + hh - - val qfx = qX + qW - val qfy = qY + qH - in - isColliding (iX, iY, ifx, ify, qX, qY, qmx, qmy) - end - - fun visitTopRight (iX, iY, iW, iH, qX, qY, qW, qH) = - let - val hw = qW div 2 - val hh = qH div 2 - - val ifx = iX + iW - val ify = iY + iH - - val qmx = qX + hw - val qmy = qY + hh - - val qfx = qX + qW - val qfy = qY + qH - in - isColliding (iX, iY, ifx, ify, qmx, qY, qfx, qmy) - end - - fun visitBottomLeft (iX, iY, iW, iH, qX, qY, qW, qH) = - let - val hw = qW div 2 - val hh = qH div 2 - - val ifx = iX + iW - val ify = iY + iH - - val qmx = qX + hw - val qmy = qY + hh - - val qfx = qX + qW - val qfy = qY + qH - in - isColliding (iX, iY, ifx, ify, qX, qmy, qmx, qfy) - end - - fun visitBottomRight (iX, iY, iW, iH, qX, qY, qW, qH) = - let - val hw = qW div 2 - val hh = qH div 2 - - val ifx = iX + iW - val ify = iY + iH - - val qmx = qX + hw - val qmy = qY + hh - - val qfx = qX + qW - val qfy = qY + qH - in - isColliding (iX, iY, ifx, ify, qmx, qmy, qfx, qfy) - end -end diff --git a/fcore/pointer-quad-tree.sml b/fcore/pointer-quad-tree.sml deleted file mode 100644 index 4693521..0000000 --- a/fcore/pointer-quad-tree.sml +++ /dev/null @@ -1,249 +0,0 @@ -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 - - type item = PointerQuadTreeType.item - - type t = {width: int, height: int, tree: PointerQuadTreeType.t} - - fun mkItem (id, startX, startY, width, height) : item = - { itemID = id - , startX = startX - , startY = startY - , width = width - , height = height - } - - fun create (width, height) = {width = width, height = height, tree = EMPTY} - - fun hasSameCoordinates (prev: item, new: item) = - let - val {startX = px, startY = py, width = pw, height = ph, ...} = prev - val {startX = nx, startY = ny, width = nw, height = nh, ...} = new - in - px = nx andalso py = ny andalso pw = nw andalso ph = nh - end - - fun mkLeaf (visitPrev, visitNew, prevItem, newItem) = - if visitPrev then LEAF prevItem - else if visitNew then LEAF newItem - else EMPTY - - fun helpSplitLeaf (x, y, w, h, prevItem, newItem) = - let - val {startX = px, startY = py, width = pw, height = ph, ...} = prevItem - val {startX = nx, startY = ny, width = nw, height = nh, ...} = newItem - - val vtlPrev = visitTopLeft (px, py, pw, ph, x, y, w, h) - val vtrPrev = visitTopRight (px, py, pw, ph, x, y, w, h) - val vblPrev = visitBottomLeft (px, py, pw, ph, x, y, w, h) - val vbrPrev = visitBottomRight (px, py, pw, ph, x, y, w, h) - - val vtlNew = visitTopLeft (nx, ny, nw, nh, x, y, w, h) - val vtrNew = visitTopRight (nx, ny, nw, nh, x, y, w, h) - val vblNew = visitBottomLeft (nx, ny, nw, nh, x, y, w, h) - val vbrNew = visitBottomRight (nx, ny, nw, nh, x, y, w, h) - - val hw = w div 2 - val hh = h div 2 - val mx = x + hw - val my = y + hh - - val tl = - if vtlPrev andalso vtlNew then - helpSplitLeaf (x, y, hw, hh, prevItem, newItem) - else - mkLeaf (vtlPrev, vtlNew, prevItem, newItem) - - val tr = - if vtrPrev andalso vtrNew then - helpSplitLeaf (mx, y, hw, hh, prevItem, newItem) - else - mkLeaf (vtrPrev, vtrNew, prevItem, newItem) - - val bl = - if vblPrev andalso vblNew then - helpSplitLeaf (x, my, hw, hh, prevItem, newItem) - else - mkLeaf (vblPrev, vblNew, prevItem, newItem) - - val br = - if vbrPrev andalso vbrNew then - helpSplitLeaf (mx, my, hw, hh, prevItem, newItem) - else - mkLeaf (vbrPrev, vbrNew, prevItem, newItem) - in - NODE {tl = tl, tr = tr, bl = bl, br = br} - end - - fun splitLeaf (x, y, w, h, prevItem, newItem) = - if hasSameCoordinates (prevItem, newItem) then - SHARE_LEAF [prevItem, newItem] - else - helpSplitLeaf (x, y, w, h, prevItem, newItem) - - fun mkShareLeaf (visitPrev, visitNew, oldItems, newItem) = - if visitPrev then SHARE_LEAF oldItems - else if visitNew then LEAF newItem - else EMPTY - - fun helpSplitShareLeaf (x, y, w, h, oldItems, prevItem, newItem) = - let - val {startX = px, startY = py, width = pw, height = ph, ...} = prevItem - val {startX = nx, startY = ny, width = nw, height = nh, ...} = newItem - - val vtlPrev = visitTopLeft (px, py, pw, ph, x, y, w, h) - val vtrPrev = visitTopRight (px, py, pw, ph, x, y, w, h) - val vblPrev = visitBottomLeft (px, py, pw, ph, x, y, w, h) - val vbrPrev = visitBottomRight (px, py, pw, ph, x, y, w, h) - - val vtlNew = visitTopLeft (nx, ny, nw, nh, x, y, w, h) - val vtrNew = visitTopRight (nx, ny, nw, nh, x, y, w, h) - val vblNew = visitBottomLeft (nx, ny, nw, nh, x, y, w, h) - val vbrNew = visitBottomRight (nx, ny, nw, nh, x, y, w, h) - - val hw = w div 2 - val hh = h div 2 - val mx = x + hw - val my = y + hh - - val tl = - if vtlPrev andalso vtlNew then - helpSplitShareLeaf (x, y, hw, hh, oldItems, prevItem, newItem) - else - mkShareLeaf (vtlPrev, vtlNew, oldItems, newItem) - - val tr = - if vtrPrev andalso vtrNew then - helpSplitShareLeaf (mx, y, hw, hh, oldItems, prevItem, newItem) - else - mkShareLeaf (vtrPrev, vtrNew, oldItems, newItem) - - val bl = - if vblPrev andalso vblNew then - helpSplitShareLeaf (x, my, hw, hh, oldItems, prevItem, newItem) - else - mkShareLeaf (vblPrev, vblNew, oldItems, newItem) - - val br = - if vbrPrev andalso vbrNew then - helpSplitShareLeaf (mx, my, hw, hh, oldItems, prevItem, newItem) - else - mkShareLeaf (vbrPrev, vbrNew, oldItems, newItem) - in - NODE {tl = tl, tr = tr, bl = bl, br = br} - end - - fun splitShareLeaf (x, y, w, h, oldItems, newItem) = - case oldItems of - prevItem :: tl => - if hasSameCoordinates (prevItem, newItem) then - let val newItems = newItem :: oldItems - in SHARE_LEAF newItems - end - else - helpSplitShareLeaf (x, y, w, h, oldItems, prevItem, newItem) - | [] => - (* this case never occurs *) - LEAF newItem - - fun helpInsert (ix, iy, iw, ih, itemID, qx, qy, qw, qh, tree) = - case tree of - NODE {tl, tr, bl, br} => - let - val vtl = visitTopLeft (ix, iy, iw, ih, qx, qy, qw, qh) - val vtr = visitTopRight (ix, iy, iw, ih, qx, qy, qw, qh) - val vbl = visitBottomLeft (ix, iy, iw, ih, qx, qy, qw, qh) - val vbr = visitBottomRight (ix, iy, iw, ih, qx, qy, qw, qh) - - val hw = qw div 2 - val hh = qh div 2 - - val tl = - if vtl then helpInsert (ix, iy, iw, ih, itemID, qw, qy, hw, hh, tl) - else tl - - val tr = - if vtr then - helpInsert (ix, iy, iw, ih, itemID, qx + hw, qy, hw, hh, tr) - else - tr - - val bl = - if vbl then - helpInsert (ix, iy, iw, ih, itemID, qx, qy + hh, hw, hh, bl) - else - bl - - val br = - if vbr then - helpInsert (ix, iy, iw, ih, itemID, qx + hw, qy + hh, hw, hh, br) - else - br - in - NODE {tl = tl, tr = tr, bl = bl, br = br} - end - | LEAF prevItem => - let val newItem = mkItem (itemID, ix, iy, iw, ih) - in splitLeaf (qx, qy, qw, qh, prevItem, newItem) - end - | EMPTY => - let val newItem = mkItem (itemID, ix, iy, iw, ih) - in LEAF newItem - end - | SHARE_LEAF oldItems => - 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 17e96f1..f24790d 100644 --- a/oms.mlb +++ b/oms.mlb @@ -7,10 +7,6 @@ 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