{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_HADDOCK hide #-}
module Graphics.WorldTurtle.Internal.Sequence
  ( Turtle 
  , TSC
  , SequenceCommand
  , SequencePause
  , defaultTSC
  , startSequence
  , resumeSequence
  , renderPause
  , decrementSimTime
  , addPicture
  , pics
  , finalPics
  , turtles
  , generateTurtle
  , animate'
  , runParallel
  ) where

import Graphics.WorldTurtle.Internal.Turtle
    ( defaultTurtle, drawTurtle, TurtleData )

import Graphics.Gloss.Data.Picture (Picture, pictures)

import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict
    ( StateT, get, put, evalStateT )

import Control.Lens
    ( (.~), (&), (+=), (^.), (%=), (.=), use, makeLenses )

import Control.Monad.Coroutine (Coroutine(..))
import Control.Monad.Coroutine.SuspensionFunctors (Request(..), request )

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 = StateT TSC IO

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

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

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

type SequenceCommand a = Coroutine (Request TSC Float) TurtleState a
type SequencePause a = Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC)

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

data TSC = TSC
  { TSC -> [Picture]
_pics :: ![Picture] -- ^ All pictures currently drawn this sequence.

  , TSC -> [Picture]
_finalPics :: ![Picture] -- ^ All pictures that have successfuly drawn in previous sequences.

  , TSC -> Float
_simTime :: !Float -- ^ Total simulation time.

  , 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 :: TSC
defaultTSC :: TSC
defaultTSC = TSC :: [Picture]
-> [Picture] -> Float -> Map Turtle TurtleData -> Int -> TSC
TSC 
           { _pics :: [Picture]
_pics = [Picture]
forall a. Monoid a => a
mempty
           , _finalPics :: [Picture]
_finalPics = [Picture]
forall a. Monoid a => a
mempty
           , _simTime :: Float
_simTime = Float
0
           , _turtles :: Map Turtle TurtleData
_turtles = Map Turtle TurtleData
forall k a. Map k a
Map.empty
           , _nextTurtleId :: Int
_nextTurtleId = Int
0
           }

-- | Attempts to reduce our simulation time by @d@. 

--   If we run out of simualtion time, this Monad whill yield,

--   allowing for a render, before it continues once again.

decrementSimTime :: Float -- ^ Decrement simulation time by this amount. 

                 -> SequenceCommand Bool -- ^ True if simulation yielded, false otherwise.

decrementSimTime :: Float -> SequenceCommand Bool
decrementSimTime Float
d = do
  Float
t <- TurtleState Float
-> Coroutine (Request TSC Float) TurtleState Float
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState Float
 -> Coroutine (Request TSC Float) TurtleState Float)
-> TurtleState Float
-> Coroutine (Request TSC Float) TurtleState Float
forall a b. (a -> b) -> a -> b
$ Getting Float TSC Float -> TurtleState Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float TSC Float
Lens' TSC Float
simTime
  let t' :: Float
t' = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
t Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
d)
  let outOfTime :: Bool
outOfTime = Float
t' Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0
  TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState () -> Coroutine (Request TSC Float) TurtleState ())
-> TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall a b. (a -> b) -> a -> b
$ (Float -> Identity Float) -> TSC -> Identity TSC
Lens' TSC Float
simTime ((Float -> Identity Float) -> TSC -> Identity TSC)
-> Float -> TurtleState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Float
t' 
  Bool
-> Coroutine (Request TSC Float) TurtleState ()
-> Coroutine (Request TSC Float) TurtleState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
outOfTime (Coroutine (Request TSC Float) TurtleState ()
 -> Coroutine (Request TSC Float) TurtleState ())
-> Coroutine (Request TSC Float) TurtleState ()
-> Coroutine (Request TSC Float) TurtleState ()
forall a b. (a -> b) -> a -> b
$ do
    --- Before we yield, take the chance to concat our final pics.

    TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState () -> Coroutine (Request TSC Float) TurtleState ())
-> TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall a b. (a -> b) -> a -> b
$ ([Picture] -> Identity [Picture]) -> TSC -> Identity TSC
Lens' TSC [Picture]
finalPics (([Picture] -> Identity [Picture]) -> TSC -> Identity TSC)
-> ([Picture] -> [Picture]) -> TurtleState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \[Picture]
f -> [[Picture] -> Picture
pictures [Picture]
f]
    -- If we have run out of time,

    -- pause the continuation to allow for

    -- a render, then resume.

    TSC
