Skip to content

Instantly share code, notes, and snippets.

@folkertdev

folkertdev/RTree.elm

Created August 8, 2018 21:01
Show Gist options
  • Save folkertdev/912cdf4ffe59fdd4c76918ba87d53ac4 to your computer and use it in GitHub Desktop.
Save folkertdev/912cdf4ffe59fdd4c76918ba87d53ac4 to your computer and use it in GitHub Desktop.
Download ZIP
A more optimized/less readable RTree
Raw
RTree.elm
module RTree exposing (..)
import BoundingBox2d exposing (BoundingBox2d)
import Point2d exposing (Point2d)
import List.Extra as List
-- bounding boxes can go to infintiy
-- minNode <= maxNode // 2
-- the root node has at least 2 children, unless it is a leaf
-- all leaves appear on the same level
type RTree a
= Empty
| NonEmpty (NonEmptyRTree a)
type NonEmptyRTree a
= Leaf { boundingBox : BoundingBox2d, values : List ( BoundingBox2d, a ) }
| Node { boundingBox : BoundingBox2d, children : ( NonEmptyRTree a, List (NonEmptyRTree a) ) }
| Node2 { boundingBox : BoundingBox2d, child1 : NonEmptyRTree a, child2 : NonEmptyRTree a }
map : (a -> b) -> RTree a -> RTree b
map f rtree =
case rtree of
Empty ->
Empty
NonEmpty nonEmpty ->
NonEmpty (mapNonEmpty f nonEmpty)
mapNonEmpty : (a -> b) -> NonEmptyRTree a -> NonEmptyRTree b
mapNonEmpty f rtree =
case rtree of
Leaf leaf ->
Leaf { boundingBox = leaf.boundingBox, values = List.map (Tuple.mapSecond f) leaf.values }
Node node ->
let
( first, rest ) =
node.children
in
Node { boundingBox = node.boundingBox, children = ( mapNonEmpty f first, List.map (mapNonEmpty f) rest ) }
Node2 node ->
Node2
{ boundingBox = node.boundingBox
, child1 = mapNonEmpty f node.child1
, child2 = mapNonEmpty f node.child2
}
depthNonEmpty : NonEmptyRTree a -> Int
depthNonEmpty nonEmpty =
case nonEmpty of
Leaf leaf ->
List.length leaf.values
Node node ->
let
( first, rest ) =
node.children
folder item accum =
accum + depthNonEmpty item
in
0 + depthNonEmpty first + List.foldl folder 0 rest
Node2 node ->
depthNonEmpty node.child1 + depthNonEmpty node.child2
depth : RTree a -> Int
depth rtree =
case rtree of
Empty ->
0
NonEmpty subtree ->
depthNonEmpty subtree
empty : RTree a
empty =
Empty
singleton : BoundingBox2d -> a -> RTree a
singleton boundingBox value =
NonEmpty (Leaf { boundingBox = boundingBox, values = [ ( boundingBox, value ) ] })
getBoundingBox : NonEmptyRTree a -> BoundingBox2d
getBoundingBox rtree =
case rtree of
Leaf { boundingBox } ->
boundingBox
Node { boundingBox } ->
boundingBox
Node2 { boundingBox } ->
boundingBox
insert : BoundingBox2d -> a -> RTree a -> RTree a
insert boundingBox value rtree =
case rtree of
Empty ->
singleton boundingBox value
NonEmpty nonEmpty ->
NonEmpty (insertNonEmpty boundingBox value nonEmpty)
insertNonEmpty : BoundingBox2d -> a -> NonEmptyRTree a -> NonEmptyRTree a
insertNonEmpty boundingBox value rtree =
case insertNonEmptyHelper boundingBox value rtree of
Done v ->
v
Split combinedBoundingBox x y ->
Node2
{ boundingBox = combinedBoundingBox
, child1 = x
, child2 = y
}
type Split a
= Done a
| Split BoundingBox2d a a
maxNodes : Int
maxNodes =
8
minNodes : Int
minNodes =
2
maxByAndRest : (a -> comparable) -> a -> List a -> ( a, List a )
maxByAndRest toComparable default list =
let
go items ( smallestSoFar, smallestItemSoFar, accum ) =
case items of
item :: remaining ->
let
current =
toComparable item
in
if current > smallestSoFar then
go remaining ( current, item, smallestItemSoFar :: accum )
else
go remaining ( smallestSoFar, smallestItemSoFar, item :: accum )
[] ->
( smallestItemSoFar, accum )
in
go list ( toComparable default, default, [] )
minByAndRest : (a -> comparable) -> a -> List a -> ( a, List a )
minByAndRest toComparable default list =
let
go items ( smallestSoFar, smallestItemSoFar, accum ) =
case items of
item :: remaining ->
let
current =
toComparable item
in
if current < smallestSoFar then
go remaining ( current, item, smallestItemSoFar :: accum )
else
go remaining ( smallestSoFar, smallestItemSoFar, item :: accum )
[] ->
( smallestItemSoFar, accum )
in
go list ( toComparable default, default, [] )
insertNonEmptyHelper : BoundingBox2d -> a -> NonEmptyRTree a -> Split (NonEmptyRTree a)
insertNonEmptyHelper boundingBox value rtree =
case rtree of
Leaf leaf ->
if List.length leaf.values >= maxNodes then
let
( a, b ) =
quadraticSplit (( boundingBox, value ) :: leaf.values)
in
Done
(Node2
{ boundingBox = BoundingBox2d.hull a.boundingBox b.boundingBox
, child1 = (Leaf a)
, child2 = (Leaf b)
}
)
-- using split improves search performance, but decreases remove performance
-- Split (BoundingBox2d.hull a.boundingBox b.boundingBox) (Leaf a) (Leaf b)
else
Done
(Leaf
{ boundingBox = BoundingBox2d.hull leaf.boundingBox boundingBox
, values = ( boundingBox, value ) :: leaf.values
}
)
Node2 node ->
let
( toInsert, other ) =
if boundingBoxDelta (getBoundingBox node.child1) boundingBox < boundingBoxDelta (getBoundingBox node.child2) boundingBox then
( node.child1, node.child2 )
else
( node.child2, node.child1 )
in
case insertNonEmptyHelper boundingBox value toInsert of
Done newChild ->
let
newBoundingBox =
if getBoundingBox newChild == getBoundingBox toInsert then
-- bounding box didn't change
node.boundingBox
else
BoundingBox2d.hull node.boundingBox boundingBox
in
Done
(Node2
{ boundingBox = newBoundingBox
, child1 = newChild
, child2 = other
}
)
Split combinedBoundingBox left right ->
let
newBoundingBox =
BoundingBox2d.hull node.boundingBox combinedBoundingBox
in
Done (Node { boundingBox = newBoundingBox, children = ( other, [ left, right ] ) })
Node node ->
let
( first, rest ) =
node.children
( x, xs ) =
minByAndRest (\subtree -> boundingBoxDelta (getBoundingBox subtree) boundingBox) first rest
in
case insertNonEmptyHelper boundingBox value x of
Done newFirst ->
let
newBoundingBox =
if (getBoundingBox newFirst) == (getBoundingBox x) then
-- bounding box didn't change
node.boundingBox
else
BoundingBox2d.hull node.boundingBox boundingBox
in
Done
(Node
{ boundingBox = newBoundingBox
, children = ( newFirst, xs )
}
)
Split combinedBoundingBox left right ->
let
size =
2 + List.length xs
in
if size > maxNodes then
let
( a, b ) =
quadraticSplitNode (left :: right :: xs)
newLeft =
case a.values of
[ y, z ] ->
Node2 { boundingBox = a.boundingBox, child1 = y, child2 = z }
y :: ys ->
Node { boundingBox = a.boundingBox, children = ( y, ys ) }
_ ->
Debug.crash ""
newRight =
case b.values of
[ y, z ] ->
Node2 { boundingBox = b.boundingBox, child1 = y, child2 = z }
y :: ys ->
Node { boundingBox = b.boundingBox, children = ( y, ys ) }
_ ->
Debug.crash ""
in
Done
(Node2
{ boundingBox = combinedBoundingBox
, child1 = newLeft
, child2 = newRight
}
)
else
let
newBoundingBox =
if BoundingBox2d.isContainedIn node.boundingBox boundingBox then
node.boundingBox
else
BoundingBox2d.hull node.boundingBox boundingBox
in
Done
(Node
{ boundingBox = newBoundingBox
, children = ( left, right :: xs )
}
)
cartesianProduct : List a -> List ( a, a )
cartesianProduct list =
cartesianProductHelper list []
cartesianProductHelper : List a -> List ( a, a ) -> List ( a, a )
cartesianProductHelper list accum =
case list of
[] ->
accum
x :: xs ->
cartesianProductHelper xs (List.foldl (::) accum (List.map (\v -> ( x, v )) xs))
pickSeedsBy : (a -> BoundingBox2d) -> List a -> Maybe ( a, a )
pickSeedsBy toBoundingBox nodes =
let
pairs =
cartesianProduct nodes
costFunction ( a, b ) =
boundingBoxDistance (toBoundingBox a) (toBoundingBox b)
in
List.maximumBy costFunction pairs
pickNextBy : (a -> BoundingBox2d) -> BoundingBox2d -> BoundingBox2d -> List a -> Maybe ( a, List a )
pickNextBy toBoundingBox bb bb_ nodes =
case nodes of
[] ->
Nothing
x :: xs ->
let
diff value =
let
bb__ =
toBoundingBox value
in
abs ((boundingBoxDelta bb bb__) - (boundingBoxDelta bb_ bb__))
in
Just (maxByAndRest diff x xs)
split :
(a -> BoundingBox2d)
-> BoundingBox2d
-> List a
-> BoundingBox2d
-> List a
-> List a
-> ( { boundingBox : BoundingBox2d, values : List a }, { boundingBox : BoundingBox2d, values : List a } )
split toBoundingBox ns_bb ns ms_bb ms nodes =
case nodes of
[] ->
( { boundingBox = ns_bb, values = ns }
, { boundingBox = ms_bb, values = ms }
)
[ x ] ->
case ( ns, ms ) of
( [ _ ], _ ) ->
( { boundingBox = BoundingBox2d.hull (toBoundingBox x) ns_bb, values = x :: ns }
, { boundingBox = ms_bb, values = ms }
)
( _, [ _ ] ) ->
( { boundingBox = ns_bb, values = ns }
, { boundingBox = BoundingBox2d.hull (toBoundingBox x) ms_bb, values = x :: ms }
)
_ ->
case pickNextBy toBoundingBox ns_bb ms_bb nodes of
Nothing ->
( { boundingBox = ns_bb, values = ns }
, { boundingBox = ms_bb, values = ms }
)
Just ( first, rest ) ->
let
bb =
toBoundingBox first
delta_n =
boundingBoxDelta bb ns_bb
delta_m =
boundingBoxDelta bb ms_bb
in
if delta_n < delta_m then
split toBoundingBox (BoundingBox2d.hull ns_bb bb) (first :: ns) ms_bb ms rest
else
split toBoundingBox ns_bb ns (BoundingBox2d.hull ms_bb bb) (first :: ms) rest
_ ->
case pickNextBy toBoundingBox ns_bb ms_bb nodes of
Nothing ->
( { boundingBox = ns_bb, values = ns }
, { boundingBox = ms_bb, values = ms }
)
Just ( first, rest ) ->
let
bb =
toBoundingBox first
delta_n =
boundingBoxDelta bb ns_bb
delta_m =
boundingBoxDelta bb ms_bb
in
if delta_n < delta_m then
split toBoundingBox (BoundingBox2d.hull ns_bb bb) (first :: ns) ms_bb ms rest
else
split toBoundingBox ns_bb ns (BoundingBox2d.hull ms_bb bb) (first :: ms) rest
quadraticSplit :
List ( BoundingBox2d, a )
-> ( { boundingBox : BoundingBox2d, values : List ( BoundingBox2d, a ) }, { boundingBox : BoundingBox2d, values : List ( BoundingBox2d, a ) } )
quadraticSplit values =
case pickSeedsBy Tuple.first values of
Nothing ->
Debug.crash "Can't split empty list"
Just ( ( bb1, _ ) as s1, ( bb2, _ ) as s2 ) ->
let
rest =
List.filter (\n -> n /= s1 && n /= s2) values
in
split Tuple.first bb1 [ s1 ] bb2 [ s2 ] rest
{-| the name is a lie! just splitting evenly yields much better results for our input
-}
quadraticSplitNode :
List (NonEmptyRTree a)
-> ( { boundingBox : BoundingBox2d, values : List (NonEmptyRTree a) }, { boundingBox : BoundingBox2d, values : List (NonEmptyRTree a) } )
quadraticSplitNode values =
case pickSeedsBy getBoundingBox values of
Nothing ->
Debug.crash "Can't split empty list"
-- Just ( ( bb1, _ ) as s1, ( bb2, _ ) as s2 ) ->
Just ( option1, option2 ) ->
let
rest =
List.filter (\n -> n /= option1 && n /= option2) values
in
split getBoundingBox (getBoundingBox option1) [ option1 ] (getBoundingBox option2) [ option2 ] rest
cheapSplit :
List ( BoundingBox2d, a )
-> ( { boundingBox : BoundingBox2d, values : List ( BoundingBox2d, a ) }, { boundingBox : BoundingBox2d, values : List ( BoundingBox2d, a ) } )
cheapSplit values =
let
n =
List.length values // 2
xs =
List.take n values
ys =
List.drop n values
in
case ( List.map Tuple.first xs |> BoundingBox2d.aggregate, List.map Tuple.first ys |> BoundingBox2d.aggregate ) of
( Just bb1, Just bb2 ) ->
( { boundingBox = bb1, values = xs }
, { boundingBox = bb2, values = ys }
)
_ ->
Debug.crash "not enough items"
splitLinear :
(a -> BoundingBox2d)
-> BoundingBox2d
-> List a
-> BoundingBox2d
-> List a
-> List a
-> ( { boundingBox : BoundingBox2d, values : List a }, { boundingBox : BoundingBox2d, values : List a } )
splitLinear toBoundingBox ns_bb ns ms_bb ms nodes =
case nodes of
[] ->
( { boundingBox = ns_bb, values = ns }
, { boundingBox = ms_bb, values = ms }
)
[ x ] ->
case ( ns, ms ) of
( [ _ ], _ ) ->
( { boundingBox = BoundingBox2d.hull (toBoundingBox x) ns_bb, values = x :: ns }
, { boundingBox = ms_bb, values = ms }
)
( _, [ _ ] ) ->
( { boundingBox = ns_bb, values = ns }
, { boundingBox = BoundingBox2d.hull (toBoundingBox x) ms_bb, values = x :: ms }
)
_ ->
let
rest =
[]
first =
x
bb =
toBoundingBox first
delta_n =
boundingBoxDelta bb ns_bb
delta_m =
boundingBoxDelta bb ms_bb
in
if delta_n < delta_m then
splitLinear toBoundingBox (BoundingBox2d.hull ns_bb bb) (first :: ns) ms_bb ms rest
else
splitLinear toBoundingBox ns_bb ns (BoundingBox2d.hull ms_bb bb) (first :: ms) rest
first :: rest ->
let
bb =
toBoundingBox first
delta_n =
boundingBoxDelta bb ns_bb
delta_m =
boundingBoxDelta bb ms_bb
in
if delta_n < delta_m then
splitLinear toBoundingBox (BoundingBox2d.hull ns_bb bb) (first :: ns) ms_bb ms rest
else
splitLinear toBoundingBox ns_bb ns (BoundingBox2d.hull ms_bb bb) (first :: ms) rest
linearSplit :
List ( BoundingBox2d, a )
-> ( { boundingBox : BoundingBox2d, values : List ( BoundingBox2d, a ) }, { boundingBox : BoundingBox2d, values : List ( BoundingBox2d, a ) } )
linearSplit values =
case values of
[] ->
Debug.crash "Can't split empty list"
[ _ ] ->
Debug.crash "Can't split one-element list"
x :: y :: xs ->
let
distanceX =
BoundingBox2d.minX (Tuple.first extremes.highestX) - BoundingBox2d.maxX (Tuple.first extremes.lowestX)
distanceY =
BoundingBox2d.minY (Tuple.first extremes.highestY) - BoundingBox2d.maxY (Tuple.first extremes.lowestY)
extremes =
f Tuple.first
xs
{ boundingBox = Tuple.first x
, highestX = x
, highestY = x
, lowestX = x
, lowestY = x
, others = []
}
seeds =
if max distanceX distanceY <= 0 then
Just ( x, y )
else if distanceX > distanceY then
Just ( extremes.lowestX, extremes.highestX )
else
Just ( extremes.lowestY, extremes.highestY )
in
-- case pickSeedsBy Tuple.first values of
case seeds of
Nothing ->
Debug.crash "Can't split empty list"
Just ( option1, option2 ) ->
let
rest =
List.filter (\n -> n /= option1 && n /= option2) values
in
splitLinear Tuple.first (Tuple.first option1) [ option1 ] (Tuple.first option2) [ option2 ] rest
linearSplitNode :
List (NonEmptyRTree a)
-> ( { boundingBox : BoundingBox2d, values : List (NonEmptyRTree a) }, { boundingBox : BoundingBox2d, values : List (NonEmptyRTree a) } )
linearSplitNode values =
case values of
[] ->
Debug.crash "Can't split empty list"
[ _ ] ->
Debug.crash "Can't split one-element list"
x :: y :: xs ->
let
distanceX =
BoundingBox2d.minX (getBoundingBox extremes.highestX) - BoundingBox2d.maxX (getBoundingBox extremes.lowestX)
distanceY =
BoundingBox2d.minY (getBoundingBox extremes.highestY) - BoundingBox2d.maxY (getBoundingBox extremes.lowestY)
extremes =
f getBoundingBox
xs
{ boundingBox = getBoundingBox x
, highestX = x
, highestY = x
, lowestX = x
, lowestY = x
, others = []
}
seeds =
if max distanceX distanceY <= 0 then
Just ( x, y )
else if distanceX > distanceY then
Just ( extremes.lowestX, extremes.highestX )
else
Just ( extremes.lowestY, extremes.highestY )
in
-- case pickSeedsBy getBoundingBox values of
case seeds of
Nothing ->
Debug.crash "Can't split empty list"
Just ( option1, option2 ) ->
let
rest =
List.filter (\n -> n /= option1 && n /= option2) values
in
splitLinear getBoundingBox (getBoundingBox option1) [ option1 ] (getBoundingBox option2) [ option2 ] rest
f :
(a -> BoundingBox2d)
-> List a
-> { boundingBox : BoundingBox2d, highestX : a, lowestX : a, highestY : a, lowestY : a, others : List a }
-> { boundingBox : BoundingBox2d, highestX : a, lowestX : a, highestY : a, lowestY : a, others : List a }
f toBoundingBox values accum =
case values of
[] ->
accum
first :: rest ->
let
firstBoundingBox =
toBoundingBox first
in
if BoundingBox2d.isContainedIn accum.boundingBox firstBoundingBox then
f toBoundingBox rest { accum | others = first :: accum.others }
else
let
{ minX, maxX, minY, maxY } =
BoundingBox2d.extrema accum.boundingBox
updateLowX state =
if BoundingBox2d.minX firstBoundingBox < minX then
{ state | lowestX = first, others = state.lowestX :: state.others }
else
state
updateHighX state =
if BoundingBox2d.maxX firstBoundingBox > maxX then
{ state | highestX = first, others = state.highestX :: state.others }
else
state
updateLowY state =
if BoundingBox2d.minY firstBoundingBox < minY then
{ state | lowestY = first, others = state.lowestY :: state.others }
else
state
updateHighY state =
if BoundingBox2d.maxY firstBoundingBox > maxY then
{ state | highestY = first, others = state.highestY :: state.others }
else
state
newAccum =
accum
|> updateLowX
|> updateHighX
|> updateLowY
|> updateHighY
in
f toBoundingBox rest newAccum
{-| Remove a particular bounding box from the tree
-}
remove : BoundingBox2d -> RTree a -> RTree a
remove target rtree =
case rtree of
Empty ->
rtree
NonEmpty subtree ->
if BoundingBox2d.isContainedIn (getBoundingBox subtree) target then
case removeNonEmpty target subtree of
NowEmpty ->
Empty
Modified nonEmpty ->
NonEmpty nonEmpty
NotModified ->
NonEmpty subtree
Removed ( bbox, value ) ->
singleton bbox value
else
NonEmpty subtree
{-| Filter a list of values to remove a particular bounding box
In theory this could stop whenever a match is found, but in practice this gives wrong/weird results for delaunay triangulation
-}
removeValues : BoundingBox2d -> List ( BoundingBox2d, a ) -> List ( BoundingBox2d, a ) -> Bool -> ( Bool, List ( BoundingBox2d, a ) )
removeValues target values accum dirty =
case values of
[] ->
( dirty, accum )
(( firstBoundingBox, _ ) as first) :: rest ->
if firstBoundingBox == target then
removeValues target rest accum True
else
removeValues target rest (first :: accum) dirty
{-| Once remaining bounding boxes cover the area of the removed bounding box, we can use the original bounding box of the parent
-}
untilCovering : { target : BoundingBox2d, whenLargeEnough : BoundingBox2d, toBoundingBox : a -> BoundingBox2d, seed : BoundingBox2d } -> List a -> BoundingBox2d
untilCovering { target, whenLargeEnough, toBoundingBox, seed } =
let
go accum items =
case items of
[] ->
accum
first :: rest ->
if BoundingBox2d.isContainedIn accum target then
whenLargeEnough
else
go (BoundingBox2d.hull (toBoundingBox first) accum) rest
in
go seed
type Modified a
= NotModified
| NowEmpty
| Modified (NonEmptyRTree a)
| Removed ( BoundingBox2d, a )
{-| Remove a bounding box from a non-empty tree
-}
removeNonEmpty : BoundingBox2d -> NonEmptyRTree a -> Modified a
removeNonEmpty target rtree =
case rtree of
Leaf leaf ->
let
-- track whether a value was actually removed
( dirty, newValues ) =
removeValues target leaf.values [] False
in
if dirty then
case newValues of
[] ->
NowEmpty
[ x ] ->
-- leaf contains only one item, that's too small
-- reinsert that item somewhere else in the tree
Removed x
x :: xs ->
let
newBoundingBox =
untilCovering
{ target = target, whenLargeEnough = leaf.boundingBox, toBoundingBox = Tuple.first, seed = Tuple.first x }
xs
in
Modified (Leaf { boundingBox = newBoundingBox, values = newValues })
else
NotModified
Node2 node ->
let
modifiedChild1 =
if BoundingBox2d.isContainedIn (getBoundingBox node.child1) target then
removeNonEmpty target node.child1
else
NotModified
in
case modifiedChild1 of
NotModified ->
let
modifiedChild2 =
if BoundingBox2d.isContainedIn (getBoundingBox node.child2) target then
removeNonEmpty target node.child2
else
NotModified
in
case modifiedChild2 of
NotModified ->
NotModified
NowEmpty ->
Modified (node.child1)
Modified newChild2 ->
let
newBoundingBox =
BoundingBox2d.hull (getBoundingBox node.child1) (getBoundingBox newChild2)
in
Modified (Node2 { boundingBox = newBoundingBox, child1 = node.child1, child2 = newChild2 })
Removed ( bbox, value ) ->
Modified (insertNonEmpty bbox value node.child1)
NowEmpty ->
Modified (node.child2)
Modified newChild1 ->
let
newBoundingBox =
BoundingBox2d.hull (getBoundingBox newChild1) (getBoundingBox node.child2)
in
Modified (Node2 { boundingBox = newBoundingBox, child1 = newChild1, child2 = node.child2 })
Removed ( bbox, value ) ->
Modified (insertNonEmpty bbox value node.child2)
Node node ->
case node.children of
( first, [] ) ->
removeNonEmpty target first
( first, rest ) ->
let
baseCase accum changedBoundingBox removed =
case accum of
[] ->
NowEmpty
[ x ] ->
Modified x
[ x, y ] ->
Modified
(Node2
{ boundingBox = BoundingBox2d.hull (getBoundingBox x) (getBoundingBox y)
, child1 = x
, child2 = y
}
)
x :: xs ->
let
newBoundingBox =
if changedBoundingBox then
untilCovering
{ target = target, whenLargeEnough = node.boundingBox, toBoundingBox = getBoundingBox, seed = getBoundingBox x }
xs
else
node.boundingBox
newNode =
Node { boundingBox = newBoundingBox, children = ( x, xs ) }
in
Modified (List.foldl (uncurry insertNonEmpty) newNode removed)
go children accum =
case children of
[] ->
NotModified
firstChild :: remainingChildren ->
if BoundingBox2d.isContainedIn (getBoundingBox firstChild) target then
case removeNonEmpty target firstChild of
NotModified ->
go remainingChildren (firstChild :: accum)
NowEmpty ->
baseCase (remainingChildren ++ accum) True []
Modified nonEmpty ->
if getBoundingBox nonEmpty == getBoundingBox firstChild then
baseCase (nonEmpty :: remainingChildren ++ accum) False []
else
baseCase (nonEmpty :: remainingChildren ++ accum) True []
Removed ( bbox, value ) ->
baseCase (remainingChildren ++ accum) True [ ( bbox, value ) ]
else
go remainingChildren (firstChild :: accum)
in
go (first :: rest) []
containing : Point2d -> RTree a -> List ( BoundingBox2d, a )
containing point rtree =
case rtree of
Empty ->
[]
NonEmpty nonEmpty ->
containingNonEmptyHelper point [ nonEmpty ] []
containingNonEmptyHelper : Point2d -> List (NonEmptyRTree a) -> List ( BoundingBox2d, a ) -> List ( BoundingBox2d, a )
containingNonEmptyHelper target unfilteredToVisit =
let
filterChildrenFolder child accum =
if BoundingBox2d.contains target (getBoundingBox child) then
child :: accum
else
accum
go toVisit accumulator =
case toVisit of
[] ->
accumulator
(Node node) :: remainingTrees ->
let
( first, rest ) =
node.children
in
go (List.foldl filterChildrenFolder remainingTrees (first :: rest)) accumulator
(Node2 node) :: remainingTrees ->
let
step1 =
if BoundingBox2d.contains target (getBoundingBox node.child1) then
node.child1 :: remainingTrees
else
remainingTrees
step2 =
if BoundingBox2d.contains target (getBoundingBox node.child2) then
node.child2 :: step1
else
step1
in
go step2 accumulator
(Leaf leaf) :: remainingTrees ->
let
filterValuesFolder (( boundingBox, _ ) as child) accum =
if BoundingBox2d.contains target boundingBox then
child :: accum
else
accum
in
List.foldl filterValuesFolder accumulator leaf.values
|> go remainingTrees
in
go (List.foldl filterChildrenFolder [] unfilteredToVisit)
concatMap : (a -> List b) -> List a -> List b
concatMap toBs =
List.foldl (\a accum -> toBs a ++ accum) []
search : BoundingBox2d -> RTree a -> List ( BoundingBox2d, a )
search target rtree =
case rtree of
Empty ->
[]
NonEmpty nonEmpty ->
searchNonEmpty target nonEmpty
searchNonEmpty : BoundingBox2d -> NonEmptyRTree a -> List ( BoundingBox2d, a )
searchNonEmpty target rtree =
case rtree of
Node node ->
let
( first, rest ) =
node.children
folder child accum =
if BoundingBox2d.intersects target (getBoundingBox child) then
List.foldl (::) accum (searchNonEmpty target child)
else
accum
in
List.foldl folder [] (first :: rest)
Node2 node ->
let
step1 =
if BoundingBox2d.intersects target (getBoundingBox node.child1) then
searchNonEmpty target node.child1
else
[]
step2 =
if BoundingBox2d.intersects target (getBoundingBox node.child1) then
List.foldl (::) step1 (searchNonEmpty target node.child1)
else
step1
in
step2
Leaf leaf ->
List.filter (\( valueBoundingBox, _ ) -> BoundingBox2d.intersects target valueBoundingBox) leaf.values
fromList : List ( BoundingBox2d, a ) -> RTree a
fromList items =
List.foldl (\( boundingBox, value ) -> insert boundingBox value) empty items
toList : RTree a -> List ( BoundingBox2d, a )
toList rtree =
case rtree of
Empty ->
[]
NonEmpty nonEmpty ->
toListNonEmpty nonEmpty
toListNonEmpty : NonEmptyRTree a -> List ( BoundingBox2d, a )
toListNonEmpty rtree =
case rtree of
Leaf leaf ->
leaf.values
Node2 node ->
toListNonEmpty node.child1 ++ toListNonEmpty node.child2
Node node ->
let
( first, rest ) =
node.children
in
concatMap toListNonEmpty (first :: rest)
boundingBoxArea : BoundingBox2d -> Float
boundingBoxArea boundingBox =
let
( width, height ) =
BoundingBox2d.dimensions boundingBox
in
width * height
boundingBoxDelta : BoundingBox2d -> BoundingBox2d -> Float
boundingBoxDelta bb bb_ =
boundingBoxArea (BoundingBox2d.hull bb bb_) - boundingBoxArea bb
boundingBoxDistance bb bb_ =
(boundingBoxArea (BoundingBox2d.hull bb bb_)) - (boundingBoxArea bb) - (boundingBoxArea bb_)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment