{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
module Graphics.WorldTurtle.Internal.Sequence
  ( Turtle 
  , TSC
  , SequenceCommand
  , AlmostVal
  , renderTurtle
  , addPicture
  , simTime
  , setSimTime
  , decrementSimTime
  , pics
  , totalSimTime
  , turtles
  , generateTurtle
  , animate'
  , animate
  , combineSequence
  , alternateSequence
  , failSequence
  ) where

import Graphics.WorldTurtle.Internal.Turtle

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

import Control.Monad.Cont
import Control.Monad.State

import Control.Lens

import Data.Void (Void, absurd)
import Data.Maybe (isNothing, isJust)

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

-- | AlmostVal represents a computation that can "almost" complete. Either

--   There is enough time to solve the computation, or the computation needs

--   to exit early as there is not enough time to fully run the computation.

type AlmostVal a = Maybe a

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

type TurtleState b = State (TSC b)

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

--   /b/ is the final return type of the entire Monad sequence - this is what 

--   will be returned if/when we need to exit early from anywhere in a great big

--   sequence of steps. /a/ is the return type of the current step of the 

--   animation sequence. That is: what will be passed into the next step.

type SequenceCommand b a = ContT b (TurtleState b) 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 b = TSC
  { TSC b -> [Picture]
_pics :: ![Picture] -- ^ All pictures that make up the current canvas

  , TSC b -> SequenceCommand b b
_exitCall :: SequenceCommand b b -- ^ Stop drawing call for animations

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

  , TSC b -> Map Turtle TurtleData
_turtles :: Map Turtle TurtleData  -- Collection of all turtles.

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

  }

$(makeLenses ''TSC)

-- | Generates default parameter arguments. The TSC returned by this value

-- must never be used for sequencing as the exitCall is undefined and will only

-- be defined in the setup stage of the animation process.

defaultTSC :: Float -> TSC b
defaultTSC :: Float -> TSC b
defaultTSC Float
givenTime = TSC :: forall b.
[Picture]
-> SequenceCommand b b
-> Float
-> Map Turtle TurtleData
-> Int
-> TSC b
TSC 
           { _pics :: [Picture]
_pics = []
           , _totalSimTime :: Float
_totalSimTime = Float
givenTime
           , _exitCall :: SequenceCommand b b
_exitCall = [Char] -> SequenceCommand b b
forall a. HasCallStack => [Char] -> a
error [Char]
"Exit called but not defined in animation."
           , _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 b Float
simTime :: SequenceCommand b Float
simTime = Getting Float (TSC b) Float -> SequenceCommand b Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float (TSC b) Float
forall b. Lens' (TSC b) 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 -> SequenceCommand b ()
setSimTime :: Float -> SequenceCommand b ()
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 b -> Identity (TSC b)
forall b. Lens' (TSC b) Float
totalSimTime ((Float -> Identity Float) -> TSC b -> Identity (TSC b))
-> Float -> SequenceCommand b ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Float
newTime'
  Bool -> SequenceCommand b () -> SequenceCommand b ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
newTime' Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0) SequenceCommand b ()
forall b a. SequenceCommand b a
failSequence

-- | 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 b ()
decrementSimTime :: Float -> SequenceCommand b ()
decrementSimTime Float
duration = SequenceCommand b Float
forall b. SequenceCommand b Float
simTime SequenceCommand b Float
-> (Float -> SequenceCommand b ()) -> SequenceCommand b ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Float -> SequenceCommand b ()
forall b. Float -> SequenceCommand b ()
setSimTime (Float -> SequenceCommand b ())
-> (Float -> Float) -> Float -> SequenceCommand b ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Float -> Float -> Float) -> Float -> Float -> Float
forall a b c. (a -> b -> c) -> b -> a -> c
flip (-) Float
duration)

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

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

           -> SequenceCommand b ()