s <- StateT TSC IO TSC -> Coroutine (Request TSC Float) TurtleState TSC
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT TSC IO TSC
forall (m :: * -> *) s. Monad m => StateT s m s
get

    Float
delta <- TSC -> Coroutine (Request TSC Float) TurtleState Float
forall (m :: * -> *) x y.
Monad m =>
x -> Coroutine (Request x y) m y
request TSC
s
    TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState () -> Coroutine (Request TSC Float) TurtleState ())
-> TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall a b. (a -> b) -> a -> b
$ (Float -> Identity Float) -> TSC -> Identity TSC
Lens' TSC Float
simTime ((Float -> Identity Float) -> TSC -> Identity TSC)
-> Float -> TurtleState ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Float
delta
  Bool -> SequenceCommand Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
outOfTime

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

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

           -> SequenceCommand ()
addPicture :: Picture -> Coroutine (Request TSC Float) TurtleState ()
addPicture Picture
p = TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState () -> Coroutine (Request TSC Float) TurtleState ())
-> TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall a b. (a -> b) -> a -> b
$ ([Picture] -> Identity [Picture]) -> TSC -> Identity TSC
Lens' TSC [Picture]
pics (([Picture] -> Identity [Picture]) -> TSC -> Identity TSC)
-> ([Picture] -> [Picture]) -> TurtleState ()
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, 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).

startSequence :: TSC
              -> SequenceCommand a -- ^ Commands to execute

              -> IO (SequencePause a)
startSequence :: forall a. TSC -> SequenceCommand a -> IO (SequencePause a)
startSequence TSC
tsc SequenceCommand a
commands = StateT
  TSC
  IO
  (Either
     (Request
        TSC Float (Coroutine (Request TSC Float) TurtleState (a, TSC)))
     (a, TSC))
-> TSC
-> IO
     (Either
        (Request
           TSC Float (Coroutine (Request TSC Float) TurtleState (a, TSC)))
        (a, TSC))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Coroutine (Request TSC Float) TurtleState (a, TSC)
-> StateT
     TSC
     IO
     (Either
        (Request
           TSC Float (Coroutine (Request TSC Float) TurtleState (a, TSC)))
        (a, TSC))
forall (s :: * -> *) (m :: * -> *) r.
Coroutine s m r -> m (Either (s (Coroutine s m r)) r)
resume Coroutine (Request TSC Float) TurtleState (a, TSC)
commands') TSC
tsc
  where commands' :: Coroutine (Request TSC Float) TurtleState (a, TSC)
commands' = do
          Bool
_ <- Float -> SequenceCommand Bool
decrementSimTime Float
0 -- Kick off an immediate Yield.

          a
a <- SequenceCommand a
commands
          TSC
g <- StateT TSC IO TSC -> Coroutine (Request TSC Float) TurtleState TSC
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT TSC IO TSC
forall (m :: * -> *) s. Monad m => StateT s m s
get
          (a, TSC) -> Coroutine (Request TSC Float) TurtleState (a, TSC)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, TSC
g)

runSequence :: TSC
            -> SequenceCommand (a, TSC) -- ^ Commands to execute

            -> IO (SequencePause a)
runSequence :: forall a. TSC -> SequenceCommand (a, TSC) -> IO (SequencePause a)
runSequence TSC
tsc SequenceCommand (a, TSC)
commands = StateT
  TSC
  IO
  (Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC))
-> TSC
-> IO
     (Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (SequenceCommand (a, TSC)
-> StateT
     TSC
     IO
     (Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC))
forall (s :: * -> *) (m :: * -> *) r.
Coroutine s m r -> m (Either (s (Coroutine s m r)) r)
resume SequenceCommand (a, TSC)
commands) TSC
tsc

resumeSequence :: Float -> SequencePause a -> IO (SequencePause a)
resumeSequence :: forall a. Float -> SequencePause a -> IO (SequencePause a)
resumeSequence Float
delta (Left (Request TSC
tsc Float -> SequenceCommand (a, TSC)
response)) = TSC
-> SequenceCommand (a, TSC)
-> IO
     (Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC))
forall a. TSC -> SequenceCommand (a, TSC) -> IO (SequencePause a)
runSequence TSC
tsc (SequenceCommand (a, TSC)
 -> IO
      (Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC)))
-> SequenceCommand (a, TSC)
-> IO
     (Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC))
forall a b. (a -> b) -> a -> b
$ Float -> SequenceCommand (a, TSC)
response Float
delta
resumeSequence Float
_ Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC)
a = Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC)
-> IO
     (Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Request TSC Float (SequenceCommand (a, TSC))) (a, TSC)
