{-# 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

-- | State Monad that takes our `TSC` type as its state object.

type TurtleState = State TSC

-- | Maybe Monad on top of the State Monad of form @SequenceCommand a@.

--   This represents a computation that can be "partial." I.E. we can only 

--   animate so much of the scene with the time given.

type SequenceCommand a = MaybeT TurtleState a

-- Careful of editing the Turtle comment below as it is public docs!

-- Really "Turtle" is just a handle to internal TurtleData. It is a key that

-- looks up TurtleData in a map. Since Turtle is exposed to the user-level we 

-- do not document it in this way however.


-- | The Turtle that is drawn on the canvas! Create a new turtle using 

-- `Graphics.WorldTurtle.Commands.makeTurtle`.

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] -- ^ All pictures that make up the current canvas

  , TSC -> Float
_totalSimTime :: !Float -- ^ Remaining available for animating

  , TSC -> Map Turtle TurtleData
_turtles :: !(Map Turtle TurtleData) -- Collection of all turtles.

  , TSC -> Int
_nextTurtleId :: !Int -- ^ ID of next turtle to be generated.

  }

$(makeLenses ''TSC)

-- | Generates default parameter arguments.

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
           }

-- | Gets the remaining simulation time of the current turtle process.

-- The simulation time dictates how much time is remaining for an animation,

-- and it will be reduced as the animations play in sequence. Once this value

-- hits 0 the exit command will be called and the monad will stop processing.

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

-- | Sets the simulation time in the state monad.

-- If the simulation time is <= 0 then this setter will immediately call the

-- exit function which will kill any further processing of the monad.

setSimTime :: Float -- ^ Time to set.

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

-- | Takes a value away form the current sim time and store the updated time.

-- See `setSimTime`.

decrementSimTime :: Float -- ^ Value to subtract from store simulation time.

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

-- | Given a picture, adds it to the picture list.

addPicture :: Picture -- ^ Picture to add to our animation

           -> 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]
:)

-- | Given a sequence and a State, returns the result of the computation and the

--   final state of the computation of form @(r, s)@. When @r@ is @Just@, then 

--   the computation completed, otherwise the computation ended early due to

--   lack of time available (i.e. a partial animation).

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

-- | Given a computation to run and an amount of time to run it in, renders the

--   final "picture".

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
       --  if speed is 0 we use this as a "no animation" command from 

       --   user-space.

     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 -- simulation time to go

   let availableTime :: Float
availableTime = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
timeRemaining Float
duration
   --  Amount of time we have to complete the animation before we need to exit.

   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
   --  quotient of available time vs required time. Note that when the duration

   --   is 0 we say "don't do any animation"

   a
t <- Float -> SequenceCommand a
callback Float
timeQuot 
   --  Perform the calculation with the quotient for lerping

   Float -> SequenceCommand ()
decrementSimTime Float
availableTime
   --  Test to see if this is the end of our animation and if so exit early

   a -> SequenceCommand a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t

-- | Runs two items in parallel then applies a semigroup combination operator

--   to the result of both.

--   This combination can only return if both A and B return. Compare to 

--   `alternateSequence` which can return if one returns.

combineSequence :: Semigroup a
                => SequenceCommand a -- ^ Sequence /a/ to run.

                -> SequenceCommand a -- ^ Sequence /b/ to run.

                -> SequenceCommand a 
                    -- ^ New sequence of A and B in parallel.

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

-- | Runs two items in sequence, returns the result of /a/ if /a/ passes,

--   otherwise returns the results of /b/. The implication of this is that only

--   the result of a will be returned while animating, and b when animation is

--   finished.

alternateSequence :: SequenceCommand a -- ^ Sequence /a/ to run.

                  -> SequenceCommand a -- ^ Sequence /b/ to run.

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

-- | Given two sequences /a/ and /b/, instead of running them both as separate 

--   animations, run them both in parallel!

runParallel :: SequenceCommand a -- ^ Sequence /a/ to run.

            -> SequenceCommand b -- ^ Sequence /b/ to run.

            -> SequenceCommand (Maybe a, Maybe b)
               -- ^ New sequence of A and B which returns both results.

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
  -- Run the "A" animation

  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

  -- Run the "B" animation from the same time

  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
  -- No subsequent animation can proceed until the longest animation completes.

  -- We take the remaining animation time to be the remaining time of the 

  -- longest running animation

  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
  
  -- Now we must test the remaining sim time. The above calls might have

  -- succeeded while still exhausting our remaining time -- which as far as

  -- animating is concerned is the same as not succeeding at all!

  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)