{-# LANGUAGE RecordWildCards #-}
module Potato.Flow.BroadPhase (
AABB
, NeedsUpdateSet
, BPTree(..)
, bPTreeFromOwlPFState
, emptyBPTree
, broadPhase_cull
, broadPhase_cull_includeZero
, BroadPhaseState(..)
, emptyBroadPhaseState
, update_bPTree
) where
import Relude
import Potato.Flow.Math
import Potato.Flow.Methods.Types
import Potato.Flow.Owl
import Potato.Flow.OwlItem
import Potato.Flow.OwlState
import Potato.Flow.Methods.SEltMethods
import Potato.Flow.Serialization.Snake
import Potato.Flow.Types
import qualified Data.IntMap.Strict as IM
type AABB = LBox
type NeedsUpdateSet = [AABB]
data BPTree = BPTree {
BPTree -> REltIdMap AABB
_bPTree_potato_tree :: REltIdMap AABB
} deriving (Int -> BPTree -> ShowS
[BPTree] -> ShowS
BPTree -> String
(Int -> BPTree -> ShowS)
-> (BPTree -> String) -> ([BPTree] -> ShowS) -> Show BPTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BPTree -> ShowS
showsPrec :: Int -> BPTree -> ShowS
$cshow :: BPTree -> String
show :: BPTree -> String
$cshowList :: [BPTree] -> ShowS
showList :: [BPTree] -> ShowS
Show, BPTree -> BPTree -> Bool
(BPTree -> BPTree -> Bool)
-> (BPTree -> BPTree -> Bool) -> Eq BPTree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BPTree -> BPTree -> Bool
== :: BPTree -> BPTree -> Bool
$c/= :: BPTree -> BPTree -> Bool
/= :: BPTree -> BPTree -> Bool
Eq)
emptyBPTree :: BPTree
emptyBPTree :: BPTree
emptyBPTree = REltIdMap AABB -> BPTree
BPTree REltIdMap AABB
forall a. IntMap a
IM.empty
bPTreeFromOwlPFState :: OwlPFState -> BPTree
bPTreeFromOwlPFState :: OwlPFState -> BPTree
bPTreeFromOwlPFState OwlPFState {SCanvas
OwlTree
_owlPFState_owlTree :: OwlTree
_owlPFState_canvas :: SCanvas
_owlPFState_owlTree :: OwlPFState -> OwlTree
_owlPFState_canvas :: OwlPFState -> SCanvas
..} = BPTree
r where
potato_tree :: REltIdMap AABB
potato_tree = ((OwlItemMeta, OwlItem) -> Maybe AABB)
-> IntMap (OwlItemMeta, OwlItem) -> REltIdMap AABB
forall a b. (a -> Maybe b) -> IntMap a -> IntMap b
IM.mapMaybe (\(OwlItemMeta
_,OwlItem
oelt) -> SElt -> Maybe AABB
getSEltBox_naive (SElt -> Maybe AABB) -> (OwlItem -> SElt) -> OwlItem -> Maybe AABB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OwlItem -> SElt
owlItem_toSElt_hack (OwlItem -> Maybe AABB) -> OwlItem -> Maybe AABB
forall a b. (a -> b) -> a -> b
$ OwlItem
oelt) (OwlTree -> IntMap (OwlItemMeta, OwlItem)
_owlTree_mapping OwlTree
_owlPFState_owlTree)
r :: BPTree
r = REltIdMap AABB -> BPTree
BPTree REltIdMap AABB
potato_tree
data BroadPhaseState = BroadPhaseState {
BroadPhaseState -> BPTree
_broadPhaseState_bPTree :: BPTree
} deriving (Int -> BroadPhaseState -> ShowS
[BroadPhaseState] -> ShowS
BroadPhaseState -> String
(Int -> BroadPhaseState -> ShowS)
-> (BroadPhaseState -> String)
-> ([BroadPhaseState] -> ShowS)
-> Show BroadPhaseState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BroadPhaseState -> ShowS
showsPrec :: Int -> BroadPhaseState -> ShowS
$cshow :: BroadPhaseState -> String
show :: BroadPhaseState -> String
$cshowList :: [BroadPhaseState] -> ShowS
showList :: [BroadPhaseState] -> ShowS
Show, BroadPhaseState -> BroadPhaseState -> Bool
(BroadPhaseState -> BroadPhaseState -> Bool)
-> (BroadPhaseState -> BroadPhaseState -> Bool)
-> Eq BroadPhaseState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BroadPhaseState -> BroadPhaseState -> Bool
== :: BroadPhaseState -> BroadPhaseState -> Bool
$c/= :: BroadPhaseState -> BroadPhaseState -> Bool
/= :: BroadPhaseState -> BroadPhaseState -> Bool
Eq)
emptyBroadPhaseState :: BroadPhaseState
emptyBroadPhaseState :: BroadPhaseState
emptyBroadPhaseState = BPTree -> BroadPhaseState
BroadPhaseState BPTree
emptyBPTree
update_bPTree :: (HasOwlTree a) => a -> SuperOwlChanges -> BPTree -> (NeedsUpdateSet, BroadPhaseState)
update_bPTree :: forall a.
HasOwlTree a =>
a -> SuperOwlChanges -> BPTree -> (NeedsUpdateSet, BroadPhaseState)
update_bPTree a
ot SuperOwlChanges
changes BPTree {REltIdMap AABB
_bPTree_potato_tree :: BPTree -> REltIdMap AABB
_bPTree_potato_tree :: REltIdMap AABB
..} = (NeedsUpdateSet, BroadPhaseState)
r where
deletefn :: ([a], IntMap a) -> Int -> ([a], IntMap a)
deletefn ([a]
aabbs, IntMap a
im) Int
rid = ([a]
newaabbs, IntMap a
newim) where
(Maybe a
moldaabb, IntMap a
newim) = (Int -> a -> Maybe a) -> Int -> IntMap a -> (Maybe a, IntMap a)
forall a.
(Int -> a -> Maybe a) -> Int -> IntMap a -> (Maybe a, IntMap a)
IM.updateLookupWithKey (\Int
_ a
_ -> Maybe a
forall a. Maybe a
Nothing) Int
rid IntMap a
im
newaabbs :: [a]
newaabbs = [a] -> (a -> [a]) -> Maybe a -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a]
aabbs (\a
oldaabb -> a
oldaabba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
aabbs) Maybe a
moldaabb
insmodfn :: (NeedsUpdateSet, REltIdMap AABB)
-> (Int, AABB) -> (NeedsUpdateSet, REltIdMap AABB)
insmodfn (NeedsUpdateSet
aabbs, REltIdMap AABB
im) (Int
rid, AABB
lbox) = (NeedsUpdateSet
newaabbs, REltIdMap AABB
newim) where
(Maybe AABB
moldaabb :: Maybe AABB, REltIdMap AABB
newim) = (Int -> AABB -> AABB -> AABB)
-> Int -> AABB -> REltIdMap AABB -> (Maybe AABB, REltIdMap AABB)
forall a.
(Int -> a -> a -> a) -> Int -> a -> IntMap a -> (Maybe a, IntMap a)
IM.insertLookupWithKey (\Int
_ AABB
a AABB
_ -> AABB
a) Int
rid AABB
lbox REltIdMap AABB
im
newaabbs' :: NeedsUpdateSet
newaabbs' = AABB
lboxAABB -> NeedsUpdateSet -> NeedsUpdateSet
forall a. a -> [a] -> [a]
:NeedsUpdateSet
aabbs
newaabbs :: NeedsUpdateSet
newaabbs = NeedsUpdateSet
-> (AABB -> NeedsUpdateSet) -> Maybe AABB -> NeedsUpdateSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NeedsUpdateSet
newaabbs' (\AABB
oldaabb -> AABB
oldaabbAABB -> NeedsUpdateSet -> NeedsUpdateSet
forall a. a -> [a] -> [a]
:NeedsUpdateSet
newaabbs') Maybe AABB
moldaabb
([(Int, AABB)]
insmods, [Int]
deletes) = (([(Int, AABB)], [Int])
-> (Int, Maybe SuperOwl) -> ([(Int, AABB)], [Int]))
-> ([(Int, AABB)], [Int])
-> [(Int, Maybe SuperOwl)]
-> ([(Int, AABB)], [Int])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
(\([(Int, AABB)]
insmods',[Int]
deletes') (Int
rid, Maybe SuperOwl
msowl) -> case Maybe SuperOwl
msowl of
Maybe SuperOwl
Nothing -> ([(Int, AABB)]
insmods', Int
ridInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
deletes')
Just SuperOwl
sowl -> case SElt -> Maybe AABB
getSEltBox_naive (SuperOwl -> SElt
superOwl_toSElt_hack SuperOwl
sowl) of
Maybe AABB
Nothing -> ([(Int, AABB)]
insmods', Int
ridInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
deletes')
Just AABB
_ -> ((Int
rid, SEltDrawer -> SEltDrawerBoxFn
_sEltDrawer_box (OwlSubItem -> SEltDrawer
getDrawer (OwlItem -> OwlSubItem
_owlItem_subItem (OwlItem -> OwlSubItem) -> OwlItem -> OwlSubItem
forall a b. (a -> b) -> a -> b
$ SuperOwl -> OwlItem
_superOwl_elt SuperOwl
sowl)) a
ot)(Int, AABB) -> [(Int, AABB)] -> [(Int, AABB)]
forall a. a -> [a] -> [a]
:[(Int, AABB)]
insmods', [Int]
deletes'))
([],[])
(SuperOwlChanges -> [(Int, Maybe SuperOwl)]
forall a. IntMap a -> [(Int, a)]
IM.toList SuperOwlChanges
changes)
(NeedsUpdateSet
aabbs', REltIdMap AABB
nbpt) = ((NeedsUpdateSet, REltIdMap AABB)
-> (Int, AABB) -> (NeedsUpdateSet, REltIdMap AABB))
-> (NeedsUpdateSet, REltIdMap AABB)
-> [(Int, AABB)]
-> (NeedsUpdateSet, REltIdMap AABB)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (NeedsUpdateSet, REltIdMap AABB)
-> (Int, AABB) -> (NeedsUpdateSet, REltIdMap AABB)
insmodfn (((NeedsUpdateSet, REltIdMap AABB)
-> Int -> (NeedsUpdateSet, REltIdMap AABB))
-> (NeedsUpdateSet, REltIdMap AABB)
-> [Int]
-> (NeedsUpdateSet, REltIdMap AABB)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (NeedsUpdateSet, REltIdMap AABB)
-> Int -> (NeedsUpdateSet, REltIdMap AABB)
forall {a}. ([a], IntMap a) -> Int -> ([a], IntMap a)
deletefn ([], REltIdMap AABB
_bPTree_potato_tree) [Int]
deletes) [(Int, AABB)]
insmods
r :: (NeedsUpdateSet, BroadPhaseState)
r = (NeedsUpdateSet
aabbs', BPTree -> BroadPhaseState
BroadPhaseState (REltIdMap AABB -> BPTree
BPTree REltIdMap AABB
nbpt))
broadPhase_cull :: AABB -> BPTree -> [REltId]
broadPhase_cull :: AABB -> BPTree -> [Int]
broadPhase_cull AABB
box BPTree {REltIdMap AABB
_bPTree_potato_tree :: BPTree -> REltIdMap AABB
_bPTree_potato_tree :: REltIdMap AABB
..} = [Int]
r where
foldfn :: Int -> AABB -> [Int] -> [Int]
foldfn Int
rid AABB
aabb [Int]
cols = if AABB -> AABB -> Bool
does_lBox_intersect AABB
box AABB
aabb then Int
ridInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
cols else [Int]
cols
r :: [Int]
r = (Int -> AABB -> [Int] -> [Int]) -> [Int] -> REltIdMap AABB -> [Int]
forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey Int -> AABB -> [Int] -> [Int]
foldfn [] REltIdMap AABB
_bPTree_potato_tree
broadPhase_cull_includeZero :: AABB -> BPTree -> [REltId]
broadPhase_cull_includeZero :: AABB -> BPTree -> [Int]
broadPhase_cull_includeZero AABB
box BPTree {REltIdMap AABB
_bPTree_potato_tree :: BPTree -> REltIdMap AABB
_bPTree_potato_tree :: REltIdMap AABB
..} = [Int]
r where
foldfn :: Int -> AABB -> [Int] -> [Int]
foldfn Int
rid AABB
aabb [Int]
cols = if AABB -> AABB -> Bool
does_lBox_intersect_include_zero_area AABB
box AABB
aabb then Int
ridInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
cols else [Int]
cols
r :: [Int]
r = (Int -> AABB -> [Int] -> [Int]) -> [Int] -> REltIdMap AABB -> [Int]
forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey Int -> AABB -> [Int] -> [Int]
foldfn [] REltIdMap AABB
_bPTree_potato_tree