a

renderPause :: SequencePause a -> Picture
renderPause :: forall a. SequencePause a -> Picture
renderPause SequencePause a
sq = TSC -> Picture
renderTurtle (TSC -> Picture) -> TSC -> Picture
forall a b. (a -> b) -> a -> b
$ SequencePause a -> TSC
forall a. SequencePause a -> TSC
stateForPause SequencePause a
sq

stateForPause :: SequencePause a -> TSC
stateForPause :: forall a. SequencePause a -> TSC
stateForPause (Left (Request TSC
s Float -> SequenceCommand (a, TSC)
_)) = TSC
s
stateForPause (Right (a
_, TSC
s)) = TSC
s

-- | Exctracts the image frame from the current turtle state.

renderTurtle :: TSC -> Picture
renderTurtle :: TSC -> Picture
renderTurtle TSC
t = [Picture] -> Picture
forall a. Monoid a => [a] -> a
mconcat ([Picture] -> Picture) -> [Picture] -> Picture
forall a b. (a -> b) -> a -> b
$ 
  (TSC
t TSC -> Getting [Picture] TSC [Picture] -> [Picture]
forall s a. s -> Getting a s a -> a
^. Getting [Picture] TSC [Picture]
Lens' TSC [Picture]
finalPics) [Picture] -> [Picture] -> [Picture]
forall a. [a] -> [a] -> [a]
++
  (TSC
t 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
t 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 = TurtleState Turtle -> SequenceCommand Turtle
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState Turtle -> SequenceCommand Turtle)
-> TurtleState Turtle -> SequenceCommand Turtle
forall a b. (a -> b) -> a -> b
$ do
  Turtle
t <- Int -> Turtle
Turtle (Int -> Turtle) -> TurtleState Int -> TurtleState Turtle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting Int TSC Int -> 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)
-> TurtleState ()
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 -> TurtleState ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
1
  Turtle -> TurtleState Turtle
forall (m :: * -> *) a. Monad m => a -> m a
return Turtle
t

animate' :: Float 
         -> Float 
         -> (Float -> SequenceCommand a) 
         -> SequenceCommand a
animate' :: forall a.
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 do 
    a
t <- 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
    -- If we reach this point, then a "full" animation

    -- has completed successfully. We move the drawn images

    -- from our temp pics list to our finalPics list, and 

    -- empty the temp pics list.

    TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState () -> Coroutine (Request TSC Float) TurtleState ())
-> TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall a b. (a -> b) -> a -> b
$ do
      [Picture]
p <- Getting [Picture] TSC [Picture] -> TurtleState [Picture]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [Picture] TSC [Picture]
Lens' TSC [Picture]
pics
      ([Picture] -> Identity [Picture]) -> TSC -> Identity TSC
Lens' TSC [Picture]
finalPics (([Picture] -> Identity [Picture]) -> TSC -> Identity TSC)
-> ([Picture] -> [Picture]) -> TurtleState ()
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] -> [Picture] -> [Picture]
forall a. [a] -> [a] -> [a]
++ [Picture]
p)
      ([Picture] -> Identity [Picture]) -> TSC -> Identity TSC
Lens' TSC [Picture]
pics (([Picture] -> Identity [Picture]) -> TSC -> Identity TSC)
-> [Picture] -> TurtleState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [Picture]
forall a. Monoid a => a
mempty
    a -> SequenceCommand a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t

animate :: Float 
        -> (Float -> SequenceCommand a) 
        -> SequenceCommand a
animate :: forall a.
Float -> (Float -> SequenceCommand a) -> SequenceCommand a
animate Float
duration Float -> SequenceCommand a
callback = do
  TSC
oldState <- StateT TSC IO TSC -> Coroutine (Request TSC Float) TurtleState TSC
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT TSC IO TSC
forall (m :: * -> *) s. Monad m => StateT s m s
get

  Float
timeRemaining <- TurtleState Float
-> Coroutine (Request TSC Float) TurtleState Float
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState Float
 -> Coroutine (Request TSC Float) TurtleState Float)
-> TurtleState Float
-> Coroutine (Request TSC Float) TurtleState Float
forall a b. (a -> b) -> a -> b
$ Getting Float TSC Float -> TurtleState Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float TSC Float
Lens' TSC 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

  Bool
outOfTime <- Float -> SequenceCommand Bool
decrementSimTime Float
availableTime

    -- When out of time has occurred, all progress that has been made this `animate` call

    -- is thrown away after being drawn. We re-attempt the animation, with more simulation

    -- time available so that the sequence goes "further."

  if Bool
