diff --git a/fcore/quad-tree-fold.sml b/fcore/quad-tree-fold.sml index 4a71fca..e860226 100644 --- a/fcore/quad-tree-fold.sml +++ b/fcore/quad-tree-fold.sml @@ -11,7 +11,7 @@ sig structure Fn: QUAD_FOLDER val foldRegion: int * int * int * int * - Fn.env * Fn.state * QuadTreeType.t + Fn.env * Fn.state * {tree: QuadTreeType.t, width: int, height: int} -> Fn.state end @@ -36,25 +36,52 @@ struct foldRegionVec (rx, ry, rw, rh, env, state, pos + 1, elements) end - fun foldRegion (rx, ry, rw, rh, env, state, tree) = + fun helpFoldRegion (rx, ry, rw, rh, env, state, qx, qy, qw, qh, tree) = case tree of - NODE {nodes, 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, Vector.sub (nodes, tlIdx)) - val state = - foldRegion (rx, ry, rw, rh, env, state, Vector.sub (nodes, trIdx)) - val state = - foldRegion (rx, ry, rw, rh, env, state, Vector.sub (nodes, blIdx)) - in - foldRegion (rx, ry, rw, rh, env, state, Vector.sub (nodes, brIdx)) - 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 + NODE nodes => + 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, Vector.sub (nodes, tlIdx)) + else + state + + val state = + if vtr then + helpFoldRegion + (rx, ry, rw, rh, env, state, qx + hw, qy, hw, hh, Vector.sub (nodes, trIdx)) + else + state + + val state = + if vbl then + helpFoldRegion + (rx, ry, rw, rh, env, state, qx, qy + hh, hw, hh, Vector.sub (nodes, blIdx)) + else + state + in + if vbr then + helpFoldRegion + (rx, ry, rw, rh, env, state, qw + hw, qy + hh, hw, hh, Vector.sub (nodes, brIdx)) + else + state + end + | LEAF items => + foldRegionVec (rx, ry, rw, rh, env, state, 0, 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/quad-tree-type.sml b/fcore/quad-tree-type.sml index 76f2c4a..c931951 100644 --- a/fcore/quad-tree-type.sml +++ b/fcore/quad-tree-type.sml @@ -3,14 +3,8 @@ sig type item = {itemID: int, startX: int, startY: int, width: int, height: int} datatype t = - NODE of - { nodes: t vector - , x: int - , y: int - , w: int - , h: int - } - | LEAF of {items: item vector, x: int, y: int, w: int, h: int} + NODE of t vector + | LEAF of item vector val tlIdx: int val trIdx: int @@ -51,14 +45,8 @@ struct type item = {itemID: int, startX: int, startY: int, width: int, height: int} datatype t = - NODE of - { nodes: t vector - , x: int - , y: int - , w: int - , h: int - } - | LEAF of {items: item vector, x: int, y: int, w: int, h: int} + NODE of t vector + | LEAF of item vector val tlIdx = 0 val trIdx = 1 diff --git a/fcore/quad-tree.sml b/fcore/quad-tree.sml index caf7225..43e3f06 100644 --- a/fcore/quad-tree.sml +++ b/fcore/quad-tree.sml @@ -6,8 +6,6 @@ sig val getCollisions: int * int * int * int * int * t -> int list - val helpGetCollisions: int * int * int * int * int * int list * t -> int list - val hasCollisionAt: int * int * int * int * int * t -> bool val getItemID: int * int * int * int * t -> int @@ -21,8 +19,15 @@ struct type item = QuadTreeType.item + type t = {tree: QuadTreeType.t, width: int, height: int} + fun create (width, height) = - LEAF {items = Vector.fromList [], x = 0, y = 0, w = width, h = height} + let + val vec = Vector.fromList [] + val tree = LEAF vec + in + { tree = tree, width = width, height = height } + end fun mkItem (id, startX, startY, width, height) : item = { itemID = id @@ -32,49 +37,14 @@ struct , height = height } - type t = QuadTreeType.t - (* max size of vector before we split it further *) - val maxSize = 9 + val maxSize = 16 - fun mkTopLeft (x, y, w, h, items) = + fun mkLeaf items = let val items = Vector.fromList items - val hw = w div 2 - val hh = h div 2 in - LEAF {items = items, x = x, y = y, w = hw, h = hh} - end - - fun mkTopRight (x, y, w, h, items) = - let - val items = Vector.fromList items - val hw = w div 2 - val hh = h div 2 - val x = x + hw - in - LEAF {items = items, x = x, y = y, w = hw, h = hh} - end - - fun mkBottomLeft (x, y, w, h, items) = - let - val items = Vector.fromList items - val hw = w div 2 - val hh = h div 2 - val y = y + hh - in - LEAF {items = items, x = x, y = y, w = hw, h = hh} - end - - fun mkBottomRight (x, y, w, h, items) = - let - val items = Vector.fromList items - val hw = w div 2 - val hh = h div 2 - val x = x + hw - val y = y + hh - in - LEAF {items = items, x = x, y = y, w = hw, h = hh} + LEAF items end fun splitLeaf @@ -91,18 +61,13 @@ struct ) = if pos < 0 then let - val tl = mkTopLeft (x, y, w, h, tl) - val tr = mkTopRight (x, y, w, h, tr) - val bl = mkBottomLeft (x, y, w, h, bl) - val br = mkBottomRight (x, y, w, h, br) + val tl = mkLeaf tl + val tr = mkLeaf tr + val bl = mkLeaf bl + val br = mkLeaf br + val nodes = Vector.fromList [tl, tr, bl, br] in - NODE - { nodes = Vector.fromList [tl, tr, bl, br] - , x = x - , y = y - , w = w - , h = h - } + NODE nodes end else let @@ -115,202 +80,116 @@ struct val vbr = visitBottomRight (iX, iY, iW, iH, x, y, w, h) val tl = if vtl then item :: tl else tl - val tr = if vtr then item :: tr else tr - val bl = if vbl then item :: bl else bl - val br = if vbr then item :: br else br in splitLeaf (x, y, w, h, tl, tr, bl, br, elements, pos - 1) end + fun helpInsert (ix, iy, iw, ih, itemID, qx, qy, qw, qh, tree) = + case tree of + NODE nodes => + 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 = Vector.sub (nodes, tlIdx) + val tl = + if vtl then + helpInsert (ix, iy, iw, ih, itemID, qw, qy, hw, hh, tl) + else + tl + + val tr = Vector.sub (nodes, trIdx) + val tr = + if vtr then + helpInsert (ix, iy, iw, ih, itemID, qx + hw, qy, hw, hh, tr) + else + tr + + val bl = Vector.sub (nodes, blIdx) + val bl = + if vbl then + helpInsert (ix, iy, iw, ih, itemID, qx, qy + hh, hw, hh, bl) + else + bl + + val br = Vector.sub (nodes, brIdx) + val br = + if vbr then + helpInsert (ix, iy, iw, ih, itemID, qx + hw, qy + hh, hw, hh, br) + else + br + + val nodes = Vector.fromList [tl, tr, bl, br] + in + NODE nodes + end + | LEAF items => + if Vector.length items + 1 > maxSize then + 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 newItem = mkItem (itemID, ix, iy, iw, ih) + + val tl = if vtl then [newItem] else [] + val tr = if vtr then [newItem] else [] + val bl = if vbl then [newItem] else [] + val br = if vbr then [newItem] else [] + in + splitLeaf + (qx, qy, qw, qh, tl, tr, bl, br, items, Vector.length items - 1) + end + else + let + val newItem = mkItem (itemID, ix, iy, iw, ih) + val newItems = Vector.concat [items, Vector.fromList [newItem]] + in + LEAF newItems + end + fun insert (iX, iY, iW, iH, itemID, tree: t) = - case tree of - NODE {nodes, x, y, w, h} => - if isCollidingPlus (iX, iY, iW, iH, x, y, w, h) then - let - (* we are not necessarily inserting into all nodes. - * If isCollidingPlus returns false recursively, - * we return the same node back. *) - val tl = insert (iX, iY, iW, iH, itemID, Vector.sub (nodes, tlIdx)) - val tr = insert (iX, iY, iW, iH, itemID, Vector.sub (nodes, trIdx)) - val bl = insert (iX, iY, iW, iH, itemID, Vector.sub (nodes, blIdx)) - val br = insert (iX, iY, iW, iH, itemID, Vector.sub (nodes, brIdx)) - in - NODE - { nodes = Vector.fromList [tl, tr, bl, br] - , x = x - , y = y - , w = w - , h = h - } - end - else - tree - | LEAF {items, x, y, w, h} => - if isCollidingPlus (iX, iY, iW, iH, x, y, w, h) then - if Vector.length items + 1 > maxSize then - (* have to calculate quadrants and split *) - let - val pos = Vector.length items - 1 - val item = mkItem (itemID, iX, iY, iW, iH) + 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 - val vtl = visitTopLeft (iX, iY, iW, iH, x, y, w, h) - val vtr = visitTopRight (iX, iY, iW, iH, x, y, w, h) - val vbl = visitBottomLeft (iX, iY, iW, iH, x, y, w, h) - val vbr = visitBottomRight (iX, iY, iW, iH, x, y, w, h) + structure GetCollisions = MakeQuadTreeFold (struct + type env = unit + type state = int list + fun fold (itemID, (), lst) = itemID :: lst + end) - val tl = if vtl then [item] else [] + fun getCollisions (itemX, itemY, itemWidth, itemHeight, _, tree) = + GetCollisions.foldRegion (itemX, itemY, itemWidth, itemHeight, (), [], tree) - val tr = if vtr then [item] else [] + structure HasCollisionAt = MakeQuadTreeFold (struct + type env = unit + type state = bool + fun fold _ = true + end) - val bl = if vbl then [item] else [] + fun hasCollisionAt (ix, iy, iw, ih, _, tree) = + HasCollisionAt.foldRegion (ix, iy, iw, ih, (), false, tree) - val br = if vbr then [item] else [] - in - splitLeaf (x, y, w, h, tl, tr, bl, br, items, pos) - end - else - (* can insert itemID in items vector *) - let - val item = mkItem (itemID, iX, iY, iW, iH) - val items = Vector.concat [items, Vector.fromList [item]] - in - LEAF {items = items, x = x, y = y, w = w, h = h} - end - else - (* bounds of new item don't fit inside leaf so return old tree *) - tree + structure GetItemID = MakeQuadTreeFold (struct + type env = unit + type state = int + fun fold (itemID, (), curID) = Int.max (itemID, curID) + end) - fun getCollisionsVec (iX, iY, iW, iH, itemID, pos, elements, acc) = - if pos = Vector.length elements then - acc - else - let - val item = Vector.sub (elements, pos) - val 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 - - fun getCollisionsAll (iX, iY, iW, iH, itemID, acc, tree) = - case tree of - NODE {nodes, x, y, w, h} => - if isCollidingPlus (iX, iY, iW, iH, x, y, w, h) then - let - val acc = - getCollisionsAll (iX, iY, iW, iH, itemID, acc, Vector.sub (nodes, tlIdx)) - - val acc = - getCollisionsAll (iX, iY, iW, iH, itemID, acc, Vector.sub (nodes, trIdx)) - - val acc = - getCollisionsAll (iX, iY, iW, iH, itemID, acc, Vector.sub (nodes, blIdx)) - in - getCollisionsAll (iX, iY, iW, iH, itemID, acc, Vector.sub (nodes, brIdx)) - end - else - acc - | LEAF {items, x, y, w, h} => - if isCollidingPlus (iX, iY, iW, iH, x, y, w, h) then - getCollisionsVec (iX, iY, iW, iH, itemID, 0, items, acc) - else - acc - - fun helpGetCollisions (iX, iY, iW, iH, itemID, acc, tree: t) = - case tree of - NODE {nodes, x, y, w, h} => - if isCollidingPlus (iX, iY, iW, iH, x, y, w, h) then - let - val acc = - helpGetCollisions (iX, iY, iW, iH, itemID, acc, Vector.sub (nodes, tlIdx)) - - val acc = - helpGetCollisions (iX, iY, iW, iH, itemID, acc, Vector.sub (nodes, trIdx)) - - val acc = - helpGetCollisions (iX, iY, iW, iH, itemID, acc, Vector.sub (nodes, blIdx)) - in - helpGetCollisions - (iX, iY, iW, iH, itemID, acc, Vector.sub (nodes, brIdx)) - end - else - acc - | LEAF {items, x, y, w, h} => - if isCollidingPlus (iX, iY, iW, iH, x, y, w, h) then - getCollisionsVec (iX, iY, iW, iH, itemID, 0, items, acc) - else - acc - - fun getCollisions (itemX, itemY, itemWidth, itemHeight, itemID, tree) = - helpGetCollisions (itemX, itemY, itemWidth, itemHeight, itemID, [], tree) - - fun hasCollisionAtVec (iX, iY, iW, iH, itemID, pos, elements) = - if pos = Vector.length elements then - false - else - let - val item = Vector.sub (elements, pos) - in - isCollidingItem (iX, iY, iW, iH, itemID, item) - orelse hasCollisionAtVec (iX, iY, iW, iH, itemID, pos + 1, elements) - end - - fun hasCollisionAt (iX, iY, iW, iH, itemID, tree) = - case tree of - NODE {nodes, x, y, w, h} => - if isCollidingPlus (iX, iY, iW, iH, x, y, w, h) then - hasCollisionAt (iX, iY, iW, iH, itemID, Vector.sub (nodes, tlIdx)) - orelse hasCollisionAt (iX, iY, iW, iH, itemID, Vector.sub (nodes, trIdx)) - orelse hasCollisionAt (iX, iY, iW, iH, itemID, Vector.sub (nodes, blIdx)) - orelse hasCollisionAt (iX, iY, iW, iH, itemID, Vector.sub (nodes, brIdx)) - else - false - | LEAF {items, x, y, w, h} => - if isCollidingPlus (iX, iY, iW, iH, x, y, w, h) then - hasCollisionAtVec (iX, iY, iW, iH, itemID, 0, items) - else - false - - fun getItemIDVec (iX, iY, iW, iH, pos, elements) = - if pos = Vector.length elements then - ~1 - else - let - val item = Vector.sub (elements, pos) - in - if isCollidingItem (iX, iY, iW, iH, ~1, item) then #itemID item - else getItemIDVec (iX, iY, iW, iH, pos + 1, elements) - end - - fun getItemID (iX, iY, iW, iH, tree) = - case tree of - NODE {nodes, x, y, w, h} => - if isCollidingPlus (iX, iY, iW, iH, x, y, w, h) then - let - val try1 = getItemID (iX, iY, iW, iH, Vector.sub (nodes, tlIdx)) - val try2 = getItemID (iX, iY, iW, iH, Vector.sub (nodes, trIdx)) - val try3 = getItemID (iX, iY, iW, iH, Vector.sub (nodes, blIdx)) - val try4 = getItemID (iX, iY, iW, iH, Vector.sub (nodes, brIdx)) - - (* get max: we assume query was narrow enough - * that only one ID is valid *) - val a = Int.max (try1, try2) - val a = Int.max (a, try3) - val a = Int.max (a, try4) - in - a - end - else - ~1 - | LEAF {items, x, y, w, h} => - if isCollidingPlus (iX, iY, iW, iH, x, y, w, h) then - getItemIDVec (iX, iY, iW, iH, 0, items) - else - ~1 + 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 faa8a47..f24790d 100644 --- a/oms.mlb +++ b/oms.mlb @@ -4,8 +4,8 @@ $(SML_LIB)/basis/basis.mlb fcore/constants.sml fcore/quad-tree-type.sml -fcore/quad-tree.sml fcore/quad-tree-fold.sml +fcore/quad-tree.sml fcore/bin-search.sml fcore/bin-vec.sml