rewrite merge functions which query grid instead of quad tree (only partially)
This commit is contained in:
@@ -92,6 +92,8 @@ struct
|
||||
foldr (f, left, acc)
|
||||
end
|
||||
| LEAF => acc
|
||||
|
||||
fun toList tree = foldr (fn (item, acc) => item ::acc, tree, [])
|
||||
end
|
||||
|
||||
structure CollisionTree =
|
||||
@@ -187,7 +189,6 @@ struct
|
||||
)
|
||||
end)
|
||||
|
||||
local
|
||||
fun getClickPoint (clickPoints, pos) =
|
||||
let val idx = Int.min (pos, Vector.length clickPoints - 1)
|
||||
in Vector.sub (clickPoints, idx)
|
||||
@@ -217,7 +218,7 @@ struct
|
||||
in
|
||||
Ndc.ltrbToVertexRgb (startX, startY, endX, endY, 0.0, 0.0, 0.0) :: acc
|
||||
end
|
||||
in
|
||||
|
||||
fun toTriangles
|
||||
( windowWidth
|
||||
, windowHeight
|
||||
@@ -243,7 +244,6 @@ struct
|
||||
in
|
||||
Vector.concat vec
|
||||
end
|
||||
end
|
||||
|
||||
(* building and querying quad tree, plus compression *)
|
||||
datatype quad_tree =
|
||||
@@ -251,6 +251,22 @@ struct
|
||||
| NODE of {tl: quad_tree, tr: quad_tree, bl: quad_tree, br: quad_tree}
|
||||
| EMPTY
|
||||
|
||||
fun foldWithDuplicates (f, tree, acc) =
|
||||
case tree of
|
||||
EMPTY => acc
|
||||
| LEAF item => f (item, acc)
|
||||
| NODE {tl, tr, bl, br} =>
|
||||
let
|
||||
val acc = foldWithDuplicates (f, tl, acc)
|
||||
val acc = foldWithDuplicates (f, tr, acc)
|
||||
val acc = foldWithDuplicates (f, bl, acc)
|
||||
in
|
||||
foldWithDuplicates (f, br, acc)
|
||||
end
|
||||
|
||||
fun toBintree qtree =
|
||||
foldWithDuplicates (BinTree.insert, qtree, BinTree.empty)
|
||||
|
||||
fun buildTree (x, y, size, grid) =
|
||||
if x >= Vector.length grid orelse y >= Vector.length grid then
|
||||
EMPTY
|
||||
@@ -297,255 +313,58 @@ struct
|
||||
NODE {tl = tl, tr = tr, bl = bl, br = br}
|
||||
end)
|
||||
|
||||
fun getItemWithDataAt (x, y, qx, qy, size, tree, data) =
|
||||
case tree of
|
||||
EMPTY => NONE
|
||||
| LEAF (item as {x = ix, y = iy, ex = iex, ey = iey, data = oldData}) =>
|
||||
if (x >= ix andalso x <= iex) andalso (y >= iy andalso y <= iey) then
|
||||
(* search coordinates are in item *)
|
||||
if data = oldData then (* data matches *) SOME item else NONE
|
||||
local
|
||||
fun loop (x, y, ex, ey, grid) =
|
||||
if x > 0 then
|
||||
if quadHasSameColour (x, y, ex, ey, grid) then
|
||||
loop (x - 1, y, x, ey, grid)
|
||||
else
|
||||
NONE
|
||||
| NODE {tl, tr, bl, br} =>
|
||||
if size mod 2 = 0 orelse size = 1 then
|
||||
let
|
||||
val halfSize = size div 2
|
||||
val qmx = x + halfSize
|
||||
val qfx = x + size
|
||||
val qmy = y + halfSize
|
||||
val qfy = y + size
|
||||
ex
|
||||
else
|
||||
0
|
||||
in
|
||||
if y >= qy andalso y <= qmy then
|
||||
(* top *)
|
||||
if x >= qx andalso x <= qmx then
|
||||
(* top left *)
|
||||
getItemWithDataAt (x, y, qx, qy, halfSize, tl, data)
|
||||
else
|
||||
(* top right *)
|
||||
getItemWithDataAt (x, y, qx + halfSize, qy, halfSize, tr, data)
|
||||
else (* bottom *) if x >= qx andalso x <= qmx then
|
||||
(* bottom left *)
|
||||
getItemWithDataAt (x, y, qx, qy + halfSize, halfSize, bl, data)
|
||||
else
|
||||
(* bottom right *)
|
||||
getItemWithDataAt
|
||||
(x, y, qx + halfSize, qy + halfSize, halfSize, br, data)
|
||||
end
|
||||
else
|
||||
let
|
||||
val halfSizeBefore = size div 2
|
||||
val halfSizeAfter = (size + 1) div 2
|
||||
val qmx = x + halfSizeBefore
|
||||
val qmy = y + halfSizeBefore
|
||||
in
|
||||
if y >= qy andalso y <= qmy then
|
||||
(* top *)
|
||||
if x >= qx andalso x <= qmx then
|
||||
(* top left *)
|
||||
getItemWithDataAt (x, y, qx, qy, halfSizeAfter, tl, data)
|
||||
else
|
||||
(* top right *)
|
||||
getItemWithDataAt (x, y, qmx, qy, halfSizeAfter, tr, data)
|
||||
else (* bottom *) if x >= qx andalso x <= qmx then
|
||||
(* bottom left *)
|
||||
getItemWithDataAt (x, y, qx, qmy, halfSizeAfter, bl, data)
|
||||
else
|
||||
(* bottom right *)
|
||||
getItemWithDataAt (x, y, qmx, qmy, halfSizeAfter, br, data)
|
||||
end
|
||||
|
||||
fun getLeftmostX (rootSize, rootTree, prevItem) =
|
||||
let
|
||||
val {x = prevX, y = prevY, ex = prevEx, ey = prevEy, data = prevData} =
|
||||
prevItem
|
||||
in
|
||||
case
|
||||
getItemWithDataAt (prevX - 1, prevY, 0, 0, rootSize, rootTree, prevData)
|
||||
of
|
||||
SOME (newItem as {y = newY, ey = newEy, data = newData, ...}) =>
|
||||
if prevY = newY andalso newEy = prevEy andalso prevData = newData then
|
||||
(* Y side has same edge, so is mergeable, and data is also same *)
|
||||
getLeftmostX (rootSize, rootTree, newItem)
|
||||
else
|
||||
prevX
|
||||
| NONE => prevX
|
||||
end
|
||||
|
||||
fun getRightmostX (rootSize, rootTree, prevItem) =
|
||||
let
|
||||
val {x = prevX, y = prevY, ex = prevEx, ey = prevEy, data = prevData} =
|
||||
prevItem
|
||||
in
|
||||
case
|
||||
getItemWithDataAt
|
||||
(prevEx + 1, prevY, 0, 0, rootSize, rootTree, prevData)
|
||||
of
|
||||
SOME (newItem as {y = newY, ey = newEy, data = newData, ...}) =>
|
||||
if prevY = newY andalso newEy = prevEy andalso prevData = newData then
|
||||
getRightmostX (rootSize, rootTree, newItem)
|
||||
else
|
||||
prevEx
|
||||
| NONE => prevEx
|
||||
end
|
||||
|
||||
fun getTopmostY (rootSize, rootTree, prevItem) =
|
||||
let
|
||||
val {x = prevX, y = prevY, ex = prevEx, ey = prevEy, data = prevData} =
|
||||
prevItem
|
||||
in
|
||||
case
|
||||
getItemWithDataAt (prevX, prevY - 1, 0, 0, rootSize, rootTree, prevData)
|
||||
of
|
||||
SOME (newItem as {x = newX, ex = newEx, data = newData, ...}) =>
|
||||
if prevX = newX andalso prevEx = newEx andalso prevData = newData then
|
||||
(* X side has same edge and data is also same, so mergeable *)
|
||||
getTopmostY (rootSize, rootTree, newItem)
|
||||
else
|
||||
prevY
|
||||
| NONE => prevY
|
||||
end
|
||||
|
||||
fun getBottomY (rootSize, rootTree, prevItem) =
|
||||
let
|
||||
val {x = prevX, y = prevY, ex = prevEx, ey = prevEy, data = prevData} =
|
||||
prevItem
|
||||
in
|
||||
case
|
||||
getItemWithDataAt
|
||||
(prevX, prevEy + 1, 0, 0, rootSize, rootTree, prevData)
|
||||
of
|
||||
SOME (newItem as {x = newX, ex = newEx, data = newData, ...}) =>
|
||||
if prevX = newX andalso prevEx = newEx andalso prevData = newData then
|
||||
(* X side has same edge and data is also same, so mergeable *)
|
||||
getBottomY (rootSize, rootTree, newItem)
|
||||
else
|
||||
prevEy
|
||||
| NONE => prevEy
|
||||
end
|
||||
|
||||
datatype merge_dir =
|
||||
HORIZONTAL of {left: int, right: int}
|
||||
| VERTICAL of {up: int, down: int}
|
||||
| NO_MERGE
|
||||
|
||||
fun getHorizontal (ox, oex, leftX, rightX) =
|
||||
let
|
||||
val left = if leftX < ox then ox - 1 else ox
|
||||
val right = if rightX > oex then oex + 1 else oex
|
||||
in
|
||||
HORIZONTAL {left = left, right = right}
|
||||
end
|
||||
|
||||
fun getVertical (oy, oey, upY, bottomY) =
|
||||
let
|
||||
val up = if upY < oy then oy - 1 else oy
|
||||
val down = if bottomY > oey then oey + 1 else oey
|
||||
in
|
||||
VERTICAL {up = up, down = down}
|
||||
end
|
||||
|
||||
fun getMergeDir (rootSize, rootTree, item) =
|
||||
let
|
||||
val {x = ox, y = oy, ex = oex, ey = oey, data} = item
|
||||
|
||||
val leftX = getLeftmostX (rootSize, rootTree, item)
|
||||
val rightX = getRightmostX (rootSize, rootTree, item)
|
||||
val upY = getTopmostY (rootSize, rootTree, item)
|
||||
val bottomY = getBottomY (rootSize, rootTree, item)
|
||||
|
||||
val xChanged = leftX <> ox orelse rightX <> oex
|
||||
val yChanged = upY <> oy orelse bottomY <> oey
|
||||
in
|
||||
if xChanged andalso yChanged then
|
||||
let
|
||||
val diffX = abs (rightX - leftX)
|
||||
val diffY = abs (bottomY - upY)
|
||||
in
|
||||
if diffX > diffY then getHorizontal (ox, oex, leftX, rightX)
|
||||
else getVertical (oy, oey, upY, bottomY)
|
||||
end
|
||||
else if xChanged then
|
||||
getHorizontal (ox, oex, leftX, rightX)
|
||||
else if yChanged then
|
||||
getVertical (oy, oey, upY, bottomY)
|
||||
else
|
||||
NO_MERGE
|
||||
end
|
||||
|
||||
fun mergeHorizontal (item, newX, newEx) =
|
||||
let val {y, ey, data, x = _, ex = _} = item
|
||||
in {x = newX, ex = newEx, y = y, ey = ey, data = data}
|
||||
end
|
||||
|
||||
fun mergeVertical (item, newY, newEy) =
|
||||
let val {x, ex, data, y = _, ey = _} = item
|
||||
in {y = newY, ey = newEy, x = x, ex = ex, data = data}
|
||||
fun getLeftmostX ({x, y, ex, ey, data}, grid) =
|
||||
loop (x - 1, y, x, ey, grid)
|
||||
end
|
||||
|
||||
local
|
||||
fun mergePass (qx, qy, size, tree, rootSize, rootTree) =
|
||||
case tree of
|
||||
EMPTY => (EMPTY, false)
|
||||
| LEAF item =>
|
||||
let
|
||||
val mergeDir = getMergeDir (rootSize, rootTree, item)
|
||||
in
|
||||
case mergeDir of
|
||||
NO_MERGE => (LEAF item, false)
|
||||
| VERTICAL {up, down} =>
|
||||
(LEAF (mergeVertical (item, up, down)), true)
|
||||
| HORIZONTAL {left, right} =>
|
||||
(LEAF (mergeHorizontal (item, left, right)), true)
|
||||
end
|
||||
| NODE {tl, tr, bl, br} =>
|
||||
if size = 1 orelse size mod 2 = 0 then
|
||||
let
|
||||
val halfSize = size div 2
|
||||
|
||||
val (tl, didMergeTl) = mergePass
|
||||
(qx, qy, halfSize, tl, rootSize, rootTree)
|
||||
val (tr, didMergeTr) = mergePass
|
||||
(qx + halfSize, qy, halfSize, tr, rootSize, rootTree)
|
||||
val (bl, didMergeBl) = mergePass
|
||||
(qx, qy + halfSize, halfSize, bl, rootSize, rootTree)
|
||||
val (br, didMergeBr) = mergePass
|
||||
(qx + halfSize, qy + halfSize, halfSize, br, rootSize, rootTree)
|
||||
|
||||
val didMergeAny =
|
||||
didMergeTl orelse didMergeTr orelse didMergeBl orelse didMergeBr
|
||||
val node = NODE {tl = tl, tr = tr, bl = bl, br = br}
|
||||
in
|
||||
(node, didMergeAny)
|
||||
end
|
||||
fun loop (x, y, ex, ey, grid) =
|
||||
if x < Vector.length grid andalso ex < Vector.length grid then
|
||||
if quadHasSameColour (x, y, ex, ey, grid) then
|
||||
loop (ex, y, ex + 1, ey, grid)
|
||||
else
|
||||
let
|
||||
val halfSizeBefore = size div 2
|
||||
val halfSizeAfter = (size + 1) div 2
|
||||
val qmx = qx + halfSizeBefore
|
||||
val qmy = qy + halfSizeAfter
|
||||
|
||||
val (tl, didMergeTl) = mergePass
|
||||
(qx, qy, halfSizeAfter, tl, rootSize, rootTree)
|
||||
val (tr, didMergeTr) = mergePass
|
||||
(qmx, qy, halfSizeAfter, tr, rootSize, rootTree)
|
||||
val (bl, didMergeBl) = mergePass
|
||||
(qx, qmy, halfSizeAfter, bl, rootSize, rootTree)
|
||||
val (br, didMergeBr) = mergePass
|
||||
(qmx, qmy, halfSizeAfter, br, rootSize, rootTree)
|
||||
|
||||
val didMergeAny =
|
||||
didMergeTl orelse didMergeTr orelse didMergeBl orelse didMergeBr
|
||||
val node = NODE {tl = tl, tr = tr, bl = bl, br = br}
|
||||
x
|
||||
else
|
||||
Vector.length grid - 1
|
||||
in
|
||||
(node, didMergeAny)
|
||||
fun getRightmostX ({x, y, ex, ey, data}, grid) =
|
||||
loop (ex, y, ex + 1, ey, grid)
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (x, y, ex, ey, grid) =
|
||||
if y < 0 then 0
|
||||
else
|
||||
if quadHasSameColour (x, y, ex, ey, grid) then
|
||||
loop (x, y - 1, ex, y, grid)
|
||||
else
|
||||
ey
|
||||
in
|
||||
fun merge (rootSize, rootTree) =
|
||||
let
|
||||
val (newTree, didMerge) = mergePass
|
||||
(0, 0, rootSize, rootTree, rootSize, rootTree)
|
||||
in
|
||||
if didMerge then merge (rootSize, newTree) else newTree
|
||||
fun getTopmostY ({x, y, ex, ey, data}, grid) =
|
||||
loop (x, y - 1, ex, y, grid)
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (x, y, ex, ey, grid) =
|
||||
if y < Vector.length grid andalso ey < Vector.length grid then
|
||||
if quadHasSameColour (x, y, ex, ey, grid) then
|
||||
loop (x, ey, ex, ey + 1, grid)
|
||||
else
|
||||
y
|
||||
else
|
||||
Vector.length grid - 1
|
||||
in
|
||||
fun getBottomY ({x, y, ex, ey, data}, grid) =
|
||||
loop (x, ey, ex, ey + 1, grid)
|
||||
end
|
||||
end
|
||||
|
||||
Reference in New Issue
Block a user