outOfTime then do
      let oldTime :: Float
oldTime = TSC
oldState TSC -> Getting Float TSC Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float TSC Float
Lens' TSC Float
simTime
      Float
newTime <- TurtleState Float
-> Coroutine (Request TSC Float) TurtleState Float
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState Float
 -> Coroutine (Request TSC Float) TurtleState Float)
-> TurtleState Float
-> Coroutine (Request TSC Float) TurtleState Float
forall a b. (a -> b) -> a -> b
$ Getting Float TSC Float -> TurtleState Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float TSC Float
Lens' TSC Float
simTime
      let time :: Float
time = Float
newTime Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
oldTime
      TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState () -> Coroutine (Request TSC Float) TurtleState ())
-> TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall a b. (a -> b) -> a -> b
$ TSC -> TurtleState ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TSC -> TurtleState ()) -> TSC -> TurtleState ()
forall a b. (a -> b) -> a -> b
$ TSC
oldState TSC -> (TSC -> TSC) -> TSC
forall a b. a -> (a -> b) -> b
& (Float -> Identity Float) -> TSC -> Identity TSC
Lens' TSC Float
simTime ((Float -> Identity Float) -> TSC -> Identity TSC)
-> Float -> TSC -> TSC
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Float
time
      Float -> (Float -> SequenceCommand a) -> SequenceCommand a
forall a.
Float -> (Float -> SequenceCommand a) -> SequenceCommand a
animate Float
duration Float -> SequenceCommand a
callback
    else 
      a -> SequenceCommand a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t


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

--   animations, run them both in parallel!

runParallel :: (a -> b -> SequenceCommand c)
            -> SequenceCommand a -- ^ Sequence /a/ to run.

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

            -> SequenceCommand c
               -- ^ New sequence of A and B which returns both results.

runParallel :: forall a b c.
(a -> b -> SequenceCommand c)
-> SequenceCommand a -> SequenceCommand b -> SequenceCommand c
runParallel a -> b -> SequenceCommand c
f SequenceCommand a
a SequenceCommand b
b = 
  let a' :: Coroutine (Request TSC Float) TurtleState (a, TSC)
a' = SequenceCommand a
a SequenceCommand a
-> (a -> Coroutine (Request TSC Float) TurtleState (a, TSC))
-> Coroutine (Request TSC Float) TurtleState (a, TSC)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
ax -> StateT TSC IO TSC -> Coroutine (Request TSC Float) TurtleState TSC
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT TSC IO TSC
forall (m :: * -> *) s. Monad m => StateT s m s
get Coroutine (Request TSC Float) TurtleState TSC
-> (TSC -> Coroutine (Request TSC Float) TurtleState (a, TSC))
-> Coroutine (Request TSC Float) TurtleState (a, TSC)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TSC
g -> (a, TSC) -> Coroutine (Request TSC Float) TurtleState (a, TSC)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
ax, TSC
g)
      b' :: Coroutine (Request TSC Float) TurtleState (b, TSC)
b' = SequenceCommand b
b SequenceCommand b
-> (b -> Coroutine (Request TSC Float) TurtleState (b, TSC))
-> Coroutine (Request TSC Float) TurtleState (b, TSC)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
bx -> StateT TSC IO TSC -> Coroutine (Request TSC Float) TurtleState TSC
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT TSC IO TSC
forall (m :: * -> *) s. Monad m => StateT s m s
get Coroutine (Request TSC Float) TurtleState TSC
-> (TSC -> Coroutine (Request TSC Float) TurtleState (b, TSC))
-> Coroutine (Request TSC Float) TurtleState (b, TSC)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TSC
g -> (b, TSC) -> Coroutine (Request TSC Float) TurtleState (b, TSC)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
bx, TSC
g)
   in (a -> b -> SequenceCommand c)
-> Coroutine (Request TSC Float) TurtleState (a, TSC)
-> Coroutine (Request TSC Float) TurtleState (b, TSC)
-> SequenceCommand c
forall a b c.
(a -> b -> SequenceCommand c)
-> SequenceCommand (a, TSC)
-> SequenceCommand (b, TSC)
-> SequenceCommand c
runParallel_ a -> b -> SequenceCommand c
f Coroutine (Request TSC Float) TurtleState (a, TSC)
a' Coroutine (Request TSC Float) TurtleState (b, TSC)
b' 

-- | Main body for parallel animations. Runs one sequence, rewinds, then 

