humza/sml-projects
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

delete pointer quad tree because it is twice as slow to construct as the vector-based implementation

Browse Source
This commit is contained in:
Humza Shahid
2025-02-01 10:11:32 +00:00
parent bf3f0b3927
commit e1e1228983
4 changed files with 0 additions and 475 deletions
Download Patch File Download Diff File Expand all files Collapse all files

92
fcore/pointer-quad-tree-fold.sml
View File

@@ -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

130
fcore/pointer-quad-tree-type.sml
View File

@@ -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

249
fcore/pointer-quad-tree.sml
View File

@@ -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

4
oms.mlb
View File

@@ -7,10 +7,6 @@ fcore/quad-tree-type.sml
fcore/quad-tree-fold.sml fcore/quad-tree-fold.sml
fcore/quad-tree.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-search.sml
fcore/bin-vec.sml fcore/bin-vec.sml