addPicture :: Picture -> SequenceCommand b ()
addPicture Picture
p = ([Picture] -> Identity [Picture]) -> TSC b -> Identity (TSC b)
forall b. Lens' (TSC b) [Picture]
pics (([Picture] -> Identity [Picture]) -> TSC b -> Identity (TSC b))
-> ([Picture] -> [Picture]) -> SequenceCommand b ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Picture
p Picture -> [Picture] -> [Picture]
forall a. a -> [a] -> [a]
:)

-- | Never call an animation directly, always call this instead!

-- This is part of our setup stage to inject the exit call into the animation

-- before running the animation. What is returned by this class is either

-- the completed animation or an early exit. 

--

-- We take our command and an exit call, and store the exit in the state monad 

-- then execute the command.

-- The return value is either a `Nothing` which means the exit was called early

-- or a `Just a` which is the monad successfully completed.

exitCondition :: SequenceCommand (AlmostVal a) a -- ^ Animation passed in.

              -> SequenceCommand (AlmostVal a) (AlmostVal a)
exitCondition :: SequenceCommand (AlmostVal a) a
-> SequenceCommand (AlmostVal a) (AlmostVal a)
exitCondition SequenceCommand (AlmostVal a) a
commands = ((AlmostVal a -> SequenceCommand (AlmostVal a) (AlmostVal a))
 -> SequenceCommand (AlmostVal a) (AlmostVal a))
-> SequenceCommand (AlmostVal a) (AlmostVal a)
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (((AlmostVal a -> SequenceCommand (AlmostVal a) (AlmostVal a))
  -> SequenceCommand (AlmostVal a) (AlmostVal a))
 -> SequenceCommand (AlmostVal a) (AlmostVal a))
-> ((AlmostVal a -> SequenceCommand (AlmostVal a) (AlmostVal a))
    -> SequenceCommand (AlmostVal a) (AlmostVal a))
-> SequenceCommand (AlmostVal a) (AlmostVal a)
forall a b. (a -> b) -> a -> b
$ \AlmostVal a -> SequenceCommand (AlmostVal a) (AlmostVal a)
exit -> do
    (SequenceCommand (AlmostVal a) (AlmostVal a)
 -> Identity (SequenceCommand (AlmostVal a) (AlmostVal a)))
-> TSC (AlmostVal a) -> Identity (TSC (AlmostVal a))
forall b b.
Lens (TSC b) (TSC b) (SequenceCommand b b) (SequenceCommand b b)
exitCall ((SequenceCommand (AlmostVal a) (AlmostVal a)
  -> Identity (SequenceCommand (AlmostVal a) (AlmostVal a)))
 -> TSC (AlmostVal a) -> Identity (TSC (AlmostVal a)))
-> SequenceCommand (AlmostVal a) (AlmostVal a)
-> ContT (AlmostVal a) (TurtleState (AlmostVal a)) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= AlmostVal a -> SequenceCommand (AlmostVal a) (AlmostVal a)
exit AlmostVal a
forall a. Maybe a
Nothing
    Float -> ContT (AlmostVal a) (TurtleState (AlmostVal a)) ()
forall b. Float -> SequenceCommand b ()
decrementSimTime Float
0 -- In case we are already at a time of 0.

    a -> AlmostVal a