--   runs the other sequence, we then attempt to continue our calculations.

runParallel_ :: (a -> b -> SequenceCommand c)
            -> SequenceCommand (a, TSC) -- ^ Sequence /a/ to run.

            -> SequenceCommand (b, TSC) -- ^ Sequence /b/ to run.

            -> SequenceCommand c
               -- ^ New sequence of A and B which returns both results.

runParallel_ :: forall a b c.
(a -> b -> SequenceCommand c)
-> SequenceCommand (a, TSC)
-> SequenceCommand (b, TSC)
-> SequenceCommand c
runParallel_ a -> b -> SequenceCommand c
f SequenceCommand (a, TSC)
a SequenceCommand (b, TSC)
b = do
  Float
startSimTime <- TurtleState Float
-> Coroutine (Request TSC Float) TurtleState Float
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState Float
 -> Coroutine (Request TSC Float) TurtleState Float)
-> TurtleState Float
-> Coroutine (Request TSC Float) TurtleState Float
forall a b. (a -> b) -> a -> b
$ Getting Float TSC Float -> TurtleState Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float TSC Float
Lens' TSC Float
simTime
  TSC
s <- StateT TSC IO TSC -> Coroutine (Request TSC Float) TurtleState TSC
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT TSC IO TSC
forall (m :: * -> *) s. Monad m => StateT s m s
get
  
  -- Run the "A" animation

  SequencePause a
aVal <- IO (SequencePause a)
-> Coroutine (Request TSC Float) TurtleState (SequencePause a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SequencePause a)
 -> Coroutine (Request TSC Float) TurtleState (SequencePause a))
-> IO (SequencePause a)
-> Coroutine (Request TSC Float) TurtleState (SequencePause a)
forall a b. (a -> b) -> a -> b
$ TSC -> SequenceCommand (a, TSC) -> IO (SequencePause a)
forall a. TSC -> SequenceCommand (a, TSC) -> IO (SequencePause a)
runSequence TSC
s SequenceCommand (a, TSC)
a
  let s' :: TSC
s' = SequencePause a -> TSC
forall {request} {response} {x} {a}.
Either (Request request response x) (a, request) -> request
grabState SequencePause a
aVal
  let aTime :: Float
aTime = TSC
s' TSC -> Getting Float TSC Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float TSC Float
Lens' TSC Float
simTime

  -- Run the "B" animation, with a reset time.

  let s'' :: TSC
s'' = TSC
s' TSC -> (TSC -> TSC) -> TSC
forall a b. a -> (a -> b) -> b
& (Float -> Identity Float) -> TSC -> Identity TSC
Lens' TSC Float
simTime ((Float -> Identity Float) -> TSC -> Identity TSC)
-> Float -> TSC -> TSC
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Float
startSimTime
  SequencePause b
bVal <- IO (SequencePause b)
-> Coroutine (Request TSC Float) TurtleState (SequencePause b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SequencePause b)
 -> Coroutine (Request TSC Float) TurtleState (SequencePause b))
-> IO (SequencePause b)
-> Coroutine (Request TSC Float) TurtleState (SequencePause b)
forall a b. (a -> b) -> a -> b
$ TSC -> SequenceCommand (b, TSC) -> IO (SequencePause b)
forall a. TSC -> SequenceCommand (a, TSC) -> IO (SequencePause a)
runSequence TSC
s'' SequenceCommand (b, TSC)
b
  let s''' :: TSC
s''' = SequencePause b -> TSC
forall {request} {response} {x} {a}.
Either (Request request response x) (a, request) -> request
grabState SequencePause b
bVal
  let bTime :: Float
bTime = TSC
s''' TSC -> Getting Float TSC Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float TSC Float
Lens' TSC Float
simTime

  -- Test to see if we need to yield.

  let elapsedTime :: Float
elapsedTime = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
aTime Float
bTime
  TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState () -> Coroutine (Request TSC Float) TurtleState ())
-> TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall a b. (a -> b) -> a -> b
$ TSC -> TurtleState ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TSC
s''' TSC -> (TSC -> TSC) -> TSC
forall a b. a -> (a -> b) -> b
& (Float -> Identity Float) -> TSC -> Identity TSC
Lens' TSC Float
simTime ((Float -> Identity Float) -> TSC -> Identity TSC)
-> Float -> TSC -> TSC
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Float
elapsedTime)
  Bool
outOfTime <- Float -> SequenceCommand Bool
decrementSimTime Float
0
  
  -- If we were out of time, redo the operation.

  Float
