{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_HADDOCK hide #-}
module Graphics.WorldTurtle.Internal.Sequence
( Turtle
, TSC
, SequenceCommand
, defaultTSC
, processTurtle
, renderTurtle
, addPicture
, simTime
, setSimTime
, decrementSimTime
, pics
, totalSimTime
, turtles
, generateTurtle
, animate'
, animate
, combineSequence
, alternateSequence
) where
import Graphics.WorldTurtle.Internal.Turtle
import Graphics.Gloss.Data.Picture (Picture)
import Control.Applicative (empty)
import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State.Strict
import Control.Lens
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
type TurtleState = State TSC
type SequenceCommand a = MaybeT TurtleState a
newtype Turtle = Turtle Int deriving (Turtle -> Turtle -> Bool
(Turtle -> Turtle -> Bool)
-> (Turtle -> Turtle -> Bool) -> Eq Turtle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Turtle -> Turtle -> Bool
$c/= :: Turtle -> Turtle -> Bool
== :: Turtle -> Turtle -> Bool
$c== :: Turtle -> Turtle -> Bool
Eq, Eq Turtle
Eq Turtle
-> (Turtle -> Turtle -> Ordering)
-> (Turtle -> Turtle -> Bool)
-> (Turtle -> Turtle -> Bool)
-> (Turtle -> Turtle -> Bool)
-> (Turtle -> Turtle -> Bool)
-> (Turtle -> Turtle -> Turtle)
-> (Turtle -> Turtle -> Turtle)
-> Ord Turtle
Turtle -> Turtle -> Bool
Turtle -> Turtle -> Ordering
Turtle -> Turtle -> Turtle
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
min :: Turtle -> Turtle -> Turtle
$cmin :: Turtle -> Turtle -> Turtle
max :: Turtle -> Turtle -> Turtle
$cmax :: Turtle -> Turtle -> Turtle
>= :: Turtle -> Turtle -> Bool
$c>= :: Turtle -> Turtle -> Bool
> :: Turtle -> Turtle -> Bool
$c> :: Turtle -> Turtle -> Bool
<= :: Turtle -> Turtle -> Bool
$c<= :: Turtle -> Turtle -> Bool
< :: Turtle -> Turtle -> Bool
$c< :: Turtle -> Turtle -> Bool
compare :: Turtle -> Turtle -> Ordering
$ccompare :: Turtle -> Turtle -> Ordering
$cp1Ord :: Eq Turtle
Ord)
data TSC = TSC
{ TSC -> [Picture]
_pics :: ![Picture]
, TSC -> Float
_totalSimTime :: !Float
, TSC -> Map Turtle TurtleData
_turtles :: !(Map Turtle TurtleData)
, TSC -> Int
_nextTurtleId :: !Int
}
$(makeLenses ''TSC)
defaultTSC :: Float -> TSC
defaultTSC :: Float -> TSC
defaultTSC Float
givenTime = TSC :: [Picture] -> Float -> Map Turtle TurtleData -> Int -> TSC
TSC
{ _pics :: [Picture]
_pics = [Picture]
forall a. Monoid a => a
mempty
, _totalSimTime :: Float
_totalSimTime = Float
givenTime
, _turtles :: Map Turtle TurtleData
_turtles = Map Turtle TurtleData
forall k a. Map k a
Map.empty
, _nextTurtleId :: Int
_nextTurtleId = Int
0
}
simTime :: SequenceCommand Float
simTime :: SequenceCommand Float
simTime = Getting Float TSC Float -> SequenceCommand Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float TSC Float
Lens' TSC Float
totalSimTime
setSimTime :: Float
-> SequenceCommand ()
setSimTime :: Float -> SequenceCommand ()
setSimTime Float
newTime = do
let newTime' :: Float
newTime' = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
newTime
(Float -> Identity Float) -> TSC -> Identity TSC
Lens' TSC Float
totalSimTime ((Float -> Identity Float) -> TSC -> Identity TSC)
-> Float -> SequenceCommand ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Float
newTime'
Bool -> SequenceCommand () -> SequenceCommand ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
newTime' Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0) SequenceCommand ()
forall (f :: * -> *) a. Alternative f => f a
empty
decrementSimTime :: Float
-> SequenceCommand ()
decrementSimTime :: Float -> SequenceCommand ()
decrementSimTime Float
duration = SequenceCommand Float
simTime SequenceCommand Float
-> (Float -> SequenceCommand ()) -> SequenceCommand ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Float
t -> Float -> SequenceCommand ()
setSimTime (Float
t Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
duration)
addPicture :: Picture
-> SequenceCommand ()
addPicture :: Picture -> SequenceCommand ()
addPicture Picture
p = ([Picture] -> Identity [Picture]) -> TSC -> Identity TSC
Lens' TSC [Picture]
pics (([Picture] -> Identity [Picture]) -> TSC -> Identity TSC)
-> ([Picture] -> [Picture]) -> SequenceCommand ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([Picture] -> [Picture]) -> [Picture] -> [Picture]
forall a b. (a -> b) -> a -> b
($!) (Picture
p Picture -> [Picture] -> [Picture]
forall a. a -> [a] -> [a]
:)
processTurtle :: SequenceCommand a
-> TSC
-> (Maybe a, TSC)
processTurtle :: SequenceCommand a -> TSC -> (Maybe a, TSC)
processTurtle SequenceCommand a
commands TSC
tsc =
let drawS :: TurtleState (Maybe a)
drawS = SequenceCommand a -> TurtleState (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (SequenceCommand a -> TurtleState (Maybe a))
-> SequenceCommand a -> TurtleState (Maybe a)
forall a b. (a -> b) -> a -> b
$ Float -> SequenceCommand ()
decrementSimTime Float
0 SequenceCommand () -> SequenceCommand a -> SequenceCommand a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SequenceCommand a
commands
in TurtleState (Maybe a) -> TSC -> (Maybe a, TSC)
forall s a. State s a -> s -> (a, s)
runState TurtleState (Maybe a)
drawS TSC
tsc
renderTurtle :: SequenceCommand a
-> Float
-> Picture
renderTurtle :: SequenceCommand a -> Float -> Picture
renderTurtle SequenceCommand a
c Float
f = let (Maybe a
_, TSC
s) = SequenceCommand a -> TSC -> (Maybe a, TSC)
forall a. SequenceCommand a -> TSC -> (Maybe a, TSC)
processTurtle SequenceCommand a
c TSC
t
t :: TSC
t = Float -> TSC
defaultTSC Float
f
in [Picture] -> Picture
forall a. Monoid a => [a] -> a
mconcat ([Picture] -> Picture) -> [Picture] -> Picture
forall a b. (a -> b) -> a -> b
$ [Picture] -> [Picture]
forall a. [a] -> [a]
reverse (TSC
s TSC -> Getting [Picture] TSC [Picture] -> [Picture]
forall s a. s -> Getting a s a -> a
^. Getting [Picture] TSC [Picture]
Lens' TSC [Picture]
pics) [Picture] -> [Picture] -> [Picture]
forall a. [a] -> [a] -> [a]
++ Map Turtle TurtleData -> [Picture]
drawTurtles (TSC
s TSC
-> Getting (Map Turtle TurtleData) TSC (Map Turtle TurtleData)
-> Map Turtle TurtleData
forall s a. s -> Getting a s a -> a
^. Getting (Map Turtle TurtleData) TSC (Map Turtle TurtleData)
Lens' TSC (Map Turtle TurtleData)
turtles)
drawTurtles :: Map Turtle TurtleData -> [Picture]
drawTurtles :: Map Turtle TurtleData -> [Picture]
drawTurtles Map Turtle TurtleData
m = TurtleData -> Picture
drawTurtle (TurtleData -> Picture) -> [TurtleData] -> [Picture]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Turtle TurtleData -> [TurtleData]
forall k a. Map k a -> [a]
Map.elems Map Turtle TurtleData
m
generateTurtle :: SequenceCommand Turtle
generateTurtle :: SequenceCommand Turtle
generateTurtle = do
Turtle
t <- Int -> Turtle
Turtle (Int -> Turtle) -> MaybeT TurtleState Int -> SequenceCommand Turtle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting Int TSC Int -> MaybeT TurtleState Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int TSC Int
Lens' TSC Int
nextTurtleId
(Map Turtle TurtleData -> Identity (Map Turtle TurtleData))
-> TSC -> Identity TSC
Lens' TSC (Map Turtle TurtleData)
turtles ((Map Turtle TurtleData -> Identity (Map Turtle TurtleData))
-> TSC -> Identity TSC)
-> (Map Turtle TurtleData -> Map Turtle TurtleData)
-> SequenceCommand ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Turtle
-> TurtleData -> Map Turtle TurtleData -> Map Turtle TurtleData
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Turtle
t TurtleData
defaultTurtle
(Int -> Identity Int) -> TSC -> Identity TSC
Lens' TSC Int
nextTurtleId ((Int -> Identity Int) -> TSC -> Identity TSC)
-> Int -> SequenceCommand ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
1
Turtle -> SequenceCommand Turtle
forall (m :: * -> *) a. Monad m => a -> m a
return Turtle
t
animate' :: Float
-> Float
-> (Float -> SequenceCommand a)
-> SequenceCommand a
animate' :: Float -> Float -> (Float -> SequenceCommand a) -> SequenceCommand a
animate' Float
distance Float
turtleSpeed Float -> SequenceCommand a
callback =
let duration :: Float
duration = Float
distance Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
turtleSpeed
d' :: Float
d' = if Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
duration Bool -> Bool -> Bool
|| Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Float
duration then Float
0 else Float
duration
in Float -> (Float -> SequenceCommand a) -> SequenceCommand a
forall a.
Float -> (Float -> SequenceCommand a) -> SequenceCommand a
animate (Float -> Float
forall a. Num a => a -> a
abs Float
d') Float -> SequenceCommand a
callback
animate :: Float
-> (Float -> SequenceCommand a)
-> SequenceCommand a
animate :: Float -> (Float -> SequenceCommand a) -> SequenceCommand a
animate Float
duration Float -> SequenceCommand a
callback = do
Float
timeRemaining <- SequenceCommand Float
simTime
let availableTime :: Float
availableTime = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
timeRemaining Float
duration
let timeQuot :: Float
timeQuot = if Float
availableTime Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 then Float
1 else Float
availableTime Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
duration
a
t <- Float -> SequenceCommand a
callback Float
timeQuot
Float -> SequenceCommand ()
decrementSimTime Float
availableTime
a -> SequenceCommand a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t
combineSequence :: Semigroup a
=> SequenceCommand a
-> SequenceCommand a
-> SequenceCommand a
combineSequence :: SequenceCommand a -> SequenceCommand a -> SequenceCommand a
combineSequence SequenceCommand a
a SequenceCommand a
b = do
(Maybe a
aVal, Maybe a
bVal) <- SequenceCommand a
-> SequenceCommand a -> SequenceCommand (Maybe a, Maybe a)
forall a b.
SequenceCommand a
-> SequenceCommand b -> SequenceCommand (Maybe a, Maybe b)
runParallel SequenceCommand a
a SequenceCommand a
b
Maybe a -> Maybe a -> SequenceCommand a
forall (m :: * -> *) a.
(Monad m, Semigroup a, Alternative m) =>
Maybe a -> Maybe a -> m a
combo Maybe a
aVal Maybe a
bVal
where combo :: Maybe a -> Maybe a -> m a
combo (Just a
x) (Just a
y) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)
combo Maybe a
_ Maybe a
_ = m a
forall (f :: * -> *) a. Alternative f => f a
empty
alternateSequence :: SequenceCommand a
-> SequenceCommand a
-> SequenceCommand a
alternateSequence :: SequenceCommand a -> SequenceCommand a -> SequenceCommand a
alternateSequence SequenceCommand a
a SequenceCommand a
b = do
(Maybe a
aVal, Maybe a
bVal) <- SequenceCommand a
-> SequenceCommand a -> SequenceCommand (Maybe a, Maybe a)
forall a b.
SequenceCommand a
-> SequenceCommand b -> SequenceCommand (Maybe a, Maybe b)
runParallel SequenceCommand a
a SequenceCommand a
b
Maybe a -> Maybe a -> SequenceCommand a
forall (m :: * -> *) a.
(Monad m, Alternative m) =>
Maybe a -> Maybe a -> m a
combo Maybe a
aVal Maybe a
bVal
where combo :: Maybe a -> Maybe a -> m a
combo (Just a
x) Maybe a
_ = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
combo Maybe a
_ (Just a
y) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
y
combo Maybe a
_ Maybe a
_ = m a
forall (f :: * -> *) a. Alternative f => f a
empty
runParallel :: SequenceCommand a
-> SequenceCommand b
-> SequenceCommand (Maybe a, Maybe b)
runParallel :: SequenceCommand a
-> SequenceCommand b -> SequenceCommand (Maybe a, Maybe b)
runParallel SequenceCommand a
a SequenceCommand b
b = do
Float
startSimTime <- Getting Float TSC Float -> SequenceCommand Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float TSC Float
Lens' TSC Float
totalSimTime
TSC
s <- StateT TSC Identity TSC -> MaybeT TurtleState TSC
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT TSC Identity TSC
forall (m :: * -> *) s. Monad m => StateT s m s
get
let (Maybe a
aVal, TSC
s') = SequenceCommand a -> TSC -> (Maybe a, TSC)
forall a. SequenceCommand a -> TSC -> (Maybe a, TSC)
processTurtle SequenceCommand a
a TSC
s
let aSimTime :: Float
aSimTime = TSC
s' TSC -> Getting Float TSC Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float TSC Float
Lens' TSC Float
totalSimTime
let (Maybe b
bVal, TSC
s'') = SequenceCommand b -> TSC -> (Maybe b, TSC)
forall a. SequenceCommand a -> TSC -> (Maybe a, TSC)
processTurtle SequenceCommand b
b (TSC -> (Maybe b, TSC)) -> TSC -> (Maybe b, TSC)
forall a b. (a -> b) -> a -> b
$ TSC
s' TSC -> (TSC -> TSC) -> TSC
forall a b. a -> (a -> b) -> b
& (Float -> Identity Float) -> TSC -> Identity TSC
Lens' TSC Float
totalSimTime ((Float -> Identity Float) -> TSC -> Identity TSC)
-> Float -> TSC -> TSC
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Float
startSimTime
StateT TSC Identity () -> SequenceCommand ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TSC Identity () -> SequenceCommand ())
-> StateT TSC Identity () -> SequenceCommand ()
forall a b. (a -> b) -> a -> b
$ TSC -> StateT TSC Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TSC -> StateT TSC Identity ()) -> TSC -> StateT TSC Identity ()
forall a b. (a -> b) -> a -> b
$ TSC
s'' TSC -> (TSC -> TSC) -> TSC
forall a b. a -> (a -> b) -> b
& (Float -> Identity Float) -> TSC -> Identity TSC
Lens' TSC Float
totalSimTime ((Float -> Identity Float) -> TSC -> Identity TSC)
-> (Float -> Float) -> TSC -> TSC
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
aSimTime
Float -> SequenceCommand ()
decrementSimTime Float
0
(Maybe a, Maybe b) -> SequenceCommand (Maybe a, Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
aVal, Maybe b
bVal)