forall a. a -> Maybe a
Just (a -> AlmostVal a)
-> SequenceCommand (AlmostVal a) a
-> SequenceCommand (AlmostVal a) (AlmostVal a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SequenceCommand (AlmostVal a) a
commands

processTurtle :: SequenceCommand (AlmostVal a) a 
              -> TSC (AlmostVal a)
              -> (AlmostVal a, TSC (AlmostVal a))
processTurtle :: SequenceCommand (AlmostVal a) a
-> TSC (AlmostVal a) -> (AlmostVal a, TSC (AlmostVal a))
processTurtle SequenceCommand (AlmostVal a) a
commands TSC (AlmostVal a)
tsc = 
  let drawS :: TurtleState (AlmostVal a) (AlmostVal a)
drawS = ContT (AlmostVal a) (TurtleState (AlmostVal a)) (AlmostVal a)
-> (AlmostVal a -> TurtleState (AlmostVal a) (AlmostVal a))
-> TurtleState (AlmostVal a) (AlmostVal a)
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT (SequenceCommand (AlmostVal a) a
-> ContT (AlmostVal a) (TurtleState (AlmostVal a)) (AlmostVal a)
forall a.
SequenceCommand (AlmostVal a) a
-> SequenceCommand (AlmostVal a) (AlmostVal a)
exitCondition SequenceCommand (AlmostVal a) a
commands) AlmostVal a -> TurtleState (AlmostVal a) (AlmostVal a)
forall (m :: * -> *) a. Monad m => a -> m a
return
   in TurtleState (AlmostVal a) (AlmostVal a)
-> TSC (AlmostVal a) -> (AlmostVal a, TSC (AlmostVal a))
forall s a. State s a -> s -> (a, s)
runState TurtleState (AlmostVal a) (AlmostVal a)
drawS TSC (AlmostVal a)
tsc

renderTurtle :: SequenceCommand (AlmostVal a) a -> Float ->  Picture
renderTurtle :: SequenceCommand (AlmostVal a) a -> Float -> Picture
renderTurtle SequenceCommand (AlmostVal a) a
c Float
f = let (AlmostVal a
_, TSC (AlmostVal a)
s) = SequenceCommand (AlmostVal a) a
-> TSC (AlmostVal a) -> (AlmostVal a, TSC (AlmostVal a))
forall a.
SequenceCommand (AlmostVal a) a
-> TSC (AlmostVal a) -> (AlmostVal a, TSC (AlmostVal a))
processTurtle SequenceCommand (AlmostVal a) a
c (Float -> TSC (AlmostVal a)
forall b. Float -> TSC b
defaultTSC Float
f)
                    in [Picture] -> Picture
pictures ([Picture] -> Picture) -> [Picture] -> Picture
forall a b. (a -> b) -> a -> b
$ TSC (AlmostVal a)
s TSC (AlmostVal a)
-> Getting [Picture] (TSC (AlmostVal a)) [Picture] -> [Picture]
forall s a. s -> Getting a s a -> a
^. Getting [Picture] (TSC (AlmostVal a)) [Picture]
forall b. Lens' (TSC b) [Picture]
pics [Picture] -> [Picture] -> [Picture]
forall a. [a] -> [a] -> [a]
++ Map Turtle TurtleData -> [Picture]
drawTurtles (TSC (AlmostVal a)
s TSC (AlmostVal a)
-> Getting
     (Map Turtle TurtleData) (TSC (AlmostVal a)) (Map Turtle TurtleData)
-> Map Turtle TurtleData
forall s a. s -> Getting a s a -> a
^. Getting
  (Map Turtle TurtleData) (TSC (AlmostVal a)) (Map Turtle TurtleData)
forall b. Lens' (TSC b) (Map Turtle TurtleData)
turtles)

drawTurtles :: Map Turtle TurtleData -> [Picture]
drawTurtles :: Map Turtle TurtleData -> [Picture]
drawTurtles Map Turtle TurtleData
m = (TurtleData -> Picture) -> [TurtleData] -> [Picture]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TurtleData -> Picture
drawTurtle ([TurtleData] -> [Picture]) -> [TurtleData] -> [Picture]
forall a b. (a -> b) -> a -> b
$ Map Turtle TurtleData -> [TurtleData]
forall k a. Map k a -> [a]
Map.elems Map Turtle TurtleData
m 

generateTurtle :: SequenceCommand b Turtle
generateTurtle :: SequenceCommand b Turtle
generateTurtle = do
  Turtle
t <- Int -> Turtle
Turtle (Int -> Turtle)
-> ContT b (TurtleState b) Int -> SequenceCommand b Turtle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting Int (TSC b) Int -> ContT b (TurtleState b) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int (TSC b) Int
forall b. Lens' (TSC b) Int
nextTurtleId
  (Map Turtle TurtleData -> Identity (Map Turtle TurtleData))
-> TSC b -> Identity (TSC b)
forall b. Lens' (TSC b) (Map Turtle TurtleData)
turtles ((Map Turtle TurtleData -> Identity (Map Turtle TurtleData))
 -> TSC b -> Identity (TSC b))
-> (Map Turtle TurtleData -> Map Turtle TurtleData)
-> ContT b (TurtleState b) ()
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 b -> Identity (TSC b)
forall b. Lens' (TSC b) Int
nextTurtleId ((Int -> Identity Int) -> TSC b -> Identity (TSC b))
-> Int -> ContT b (TurtleState b) ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
1
  Turtle -> SequenceCommand b Turtle
forall (m :: * -> *) a. Monad m => a -> m a
return Turtle
t

animate' :: Float 
         -> Float 
         -> (Float -> SequenceCommand b a) 
         -> SequenceCommand b a
animate' :: Float
-> Float -> (Float -> SequenceCommand b a) -> SequenceCommand b a
animate' !Float
distance !Float
turtleSpeed Float -> SequenceCommand b 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 b a) -> SequenceCommand b a
forall b a.
Float -> (Float -> SequenceCommand b a) -> SequenceCommand b a
animate (Float -> Float
forall a. Num a => a -> a
abs Float
d') Float -> SequenceCommand b a
callback

animate :: Float -> (Float -> SequenceCommand b a) -> SequenceCommand b a
animate :: Float -> (Float -> SequenceCommand b a) -> SequenceCommand b a
animate !Float
duration Float -> SequenceCommand b a
callback = do
   Float
timeRemaining <- SequenceCommand b Float
forall b. SequenceCommand b 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 b a
callback Float
timeQuot 
   --  Perform the calculation with the quotient for lerping

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

   a -> SequenceCommand b 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 b a -- ^ Sequence /a/ to run.

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

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

combineSequence :: SequenceCommand b a -> SequenceCommand b a -> SequenceCommand b a
combineSequence SequenceCommand b a
a SequenceCommand b a
b = do
  (!AlmostVal a
aVal, !AlmostVal a
bVal) <- SequenceCommand b a
-> SequenceCommand b a
-> SequenceCommand b (AlmostVal a, AlmostVal a)
forall c a b.
SequenceCommand c a
-> SequenceCommand c b
-> SequenceCommand c (AlmostVal a, AlmostVal b)
runParallel SequenceCommand b a
a SequenceCommand b a
b
  -- If either attempt failed, we fail also.

  Bool -> ContT b (TurtleState b) () -> ContT b (TurtleState b) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AlmostVal a -> Bool
forall a. Maybe a -> Bool
isNothing AlmostVal a
aVal Bool -> Bool -> Bool
|| AlmostVal a -> Bool
forall a. Maybe a -> Bool
isNothing AlmostVal a
bVal) ContT b (TurtleState b) ()
forall b a. SequenceCommand b a
failSequence

  -- Everything is hunky dory so we continue on into the next bind of the monad.

  let (Just !a
aVal') = AlmostVal a
aVal
  let (Just !a
bVal') = AlmostVal a
bVal
  a -> SequenceCommand b a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> SequenceCommand b a) -> a -> SequenceCommand b a
forall a b. (a -> b) -> a -> b
$ a
aVal' a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
bVal'

-- | 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 b a -- ^ Sequence /a/ to run.

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

                  -> SequenceCommand b a
alternateSequence :: SequenceCommand b a -> SequenceCommand b a -> SequenceCommand b a
alternateSequence SequenceCommand b a
a SequenceCommand b a
b = do
  (!AlmostVal a
aVal, !AlmostVal a
bVal) <- SequenceCommand b a
-> SequenceCommand b a
-> SequenceCommand b (AlmostVal a, AlmostVal a)
forall c a b.
SequenceCommand c a
-> SequenceCommand c b
-> SequenceCommand c (AlmostVal a, AlmostVal b)
runParallel SequenceCommand b a
a SequenceCommand b a
b
  
  -- If both values failed we fail also.

  Bool -> ContT b (TurtleState b) () -> ContT b (TurtleState b) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AlmostVal a -> Bool
forall a. Maybe a -> Bool
isNothing AlmostVal a
aVal Bool -> Bool -> Bool
&& AlmostVal a -> Bool
forall a. Maybe a -> Bool
isNothing AlmostVal a
bVal) ContT b (TurtleState b) ()
forall b a. SequenceCommand b a
failSequence

  -- If A passes, return the value of A, otherwise return the value of B.

  if AlmostVal a -> Bool
