-- |
-- Module: M.Collision.Effectful
-- Description: Effectful collision detection and resolution system
-- Copyright: (c) axionbuster, 2025
-- License: BSD-3-Clause
--
-- Provides the core collision detection and resolution system with effects.
-- Handles block-based collision detection, movement resolution, and ground contact states.
--
-- = Parts
--
-- 1. The 'GetBlock' effect
-- 2. The 'Resolve' data type and 'resolve' function (the main part)
-- 3. The 'NewlyTouchingGround' data type and 'updonground' function
--
-- = Usage
--
-- 1. Use 'getblock' to get a block's shape at integer coordinates
-- 2. Use 'resolve' to detect and resolve collision
-- 3. Use 'updonground' to update the on-ground status (from \#2)
module M.Collision.Effectful
  ( GetBlock (..),
    getblock,
    Resolve (..),
    resolve,
    _respos,
    _resdis,
    _restou,
    NewlyTouchingGround (..),
    updonground,
    islanding,
    istakingoff,
  )
where

import Control.Lens hiding (index)
import Control.Monad
import Control.Monad.Fix
import Data.Bits
import Data.Coerce
import Data.Data
import Data.Foldable
import Data.Functor.Rep
import Data.Hashable
import Data.Kind
import Data.List (nub)
import Data.Semigroup
import Data.Traversable
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Exception
import Effectful.Reader.Static
import GHC.Generics (Generic)
import Linear
import M.Collision.Internal.Face
import M.Collision.Internal.March
import M.Collision.Pure
import Prelude hiding (break)

-- | collision resolution data type
data Resolve a = Resolve
  { -- | final position
    forall a. Resolve a -> V3 a
respos :: !(V3 a),
    -- | remaining displacement
    forall a. Resolve a -> V3 a
resdis :: !(V3 a),
    -- | what to do with the on-ground status
    forall a. Resolve a -> NewlyTouchingGround
restou :: !NewlyTouchingGround
  }
  deriving (Int -> Resolve a -> ShowS
[Resolve a] -> ShowS
Resolve a -> String
(Int -> Resolve a -> ShowS)
-> (Resolve a -> String)
-> ([Resolve a] -> ShowS)
-> Show (Resolve a)
forall a. Show a => Int -> Resolve a -> ShowS
forall a. Show a => [Resolve a] -> ShowS
forall a. Show a => Resolve a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Resolve a -> ShowS
showsPrec :: Int -> Resolve a -> ShowS
$cshow :: forall a. Show a => Resolve a -> String
show :: Resolve a -> String
$cshowList :: forall a. Show a => [Resolve a] -> ShowS
showList :: [Resolve a] -> ShowS
Show, Resolve a -> Resolve a -> Bool
(Resolve a -> Resolve a -> Bool)
-> (Resolve a -> Resolve a -> Bool) -> Eq (Resolve a)
forall a. Eq a => Resolve a -> Resolve a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Resolve a -> Resolve a -> Bool
== :: Resolve a -> Resolve a -> Bool
$c/= :: forall a. Eq a => Resolve a -> Resolve a -> Bool
/= :: Resolve a -> Resolve a -> Bool
Eq, (forall x. Resolve a -> Rep (Resolve a) x)
-> (forall x. Rep (Resolve a) x -> Resolve a)
-> Generic (Resolve a)
forall x. Rep (Resolve a) x -> Resolve a
forall x. Resolve a -> Rep (Resolve a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Resolve a) x -> Resolve a
forall a x. Resolve a -> Rep (Resolve a) x
$cfrom :: forall a x. Resolve a -> Rep (Resolve a) x
from :: forall x. Resolve a -> Rep (Resolve a) x
$cto :: forall a x. Rep (Resolve a) x -> Resolve a
to :: forall x. Rep (Resolve a) x -> Resolve a
Generic, Typeable, (forall a b. (a -> b) -> Resolve a -> Resolve b)
-> (forall a b. a -> Resolve b -> Resolve a) -> Functor Resolve
forall a b. a -> Resolve b -> Resolve a
forall a b. (a -> b) -> Resolve a -> Resolve b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Resolve a -> Resolve b
fmap :: forall a b. (a -> b) -> Resolve a -> Resolve b
$c<$ :: forall a b. a -> Resolve b -> Resolve a
<$ :: forall a b. a -> Resolve b -> Resolve a
Functor, Eq (Resolve a)
Eq (Resolve a) =>
(Int -> Resolve a -> Int)
-> (Resolve a -> Int) -> Hashable (Resolve a)
Int -> Resolve a -> Int
Resolve a -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall a. Hashable a => Eq (Resolve a)
forall a. Hashable a => Int -> Resolve a -> Int
forall a. Hashable a => Resolve a -> Int
$chashWithSalt :: forall a. Hashable a => Int -> Resolve a -> Int
hashWithSalt :: Int -> Resolve a -> Int
$chash :: forall a. Hashable a => Resolve a -> Int
hash :: Resolve a -> Int
Hashable, Typeable (Resolve a)
Typeable (Resolve a) =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Resolve a -> c (Resolve a))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Resolve a))
-> (Resolve a -> Constr)
-> (Resolve a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Resolve a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (Resolve a)))
-> ((forall b. Data b => b -> b) -> Resolve a -> Resolve a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Resolve a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Resolve a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Resolve a -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Resolve a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a))
-> Data (Resolve a)
Resolve a -> Constr
Resolve a -> DataType
(forall b. Data b => b -> b) -> Resolve a -> Resolve a
forall a. Data a => Typeable (Resolve a)
forall a. Data a => Resolve a -> Constr
forall a. Data a => Resolve a -> DataType
forall a.
Data a =>
(forall b. Data b => b -> b) -> Resolve a -> Resolve a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Resolve a -> u
forall a u.
Data a =>
(forall d. Data d => d -> u) -> Resolve a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Resolve a -> r
forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Resolve a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Resolve a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Resolve a -> c (Resolve a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Resolve a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Resolve a))
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Resolve a -> u
forall u. (forall d. Data d => d -> u) -> Resolve a -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Resolve a -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Resolve a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Resolve a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Resolve a -> c (Resolve a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Resolve a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Resolve a))
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Resolve a -> c (Resolve a)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Resolve a -> c (Resolve a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Resolve a)
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Resolve a)
$ctoConstr :: forall a. Data a => Resolve a -> Constr
toConstr :: Resolve a -> Constr
$cdataTypeOf :: forall a. Data a => Resolve a -> DataType
dataTypeOf :: Resolve a -> DataType
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Resolve a))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Resolve a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Resolve a))
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Resolve a))
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> Resolve a -> Resolve a
gmapT :: (forall b. Data b => b -> b) -> Resolve a -> Resolve a
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Resolve a -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Resolve a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Resolve a -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Resolve a -> r
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> Resolve a -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> Resolve a -> [u]
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Resolve a -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Resolve a -> u
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Resolve a -> m (Resolve a)
Data)

