{-# 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.SEltMethods
import           Potato.Flow.SElts
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BPTree] -> ShowS
$cshowList :: [BPTree] -> ShowS
show :: BPTree -> String
$cshow :: BPTree -> String
showsPrec :: Int -> BPTree -> ShowS
$cshowsPrec :: Int -> BPTree -> ShowS
Show, BPTree -> BPTree -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BPTree -> BPTree -> Bool
$c/= :: BPTree -> BPTree -> Bool
== :: BPTree -> BPTree -> Bool
$c== :: BPTree -> BPTree -> Bool
Eq)

emptyBPTree :: BPTree
emptyBPTree :: BPTree
emptyBPTree = REltIdMap AABB -> BPTree
BPTree 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_canvas :: OwlPFState -> SCanvas
_owlPFState_owlTree :: OwlPFState -> OwlTree
_owlPFState_canvas :: SCanvas
_owlPFState_owlTree :: OwlTree
..} = BPTree
r where
  potato_tree :: REltIdMap AABB
potato_tree = forall a b. (a -> Maybe b) -> IntMap a -> IntMap b
IM.mapMaybe (\(OwlItemMeta
_,OwlItem
oelt) -> SElt -> Maybe AABB
getSEltBox_naive forall b c a. (b -> c) -> (a -> b) -> a -> c
. OwlItem -> SElt
owlItem_toSElt_hack forall a b. (a -> b) -> a -> b
$ OwlItem
oelt) (OwlTree -> OwlMapping
_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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BroadPhaseState] -> ShowS
$cshowList :: [BroadPhaseState] -> ShowS
show :: BroadPhaseState -> String
$cshow :: BroadPhaseState -> String
showsPrec :: Int -> BroadPhaseState -> ShowS
$cshowsPrec :: Int -> BroadPhaseState -> ShowS
Show, BroadPhaseState -> BroadPhaseState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BroadPhaseState -> BroadPhaseState -> Bool
$c/= :: BroadPhaseState -> BroadPhaseState -> Bool
== :: BroadPhaseState -> BroadPhaseState -> Bool
$c== :: 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 :: REltIdMap AABB
_bPTree_potato_tree :: BPTree -> 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) = forall a.
(Int -> a -> Maybe a) -> Int -> IntMap a -> (Maybe a, IntMap a)
IM.updateLookupWithKey (\Int
_ a
_ -> forall a. Maybe a
Nothing) Int
rid IntMap a
im
    newaabbs :: [a]
newaabbs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a]
aabbs (\a
oldaabb -> a
oldaabbforall 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) = 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
lboxforall a. a -> [a] -> [a]
:NeedsUpdateSet
aabbs
    newaabbs :: NeedsUpdateSet
newaabbs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe NeedsUpdateSet
newaabbs' (\AABB
oldaabb -> AABB
oldaabbforall a. a -> [a] -> [a]
:NeedsUpdateSet
newaabbs') Maybe AABB
moldaabb

  ([(Int, AABB)]
insmods, [Int]
deletes) = 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
ridforall 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
ridforall 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 forall a b. (a -> b) -> a -> b
$ SuperOwl -> OwlItem
_superOwl_elt SuperOwl
sowl)) a
ot)forall a. a -> [a] -> [a]
:[(Int, AABB)]
insmods', [Int]
deletes'))


    ([],[])
    (forall a. IntMap a -> [(Int, a)]
IM.toList SuperOwlChanges
changes)
  (NeedsUpdateSet
aabbs', REltIdMap AABB
nbpt) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (NeedsUpdateSet, REltIdMap AABB)
-> (Int, AABB) -> (NeedsUpdateSet, REltIdMap AABB)
insmodfn (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 :: REltIdMap AABB
_bPTree_potato_tree :: BPTree -> 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
ridforall a. a -> [a] -> [a]
:[Int]
cols else [Int]
cols
  r :: [Int]
r = 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 :: REltIdMap AABB
_bPTree_potato_tree :: BPTree -> 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
ridforall a. a -> [a] -> [a]
:[Int]
cols else [Int]
cols
  r :: [Int]
r = forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey Int -> AABB -> [Int] -> [Int]
foldfn [] REltIdMap AABB
_bPTree_potato_tree