module M.Collision.Internal.March (March (..), march) where
import Control.Lens hiding (index)
import Control.Monad.Fix
import Control.Monad.ST.Lazy
import Data.Foldable
import Data.Functor
import Data.Functor.Rep
import Data.STRef.Lazy
import Linear hiding (trace)
import Prelude hiding (read)
nonegzero :: (RealFloat a) => a -> a
nonegzero :: forall a. RealFloat a => a -> a
nonegzero a
x | a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x = a
0
nonegzero a
x = a
x
isfinite :: (RealFloat a) => a -> Bool
isfinite :: forall a. RealFloat a => a -> Bool
isfinite a
x = Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x)
add ::
(Num a) =>
a ->
a ->
a ->
(a, a)
add :: forall a. Num a => a -> a -> a -> (a, a)
add a
x a
y a
c =
let y' :: a
y' = a
y a -> a -> a
forall a. Num a => a -> a -> a
- a
c
u :: a
u = a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y'
c' :: a
c' = a
u a -> a -> a
forall a. Num a => a -> a -> a
- a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
y'
in (a
u, a
c')
data I f a = I
{
forall (f :: * -> *) a. I f a -> a
itim :: !a,
forall (f :: * -> *) a. I f a -> f a
icur :: !(f a),
forall (f :: * -> *) a. I f a -> f a
icom :: !(f a),
forall (f :: * -> *) a. I f a -> [f Int]
igrid :: ![f Int]
}
data March f a = March
{
forall (f :: * -> *) a. March f a -> a
mtot :: a,
forall (f :: * -> *) a. March f a -> f a
mpct :: f a,
forall (f :: * -> *) a. March f a -> [f Int]
mict :: [f Int]
}
march ::
forall f a.
( Foldable f,
Representable f,
Rep f ~ E f,
RealFloat a,
Epsilon a
) =>
f a ->
f a ->
[March f a]
march :: forall (f :: * -> *) a.
(Foldable f, Representable f, Rep f ~ E f, RealFloat a,
Epsilon a) =>
f a -> f a -> [March f a]
march f a
_ f a
direction | (Bool -> Bool
not (Bool -> Bool) -> (f a -> Bool) -> f a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> f a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all a -> Bool
forall a. RealFloat a => a -> Bool
isfinite) f a
direction = []
march f a
_ f a
direction | (a -> Bool) -> f a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all a -> Bool
forall a. Epsilon a => a -> Bool
nearZero f a
direction = []
march f a
start ((a -> a) -> f a -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. RealFloat a => a -> a
nonegzero -> f a
direction) = (forall s. ST s [March f a]) -> [March f a]
forall a. (forall s. ST s a) -> a
runST do
let fi :: Int -> a
fi = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> a
! :: f a -> Rep f -> a
(!) = f a -> Rep f -> a
forall a. f a -> Rep f -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index
new :: a -> ST s (STRef s a)
new = a -> ST s (STRef s a)
forall a s. a -> ST s (STRef s a)
newSTRef
read :: STRef s a -> ST s a
read = STRef s a -> ST s a
forall s a. STRef s a -> ST s a
readSTRef
write :: STRef s a -> a -> ST s ()
write = STRef s a -> a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef
modify :: STRef s a -> (a -> a) -> ST s ()
modify = STRef s a -> (a -> a) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef
lift2 :: (Int -> Int -> Int) -> f Int -> f Int -> f Int
lift2 Int -> Int -> Int
f f Int
x f Int
y = forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate @f \Rep f
i -> Int -> Int -> Int
f (f Int
x f Int -> Rep f -> Int
forall a. f a -> Rep f -> a
! Rep f
i) (f Int
y f Int -> Rep f -> Int
forall a. f a -> Rep f -> a
! Rep f
i)
minimum_ :: [a] -> a
minimum_ = (a -> a -> a) -> [a] -> a
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 \a
a a
b ->
if
| a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
a -> a
b
| a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
b -> a
a
| Bool
otherwise -> a -> a -> a
forall a. Ord a => a -> a -> a
min a
a a
b
computesig :: f b -> f b
computesig f b
d = b -> b
forall {a}. (Eq a, Num a) => a -> a
f (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
forall b. Integral b => b -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
forall a. Num a => a -> a
signum (b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
d
where
f :: a -> a
f a
0 = a
1
f a
x = a
x
round_ :: a -> a -> b
round_ (-1) = a -> b
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling
round_ a
1 = a -> b
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor
round_ a
_ = [Char] -> a -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"signum neither -1 nor 1"
gengridpoints :: f (f Int -> f a -> f Int)
gengridpoints = (Rep f -> f Int -> f a -> f Int) -> f (f Int -> f a -> f Int)
forall a. (Rep f -> a) -> f a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate \Rep f
i f Int
sig f a
v ->
let roundedv :: f Int
roundedv = (Rep f -> Int) -> f Int
forall a. (Rep f -> a) -> f a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate \Rep f
j -> Int -> a -> Int
forall {a} {b} {a}.
(RealFrac a, Integral b, Eq a, Num a) =>
a -> a -> b
round_ (-(f Int
sig f Int -> Rep f -> Int
forall a. f a -> Rep f -> a
! Rep f
j)) (f a
v f a -> Rep f -> a
forall a. f a -> Rep f -> a
! Rep f
j)
in (Int -> Int -> Int) -> f Int -> f Int -> f Int
lift2 (-) f Int
roundedv (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> f Int -> f Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Int
sig) f Int -> (f Int -> f Int) -> f Int
forall a b. a -> (a -> b) -> b
& E f -> forall x. Lens' (f x) x
forall (t :: * -> *). E t -> forall x. Lens' (t x) x
el Rep f
E f
i ((Int -> Identity Int) -> f Int -> Identity (f Int))
-> Int -> f Int -> f Int
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ f Int
sig f Int -> Rep f -> Int
forall a. f a -> Rep f -> a
! Rep f
i
inter :: f Int -> f a -> f a -> f a -> I f a
inter f Int
sig f a
dir f a
com f a
cur =
let times :: f (a, f a -> f Int)
times = (Rep f -> (a, f a -> f Int)) -> f (a, f a -> f Int)
forall a. (Rep f -> a) -> f a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate \Rep f
i ->
let r :: a -> Int
r = Int -> a -> Int
forall {a} {b} {a}.
(RealFrac a, Integral b, Eq a, Num a) =>
a -> a -> b
round_ (Int -> a -> Int) -> Int -> a -> Int
forall a b. (a -> b) -> a -> b
$ f Int
sig f Int -> Rep f -> Int
forall a. f a -> Rep f -> a
! Rep f
i
u :: a
u = Int -> a
fi (a -> Int
r (f a
cur f a -> Rep f -> a
forall a. f a -> Rep f -> a
! Rep f
i) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ f Int
sig f Int -> Rep f -> Int
forall a. f a -> Rep f -> a
! Rep f
i) a -> a -> a
forall a. Num a => a -> a -> a
- f a
cur f a -> Rep f -> a
forall a. f a -> Rep f -> a
! Rep f
i
in (a
u a -> a -> a
forall a. Fractional a => a -> a -> a
/ f a
dir f a -> Rep f -> a
forall a. f a -> Rep f -> a
! Rep f
i, (f (f Int -> f a -> f Int)
gengridpoints f (f Int -> f a -> f Int) -> Rep f -> f Int -> f a -> f Int
forall a. f a -> Rep f -> a
! Rep f
i) f Int
sig)
t :: a
t = [a] -> a
minimum_ ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ ((a, f a -> f Int) -> a) -> [(a, f a -> f Int)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, f a -> f Int) -> a
forall a b. (a, b) -> a
fst ([(a, f a -> f Int)] -> [a]) -> [(a, f a -> f Int)] -> [a]
forall a b. (a -> b) -> a -> b
$ f (a, f a -> f Int) -> [(a, f a -> f Int)]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (a, f a -> f Int)
times
eqtim :: a -> Bool
eqtim = a -> Bool
forall a. Epsilon a => a -> Bool
nearZero (a -> Bool) -> (a -> a) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a. Num a => a -> a -> a
subtract a
t
gridcoordsf :: [f a -> f Int]
gridcoordsf = ((a, f a -> f Int) -> f a -> f Int)
-> [(a, f a -> f Int)] -> [f a -> f Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, f a -> f Int) -> f a -> f Int
forall a b. (a, b) -> b
snd ([(a, f a -> f Int)] -> [f a -> f Int])
-> [(a, f a -> f Int)] -> [f a -> f Int]
forall a b. (a -> b) -> a -> b
$ ((a, f a -> f Int) -> Bool)
-> [(a, f a -> f Int)] -> [(a, f a -> f Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Bool
eqtim (a -> Bool)
-> ((a, f a -> f Int) -> a) -> (a, f a -> f Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, f a -> f Int) -> a
forall a b. (a, b) -> a
fst) ([(a, f a -> f Int)] -> [(a, f a -> f Int)])
-> [(a, f a -> f Int)] -> [(a, f a -> f Int)]
forall a b. (a -> b) -> a -> b
$ f (a, f a -> f Int) -> [(a, f a -> f Int)]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (a, f a -> f Int)
times
vadd :: f a -> f a -> f (a, a)
vadd f a
v f a
w = (Rep f -> (a, a)) -> f (a, a)
forall a. (Rep f -> a) -> f a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate \Rep f
i -> a -> a -> a -> (a, a)
forall a. Num a => a -> a -> a -> (a, a)
add (f a
v f a -> Rep f -> a
forall a. f a -> Rep f -> a
! Rep f
i) (f a
w f a -> Rep f -> a
forall a. f a -> Rep f -> a
! Rep f
i) (f a
com f a -> Rep f -> a
forall a. f a -> Rep f -> a
! Rep f
i)
s :: f (a, a)
s = f a -> f a -> f (a, a)
vadd f a
cur (f a -> f (a, a)) -> f a -> f (a, a)
forall a b. (a -> b) -> a -> b
$ f a
dir f a -> (a -> a) -> f a
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (a -> a -> a
forall a. Num a => a -> a -> a
* a
t)
icur_ :: f a
icur_ = (a, a) -> a
forall a b. (a, b) -> a
fst ((a, a) -> a) -> f (a, a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, a)
s
icom :: f a
icom = (a, a) -> a
forall a b. (a, b) -> b
snd ((a, a) -> a) -> f (a, a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, a)
s
icur :: f a
icur = (Rep f -> a) -> f a
forall a. (Rep f -> a) -> f a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate \Rep f
i ->
let n :: a
n = f a
icur_ f a -> Rep f -> a
forall a. f a -> Rep f -> a
! Rep f
i
in if a -> Bool
eqtim (a -> Bool) -> a -> Bool
forall a b. (a -> b) -> a -> b
$ (a, f a -> f Int) -> a
forall a b. (a, b) -> a
fst ((a, f a -> f Int) -> a) -> (a, f a -> f Int) -> a
forall a b. (a -> b) -> a -> b
$ f (a, f a -> f Int)
times f (a, f a -> f Int) -> Rep f -> (a, f a -> f Int)
forall a. f a -> Rep f -> a
! Rep f
i
then Int -> a
fi (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ a -> Int
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round a
n
else a
n
in I {itim :: a
itim = a
t, f a
icur :: f a
icur :: f a
icur, f a
icom :: f a
icom :: f a
icom, igrid :: [f Int]
igrid = [f a -> f Int]
gridcoordsf [f a -> f Int] -> ((f a -> f Int) -> f Int) -> [f Int]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((f a -> f Int) -> f a -> f Int
forall a b. (a -> b) -> a -> b
$ f a
icur)}
STRef s (f a)
cur <- f a -> ST s (STRef s (f a))
forall a s. a -> ST s (STRef s a)
new f a
start
STRef s (f a)
com <- f a -> ST s (STRef s (f a))
forall a s. a -> ST s (STRef s a)
new (f a -> ST s (STRef s (f a))) -> f a -> ST s (STRef s (f a))
forall a b. (a -> b) -> a -> b
$ (Rep f -> a) -> f a
forall a. (Rep f -> a) -> f a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate ((Rep f -> a) -> f a) -> (Rep f -> a) -> f a
forall a b. (a -> b) -> a -> b
$ a -> E f -> a
forall a b. a -> b -> a
const a
0
STRef s (a, a)
tot <- (a, a) -> ST s (STRef s (a, a))
forall a s. a -> ST s (STRef s a)
new (a
0, a
0)
do
let d :: f a
d = (a -> a -> a
forall a. Num a => a -> a -> a
* (-a
1)) (a -> a) -> f a -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
direction
I {a
itim :: forall (f :: * -> *) a. I f a -> a
itim :: a
itim, f a
icur :: forall (f :: * -> *) a. I f a -> f a
icur :: f a
icur, f a
icom :: forall (f :: * -> *) a. I f a -> f a
icom :: f a
icom} <- f Int -> f a -> f a -> f a -> I f a
inter (f a -> f Int
forall {f :: * -> *} {b} {b}.
(Functor f, RealFrac b, Integral b) =>
f b -> f b
computesig f a
d) f a
d (f a -> f a -> I f a) -> ST s (f a) -> ST s (f a -> I f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STRef s (f a) -> ST s (f a)
forall s a. STRef s a -> ST s a
read STRef s (f a)
com ST s (f a -> I f a) -> ST s (f a) -> ST s (I f a)
forall a b. ST s (a -> b) -> ST s a -> ST s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STRef s (f a) -> ST s (f a)
forall s a. STRef s a -> ST s a
read STRef s (f a)
cur
STRef s (a, a) -> (a, a) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
write STRef s (a, a)
tot (-a
itim, a
0)
STRef s (f a) -> f a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
write STRef s (f a)
cur f a
icur
STRef s (f a) -> f a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
write STRef s (f a)
com f a
icom
(ST s [March f a] -> ST s [March f a]) -> ST s [March f a]
forall a. (a -> a) -> a
fix \ST s [March f a]
this -> do
let sig :: f Int
sig = f a -> f Int
forall {f :: * -> *} {b} {b}.
(Functor f, RealFrac b, Integral b) =>
f b -> f b
computesig f a
direction
I {a
itim :: forall (f :: * -> *) a. I f a -> a
itim :: a
itim, f a
icur :: forall (f :: * -> *) a. I f a -> f a
icur :: f a
icur, f a
icom :: forall (f :: * -> *) a. I f a -> f a
icom :: f a
icom, [f Int]
igrid :: forall (f :: * -> *) a. I f a -> [f Int]
igrid :: [f Int]
igrid} <- f Int -> f a -> f a -> f a -> I f a
inter f Int
sig f a
direction (f a -> f a -> I f a) -> ST s (f a) -> ST s (f a -> I f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STRef s (f a) -> ST s (f a)
forall s a. STRef s a -> ST s a
read STRef s (f a)
com ST s (f a -> I f a) -> ST s (f a) -> ST s (I f a)
forall a b. ST s (a -> b) -> ST s a -> ST s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STRef s (f a) -> ST s (f a)
forall s a. STRef s a -> ST s a
read STRef s (f a)
cur
(a
t, a
_) <- STRef s (a, a) -> ((a, a) -> (a, a)) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modify STRef s (a, a)
tot ((a -> a -> (a, a)) -> (a, a) -> (a, a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (a -> a -> a -> (a, a)
forall a. Num a => a -> a -> a -> (a, a)
add a
itim)) ST s () -> ST s (a, a) -> ST s (a, a)
forall a b. ST s a -> ST s b -> ST s b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> STRef s (a, a) -> ST s (a, a)
forall s a. STRef s a -> ST s a
read STRef s (a, a)
tot
STRef s (f a) -> f a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
write STRef s (f a)
cur f a
icur
STRef s (f a) -> f a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
write STRef s (f a)
com f a
icom
(a -> f a -> [f Int] -> March f a
forall (f :: * -> *) a. a -> f a -> [f Int] -> March f a
March a
t f a
icur [f Int]
igrid :) ([March f a] -> [March f a])
-> ST s [March f a] -> ST s [March f a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ST s [March f a]
this
{-# INLINEABLE march #-}
{-# SPECIALIZE march :: V3 Double -> V3 Double -> [March V3 Double] #-}
{-# SPECIALIZE march :: V3 Float -> V3 Float -> [March V3 Float] #-}