-- | lens for 'Resolve' position
_respos :: Lens' (Resolve a) (V3 a)
_respos :: forall a (f :: * -> *).
Functor f =>
(V3 a -> f (V3 a)) -> Resolve a -> f (Resolve a)
_respos = (Resolve a -> V3 a)
-> (Resolve a -> V3 a -> Resolve a)
-> Lens (Resolve a) (Resolve a) (V3 a) (V3 a)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Resolve a -> V3 a
forall a. Resolve a -> V3 a
respos \Resolve a
x V3 a
y -> Resolve a
x {respos = y}
{-# INLINE _respos #-}

-- | lens for 'Resolve' displacement
_resdis :: Lens' (Resolve a) (V3 a)
_resdis :: forall a (f :: * -> *).
Functor f =>
(V3 a -> f (V3 a)) -> Resolve a -> f (Resolve a)
_resdis = (Resolve a -> V3 a)
-> (Resolve a -> V3 a -> Resolve a)
-> Lens (Resolve a) (Resolve a) (V3 a) (V3 a)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Resolve a -> V3 a
forall a. Resolve a -> V3 a
resdis \Resolve a
x V3 a
y -> Resolve a
x {resdis = y}
{-# INLINE _resdis #-}

-- | lens for 'Resolve' newly touching ground
_restou :: Lens' (Resolve a) NewlyTouchingGround
_restou :: forall a (f :: * -> *).
Functor f =>
(NewlyTouchingGround -> f NewlyTouchingGround)
-> Resolve a -> f (Resolve a)
_restou = (Resolve a -> NewlyTouchingGround)
-> (Resolve a -> NewlyTouchingGround -> Resolve a)
-> Lens
     (Resolve a) (Resolve a) NewlyTouchingGround NewlyTouchingGround
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Resolve a -> NewlyTouchingGround
forall a. Resolve a -> NewlyTouchingGround
restou \Resolve a
x NewlyTouchingGround
y -> Resolve a
x {restou = y}
{-# INLINE _restou #-}

-- | \'upgrade\' a boolean: find @y@ as in @y CMP x || y == x@
-- but if @CMP@ is not 'EQ', prefer @y /= x@
--
-- used to implement 'updonground'
boolupgr ::
  -- | comparison (@CMP@)
  Ordering ->
  -- | the @x@
  Bool ->
  -- | left-hand side of the @CMP@ comparison
  Bool
boolupgr :: Ordering -> Bool -> Bool
boolupgr Ordering
LT Bool
True = Bool
False
boolupgr Ordering
LT Bool
False = Bool
False
boolupgr Ordering
EQ Bool
x = Bool
x
boolupgr Ordering
GT Bool
True = Bool
True
boolupgr Ordering
GT Bool
False = Bool
True
{-# INLINE boolupgr #-}

-- | \'update\' the on-ground status
updonground :: NewlyTouchingGround -> Bool -> Bool
updonground :: NewlyTouchingGround -> Bool -> Bool
updonground = (Ordering -> Bool -> Bool) -> NewlyTouchingGround -> Bool -> Bool
forall a b. Coercible a b => a -> b
coerce Ordering -> Bool -> Bool
boolupgr
{-# INLINE updonground #-}

-- internal control-flow exception because i don't think i can use call/cc
newtype EarlyExit a = EarlyExit (Resolve a)
  deriving stock ((forall x. EarlyExit a -> Rep (EarlyExit a) x)
-> (forall x. Rep (EarlyExit a) x -> EarlyExit a)
-> Generic (EarlyExit a)
forall x. Rep (EarlyExit a) x -> EarlyExit a
forall x. EarlyExit a -> Rep (EarlyExit a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (EarlyExit a) x -> EarlyExit a
forall a x. EarlyExit a -> Rep (EarlyExit a) x
$cfrom :: forall a x. EarlyExit a -> Rep (EarlyExit a) x
from :: forall x. EarlyExit a -> Rep (EarlyExit a) x
$cto :: forall a x. Rep (EarlyExit a) x -> EarlyExit a
to :: forall x. Rep (EarlyExit a) x -> EarlyExit a
Generic, Typeable)
  deriving anyclass (Show (EarlyExit a)
Typeable (EarlyExit a)
(Typeable (EarlyExit a), Show (EarlyExit a)) =>
(EarlyExit a -> SomeException)
-> (SomeException -> Maybe (EarlyExit a))
-> (EarlyExit a -> String)
-> Exception (EarlyExit a)
SomeException -> Maybe (EarlyExit a)
EarlyExit a -> String
EarlyExit a -> SomeException
forall a. Typeable a => Show (EarlyExit a)
forall a. Typeable a => Typeable (EarlyExit a)
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
forall a. Typeable a => SomeException -> Maybe (EarlyExit a)
forall a. Typeable a => EarlyExit a -> String
forall a. Typeable a => EarlyExit a -> SomeException
$ctoException :: forall a. Typeable a => EarlyExit a -> SomeException
toException :: EarlyExit a -> SomeException
$cfromException :: forall a. Typeable a => SomeException -> Maybe (EarlyExit a)
fromException :: SomeException -> Maybe (EarlyExit a)
$cdisplayException :: forall a. Typeable a => EarlyExit a -> String
displayException :: EarlyExit a -> String
Exception)

instance Show (EarlyExit a) where
  show :: EarlyExit a -> String
show EarlyExit a
_ = String
"EarlyExit"

-- | newly touching ground?
--
-- - 'LT' means it taking off from the ground
-- - 'EQ' means it should maintain the previous state
-- - 'GT' means it landing on the ground
newtype NewlyTouchingGround = NewlyTouchingGround {NewlyTouchingGround -> Ordering
newonground :: Ordering}
  deriving newtype (Int -> NewlyTouchingGround -> ShowS
[NewlyTouchingGround] -> ShowS
NewlyTouchingGround -> String
(Int -> NewlyTouchingGround -> ShowS)
-> (NewlyTouchingGround -> String)
-> ([NewlyTouchingGround] -> ShowS)
-> Show NewlyTouchingGround
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NewlyTouchingGround -> ShowS
showsPrec :: Int -> NewlyTouchingGround -> ShowS
$cshow :: NewlyTouchingGround -> String
show :: NewlyTouchingGround -> String
$cshowList :: [NewlyTouchingGround] -> ShowS
showList :: [NewlyTouchingGround] -> ShowS
Show, NewlyTouchingGround -> NewlyTouchingGround -> Bool
(NewlyTouchingGround -> NewlyTouchingGround -> Bool)
-> (NewlyTouchingGround -> NewlyTouchingGround -> Bool)
-> Eq NewlyTouchingGround
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
== :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
$c/= :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
/= :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
Eq, Eq NewlyTouchingGround
Eq NewlyTouchingGround =>
(NewlyTouchingGround -> NewlyTouchingGround -> Ordering)
-> (NewlyTouchingGround -> NewlyTouchingGround -> Bool)
-> (NewlyTouchingGround -> NewlyTouchingGround -> Bool)
-> (NewlyTouchingGround -> NewlyTouchingGround -> Bool)
-> (NewlyTouchingGround -> NewlyTouchingGround -> Bool)
-> (NewlyTouchingGround
    -> NewlyTouchingGround -> NewlyTouchingGround)
-> (NewlyTouchingGround
    -> NewlyTouchingGround -> NewlyTouchingGround)
-> Ord NewlyTouchingGround
NewlyTouchingGround -> NewlyTouchingGround -> Bool
NewlyTouchingGround -> NewlyTouchingGround -> Ordering
NewlyTouchingGround -> NewlyTouchingGround -> NewlyTouchingGround
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NewlyTouchingGround -> NewlyTouchingGround -> Ordering
compare :: NewlyTouchingGround -> NewlyTouchingGround -> Ordering
$c< :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
< :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
$c<= :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
<= :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
$c> :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
> :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
$c>= :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
>= :: NewlyTouchingGround -> NewlyTouchingGround -> Bool
$cmax :: NewlyTouchingGround -> NewlyTouchingGround -> NewlyTouchingGround
max :: NewlyTouchingGround -> NewlyTouchingGround -> NewlyTouchingGround
$cmin :: NewlyTouchingGround -> NewlyTouchingGround -> NewlyTouchingGround
min :: NewlyTouchingGround -> NewlyTouchingGround -> NewlyTouchingGround
Ord, Int -> NewlyTouchingGround
NewlyTouchingGround -> Int
NewlyTouchingGround -> [NewlyTouchingGround]
NewlyTouchingGround -> NewlyTouchingGround
NewlyTouchingGround -> NewlyTouchingGround -> [NewlyTouchingGround]
NewlyTouchingGround
-> NewlyTouchingGround
-> NewlyTouchingGround
-> [NewlyTouchingGround]
(NewlyTouchingGround -> NewlyTouchingGround)
-> (NewlyTouchingGround -> NewlyTouchingGround)
-> (Int -> NewlyTouchingGround)
-> (NewlyTouchingGround -> Int)
-> (NewlyTouchingGround -> [NewlyTouchingGround])
-> (NewlyTouchingGround
    -> NewlyTouchingGround -> [NewlyTouchingGround])
-> (NewlyTouchingGround
    -> NewlyTouchingGround -> [NewlyTouchingGround])
-> (NewlyTouchingGround
    -> NewlyTouchingGround
    -> NewlyTouchingGround
    -> [NewlyTouchingGround])
-> Enum NewlyTouchingGround
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: NewlyTouchingGround -> NewlyTouchingGround
succ :: NewlyTouchingGround -> NewlyTouchingGround
$cpred :: NewlyTouchingGround -> NewlyTouchingGround
pred :: NewlyTouchingGround -> NewlyTouchingGround
$ctoEnum :: Int -> NewlyTouchingGround
toEnum :: Int -> NewlyTouchingGround
$cfromEnum :: NewlyTouchingGround -> Int
fromEnum :: NewlyTouchingGround -> Int
$cenumFrom :: NewlyTouchingGround -> [NewlyTouchingGround]
enumFrom :: NewlyTouchingGround -> [NewlyTouchingGround]
$cenumFromThen :: NewlyTouchingGround -> NewlyTouchingGround -> [NewlyTouchingGround]
enumFromThen :: NewlyTouchingGround -> NewlyTouchingGround -> [NewlyTouchingGround]
$cenumFromTo :: NewlyTouchingGround -> NewlyTouchingGround -> [NewlyTouchingGround]
enumFromTo :: NewlyTouchingGround -> NewlyTouchingGround -> [NewlyTouchingGround]
$cenumFromThenTo :: NewlyTouchingGround
-> NewlyTouchingGround
-> NewlyTouchingGround
-> [NewlyTouchingGround]
enumFromThenTo :: NewlyTouchingGround
-> NewlyTouchingGround
-> NewlyTouchingGround
-> [NewlyTouchingGround]
Enum, NewlyTouchingGround
NewlyTouchingGround
-> NewlyTouchingGround -> Bounded NewlyTouchingGround
forall a. a -> a -> Bounded a
$cminBound :: NewlyTouchingGround
minBound :: NewlyTouchingGround
$cmaxBound :: NewlyTouchingGround
maxBound :: NewlyTouchingGround
Bounded, Eq NewlyTouchingGround
Eq NewlyTouchingGround =>
(Int -> NewlyTouchingGround -> Int)
-> (NewlyTouchingGround -> Int) -> Hashable NewlyTouchingGround
Int -> NewlyTouchingGround -> Int
NewlyTouchingGround -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> NewlyTouchingGround -> Int
hashWithSalt :: Int -> NewlyTouchingGround -> Int
$chash :: NewlyTouchingGround -> Int
hash :: NewlyTouchingGround -> Int
Hashable)
  deriving stock (Typeable NewlyTouchingGround
Typeable NewlyTouchingGround =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g)
 -> NewlyTouchingGround
 -> c NewlyTouchingGround)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c NewlyTouchingGround)
-> (NewlyTouchingGround -> Constr)
-> (NewlyTouchingGround -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c NewlyTouchingGround))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c NewlyTouchingGround))
-> ((forall b. Data b => b -> b)
    -> NewlyTouchingGround -> NewlyTouchingGround)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> NewlyTouchingGround -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> NewlyTouchingGround -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> NewlyTouchingGround -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> NewlyTouchingGround -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> NewlyTouchingGround -> m NewlyTouchingGround)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> NewlyTouchingGround -> m NewlyTouchingGround)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> NewlyTouchingGround -> m NewlyTouchingGround)
