{-# LANGUAGE RecordWildCards #-}

module Potato.Flow.BroadPhase (
  AABB
  , NeedsUpdateSet
  , BPTree(..)
  , bPTreeFromOwlPFState
  , emptyBPTree
  , broadPhase_cull
  , broadPhase_cull_includeZero

  , BroadPhaseState(..)
  , emptyBroadPhaseState

  -- exposed for testing
  , 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]

-- TODO actual BroadPhase...
data BPTree = BPTree {
  -- TODO you want something sortable too...
  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

-- TODO
--bPTreeFromPFState :: PFState -> BPTree
--bPTreeFromPFState PFState {..} = r where
--  potato_tree = IM.mapMaybe (getSEltBox_naive . _sEltLabel_sElt) _pFState_directory
--  r = BPTree potato_tree

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




-- | updates a BPTree and returns list of AABBs that were affected
-- exposed for testing only, do not call this directly
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
  -- deletions
  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

  -- modify/insert
  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')

      -- TODO don't use getSEltBox_naive like this come on -__-
      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')
        
        -- TODO this needs to use expanded wide char box
        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))

-- TODO prob don't need this, DELETE
--update_bPTree' ::  (REltId, Maybe SEltLabel) -> BPTree -> BPTree
--update_bPTree' (rid, ms) BPTree {..} = BPTree $ IM.alter (const (ms >>= getSEltBox_naive . _sEltLabel_sElt)) rid _bPTree_potato_tree

-- | returns list of REltIds that intersect with given AABB
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

-- | same as above but also returns zero area elements for selecting
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