forall a. Maybe a -> Bool
isJust AlmostVal a
aVal 
    then let (Just !a
aVal') = AlmostVal a
aVal in a -> SequenceCommand b a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> SequenceCommand b a) -> a -> SequenceCommand b a
forall a b. (a -> b) -> a -> b
$! a
aVal'
    else let (Just !a
bVal') = AlmostVal a
bVal in a -> SequenceCommand b a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> SequenceCommand b a) -> a -> SequenceCommand b a
forall a b. (a -> b) -> a -> b
$! a
bVal'

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

--   animations, run them both in parallel!

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

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

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

runParallel :: SequenceCommand c a
-> SequenceCommand c b
-> SequenceCommand c (AlmostVal a, AlmostVal b)
runParallel SequenceCommand c a
a SequenceCommand c b
b = do
  Float
startSimTime <- Getting Float (TSC c) Float -> ContT c (TurtleState c) Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float (TSC c) Float
forall b. Lens' (TSC b) Float
totalSimTime
  SequenceCommand c c
parentExitCall <- Getting (SequenceCommand c c) (TSC c) (SequenceCommand c c)
-> ContT c (TurtleState c) (SequenceCommand c c)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (SequenceCommand c c) (TSC c) (SequenceCommand c c)
forall b b.
Lens (TSC b) (TSC b) (SequenceCommand b b) (SequenceCommand b b)
exitCall

  -- Run A, and return back to this point when/if it fails.

  AlmostVal a
