worldturtle 0.2.2.1 → 0.3.0.0
raw patch · 6 files changed
+438/−258 lines, 6 filesdep +monad-coroutinedep +monad-paralleldep ~basedep ~lens
Dependencies added: monad-coroutine, monad-parallel
Dependency ranges changed: base, lens
Files
- ChangeLog.md +23/−0
- Graphics/WorldTurtle.hs +87/−78
- Graphics/WorldTurtle/Commands.hs +140/−37
- Graphics/WorldTurtle/Internal/Commands.hs +15/−19
- Graphics/WorldTurtle/Internal/Sequence.hs +167/−120
- worldturtle.cabal +6/−4
ChangeLog.md view
@@ -1,5 +1,28 @@ # Changelog for turtle-haskell +## v0.3.0.0 + +* Upgraded to `lts-18.27`. +* Added `runWorld'` and `runTurtle'` variant commands which take a background color. +* Deprecated `setPosition`. +* Added `jump`, which is a variant of `goto` which never draws a line. +* Added `wait` command, which is a `TurtleCommand` variant of `sleep`. +* Added `label` and `label'` commands, which allows text to be drawn at turtle's position. +* Added `repeatFor` method which is an alias for `Control.Monad.replicateM_` (this is purely + to help ease students into Monad concepts.) +* `TurtleCommand` and `WorldCommand` are now instances of `MonadIO`. +* Major internal performance improvements. `SequenceCommand`, is now a `Coroutine`. + This reduces wasted calculations per-frame as the state of the previous frame + can now be carried into the next frame of animation. +* Removed `WorldCommand` as an instance of `Control.Applicative` and `MonadPlus`. This did not + make sense in terms of parallelization. Instead, `WorldComamnd` is now an instance of `MonadParallel` +* Introduced new `>!>` operator for parallel animations. +* `setPenDown` has been split into `setPenDown` and `setPenUp` to be more LOGO-like. +* `setVisible` has been split into `setVisible` and `setInvisible` to be more LOGO-like. +* Added the `labelwait-exe` test. +* Updated examples to account for command changes. +* Removed `spaceleak-exe` test. + ## v0.2.2.1 * Upgrading upper bounds of the lens package to allow for compilation with GHC
Graphics/WorldTurtle.hs view
@@ -20,38 +20,38 @@ -- * Running on a single turtle. -- $running runTurtle + , runTurtle' , TurtleCommand -- * Running a world of turtles. -- $multiturtle , runWorld + , runWorld' , WorldCommand , run , (>/>) -- * Parallel animation - -- $parallel - , (<|>) - -- * Stop an animation - -- $empty - , empty + , (>!>) -- * Further documentation , module Graphics.WorldTurtle.Commands , module Graphics.WorldTurtle.Shapes , module Graphics.WorldTurtle.Color ) where -import Control.Applicative (empty, (<|>)) +import Control.Monad.Parallel import Graphics.Gloss.Data.Display (Display (..)) import qualified Graphics.Gloss.Data.ViewState as G import qualified Graphics.Gloss.Data.ViewPort as G -import qualified Graphics.Gloss.Interface.Pure.Game as G +import qualified Graphics.Gloss.Interface.IO.Game as G import Graphics.WorldTurtle.Color import Graphics.WorldTurtle.Commands -import Graphics.WorldTurtle.Internal.Sequence (renderTurtle) +import Graphics.WorldTurtle.Internal.Sequence (SequencePause, startSequence, resumeSequence, renderPause, defaultTSC) import Graphics.WorldTurtle.Internal.Commands ( TurtleCommand - , WorldCommand (..), seqW - , run) + , WorldCommand (..) + , run + , seqW + ) import Graphics.WorldTurtle.Shapes -- | Takes a `TurtleCommand` and executes the command on an implicitly created @@ -64,8 +64,50 @@ -- See also: `Graphics.WorldTurtle.Commands.makeTurtle`. runTurtle :: TurtleCommand () -- ^ Command sequence to execute. -> IO () -runTurtle c = runWorld $ makeTurtle >>= run c +runTurtle = runTurtle' white +-- | Variant of `runTurtle` which takes an additional background color parameter. +runTurtle' :: Color -- ^ Background color. + -> TurtleCommand () -- ^ Command sequence to execute. + -> IO () +runTurtle' bckCol c = runWorld' bckCol $ makeTurtle >>= run c + +-- | While `WorldCommand`s can be combined with `(>>)` to produce sequential +-- instructions, we can also use the +-- parallel animation operator `(>!>)` to achieve parallel instructions. +-- That is: animate two turtles at time! +-- +-- Here is an example: +-- +-- > import Graphics.WorldTurtle +-- > +-- > main :: IO () +-- > main = runWorld $ do +-- > t1 <- makeTurtle' (0, 0) north green +-- > t2 <- makeTurtle' (0, 0) north red +-- > +-- > -- Draw the anticlockwise and clockwise circles in sequence. +-- > t1 >/> circle 90 >> t2 >/> circle (-90) +-- > +-- > clear +-- > +-- > -- Draw the anticlockwise and clockwise circles in parallel. +-- > t1 >/> circle 90 >!> t2 >/> circle (-90) +-- +-- Which would produce an animation like this +-- +--  +-- +-- Note that `(>!>)` is an alias for `bindM2`, and is defined as: +-- +-- > (>!>) = bindM2 (const . return) +-- +(>!>) :: WorldCommand () -- ^ First command to execute in parallel + -> WorldCommand () -- ^ Second command to execute in parallel. + -> WorldCommand () -- ^ Result command +(>!>) = bindM2 (const . return) +infixl 3 >!> + {- | `runWorld` takes a `WorldCommand` and produces the animation in a new window! @@ -91,23 +133,33 @@ -} runWorld :: WorldCommand () -- ^ Command sequence to execute -> IO () -runWorld tc = G.play display white 30 defaultWorld iterateRender input timePass +runWorld = runWorld' white + +-- | Variant of `runWorld` which takes an additional background color parameter. +runWorld' :: Color -- ^ Background color + -> WorldCommand () -- ^ Command sequence to execute + -> IO () +runWorld' bckCol cmd = G.playIO display bckCol 30 (defaultWorld cmd) iterateRender input timePass where display = InWindow "World Turtle" (800, 600) (400, 300) - iterateRender w = G.applyViewPortToPicture - (G.viewStateViewPort $ state w) - $ renderTurtle (seqW tc) (elapsedTime w) + iterateRender w = do + sq <- worldComputation w + let p = renderPause sq -- Render whatever is in the coroutine. + return $ G.applyViewPortToPicture (G.viewStateViewPort $ viewState w) p input e w -- Reset key resets sim state (including unpausing). We -- deliberately keep view state the same. - | isResetKey_ e = w { elapsedTime = 0, running = True } + | isResetKey_ e = return w {worldComputation = restartSequence cmd, running = True } -- Pause prevents any proceeding. - | isPauseKey_ e = w { running = not $ running w } + | isPauseKey_ e = return w { running = not $ running w } -- Let Gloss consume the command. - | otherwise = w { state = G.updateViewStateWithEvent e $ state w } + | otherwise = return w { viewState = G.updateViewStateWithEvent e $ viewState w } -- Increment simulation time if we are not paused. timePass f w - | running w = w { elapsedTime = f + elapsedTime w } - | otherwise = w + | running w = do + sq <- worldComputation w -- Grab previous sequence + sq' <- resumeSequence f sq -- Calculate new sequence + return w { worldComputation = return sq'} + | otherwise = return w -- | This is an infix version of `run` where the arguments are swapped. -- @@ -129,19 +181,22 @@ (>/>) = flip run infixl 4 >/> -data World = World { elapsedTime :: !Float - , running :: !Bool - , state :: G.ViewState - } +data World a = World { running :: !Bool + , worldComputation:: IO (SequencePause a) + , viewState :: G.ViewState + } -defaultWorld :: World -defaultWorld = World 0 True - $ G.viewStateInitWithConfig - -- Easier to do this to have spacebar overwrite R. - $ reverse - $ (G.CRestore, [(G.SpecialKey G.KeySpace, Nothing)]) - : G.defaultCommandConfig +restartSequence :: WorldCommand a -> IO (SequencePause a) +restartSequence cmnd = startSequence defaultTSC (seqW cmnd) +defaultWorld :: WorldCommand a -> World a +defaultWorld cmd = World True (restartSequence cmd) + $ G.viewStateInitWithConfig + -- Easier to do this to have spacebar overwrite R. + $ reverse + $ (G.CRestore, [(G.SpecialKey G.KeySpace, Nothing)]) + : G.defaultCommandConfig + -- | Tests to see if a key-event is the reset key. isResetKey_ :: G.Event -> Bool isResetKey_ (G.EventKey (G.Char 'r') G.Down _ _) = True @@ -159,11 +214,10 @@ To start animating a single turtle, you just pass your commands to `runTurtle` like so: - > import Control.Monad (replicateM_) > import Graphics.WorldTurtle > > drawSquare :: Float -> TurtleCommand () - > drawSquare size = replicateM_ 4 $ forward size >> right 90 + > drawSquare size = repeatFor 4 $ forward size >> right 90 > > main :: IO () > main = runTurtle $ drawSquare 100 @@ -192,49 +246,4 @@ Notice that in a `WorldCommand` context we must create our own turtles with `makeTurtle`! We them apply the `TurtleCommand` on our turtles using the run operator `(>/>)`. --} - -{- $parallel - - #parallel# - - While `WorldCommand`s can be combined with `(>>)` to produce sequential - instructions, we can also use the - alternative operator `(<|>)` to achieve parallel instructions. That is: - animate two turtles at time! - - Here is an example: - - > import Graphics.WorldTurtle - > - > main :: IO () - > main = runWorld $ do - > t1 <- makeTurtle' (0, 0) north green - > t2 <- makeTurtle' (0, 0) north red - > - > -- Draw the anticlockwise and clockwise circles in sequence. - > t1 >/> circle 90 >> t2 >/> circle (-90) - > - > clear - > - > -- Draw the anticlockwise and clockwise circles in parallel. - > t1 >/> circle 90 <|> t2 >/> circle (-90) - - Which would produce an animation like this - -  - - Note that the result of @x \<|\> y@ is: - - >>> x <|> y - x - - when @x@ is not `Control.Applicative.empty`, otherwise the result is @y@. --} - -{- $empty - If a `WorldCommand` is `Control.Applicative.empty`, then this stops this - section of animation and it does not progress. To this end - `Control.Monad.guard` can be used to calculate when to stop part of an - animation sequence. -}
Graphics/WorldTurtle/Commands.hs view
@@ -37,15 +37,20 @@ , rt , Graphics.WorldTurtle.Commands.circle , Graphics.WorldTurtle.Commands.arc + , jump , goto , setPosition , home , setHeading , setSpeed , setRotationSpeed + , wait + , repeatFor -- * Styling commands. , stamp , representation + , label + , label' -- ** Query turtle's state. , position , heading @@ -59,9 +64,11 @@ , branch , setPenColor , setPenDown + , setPenUp , setPenSize , setRepresentation , setVisible + , setInvisible -- * Common constants , east , north @@ -73,6 +80,7 @@ import Control.Lens import Control.Monad +import Control.Monad.Trans.Class (lift) import Graphics.WorldTurtle.Shapes @@ -110,7 +118,7 @@ > myCommand = do > t1 <- makeTurtle' (0, 0) 0 green > t2 <- makeTurtle' (0, 0) 90 red - > (t1 >/> forward 90) \<|\> (t2 >/> forward 90) + > (t1 >/> forward 90) >!> (t2 >/> forward 90) See `makeTurtle`. -} @@ -121,10 +129,11 @@ makeTurtle' p f c = WorldCommand $ do turtle <- generateTurtle let ts = turtLens_ turtle - ts . T.position .= p - ts . T.heading .= f - ts . T.representation .= turtleArrow black c - ts . T.penColor .= c + lift $ do + ts . T.position .= p + ts . T.heading .= f + ts . T.representation .= turtleArrow black c + ts . T.penColor .= c return turtle -- | Move the turtle backward by the specified @distance@, in the direction the @@ -162,7 +171,7 @@ addPicture $ color (t ^. T.penColor) $ thickLine startP midP (t ^. T.penSize) -- Draw line from startPoint to midPoint. - turtLens_ turtle . T.position .= midP + lift $ turtLens_ turtle . T.position .= midP -- Update the turtle to a new position -- | Shorthand for `forward`. @@ -174,6 +183,31 @@ stamp :: TurtleCommand () stamp = seqToT $ tData_ >=> (addPicture . T.drawTurtle) +-- | Writes a string to screen at the turtle's position. +-- +-- The written text color will match turtle pen color. +-- +-- This is eqivelent to: +-- +-- > label = label' 0.2 +label :: String -- ^ String to write to screen. + -> TurtleCommand () +label = label' 0.2 + +-- | Variant of `label` which takes a scale argument to scale the +-- size of the drawn text. +label' :: Float -- ^ Scale of text to draw. + -> String -- ^ String to write to screen. + -> TurtleCommand () +label' s txt = seqToT $ \ turtle -> do + !t <- tData_ turtle + let (x, y) = t ^. T.position + addPicture $ translate x y + $ scale s s + $ color (t ^. T.penColor) + $ text txt + + -- | Turn a turtle right by the given degrees amount. right :: Float -- ^ Rotation amount to apply to turtle. -> TurtleCommand () @@ -203,7 +237,7 @@ let newHeading = P.normalizeHeading $ if rightBias then h - q * r' else h + q * r' -- Get new heading via percentage - turtLens_ turtle . T.heading .= newHeading + lift $ turtLens_ turtle . T.heading .= newHeading -- | Draw a circle with a given @radius@. The center is @radius@ units left of -- the @turtle@ if positive. Otherwise @radius@ units right of the @turtle@ @@ -271,13 +305,14 @@ (t ^. T.penSize) (t ^. T.penColor) -- Update the turtle with the new values. - let ts = turtLens_ turtle - ts . T.heading .= P.normalizeHeading (if radius >= 0 + lift $ do + let ts = turtLens_ turtle + ts . T.heading .= P.normalizeHeading (if radius >= 0 then startAngle - 90 + angle else startAngle - 90 - angle) - let !p' = calculateNewPointC_ p radius startAngle angle - ts . T.position .= p' + let !p' = calculateNewPointC_ p radius startAngle angle + ts . T.position .= p' -- | Returns the turtle's current position. -- Default (starting) position is @(0, 0)@. @@ -289,14 +324,32 @@ home :: TurtleCommand () home = seqToT $ \ turtle -> do let ts = turtLens_ turtle - ts . T.position .= (0, 0) - ts . T.heading .= 90 + lift $ do + ts . T.position .= (0, 0) + ts . T.heading .= 90 --- | Warps the turtle to a new position. --- The turtle jumps to this new position with no animation. If the pen is down --- then a line is drawn. --- --- This does not affect the turtle's heading. +-- | Sets the turtle's position to the new given value. +-- +-- This command does not animate, nor is a line drawn +-- between the old position and the new position. +-- +-- Use `goto` if you want a drawn line. +-- +-- This command does not affect the turtle's heading. +jump :: P.Point -- ^ Position to warp to. + -> TurtleCommand () +jump point = seqToT $ \ turtle -> do + lift $ turtLens_ turtle . T.position .= point + +-- | Sets the turtle's position to the new given value. +-- +-- This command does not animate. A line will be drawn between +-- the turtle's old position and the new set position if the turtle's +-- pen is down. +-- +-- Use `jump` if you do not want a drawn line. +-- +-- This command does not affect the turtle's heading. goto :: P.Point -- ^ Position to warp to. -> TurtleCommand () goto point = seqToT $ \ turtle -> do @@ -305,8 +358,9 @@ when (t ^. T.penDown) $ addPicture $ color (t ^. T.penColor) $ thickLine startP point (t ^. T.penSize) - turtLens_ turtle . T.position .= point + lift $ turtLens_ turtle . T.position .= point +{-# DEPRECATED setPosition "Use `goto` instead." #-} -- | Alias of `goto`. setPosition :: P.Point -> TurtleCommand () setPosition = goto @@ -346,12 +400,16 @@ penDown :: TurtleCommand Bool -- ^ True if pen is down, false if not. penDown = getter_ False T.penDown --- | Sets the turtle's pen to down or up. --- See `penDown`. -setPenDown :: Bool -- ^ New state for pen flag. True for down. False for up. - -> TurtleCommand () -setPenDown = setter_ T.penDown +-- | Sets the turtle's pen to down. Turtle will draw as it moves. +-- See `penDown` and `setPenUp`. +setPenDown :: TurtleCommand () +setPenDown = setter_ T.penDown True +-- | Sets the turtle's pen to up. Turtle will not draw as it moves. +-- See `penDown` and `setPenDown`. +setPenUp :: TurtleCommand () +setPenUp = setter_ T.penDown False + -- | Returns the turtle's pen size. -- Defaults to @2@. penSize :: TurtleCommand Float -- ^ Size of turtle's pen. @@ -368,12 +426,22 @@ visible :: TurtleCommand Bool -- ^ @True@ if turtle is visible, @False@ if not. visible = getter_ False T.visible --- | Sets the turtle's visibility. --- See `visible`. -setVisible :: Bool -- ^ New state for visible flag. - -> TurtleCommand () -setVisible = setter_ T.visible +-- | Sets the turtle's visibility to visible. +-- +-- The turtle's representation will be drawn to canvas. +-- +-- See `visible` and `setInvisible`. +setVisible :: TurtleCommand () +setVisible = setter_ T.visible True +-- | Sets the turtle's visibility to invisible. +-- +-- The turtle's representation will not be drawn to canvas. +-- +-- See `visible` and `setVisible`. +setInvisible :: TurtleCommand () +setInvisible = setter_ T.visible False + -- | Returns the turtle's current speed. -- Speed is is @distance@ per second. -- A speed of @0@ is equivalent to no animation being performed and instant @@ -426,20 +494,55 @@ -- | Clears all drawings form the canvas. Does not alter any turtle's state. clear :: WorldCommand () -clear = WorldCommand $ pics .= mempty +clear = WorldCommand $ lift $ do + pics .= mempty + finalPics .= mempty --- | Sleep for a given amount of time in seconds. When sleeping no animation --- runs. A negative value will be clamped to @0@. -sleep :: Float -> WorldCommand () -sleep = WorldCommand . decrementSimTime . max 0 +-- | World sleeps for a given amount of time in seconds +-- before running the next command. +-- +-- This is the `WorldComamnd` variant of `wait`. +-- +-- A negative value will be clamped to @0@. +sleep :: Float -- ^ Amount of time to sleep in seconds. + -> WorldCommand () +sleep = WorldCommand . void . decrementSimTime . max 0 +-- | Turtle waits for a given amount of time in seconds +-- before continuing with the next command. +-- +-- This is the `TurtleCommand` variant of `sleep`. +-- +-- A negative value will be clamped to @0@. +wait :: Float -- ^ Amount of time to wait in seconds. + -> TurtleCommand () +wait f = seqToT $ \ _ -> void . decrementSimTime $ max 0 f + +-- | Repeats the same command several times. +-- +-- Example: +-- +-- > repeatFor 4 $ do +-- > forward 50 +-- > right 90 +-- +-- This is an alias of `replicateM_`. +-- +-- That is: +-- +-- > repeatFor = replicateM_ +repeatFor :: Int -- ^ Number of times to repeat a command. + -> TurtleCommand a -- ^ Command to repeat. + -> TurtleCommand () +repeatFor = replicateM_ + -- | Given a command, runs the command, then resets the turtle's state back to -- what the state was before the command was run. branch :: TurtleCommand a -> TurtleCommand a branch (TurtleCommand p ) = seqToT $ \ turtle -> do !t <- tData_ turtle output <- seqW $ p turtle - turtLens_ turtle .= t + lift $ turtLens_ turtle .= t return output -- | @90@ degrees. @@ -476,7 +579,7 @@ -- | This is a helper function for our getter commands. -- It takes a default value, the lense to compose, and the turtle to inspect. getter_ :: a -> Lens' T.TurtleData a -> TurtleCommand a -getter_ def l = seqToT $ \ t -> fromMaybe def <$> preuse (turtLens_ t . l) +getter_ def l = seqToT $ \ t -> lift $ fromMaybe def <$> preuse (turtLens_ t . l) {-# INLINE getter_ #-} -- | This is a helper function that extracts the turtle data for a given turtle. @@ -487,5 +590,5 @@ -- | This is a helper function for our setter commands -- It takes a lens, the value to apply, and the turtle to modify. setter_ :: Lens' T.TurtleData b -> b -> TurtleCommand () -setter_ l val = seqToT $ \ t -> turtLens_ t . l .= val +setter_ l val = seqToT $ \ t -> lift $ turtLens_ t . l .= val {-# INLINE setter_ #-}
Graphics/WorldTurtle/Internal/Commands.hs view
@@ -7,27 +7,26 @@ ) where import Control.Applicative -import Control.Monad - +import Control.Monad.IO.Class import Graphics.Gloss.Data.Picture (text) +import Control.Monad.Parallel import Graphics.WorldTurtle.Internal.Sequence + ( Turtle, SequenceCommand, addPicture, runParallel ) {- | A `WorldCommand` represents an instruction that affects the entire animation canvas. - This could be as simple as "make a turtle" or more complicated like + This could be as simple as "make a turtle" or more complicated, such as "run these 5 turtles in parallel." - Like `TurtleCommand`s, `WorldCommand`s can be executed in order by + Like `TurtleCommand`s, `WorldCommand`s can be executed in sequence by combining commands in order using the monadic operator `(>>)`. - To execute a `TurtleCommand` in a `WorldCommand`, use either the - `Graphics.WorldTurtle.run` function or the - `Graphics.WorldTurtle.>/>` operator. + To execute a `TurtleCommand` within a `WorldCommand`, use the + `Graphics.WorldTurtle.run` function or `Graphics.WorldTurtle.>/>` operator. - For how to achieve parallel animations - see "Graphics.WorldTurtle#parallel". + For parallel animations, see `Graphics.WorldTurtle.>!>`. -} newtype WorldCommand a = WorldCommand { @@ -44,21 +43,15 @@ instance Monad WorldCommand where (WorldCommand a) >>= f = WorldCommand $! a >>= \s -> seqW $! f s -instance Alternative WorldCommand where - empty = WorldCommand empty - (<|>) (WorldCommand a) (WorldCommand b) = - WorldCommand $! alternateSequence a b - -instance Semigroup a => Semigroup (WorldCommand a) where - (WorldCommand a) <> (WorldCommand b) = - WorldCommand $! combineSequence a b +instance MonadParallel WorldCommand where + bindM2 f (WorldCommand a) (WorldCommand b) = WorldCommand $ runParallel (\x y -> seqW (f x y)) a b -instance MonadPlus WorldCommand +instance MonadIO WorldCommand where + liftIO a = WorldCommand $ liftIO a instance MonadFail WorldCommand where fail t = WorldCommand $! addPicture (text t) >> fail t - {-| A `TurtleCommand` represents an instruction to execute on a turtle. It could be as simple as "draw a line" or more complicated like "draw 300 circles." @@ -100,6 +93,9 @@ instance MonadFail TurtleCommand where fail t = TurtleCommand $ \ _ -> fail t + +instance MonadIO TurtleCommand where + liftIO a = TurtleCommand $ \ _ -> liftIO a -- | `run` takes a `TurtleCommand` and a `Turtle` to execute the command on. -- The result of the computation is returned wrapped in a `WorldCommand`.
Graphics/WorldTurtle/Internal/Sequence.hs view
@@ -5,45 +5,49 @@ ( Turtle , TSC , SequenceCommand + , SequencePause , defaultTSC - , processTurtle - , renderTurtle - , addPicture - , simTime - , setSimTime + , startSequence + , resumeSequence + , renderPause , decrementSimTime + , addPicture , pics - , totalSimTime + , finalPics , turtles , generateTurtle , animate' - , animate - , combineSequence - , alternateSequence + , runParallel ) where import Graphics.WorldTurtle.Internal.Turtle + ( defaultTurtle, drawTurtle, TurtleData ) -import Graphics.Gloss.Data.Picture (Picture) +import Graphics.Gloss.Data.Picture (Picture, pictures) -import Control.Applicative (empty) import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Maybe 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 = State TSC +type TurtleState = StateT TSC IO --- | 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 +-- | 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 = MaybeT TurtleState a +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 @@ -55,8 +59,9 @@ newtype Turtle = Turtle Int deriving (Eq, Ord) data TSC = TSC - { _pics :: ![Picture] -- ^ All pictures that make up the current canvas - , _totalSimTime :: !Float -- ^ Remaining available for animating + { _pics :: ![Picture] -- ^ All pictures currently drawn this sequence. + , _finalPics :: ![Picture] -- ^ All pictures that have successfuly drawn in previous sequences. + , _simTime :: !Float -- ^ Total simulation time. , _turtles :: !(Map Turtle TurtleData) -- Collection of all turtles. , _nextTurtleId :: !Int -- ^ ID of next turtle to be generated. } @@ -64,67 +69,84 @@ $(makeLenses ''TSC) -- | Generates default parameter arguments. -defaultTSC :: Float -> TSC -defaultTSC givenTime = TSC +defaultTSC :: TSC +defaultTSC = TSC { _pics = mempty - , _totalSimTime = givenTime + , _finalPics = mempty + , _simTime = 0 , _turtles = Map.empty , _nextTurtleId = 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 = use 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 newTime = do - let newTime' = max 0 newTime - totalSimTime .= newTime' - when (newTime' <= 0) empty +-- | 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 d = do + t <- lift $ use simTime + let t' = max 0 (t - d) + let outOfTime = t' <= 0 + lift $ simTime .= t' + when outOfTime $ do + --- Before we yield, take the chance to concat our final pics. + lift $ finalPics %= \f -> [pictures f] + -- If we have run out of time, + -- pause the continuation to allow for + -- a render, then resume. + s <- lift get --- | 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 duration = simTime >>= \ t -> setSimTime (t - duration) + delta <- request s + lift $ simTime += delta + return outOfTime -- | Given a picture, adds it to the picture list. addPicture :: Picture -- ^ Picture to add to our animation -> SequenceCommand () -addPicture p = pics %= ($!) (p :) +addPicture p = lift $ pics %= ($!) (p :) --- | Given a sequence and a State, returns the result of the computation and the +-- | 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). -processTurtle :: SequenceCommand a - -> TSC - -> (Maybe a, TSC) -processTurtle commands tsc = - let drawS = runMaybeT $ decrementSimTime 0 >> commands - in runState drawS tsc +startSequence :: TSC + -> SequenceCommand a -- ^ Commands to execute + -> IO (SequencePause a) +startSequence tsc commands = evalStateT (resume commands') tsc + where commands' = do + _ <- decrementSimTime 0 -- Kick off an immediate Yield. + a <- commands + g <- lift get + return (a, g) --- | Given a computation to run and an amount of time to run it in, renders the --- final "picture". -renderTurtle :: SequenceCommand a - -> Float - -> Picture -renderTurtle c f = let (_, s) = processTurtle c t - t = defaultTSC f - in mconcat $ reverse (s ^. pics) ++ drawTurtles (s ^. turtles) +runSequence :: TSC + -> SequenceCommand (a, TSC) -- ^ Commands to execute + -> IO (SequencePause a) +runSequence tsc commands = evalStateT (resume commands) tsc +resumeSequence :: Float -> SequencePause a -> IO (SequencePause a) +resumeSequence delta (Left (Request tsc response)) = runSequence tsc $ response delta +resumeSequence _ a = return a + +renderPause :: SequencePause a -> Picture +renderPause sq = renderTurtle $ stateForPause sq + +stateForPause :: SequencePause a -> TSC +stateForPause (Left (Request s _)) = s +stateForPause (Right (_, s)) = s + +-- | Exctracts the image frame from the current turtle state. +renderTurtle :: TSC -> Picture +renderTurtle t = mconcat $ + (t ^. finalPics) ++ + (t ^. pics) ++ + drawTurtles (t ^. turtles) + drawTurtles :: Map Turtle TurtleData -> [Picture] drawTurtles m = drawTurtle <$> Map.elems m generateTurtle :: SequenceCommand Turtle -generateTurtle = do +generateTurtle = lift $ do t <- Turtle <$> use nextTurtleId turtles %= Map.insert t defaultTurtle nextTurtleId += 1 @@ -135,81 +157,106 @@ -> (Float -> SequenceCommand a) -> SequenceCommand a animate' distance turtleSpeed callback = - let duration = distance / turtleSpeed - d' = if isNaN duration || isInfinite duration then 0 else duration - -- if speed is 0 we use this as a "no animation" command from - -- user-space. - in animate (abs d') callback + let duration = distance / turtleSpeed + d' = if isNaN duration || isInfinite duration then 0 else duration + -- if speed is 0 we use this as a "no animation" command from + -- user-space. + in do + t <- animate (abs d') 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. + lift $ do + p <- use pics + finalPics %= ($!) (++ p) + pics .= mempty + return t animate :: Float -> (Float -> SequenceCommand a) -> SequenceCommand a animate duration callback = do - timeRemaining <- simTime -- simulation time to go - let availableTime = min timeRemaining duration - -- Amount of time we have to complete the animation before we need to exit. - let timeQuot = if availableTime == 0 then 1 else availableTime / duration - -- quotient of available time vs required time. Note that when the duration - -- is 0 we say "don't do any animation" - t <- callback timeQuot - -- Perform the calculation with the quotient for lerping - decrementSimTime availableTime - -- Test to see if this is the end of our animation and if so exit early - return t + oldState <- lift get --- | 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 a b = do - (aVal, bVal) <- runParallel a b - combo aVal bVal - where combo (Just x) (Just y) = return (x <> y) - combo _ _ = empty + timeRemaining <- lift $ use simTime -- simulation time to go + let availableTime = min timeRemaining duration + -- Amount of time we have to complete the animation before we need to exit. + let timeQuot = if availableTime == 0 then 1 else availableTime / duration + -- quotient of available time vs required time. Note that when the duration + -- is 0 we say "don't do any animation" + + t <- callback timeQuot + + -- Perform the calculation with the quotient for lerping + outOfTime <- decrementSimTime availableTime --- | 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 a b = do - (aVal, bVal) <- runParallel a b - combo aVal bVal - where combo (Just x) _ = return x - combo _ (Just y) = return y - combo _ _ = empty + -- 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 outOfTime then do + let oldTime = oldState ^. simTime + newTime <- lift $ use simTime + let time = newTime + oldTime + lift $ put $ oldState & simTime .~ time + animate duration callback + else + return t + -- | 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. +runParallel :: (a -> b -> SequenceCommand c) + -> SequenceCommand a -- ^ Sequence /a/ to run. -> SequenceCommand b -- ^ Sequence /b/ to run. - -> SequenceCommand (Maybe a, Maybe b) + -> SequenceCommand c -- ^ New sequence of A and B which returns both results. -runParallel a b = do - - startSimTime <- use totalSimTime +runParallel f a b = + let a' = a >>= \ax -> lift get >>= \g -> return (ax, g) + b' = b >>= \bx -> lift get >>= \g -> return (bx, g) + in runParallel_ f a' 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_ f a b = do + startSimTime <- lift $ use simTime s <- lift get + -- Run the "A" animation - let (aVal, s') = processTurtle a s - let aSimTime = s' ^. totalSimTime + aVal <- liftIO $ runSequence s a + let s' = grabState aVal + let aTime = s' ^. simTime - -- Run the "B" animation from the same time - let (bVal, s'') = processTurtle b $ s' & totalSimTime .~ 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 - lift $ put $ s'' & totalSimTime %~ min aSimTime + -- Run the "B" animation, with a reset time. + let s'' = s' & simTime .~ startSimTime + bVal <- liftIO $ runSequence s'' b + let s''' = grabState bVal + let bTime = s''' ^. simTime + + -- Test to see if we need to yield. + let elapsedTime = min aTime bTime + lift $ put (s''' & simTime .~ elapsedTime) + outOfTime <- decrementSimTime 0 - -- 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! - decrementSimTime 0 - return (aVal, bVal) + -- If we were out of time, redo the operation. + newTime <- lift $ use simTime + if outOfTime then do + let time = newTime + startSimTime + lift $ put $ s & simTime .~ time + runParallel_ f a b + else do + combinePauses_ f newTime aVal bVal + + where grabState (Left (Request s _)) = s + grabState (Right (_, s)) = s + +combinePauses_ :: (a -> b -> SequenceCommand c) -> Float -> SequencePause a -> SequencePause b -> SequenceCommand c +combinePauses_ f _ (Right (a, _)) (Right (b, _)) = f a b +combinePauses_ f d (Right (a, _)) (Left (Request _ y)) = y d >>= f a . fst +combinePauses_ f d (Left (Request _ x)) (Right (b, _)) = x d >>= (`f` b) . fst +combinePauses_ f d (Left (Request _ x)) (Left (Request _ y)) = runParallel_ f (x d) (y d)
worldturtle.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: worldturtle -version: 0.2.2.1 +version: 0.3.0.0 synopsis: LOGO-like Turtle graphics with a monadic interface. category: teaching homepage: https://github.com/aneilmac/worldturtle-haskell#readme @@ -12,7 +12,7 @@ license: BSD-3-Clause license-file: LICENSE build-type: Simple -tested-with: GHC == 8.10.3, GHC == 9.0.1 +tested-with: GHC == 8.10.7, GHC == 9.0.1 description: Have you ever heard of [Turtle Graphics](https://en.wikipedia.org/wiki/Turtle_graphics)? @@ -56,12 +56,14 @@ Graphics.WorldTurtle.Internal.Turtle Graphics.WorldTurtle.Shapes build-depends: - base >=4.13 && <5 + base >=4.13 && < 4.16 , containers >=0.6.2 && < 0.7 , gloss >=1.13.1 && < 1.14 - , lens >=4.18.1 && < 5.1 + , lens >=4.18.1 && < 5.2 , matrix >=0.3.6 && < 0.4 , transformers >=0.5 && < 0.6 + , monad-coroutine >= 0.9.1.3 && < 0.10 + , monad-parallel >= 0.7.2.5 && < 0.8 default-language: Haskell2010 ghc-options: -O2