-> Data NewlyTouchingGround
NewlyTouchingGround -> Constr
NewlyTouchingGround -> DataType
(forall b. Data b => b -> b)
-> NewlyTouchingGround -> NewlyTouchingGround
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> NewlyTouchingGround -> u
forall u.
(forall d. Data d => d -> u) -> NewlyTouchingGround -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NewlyTouchingGround -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NewlyTouchingGround -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NewlyTouchingGround -> m NewlyTouchingGround
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NewlyTouchingGround -> m NewlyTouchingGround
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NewlyTouchingGround
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> NewlyTouchingGround
-> c NewlyTouchingGround
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NewlyTouchingGround)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NewlyTouchingGround)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> NewlyTouchingGround
-> c NewlyTouchingGround
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> NewlyTouchingGround
-> c NewlyTouchingGround
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NewlyTouchingGround
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NewlyTouchingGround
$ctoConstr :: NewlyTouchingGround -> Constr
toConstr :: NewlyTouchingGround -> Constr
$cdataTypeOf :: NewlyTouchingGround -> DataType
dataTypeOf :: NewlyTouchingGround -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NewlyTouchingGround)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NewlyTouchingGround)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NewlyTouchingGround)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NewlyTouchingGround)
$cgmapT :: (forall b. Data b => b -> b)
-> NewlyTouchingGround -> NewlyTouchingGround
gmapT :: (forall b. Data b => b -> b)
-> NewlyTouchingGround -> NewlyTouchingGround
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NewlyTouchingGround -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NewlyTouchingGround -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NewlyTouchingGround -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NewlyTouchingGround -> r
$cgmapQ :: forall u.
(forall d. Data d => d -> u) -> NewlyTouchingGround -> [u]
gmapQ :: forall u.
(forall d. Data d => d -> u) -> NewlyTouchingGround -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> NewlyTouchingGround -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> NewlyTouchingGround -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NewlyTouchingGround -> m NewlyTouchingGround
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NewlyTouchingGround -> m NewlyTouchingGround
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NewlyTouchingGround -> m NewlyTouchingGround
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NewlyTouchingGround -> m NewlyTouchingGround
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NewlyTouchingGround -> m NewlyTouchingGround
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NewlyTouchingGround -> m NewlyTouchingGround
Data, (forall x. NewlyTouchingGround -> Rep NewlyTouchingGround x)
-> (forall x. Rep NewlyTouchingGround x -> NewlyTouchingGround)
-> Generic NewlyTouchingGround
forall x. Rep NewlyTouchingGround x -> NewlyTouchingGround
forall x. NewlyTouchingGround -> Rep NewlyTouchingGround x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NewlyTouchingGround -> Rep NewlyTouchingGround x
from :: forall x. NewlyTouchingGround -> Rep NewlyTouchingGround x
$cto :: forall x. Rep NewlyTouchingGround x -> NewlyTouchingGround
to :: forall x. Rep NewlyTouchingGround x -> NewlyTouchingGround
Generic, Typeable)