newTime <- TurtleState Float
-> Coroutine (Request TSC Float) TurtleState Float
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState Float
 -> Coroutine (Request TSC Float) TurtleState Float)
-> TurtleState Float
-> Coroutine (Request TSC Float) TurtleState Float
forall a b. (a -> b) -> a -> b
$ Getting Float TSC Float -> TurtleState Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float TSC Float
Lens' TSC Float
simTime
  if Bool
outOfTime then do
    let time :: Float
time = Float
newTime Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
startSimTime
    TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TurtleState () -> Coroutine (Request TSC Float) TurtleState ())
-> TurtleState () -> Coroutine (Request TSC Float) TurtleState ()
forall a b. (a -> b) -> a -> b
$ TSC -> TurtleState ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TSC -> TurtleState ()) -> TSC -> TurtleState ()
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
simTime ((Float -> Identity Float) -> TSC -> Identity TSC)
-> Float -> TSC -> TSC
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Float
time
    (a -> b -> SequenceCommand c)
-> SequenceCommand (a, TSC)
-> SequenceCommand (b, TSC)
-> SequenceCommand c
forall a b c.
(a -> b -> SequenceCommand c)
-> SequenceCommand (a, TSC)
-> SequenceCommand (b, TSC)
-> SequenceCommand c
runParallel_ a -> b -> SequenceCommand c
f SequenceCommand (a, TSC)
a SequenceCommand (b, TSC)
b
  else do
    (a -> b -> SequenceCommand c)
-> Float -> SequencePause a -> SequencePause b -> SequenceCommand c
forall a b c.
(a -> b -> SequenceCommand c)
-> Float -> SequencePause a -> SequencePause b -> SequenceCommand c
combinePauses_ a -> b -> SequenceCommand c
f Float
newTime SequencePause a
aVal SequencePause b
bVal

  where grabState :: Either (Request request response x) (a, request) -> request
grabState (Left (Request request
s response -> x
_)) = request
s
        grabState (Right (a
_, request
s)) = request
s

combinePauses_ :: (a -> b ->  SequenceCommand c) -> Float -> SequencePause a -> SequencePause b -> SequenceCommand c
combinePauses_ :: forall a b c.
(a -> b -> SequenceCommand c)
-> Float -> SequencePause a -> SequencePause b -> SequenceCommand c
combinePauses_ a -> b -> SequenceCommand c
f Float
_ (Right (a
a, TSC
_)) (Right (b
b, TSC
_)) = a -> b -> SequenceCommand c
f a
a b
b
combinePauses_ a -> b -> SequenceCommand c
f Float
d (Right (a
a, TSC
_)) (Left (Request TSC
_ Float -> SequenceCommand (b, TSC)
y)) = Float -> SequenceCommand (b, TSC)
y Float
d SequenceCommand (b, TSC)
-> ((b, TSC) -> SequenceCommand c) -> SequenceCommand c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> b -> SequenceCommand c
f a
a (b -> SequenceCommand c)
-> ((b, TSC) -> b) -> (b, TSC) -> SequenceCommand c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, TSC) -> b
forall a b. (a, b) -> a
fst
combinePauses_ a -> b -> SequenceCommand c
f Float
d (Left (Request TSC
_ Float -> SequenceCommand (a, TSC)
x)) (Right (b
b, TSC
_)) = Float -> SequenceCommand (a, TSC)
x Float
d SequenceCommand (a, TSC)
-> ((a, TSC) -> SequenceCommand c) -> SequenceCommand c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> b -> SequenceCommand c
`f` b
b) (a -> SequenceCommand c)
-> ((a, TSC) -> a) -> (a, TSC) -> SequenceCommand c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, TSC) -> a
forall a b. (a, b) -> a
fst
combinePauses_ a -> b -> SequenceCommand c
f Float
d (Left (Request TSC
_ Float -> SequenceCommand (a, TSC)
x)) (Left (Request TSC
_ Float -> SequenceCommand (b, TSC)
y)) = (a -> b -> SequenceCommand c)
-> SequenceCommand (a, TSC)
-> SequenceCommand (b, TSC)
-> SequenceCommand c
forall a b c.
(a -> b -> SequenceCommand c)
-> SequenceCommand (a, TSC)
-> SequenceCommand (b, TSC)
-> SequenceCommand c
runParallel_ a -> b -> SequenceCommand c
f (Float -> SequenceCommand (a, TSC)
x Float
d) (Float -> SequenceCommand (b, TSC)
y Float
d)