aVal <- ((AlmostVal a -> SequenceCommand c c)
 -> ContT c (TurtleState c) (AlmostVal a))
-> ContT c (TurtleState c) (AlmostVal a)
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (((AlmostVal a -> SequenceCommand c c)
  -> ContT c (TurtleState c) (AlmostVal a))
 -> ContT c (TurtleState c) (AlmostVal a))
-> ((AlmostVal a -> SequenceCommand c c)
    -> ContT c (TurtleState c) (AlmostVal a))
-> ContT c (TurtleState c) (AlmostVal a)
forall a b. (a -> b) -> a -> b
$ \ AlmostVal a -> SequenceCommand c c
exitFromA -> do
    (SequenceCommand c c -> Identity (SequenceCommand c c))
-> TSC c -> Identity (TSC c)
forall b b.
Lens (TSC b) (TSC b) (SequenceCommand b b) (SequenceCommand b b)
exitCall ((SequenceCommand c c -> Identity (SequenceCommand c c))
 -> TSC c -> Identity (TSC c))
-> SequenceCommand c c -> ContT c (TurtleState c) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= AlmostVal a -> SequenceCommand c c
exitFromA AlmostVal a
forall a. Maybe a
Nothing
    a -> AlmostVal a
forall a. a -> Maybe a
Just (a -> AlmostVal a)
-> SequenceCommand c a -> ContT c (TurtleState c) (AlmostVal a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SequenceCommand c a
a

  Float
aSimTime <- Getting Float (TSC c) Float -> ContT c (TurtleState c) Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float (TSC c) Float
forall b. Lens' (TSC b) Float
totalSimTime
  
  -- Run B, and return back to this point when/if it fails.

  AlmostVal b
bVal <- ((AlmostVal b -> SequenceCommand c c)
 -> ContT c (TurtleState c) (AlmostVal b))
-> ContT c (TurtleState c) (AlmostVal b)
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (((AlmostVal b -> SequenceCommand c c)
  -> ContT c (TurtleState c) (AlmostVal b))
 -> ContT c (TurtleState c) (AlmostVal b))
-> ((AlmostVal b -> SequenceCommand c c)
    -> ContT c (TurtleState c) (AlmostVal b))
-> ContT c (TurtleState c) (AlmostVal b)
forall a b. (a -> b) -> a -> b
$ \ AlmostVal b -> SequenceCommand c c
exitFromB -> do
    (SequenceCommand c c -> Identity (SequenceCommand c c))
-> TSC c -> Identity (TSC c)
forall b b.
Lens (TSC b) (TSC b) (SequenceCommand b b) (SequenceCommand b b)
exitCall ((SequenceCommand c c -> Identity (SequenceCommand c c))
 -> TSC c -> Identity (TSC c))
-> SequenceCommand c c -> ContT c (TurtleState c) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= AlmostVal b -> SequenceCommand c c
exitFromB AlmostVal b
forall a. Maybe a
Nothing
    (Float -> Identity Float) -> TSC c -> Identity (TSC c)
forall b. Lens' (TSC b) Float
totalSimTime ((Float -> Identity Float) -> TSC c -> Identity (TSC c))
-> Float -> ContT c (TurtleState c) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Float
startSimTime -- restart sim time back to initial.

    b -> AlmostVal b
forall a. a -> Maybe a
Just (b -> AlmostVal b)
-> SequenceCommand c b -> ContT c (TurtleState c) (AlmostVal b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SequenceCommand c b
b

  Float
bSimTime <- Getting Float (TSC c) Float -> ContT c (TurtleState c) Float
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Float (TSC c) Float
forall b. Lens' (TSC b) Float
totalSimTime

  -- No subsequent animation can proceed until the longest animation completes.

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

  -- running animation.

  (Float -> Identity Float) -> TSC c -> Identity (TSC c)
forall b. Lens' (TSC b) Float
totalSimTime ((Float -> Identity Float) -> TSC c -> Identity (TSC c))
-> Float -> ContT c (TurtleState c) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
aSimTime Float
bSimTime

  (SequenceCommand c c -> Identity (SequenceCommand c c))
-> TSC c -> Identity (TSC c)
forall b b.
Lens (TSC b) (TSC b) (SequenceCommand b b) (SequenceCommand b b)
exitCall ((SequenceCommand c c -> Identity (SequenceCommand c c))
 -> TSC c -> Identity (TSC c))
-> SequenceCommand c c -> ContT c (TurtleState c) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= SequenceCommand c c
parentExitCall  -- Let us exit properly again!


  -- 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 -> ContT c (TurtleState c) ()
forall b. Float -> SequenceCommand b ()
decrementSimTime Float
0

  (AlmostVal a, AlmostVal b)
-> SequenceCommand c (AlmostVal a, AlmostVal b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((AlmostVal a, AlmostVal b)
 -> SequenceCommand c (AlmostVal a, AlmostVal b))
-> (AlmostVal a, AlmostVal b)
-> SequenceCommand c (AlmostVal a, AlmostVal b)
forall a b. (a -> b) -> a -> b
$! (AlmostVal a
aVal, AlmostVal b
bVal)

-- | Calls our early exit and fails the callback. No calculations will be

--   performed beyond this call.

failSequence :: SequenceCommand b a
failSequence :: SequenceCommand b a
failSequence = do
  SequenceCommand b b
ex <- Getting (SequenceCommand b b) (TSC b) (SequenceCommand b b)
-> ContT b (TurtleState b) (SequenceCommand b b)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (SequenceCommand b b) (TSC b) (SequenceCommand b b)
forall b b.
Lens (TSC b) (TSC b) (SequenceCommand b b) (SequenceCommand b b)
exitCall
  b
_ <- SequenceCommand b b
ex
  -- We can never reach this point with our call to `ex`. So the return type

  -- can be whatever we want it to be. Let's go crazy! 

  let (Just Void
x) = (Maybe Void
forall a. Maybe a
Nothing :: Maybe Void)
   in Void -> SequenceCommand b a
forall a. Void -> a
absurd Void
x