-- | is it landing?
islanding :: NewlyTouchingGround -> Bool
islanding :: NewlyTouchingGround -> Bool
islanding = (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT) (Ordering -> Bool)
-> (NewlyTouchingGround -> Ordering) -> NewlyTouchingGround -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewlyTouchingGround -> Ordering
newonground
{-# INLINE islanding #-}

-- | is it taking off?
istakingoff :: NewlyTouchingGround -> Bool
istakingoff :: NewlyTouchingGround -> Bool
istakingoff = (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT) (Ordering -> Bool)
-> (NewlyTouchingGround -> Ordering) -> NewlyTouchingGround -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewlyTouchingGround -> Ordering
newonground
{-# INLINE istakingoff #-}

-- | get a block's shape at integer coordinates (dynamic effect)
data GetBlock (f :: Type -> Type) a :: Effect where
  -- | get a block's shape at integer coordinates
  GetBlock :: !(V3 Int) %1 -> GetBlock f a m (Maybe (f a))

type instance DispatchOf (GetBlock f a) = Dynamic

-- | get a block's shape at integer coordinates
getblock ::
  (HasCallStack, GetBlock f a :> ef) =>
  -- | integer coordinates
  V3 Int ->
  -- | if (relevant) block exists, return its shape
  --
  -- what block is \"relevant\" is up to the implementation
  Eff ef (Maybe (f a))
getblock :: forall (f :: * -> *) a (ef :: [Effect]).
(HasCallStack, GetBlock f a :> ef) =>
V3 Int -> Eff ef (Maybe (f a))
getblock = GetBlock f a (Eff ef) (Maybe (f a)) -> Eff ef (Maybe (f a))
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (GetBlock f a (Eff ef) (Maybe (f a)) -> Eff ef (Maybe (f a)))
-> (V3 Int -> GetBlock f a (Eff ef) (Maybe (f a)))
-> V3 Int
-> Eff ef (Maybe (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 Int -> GetBlock f a (Eff ef) (Maybe (f a))
forall (f :: * -> *) a (m :: * -> *).
V3 Int -> GetBlock f a m (Maybe (f a))
GetBlock
{-# INLINE getblock #-}

-- | detect and resolve collision
resolve ::
  ( Shape s,
    RealFloat n,
    Epsilon n,
    Typeable n,
    GetBlock s n :> ef
  ) =>
  -- | shape of the object who is moving
  s n ->
  -- | attempted displacement
  V3 n ->
  -- | new resolution
  --
  -- unless it got stuck, the new displacement should be zero
  Eff ef (Resolve n)
resolve :: forall (s :: * -> *) n (ef :: [Effect]).
(Shape s, RealFloat n, Epsilon n, Typeable n,
 GetBlock s n :> ef) =>
s n -> V3 n -> Eff ef (Resolve n)
resolve s n
myself V3 n
disp =
  let res0 :: Resolve n
res0 = V3 n -> V3 n -> NewlyTouchingGround -> Resolve n
forall a. V3 a -> V3 a -> NewlyTouchingGround -> Resolve a
Resolve (s n -> V3 n
forall a. (Fractional a, Ord a) => s a -> V3 a
forall (s :: * -> *) a.
(Shape s, Fractional a, Ord a) =>
s a -> V3 a
scenter s n
myself) V3 n
disp (Ordering -> NewlyTouchingGround
NewlyTouchingGround Ordering
EQ)
      fps :: [V3 n]
fps =
        (V3 Int -> V3 n) -> [V3 Int] -> [V3 n]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((s n -> V3 n
forall (s :: * -> *) a.
(Shape s, Fractional a, Ord a) =>
s a -> V3 a
slocorner s n
myself +) (V3 n -> V3 n) -> (V3 Int -> V3 n) -> V3 Int -> V3 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> n) -> V3 Int -> V3 n
forall a b. (a -> b) -> V3 a -> V3 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral) do
          V3 Int -> V3 Int -> [V3 Int]
facepoints
            (n -> Int
forall b. Integral b => n -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (n -> Int) -> V3 n -> V3 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s n -> V3 n
forall a. (Fractional a, Ord a) => s a -> V3 a
forall (s :: * -> *) a.
(Shape s, Fractional a, Ord a) =>
s a -> V3 a
sdimensions s n
myself)
            (n -> Int
forall b. Integral b => n -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (n -> Int) -> (n -> n) -> n -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> n
forall a. Num a => a -> a
signum (n -> Int) -> V3 n -> V3 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V3 n
disp)
   in Eff ef (Resolve n)
-> (EarlyExit n -> Eff ef (Resolve n)) -> Eff ef (Resolve n)
forall e (es :: [Effect]) a.
Exception e =>
Eff es a -> (e -> Eff es a) -> Eff es a
catch
        do
          if V3 n -> Bool
forall a. Epsilon a => a -> Bool
nearZero V3 n
disp
            then Resolve n -> Eff ef (Resolve n)
forall a. a -> Eff ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Resolve n
res0
            else [V3 n]
-> Eff (Reader [V3 n] : ef) (Resolve n) -> Eff ef (Resolve n)
forall r (es :: [Effect]) a.
HasCallStack =>
r -> Eff (Reader r : es) a -> Eff es a
runReader [V3 n]
fps (Eff (Reader [V3 n] : ef) (Resolve n) -> Eff ef (Resolve n))
-> (Resolve n -> Eff (Reader [V3 n] : ef) (Resolve n))
-> Resolve n
-> Eff ef (Resolve n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s n -> Resolve n -> Eff (Reader [V3 n] : ef) (Resolve n)
forall (s :: * -> *) n (ef :: [Effect]).
(Shape s, RealFloat n, Epsilon n, Typeable n, GetBlock s n :> ef,
 Reader [V3 n] :> ef) =>
s n -> Resolve n -> Eff ef (Resolve n)
resolve' s n
myself (Resolve n -> Eff ef (Resolve n))
-> Resolve n -> Eff ef (Resolve n)
forall a b. (a -> b) -> a -> b
$ Resolve n
res0
        do \(EarlyExit Resolve n
res1) -> Resolve n -> Eff ef (Resolve n)
forall a. a -> Eff ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Resolve n
res1

-- the actual implementation of 'resolve'
resolve' ::
  forall s n ef.
  ( Shape s,
    RealFloat n,
    Epsilon n,
    Typeable n,
    GetBlock s n :> ef,
    -- face points
    Reader [V3 n] :> ef
  ) =>
  s n ->
  Resolve n ->
  Eff ef (Resolve n)
resolve' :: forall (s :: * -> *) n (ef :: [Effect]).
(Shape s, RealFloat n, Epsilon n, Typeable n, GetBlock s n :> ef,
 Reader [V3 n] :> ef) =>
s n -> Resolve n -> Eff ef (Resolve n)
resolve' =
  -- this is a loop that will run until the displacement is resolved
  -- (i.e., until it stops moving due to resolution or being blocked)
  ((s n -> Resolve n -> Eff ef (Resolve n))
 -> s n -> Resolve n -> Eff ef (Resolve n))
-> s n -> Resolve n -> Eff ef (Resolve n)
forall a. (a -> a) -> a
fix \s n -> Resolve n -> Eff ef (Resolve n)
cont s n
myself Resolve n
resolution -> do
    -- sample some points off the relevant faces of the object
    -- we will grid march along the rays (of the displacement) shot
    -- from these points
    let disp :: V3 n
disp = Resolve n -> V3 n
forall a. Resolve a -> V3 a
resdis Resolve n
resolution
        gofast :: Bool
gofast =
          -- if the assumptions of the fast core algorithm are met,
          -- yeah, apply the fast core algorithm
          V3 n -> n
forall a. Num a => V3 a -> a
forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance V3 n
disp n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
1
            Bool -> Bool -> Bool
|| ( n -> n
forall a. Num a => a -> a
abs (V3 n
disp V3 n -> Getting n (V3 n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (V3 n) n
forall a. Lens' (V3 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
1
                   Bool -> Bool -> Bool
&& n -> n
forall a. Num a => a -> a
abs (V3 n
disp V3 n -> Getting n (V3 n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (V3 n) n
forall a. Lens' (V3 a) a
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z) n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
1
                   Bool -> Bool -> Bool
&& n -> n
forall a. Num a => a -> a
abs (V3 n
disp V3 n -> Getting n (V3 n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (V3 n) n
forall a. Lens' (V3 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
1
               )
        core :: Resolve n -> s n -> Eff ef (Min (Hit' n))
core
          | Bool
gofast = Resolve n -> s n -> Eff ef (Min (Hit' n))
forall (s :: * -> *) n (ef :: [Effect]).
(Shape s, Epsilon n, RealFloat n, GetBlock s n :> ef,
 Reader [V3 n] :> ef) =>
Resolve n -> s n -> Eff ef (Min (Hit' n))
fastcore
          | Bool
otherwise = Resolve n -> s n -> Eff ef (Min (Hit' n))
forall (s :: * -> *) n (ef :: [Effect]).
(Shape s, Epsilon n, RealFloat n, GetBlock s n :> ef,
 Reader [V3 n] :> ef) =>
Resolve n -> s n -> Eff ef (Min (Hit' n))
slowcore
    [V3 n]
fps <- forall r (es :: [Effect]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask @[V3 n] -- retrieve the face points
    -- if i'm currently in contact with something, i can freely
    -- move in the direction of the displacement, as part of the
    -- game physics; this is so i can unstuck myself out
    [V3 Int] -> (V3 Int -> Eff ef ()) -> Eff ef ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ((n -> Int) -> V3 n -> V3 Int
forall a b. (a -> b) -> V3 a -> V3 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n -> Int
forall b. Integral b => n -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (V3 n -> V3 Int) -> [V3 n] -> [V3 Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [V3 n]
fps) do
      V3 Int -> Eff ef (Maybe (s n))
forall (f :: * -> *) a (ef :: [Effect]).
(HasCallStack, GetBlock f a :> ef) =>
V3 Int -> Eff ef (Maybe (f a))
getblock (V3 Int -> Eff ef (Maybe (s n)))
-> (Maybe (s n) -> Eff ef ()) -> V3 Int -> Eff ef ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
        Just s n
block
          | s n -> s n -> Bool
forall a. (Fractional a, Ord a) => s a -> s a -> Bool
forall (s :: * -> *) a.
(Shape s, Fractional a, Ord a) =>
s a -> s a -> Bool
intersecting s n
myself s n
block ->
              -- i am indeed stuck, so i will just exit early
              EarlyExit n -> Eff ef ()
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO (EarlyExit n -> Eff ef ()) -> EarlyExit n -> Eff ef ()
forall a b. (a -> b) -> a -> b
$ Resolve n -> EarlyExit n
forall a. Resolve a -> EarlyExit a
EarlyExit Resolve n
resolution
        Maybe (s n)
_ -> () -> Eff ef ()
forall a. a -> Eff ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- compute the times ("hits") at which the object will hit a block
    -- and then find the earliest hit
    Min (Hit' n)
mearliest <- Resolve n -> s n -> Eff ef (Min (Hit' n))
core Resolve n
resolution s n
myself
    -- feed back (or stop)
    case Min (Hit' n) -> Hit n
forall a b. Coercible a b => a -> b
coerce Min (Hit' n)
mearliest of
      Hit n
earliest
        | Hit n -> Bool
forall a. (Num a, Ord a) => Hit a -> Bool
hitin01 Hit n
earliest ->
            -- now correct the displacement; advance position
            let ! :: V3 a -> Rep V3 -> a
(!) = V3 a -> Rep V3 -> a
forall a. V3 a -> Rep V3 -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index
                delta :: V3 n
delta = Hit n -> n
forall a. Hit a -> a
hittime Hit n
earliest n -> V3 n -> V3 n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ V3 n
disp
                collided :: V3 Bool
collided = (n -> n -> Bool
forall a. Eq a => a -> a -> Bool
/= n
0) (n -> Bool) -> V3 n -> V3 Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hit n -> V3 n
forall a. Hit a -> V3 a
hitnorm Hit n
earliest
                resdis :: V3 n
resdis =
                  (Rep V3 -> n) -> V3 n
forall a. (Rep V3 -> a) -> V3 a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate \Rep V3
i ->
                    if V3 Bool
collided V3 Bool -> Rep V3 -> Bool
forall a. V3 a -> Rep V3 -> a
! Rep V3
i
                      then n
0 -- collision cancels out the displacement
                      else (n
1 n -> n -> n
forall a. Num a => a -> a -> a
- Hit n -> n
forall a. Hit a -> a
hittime Hit n
earliest) n -> n -> n
forall a. Num a => a -> a -> a
* (V3 n
disp V3 n -> Rep V3 -> n
forall a. V3 a -> Rep V3 -> a
! Rep V3
i)
                respos :: V3 n
respos = s n -> V3 n
forall a. (Fractional a, Ord a) => s a -> V3 a
forall (s :: * -> *) a.
(Shape s, Fractional a, Ord a) =>
s a -> V3 a
scenter s n
myself V3 n -> V3 n -> V3 n
forall a. Num a => a -> a -> a
+ V3 n
delta
                restou :: NewlyTouchingGround
restou
                  | Hit n -> V3 n
forall a. Hit a -> V3 a
hitnorm Hit n
earliest V3 n -> Getting n (V3 n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (V3 n) n
forall a. Lens' (V3 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0 = Ordering -> NewlyTouchingGround
forall a b. Coercible a b => a -> b
coerce Ordering
GT -- hit the ground
                  | V3 n
disp V3 n -> Getting n (V3 n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (V3 n) n
forall a. Lens' (V3 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0 = Ordering -> NewlyTouchingGround
forall a b. Coercible a b => a -> b
coerce Ordering
LT -- on-ground becomes False
                  | Bool
otherwise = Ordering -> NewlyTouchingGround
forall a b. Coercible a b => a -> b
coerce Ordering
EQ
                res :: Resolve n
res = Resolve {V3 n
respos :: V3 n
respos :: V3 n
respos, V3 n
resdis :: V3 n
resdis :: V3 n
resdis, NewlyTouchingGround
restou :: NewlyTouchingGround
restou :: NewlyTouchingGround
restou}
             in if V3 Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or V3 Bool
collided
                  Bool -> Bool -> Bool
&& Bool -> Bool
not (V3 Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and V3 Bool
collided)
                  Bool -> Bool -> Bool
&& Bool -> Bool
not (V3 n -> Bool
forall a. Epsilon a => a -> Bool
nearZero V3 n
resdis)
                  then s n -> Resolve n -> Eff ef (Resolve n)
cont (V3 n -> s n -> s n
forall a. Num a => V3 a -> s a -> s a
forall (s :: * -> *) a. (Shape s, Num a) => V3 a -> s a -> s a
translate V3 n
delta s n
myself) Resolve n
res
                  else Resolve n -> Eff ef (Resolve n)
forall a. a -> Eff ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resolve n -> Eff ef (Resolve n))
-> Resolve n -> Eff ef (Resolve n)
forall a b. (a -> b) -> a -> b
$ Resolve n
res Resolve n -> (Resolve n -> Resolve n) -> Resolve n
forall a b. a -> (a -> b) -> b
& (V3 n -> Identity (V3 n)) -> Resolve n -> Identity (Resolve n)
forall a (f :: * -> *).
Functor f =>
(V3 a -> f (V3 a)) -> Resolve a -> f (Resolve a)
_resdis ((V3 n -> Identity (V3 n)) -> Resolve n -> Identity (Resolve n))
-> V3 n -> Resolve n -> Resolve n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ V3 n
forall a. Num a => V3 a
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
      Hit n
_ ->
        -- no collision, so apply the displacement
        Resolve n -> Eff ef (Resolve n)
forall a. a -> Eff ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          Resolve
            { respos :: V3 n
respos = Resolve n -> V3 n
forall a. Resolve a -> V3 a
respos Resolve n
resolution V3 n -> V3 n -> V3 n
forall a. Num a => a -> a -> a
+ V3 n
disp,
              resdis :: V3 n
resdis = V3 n
forall a. Num a => V3 a
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero,
              restou :: NewlyTouchingGround
restou =
                if V3 n
disp V3 n -> Getting n (V3 n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (V3 n) n
forall a. Lens' (V3 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0
                  then Ordering -> NewlyTouchingGround
forall a b. Coercible a b => a -> b
coerce Ordering
LT -- on-ground becomes False
                  else Resolve n -> NewlyTouchingGround
forall a. Resolve a -> NewlyTouchingGround
restou Resolve n
resolution -- (inherit previous decision)
            }

-- slow process ... use ray marching from each face point
-- collect all hits found from all rays
slowcore ::
  forall s n ef.
  ( Shape s,
    Epsilon n,
    RealFloat n,
    GetBlock s n :> ef,
    Reader [V3 n] :> ef
  ) =>
  Resolve n -> s n -> Eff ef (Min (Hit' n))
slowcore :: forall (s :: * -> *) n (ef :: [Effect]).
(Shape s, Epsilon n, RealFloat n, GetBlock s n :> ef,
 Reader [V3 n] :> ef) =>
Resolve n -> s n -> Eff ef (Min (Hit' n))
slowcore Resolve n
res s n
myself =
  forall r (es :: [Effect]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask @[V3 n] Eff ef [V3 n]
-> ([V3 n] -> Eff ef (Min (Hit' n))) -> Eff ef (Min (Hit' n))
forall a b. Eff ef a -> (a -> Eff ef b) -> Eff ef b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[V3 n]
fps ->
    [Min (Hit' n)] -> Min (Hit' n)
forall a. Monoid a => [a] -> a
mconcat ([Min (Hit' n)] -> Min (Hit' n))
-> Eff ef [Min (Hit' n)] -> Eff ef (Min (Hit' n))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [V3 n] -> (V3 n -> Eff ef (Min (Hit' n))) -> Eff ef [Min (Hit' n)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [V3 n]
fps \V3 n
fp ->
      -- ray marching algorithm:
      --   1. shoot ray from each face point (fp)
      --   2. track ray's path through grid cubes
      --   3. stop at first hit or when ray length > displacement
      --
      -- grid traversal details:
      --   - ray can enter multiple cubes simultaneously:
      --     * 1 cube: through face
      --     * 2 cubes: through edge (if not parallel to axis)
      --     * 3 cubes: through corner
      --   - cubes are checked for collision
      --   - early exit on first collision
      --
      -- note: behavior unspecified when ray travels exactly
      -- along grid edge or plane, but will return something
      -- for sake of completeness
      (n -> V3 n -> [V3 Int] -> March V3 n
forall (f :: * -> *) a. a -> f a -> [f Int] -> March f a
March n
0 V3 n
forall a. HasCallStack => a
undefined [n -> Int
forall b. Integral b => n -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (n -> Int) -> V3 n -> V3 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V3 n
fp] March V3 n -> [March V3 n] -> [March V3 n]
forall a. a -> [a] -> [a]
: V3 n -> V3 n -> [March V3 n]
forall (f :: * -> *) a.
(Foldable f, Representable f, Rep f ~ E f, RealFloat a,
 Epsilon a) =>
f a -> f a -> [March f a]
march V3 n
fp (Resolve n -> V3 n
forall a. Resolve a -> V3 a
resdis Resolve n
res))
        [March V3 n]
-> ([March V3 n] -> Eff ef (Min (Hit' n))) -> Eff ef (Min (Hit' n))
forall a b. a -> (a -> b) -> b
& (([March V3 n] -> Eff ef (Min (Hit' n)))
 -> [March V3 n] -> Eff ef (Min (Hit' n)))
-> [March V3 n] -> Eff ef (Min (Hit' n))
forall a. (a -> a) -> a
fix \[March V3 n] -> Eff ef (Min (Hit' n))
contrm ->
          \case
            -- some improper displacements can cause termination
            -- of ray marching (which should normally be infinite)
            [] -> Min (Hit' n) -> Eff ef (Min (Hit' n))
forall a. a -> Eff ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Min (Hit' n)
forall a. Monoid a => a
mempty
            -- no hit
            March n
t V3 n
_ [V3 Int]
_ : [March V3 n]
_ | n
t n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
1 -> Min (Hit' n) -> Eff ef (Min (Hit' n))
forall a. a -> Eff ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Min (Hit' n)
forall a. Monoid a => a
mempty
            -- entering (a) grid cube(s), are there any blocks in them?
            March n
_ V3 n
_ [V3 Int]
cubes : [March V3 n]
rm ->
              [V3 Int]
cubes [V3 Int]
-> ([V3 Int] -> Eff ef (Min (Hit' n))) -> Eff ef (Min (Hit' n))
forall a b. a -> (a -> b) -> b
& (([V3 Int] -> Eff ef (Min (Hit' n)))
 -> [V3 Int] -> Eff ef (Min (Hit' n)))
-> [V3 Int] -> Eff ef (Min (Hit' n))
forall a. (a -> a) -> a
fix \[V3 Int] -> Eff ef (Min (Hit' n))
contcb -> \case
                -- ran out of grid cubes, so, no;
                -- need to go one step further along the ray
                [] -> [March V3 n] -> Eff ef (Min (Hit' n))
contrm [March V3 n]
rm
                -- let's check the block at the grid cube
                V3 Int
cb : [V3 Int]
cb' ->
                  (s n -> Hit n)
-> Eff ef (Min (Hit' n)) -> V3 Int -> Eff ef (Min (Hit' n))
forall (s :: * -> *) n (ef :: [Effect]).
(GetBlock s n :> ef, Shape s, Fractional n, Ord n) =>
(s n -> Hit n)
-> Eff ef (Min (Hit' n)) -> V3 Int -> Eff ef (Min (Hit' n))
chkcol
                    (V3 n -> s n -> s n -> Hit n
forall a. RealFloat a => V3 a -> s a -> s a -> Hit a
forall (s :: * -> *) a.
(Shape s, RealFloat a) =>
V3 a -> s a -> s a -> Hit a
hitting (Resolve n -> V3 n
forall a. Resolve a -> V3 a
resdis Resolve n
res) s n
myself)
                    ([V3 Int] -> Eff ef (Min (Hit' n))
contcb [V3 Int]
cb')
                    V3 Int
cb

-- fast collision detection for small movements (length <= 1 or
-- diagonal |x|=|z|=1)
--
-- key idea: instead of ray marching, we check potential collision blocks
-- directly by considering the movement box - the space swept by the object
-- during movement
--
-- algorithm:
--   for each face point of the moving object:
--     1. find start (bef) and end (aft) positions
--     2. generate test points at corners of movement box:
--        - movement box is the space between bef and aft positions
--        - use binary counting (0-7) to pick coordinates:
--          * bit 0 = x: choose between bef.x (0) or aft.x (1)
--          * bit 1 = y: choose between bef.y (0) or aft.y (1)
--          * bit 2 = z: choose between bef.z (0) or aft.z (1)
--        - skip coordinates where movement is negligible
--     3. for each test point:
--        - get block at that position
--        - test if moving object would hit that block
--        - collect all hits found
--
-- example: moving +X+Y (need = <True,True,False>)
--   we only check 4 corners instead of 8 since Z movement = 0:
--   * 000 -> (bef.x, bef.y, bef.z)
--   * 001 -> (aft.x, bef.y, bef.z)
--   * 010 -> (bef.x, aft.y, bef.z)
--   * 011 -> (aft.x, aft.y, bef.z)
fastcore ::
  forall s n ef.
  ( Shape s,
    Epsilon n,
    RealFloat n,
    GetBlock s n :> ef,
    Reader [V3 n] :> ef
  ) =>
  Resolve n -> s n -> Eff ef (Min (Hit' n))
fastcore :: forall (s :: * -> *) n (ef :: [Effect]).
(Shape s, Epsilon n, RealFloat n, GetBlock s n :> ef,
 Reader [V3 n] :> ef) =>
Resolve n -> s n -> Eff ef (Min (Hit' n))
fastcore Resolve n
res s n
myself =
  forall r (es :: [Effect]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask @[V3 n] -- face points (world coordinates)
    Eff ef [V3 n]
-> ([V3 n] -> Eff ef (Min (Hit' n))) -> Eff ef (Min (Hit' n))
forall a b. Eff ef a -> (a -> Eff ef b) -> Eff ef b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([[Min (Hit' n)]] -> Min (Hit' n))
-> Eff ef [[Min (Hit' n)]] -> Eff ef (Min (Hit' n))
forall a b. (a -> b) -> Eff ef a -> Eff ef b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Min (Hit' n)] -> Min (Hit' n)
forall a. Monoid a => [a] -> a
mconcat ([Min (Hit' n)] -> Min (Hit' n))
-> ([[Min (Hit' n)]] -> [Min (Hit' n)])
-> [[Min (Hit' n)]]
-> Min (Hit' n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Min (Hit' n)]] -> [Min (Hit' n)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (Eff ef [[Min (Hit' n)]] -> Eff ef (Min (Hit' n)))
-> ([V3 n] -> Eff ef [[Min (Hit' n)]])
-> [V3 n]
-> Eff ef (Min (Hit' n))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (V3 n -> Eff ef [Min (Hit' n)])
-> [V3 n] -> Eff ef [[Min (Hit' n)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse \V3 n
bef ->
      let dis :: V3 n
dis = Resolve n -> V3 n
forall a. Resolve a -> V3 a
resdis Resolve n
res
          aft :: V3 n
aft = V3 n
bef V3 n -> V3 n -> V3 n
forall a. Num a => a -> a -> a
+ V3 n
dis -- before (bef) and after (aft) positions
          -- moving in {x,y,z} directions?
          need :: V3 Bool
need = Bool -> Bool
not (Bool -> Bool) -> (n -> Bool) -> n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Bool
forall a. Epsilon a => a -> Bool
nearZero (n -> Bool) -> V3 n -> V3 Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V3 n
dis
          -- note: chkcol uses continuation-passing to collect hits
          -- we use 'pure mempty' as the final continuation
          hits :: Eff ef [Min (Hit' n)]
hits = [V3 Int]
-> (V3 Int -> Eff ef (Min (Hit' n))) -> Eff ef [Min (Hit' n)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [V3 Int]
targets ((V3 Int -> Eff ef (Min (Hit' n))) -> Eff ef [Min (Hit' n)])
-> (V3 Int -> Eff ef (Min (Hit' n))) -> Eff ef [Min (Hit' n)]
forall a b. (a -> b) -> a -> b
$ (s n -> Hit n)
-> Eff ef (Min (Hit' n)) -> V3 Int -> Eff ef (Min (Hit' n))
forall (s :: * -> *) n (ef :: [Effect]).
(GetBlock s n :> ef, Shape s, Fractional n, Ord n) =>
(s n -> Hit n)
-> Eff ef (Min (Hit' n)) -> V3 Int -> Eff ef (Min (Hit' n))
chkcol (V3 n -> s n -> s n -> Hit n
forall a. RealFloat a => V3 a -> s a -> s a -> Hit a
forall (s :: * -> *) a.
(Shape s, RealFloat a) =>
V3 a -> s a -> s a -> Hit a
hitting V3 n
dis s n
myself) (Min (Hit' n) -> Eff ef (Min (Hit' n))
forall a. a -> Eff ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Min (Hit' n)
forall a. Monoid a => a
mempty)
            where
              ! :: V3 a -> Rep V3 -> a
(!) = V3 a -> Rep V3 -> a
forall a. V3 a -> Rep V3 -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index
              -- select position component (bef/aft) based on bit
              pos :: Int -> E V3 -> n
pos Int
n E V3
i
                | V3 Bool
need V3 Bool -> Rep V3 -> Bool
forall a. V3 a -> Rep V3 -> a
! Rep V3
E V3
i Bool -> Bool -> Bool
&& Int -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int
n (Int -> Int -> Int -> V3 Int
forall a. a -> a -> a -> V3 a
V3 Int
0 Int
1 Int
2 V3 Int -> Rep V3 -> Int
forall a. V3 a -> Rep V3 -> a
! Rep V3
E V3
i) = V3 n
aft V3 n -> Rep V3 -> n
forall a. V3 a -> Rep V3 -> a
! Rep V3
E V3
i
                | Bool
otherwise = V3 n
bef V3 n -> Rep V3 -> n
forall a. V3 a -> Rep V3 -> a
! Rep V3
E V3
i
              -- see \#2 in the algorithm description
              targets :: [V3 Int]
targets = [V3 Int] -> [V3 Int]
forall a. Eq a => [a] -> [a]
nub ([V3 Int] -> [V3 Int]) -> [V3 Int] -> [V3 Int]
forall a b. (a -> b) -> a -> b
$ (n -> Int) -> V3 n -> V3 Int
forall a b. (a -> b) -> V3 a -> V3 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n -> Int
forall b. Integral b => n -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (V3 n -> V3 Int) -> (Int -> V3 n) -> Int -> V3 Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rep V3 -> n) -> V3 n
(E V3 -> n) -> V3 n
forall a. (Rep V3 -> a) -> V3 a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate ((E V3 -> n) -> V3 n) -> (Int -> E V3 -> n) -> Int -> V3 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> E V3 -> n
pos (Int -> V3 Int) -> [Int] -> [V3 Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
Item [Int]
0 .. Int
7 :: Int]
       in Eff ef [Min (Hit' n)]
hits

-- internal helper function for 'resolve'
-- check if i hit a block at the grid cube (and check below for tall blocks)
chkcol ::
  (GetBlock s n :> ef, Shape s, Fractional n, Ord n) =>
  -- check for hit given block shape (shape has absolute coordinates)
  (s n -> Hit n) ->
  -- continuation for continuing to next grid cube
  Eff ef (Min (Hit' n)) ->
  -- where (block coordinates)
  V3 Int ->
  Eff ef (Min (Hit' n))
chkcol :: forall (s :: * -> *) n (ef :: [Effect]).
(GetBlock s n :> ef, Shape s, Fractional n, Ord n) =>
(s n -> Hit n)
-> Eff ef (Min (Hit' n)) -> V3 Int -> Eff ef (Min (Hit' n))
chkcol s n -> Hit n
chkhit Eff ef (Min (Hit' n))
continue V3 Int
cb = do
  let chkbelow :: Eff ef (Min (Hit' n) -> Min (Hit' n))
chkbelow =
        -- go below and check too
        V3 Int -> Eff ef (Maybe (s n))
forall (f :: * -> *) a (ef :: [Effect]).
(HasCallStack, GetBlock f a :> ef) =>
V3 Int -> Eff ef (Maybe (f a))
getblock (V3 Int
cb V3 Int -> (V3 Int -> V3 Int) -> V3 Int
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> V3 Int -> Identity (V3 Int)
forall a. Lens' (V3 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y ((Int -> Identity Int) -> V3 Int -> Identity (V3 Int))
-> Int -> V3 Int -> V3 Int
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1) Eff ef (Maybe (s n))
-> (Maybe (s n) -> Min (Hit' n) -> Min (Hit' n))
-> Eff ef (Min (Hit' n) -> Min (Hit' n))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          Just s n
blockbelow
            | Hit n
hit <- s n -> Hit n
chkhit s n
blockbelow,
              Hit n -> Bool
forall a. (Num a, Ord a) => Hit a -> Bool
hitin01 Hit n
hit ->
                (Hit n -> Min (Hit' n)
forall a b. Coercible a b => a -> b
coerce Hit n
hit <>)
          Maybe (s n)
_ -> Min (Hit' n) -> Min (Hit' n)
forall a. a -> a
id
      {-# INLINE chkbelow #-}
      Bool
True ? :: Bool -> f (a -> a) -> f (a -> a)
? f (a -> a)
action = f (a -> a)
action
      Bool
_ ? f (a -> a)
_ = (a -> a) -> f (a -> a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id
      short :: s a -> Bool
short s a
b = s a -> V3 a
forall (s :: * -> *) a.
(Shape s, Fractional a, Ord a) =>
s a -> V3 a
shicorner s a
b V3 a -> Getting a (V3 a) a -> a
forall s a. s -> Getting a s a -> a
^. Getting a (V3 a) a
forall a. Lens' (V3 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0.5
  -- check if a block exists at the grid cube & is solid
  -- also just in case a tall block (like a fence)
  -- is there, we check the block below it
  V3 Int -> Eff ef (Maybe (s n))
forall (f :: * -> *) a (ef :: [Effect]).
(HasCallStack, GetBlock f a :> ef) =>
V3 Int -> Eff ef (Maybe (f a))
getblock V3 Int
cb Eff ef (Maybe (s n))
-> (Maybe (s n) -> Eff ef (Min (Hit' n))) -> Eff ef (Min (Hit' n))
forall a b. Eff ef a -> (a -> Eff ef b) -> Eff ef b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just s n
block
      | Hit n
hit <- s n -> Hit n
chkhit s n
block,
        Hit n -> Bool
forall a. (Num a, Ord a) => Hit a -> Bool
hitin01 Hit n
hit ->
          -- oh, we hit something
          (s n -> Bool
forall {s :: * -> *} {a}.
(Shape s, Fractional a, Ord a) =>
s a -> Bool
short s n
block Bool
-> Eff ef (Min (Hit' n) -> Min (Hit' n))
-> Eff ef (Min (Hit' n) -> Min (Hit' n))
forall {f :: * -> *} {a}.
Applicative f =>
Bool -> f (a -> a) -> f (a -> a)
? Eff ef (Min (Hit' n) -> Min (Hit' n))
chkbelow) Eff ef (Min (Hit' n) -> Min (Hit' n))
-> Eff ef (Min (Hit' n)) -> Eff ef (Min (Hit' n))
forall a b. Eff ef (a -> b) -> Eff ef a -> Eff ef b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Hit n -> Min (Hit' n)
forall a b. Coercible a b => a -> b
coerce Hit n
hit <>) (Min (Hit' n) -> Min (Hit' n))
-> Eff ef (Min (Hit' n)) -> Eff ef (Min (Hit' n))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff ef (Min (Hit' n))
continue)
      | Bool
otherwise ->
          -- a block is there but we don't hit it
          (s n -> Bool
forall {s :: * -> *} {a}.
(Shape s, Fractional a, Ord a) =>
s a -> Bool
short s n
block Bool
-> Eff ef (Min (Hit' n) -> Min (Hit' n))
-> Eff ef (Min (Hit' n) -> Min (Hit' n))
forall {f :: * -> *} {a}.
Applicative f =>
Bool -> f (a -> a) -> f (a -> a)
? Eff ef (Min (Hit' n) -> Min (Hit' n))
chkbelow) Eff ef (Min (Hit' n) -> Min (Hit' n))
-> Eff ef (Min (Hit' n)) -> Eff ef (Min (Hit' n))
forall a b. Eff ef (a -> b) -> Eff ef a -> Eff ef b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Eff ef (Min (Hit' n))
continue
    -- no block at the grid cube
    Maybe (s n)
Nothing -> Eff ef (Min (Hit' n) -> Min (Hit' n))
chkbelow Eff ef (Min (Hit' n) -> Min (Hit' n))
-> Eff ef (Min (Hit' n)) -> Eff ef (Min (Hit' n))
forall a b. Eff ef (a -> b) -> Eff ef a -> Eff ef b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Eff ef (Min (Hit' n))
continue