worldturtle 0.2.0.0 → 0.2.2.0
raw patch · 9 files changed
+260/−280 lines, 9 filesdep +transformersdep −mtl
Dependencies added: transformers
Dependencies removed: mtl
Files
- ChangeLog.md +10/−0
- Graphics/WorldTurtle.hs +7/−26
- Graphics/WorldTurtle/Color.hs +1/−1
- Graphics/WorldTurtle/Commands.hs +53/−50
- Graphics/WorldTurtle/Internal/Commands.hs +71/−50
- Graphics/WorldTurtle/Internal/Coords.hs +4/−1
- Graphics/WorldTurtle/Internal/Sequence.hs +87/−132
- Graphics/WorldTurtle/Shapes.hs +4/−4
- worldturtle.cabal +23/−16
ChangeLog.md view
@@ -1,5 +1,15 @@ # Changelog for turtle-haskell +## v0.2.2 + +* Upgrading to GHC 8.10.3 to resolve problems GHC compiler problems with Mac +OSX. See [here](https://gitlab.haskell.org/ghc/ghc/-/issues/18446) for details. +* Fixed issue where newly drawn lines were drawn under older lines. + +## v0.2.1 + +* Internally simplified the commands system to use a Maybe Monad for sequencing. + ## v0.2.0 * Split `TurtleCommand` into `TurtleCommand` and `WorldCommand` to help reduce
Graphics/WorldTurtle.hs view
@@ -3,7 +3,7 @@ Description : WorldTurtle Copyright : (c) Archibald Neil MacDonald, 2020 License : BSD3 - Maintainer : FortOyer@hotmail.co.uk + Maintainer : archibaldnmac@gmail.com Stability : experimental Portability : POSIX @@ -11,7 +11,7 @@ in Haskell. Take a look at the - [examples](https://github.com/FortOyer/worldturtle-haskell#examples) on + [examples](https://github.com/aneilmac/worldturtle-haskell#examples) on Github! -} module Graphics.WorldTurtle @@ -49,8 +49,9 @@ import Graphics.WorldTurtle.Color import Graphics.WorldTurtle.Commands import Graphics.WorldTurtle.Internal.Sequence (renderTurtle) -import Graphics.WorldTurtle.Internal.Commands (TurtleCommand, seqT - , WorldCommand (..), seqW) +import Graphics.WorldTurtle.Internal.Commands ( TurtleCommand + , WorldCommand (..), seqW + , run) import Graphics.WorldTurtle.Shapes -- | Takes a `TurtleCommand` and executes the command on an implicitly created @@ -94,7 +95,7 @@ where display = InWindow "World Turtle" (800, 600) (400, 300) iterateRender w = G.applyViewPortToPicture (G.viewStateViewPort $ state w) - $! renderTurtle (seqW tc) (elapsedTime w) + $ renderTurtle (seqW tc) (elapsedTime w) input e w -- Reset key resets sim state (including unpausing). We -- deliberately keep view state the same. @@ -108,26 +109,6 @@ | running w = w { elapsedTime = f + elapsedTime w } | otherwise = w --- | `run` takes a `TurtleCommand` and a `Turtle` to execute the command on. --- The result of the computation is returned wrapped in a `WorldCommand`. --- --- For example, to create a turtle and get its @x@ `position` one might --- write: --- --- > myCommand :: Turtle -> WorldCommand Float --- > myCommand t = do --- > (x, _) <- run position t --- > return x --- --- Or to create a command that accepts a turtle and draws a right angle: --- --- > myCommand :: Turtle -> WorldCommand () --- > myCommand = run $ forward 10 >> right 90 >> forward 10 -run :: TurtleCommand a -- ^ Command to execute - -> Turtle -- ^ Turtle to apply the command upon. - -> WorldCommand a -- ^ Result as a `WorldCommand` -run c = WorldCommand . seqT c - -- | This is an infix version of `run` where the arguments are swapped. -- -- We take a turtle and a command to execute on the turtle. @@ -150,7 +131,7 @@ data World = World { elapsedTime :: !Float , running :: !Bool - , state :: !G.ViewState + , state :: G.ViewState } defaultWorld :: World
Graphics/WorldTurtle/Color.hs view
@@ -3,7 +3,7 @@ Description : Color functions Copyright : (c) Archibald Neil MacDonald, 2020 License : BSD3 -Maintainer : FortOyer@hotmail.co.uk +Maintainer : archibaldnmac@gmail.com Stability : experimental Portability : POSIX
Graphics/WorldTurtle/Commands.hs view
@@ -5,7 +5,7 @@ Description : The commands used Copyright : (c) Archibald Neil MacDonald, 2020 License : BSD3 -Maintainer : FortOyer@hotmail.co.uk +Maintainer : archibaldnmac@gmail.com Stability : experimental Portability : POSIX @@ -45,6 +45,7 @@ , setRotationSpeed -- * Styling commands. , stamp + , representation -- ** Query turtle's state. , position , heading @@ -53,7 +54,6 @@ , penColor , penDown , penSize - , representation , visible -- ** Mutate turtle's state. , branch @@ -90,12 +90,14 @@ Creates a new `Turtle` and displays it on the canvas. This turtle can then be manipulated! For example, to create a turtle and then move the turtle forward: + > main:: IO () > main = runWorld $ do > t <- makeTurtle > t >/> forward 90 The default turtle starts at position @(0, 0)@ and is orientated `north`. + -} makeTurtle :: WorldCommand Turtle makeTurtle = WorldCommand generateTurtle @@ -103,11 +105,12 @@ {-| This variant of `makeTurtle` takes a starting position, a starting orientation, and a color to apply to the turtle and the turtle's pen. + > myCommand :: WorldCommand () > 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`. -} @@ -128,7 +131,7 @@ -- turtle is headed. backward :: Float -- ^ Distance to move the turtle. -> TurtleCommand () -backward !d = forward (-d) +backward d = forward (-d) -- | Shorthand for `backward`. bk :: Float -> TurtleCommand () @@ -139,23 +142,23 @@ -> Float -- ^ Heading in degrees. -> Float -- ^ coefficient [0, 1] -> P.Point -calculateNewPointF_ !p !d !h !q = P.lerp q p endP - where !vec = P.rotateV (P.degToRad h) (d, 0) - !endP = vec P.+ p +calculateNewPointF_ !p !d !h !q = let !vec = P.rotateV (P.degToRad h) (d, 0) + !endP = vec P.+ p + in P.lerp q p endP -- | Move the turtle forward by the specified @distance@, in the direction the -- turtle is headed. forward :: Float -- ^ Distance to move the turtle. -> TurtleCommand () -forward !d = TurtleCommand $ \ turtle -> do - t <- tData_ turtle +forward !d = seqToT $ \ turtle -> do + !t <- tData_ turtle -- Get origin point animate' d (t ^. T.speed) $ \ q -> do -- Get new endpoint via percentage let !startP = t ^. T.position let !midP = calculateNewPointF_ startP d (t ^. T.heading) q -- don't draw if pen isn't in down state - when (t ^. T.penDown) $ + when (t ^. T.penDown) $ addPicture $ color (t ^. T.penColor) $ thickLine startP midP (t ^. T.penSize) -- Draw line from startPoint to midPoint. @@ -169,7 +172,7 @@ -- | Stamp a copy of the turtle shape onto the canvas at the current turtle -- position. stamp :: TurtleCommand () -stamp = TurtleCommand $ tData_ >=> (addPicture . T.drawTurtle) +stamp = seqToT $ tData_ >=> (addPicture . T.drawTurtle) -- | Turn a turtle right by the given degrees amount. right :: Float -- ^ Rotation amount to apply to turtle. @@ -192,18 +195,18 @@ rotateTo_ :: Bool -- ^ Bias decides in which direction rotation happens. -> Float -- ^ Amount to rotate by -> TurtleCommand () -rotateTo_ rightBias !r = TurtleCommand $ \ turtle -> do - t <- tData_ turtle - let r' = P.normalizeHeading r +rotateTo_ !rightBias !r = seqToT $ \ turtle -> do + !t <- tData_ turtle + let !r' = P.normalizeHeading r animate' (P.degToRad r') (t ^. T.rotationSpeed) $ \q -> do - let !h = t ^. T.heading - let !newHeading = P.normalizeHeading $ if rightBias then h - q * r' + let h = t ^. T.heading + let newHeading = P.normalizeHeading $ if rightBias then h - q * r' else h + q * r' -- Get new heading via percentage 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 +-- the @turtle@ if positive. Otherwise @radius@ units right of the @turtle@ -- if negative. -- -- The circle is drawn in an anticlockwise direction if the radius is @@ -236,26 +239,27 @@ -> Float -- ^ Absolute starting angle in degrees -> Float -- ^ Rotation amount about radius in degrees -> P.Point -- ^ Resulting new point -calculateNewPointC_ !p !radius !startAngle !angle = (px, py) - where !px = fst p - (radius * (cos a - cos s)) - !py = snd p - (radius * (sin a - sin s)) - !s = P.degToRad startAngle - !a = P.degToRad $ if radius >= 0 then startAngle + angle - else startAngle - angle +calculateNewPointC_ !p !radius !startAngle !angle = + let !px = fst p - (radius * (cos a - cos s)) + !py = snd p - (radius * (sin a - sin s)) + !s = P.degToRad startAngle + !a = P.degToRad $ if radius >= 0 then startAngle + angle + else startAngle - angle + in (px, py) -- | Draw an arc with a given @radius@. The center is @radius@ units left of the --- turtle if positive. Otherwise @radius@ units right of the turtle if +-- @turtle@ if positive. Otherwise @radius@ units right of the @turtle@ if -- negative. -- -- The arc is drawn in an anticlockwise direction if the radius is positive, -- otherwise, it is drawn in a clockwise direction. arc :: Float -- ^ Radius of the circle. -> Float -- ^ Angle to travel in degrees. - -- For example: @360@ for a full circle or @180@ for a - -- semicircle. + -- For example: @360@ for a full circle or @180@ for a + -- semicircle. -> TurtleCommand () -arc !radius !r = TurtleCommand $ \turtle -> do - t <- tData_ turtle +arc !radius !r = seqToT $ \turtle -> do + !t <- tData_ turtle let !r' = P.normalizeHeading r animate' (abs radius * P.degToRad r') (t ^. T.speed) $ \ q -> do let !startAngle = t ^. T.heading + 90 @@ -263,15 +267,14 @@ let !angle = r' * q -- don't draw if pen isn't in down state when (t ^. T.penDown) $ - addPicture $! drawCircle_ p radius startAngle angle - (t ^. T.penSize) (t ^. T.penColor) + addPicture $ drawCircle_ p radius startAngle angle + (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 then startAngle - 90 + angle else startAngle - 90 - angle) - let !p' = calculateNewPointC_ p radius startAngle angle ts . T.position .= p' @@ -284,7 +287,7 @@ -- | Warps the turtle to its starting position @(0, 0)@ and resets the -- orientation to `north` (@90@ degrees). No line is drawn moving the turtle. home :: TurtleCommand () -home = TurtleCommand $ \ turtle -> do +home = seqToT $ \ turtle -> do let ts = turtLens_ turtle ts . T.position .= (0, 0) ts . T.heading .= 90 @@ -296,9 +299,9 @@ -- This does not affect the turtle's heading. goto :: P.Point -- ^ Position to warp to. -> TurtleCommand () -goto point = TurtleCommand $ \ turtle -> do - t <- tData_ turtle - let startP = t ^. T.position +goto point = seqToT $ \ turtle -> do + !t <- tData_ turtle + let !startP = t ^. T.position when (t ^. T.penDown) $ addPicture $ color (t ^. T.penColor) $ thickLine startP point (t ^. T.penSize) @@ -407,8 +410,9 @@ See `representation`. For example, to set the turtle as a red circle: - > import Graphics.WorldTurtle - > import qualified Graphics.Gloss.Data.Picture as G + + > import Graphics.WorldTurtle + > import qualified Graphics.Gloss.Data.Picture as G > > myCommand :: TurtleCommand () > myCommand = do @@ -422,7 +426,7 @@ -- | Clears all drawings form the canvas. Does not alter any turtle's state. clear :: WorldCommand () -clear = WorldCommand $ pics .= [] +clear = WorldCommand $ pics .= mempty -- | Sleep for a given amount of time in seconds. When sleeping no animation -- runs. A negative value will be clamped to @0@. @@ -432,9 +436,9 @@ -- | 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 ) = TurtleCommand $ \ turtle -> do - t <- tData_ turtle - output <- p turtle +branch (TurtleCommand p ) = seqToT $ \ turtle -> do + !t <- tData_ turtle + output <- seqW $ p turtle turtLens_ turtle .= t return output @@ -459,30 +463,29 @@ -} -- | Looks up the turtle data for the given turtle in the state monad. --- This type signature comes form GHC...my prism-foo is not good enough to sugar it. +-- This type signature comes form GHC...my prism-foo is not good enough to sugar +-- it. turtLens_ :: Applicative f => Turtle -> (T.TurtleData -> f T.TurtleData) - -> TSC b - -> f (TSC b) + -> TSC + -> f TSC turtLens_ t = turtles . ix t {-# INLINE turtLens_ #-} -- | 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 = - TurtleCommand $ \ t -> fromMaybe def <$> preuse (turtLens_ t . l) +getter_ def l = seqToT $ \ t -> fromMaybe def <$> preuse (turtLens_ t . l) {-# INLINE getter_ #-} -- | This is a helper function that extracts the turtle data for a given turtle. -tData_ :: Turtle -> SeqC T.TurtleData -tData_ = seqT $ getter_ T.defaultTurtle id +tData_ :: Turtle -> SequenceCommand T.TurtleData +tData_ t = seqW $ seqT (getter_ T.defaultTurtle id) t {-# INLINE tData_ #-} -- | 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 = - TurtleCommand $ \ t -> turtLens_ t . l .= val +setter_ l val = seqToT $ \ t -> turtLens_ t . l .= val {-# INLINE setter_ #-}
Graphics/WorldTurtle/Internal/Commands.hs view
@@ -1,8 +1,9 @@ {-# OPTIONS_HADDOCK hide #-} module Graphics.WorldTurtle.Internal.Commands - ( SeqC - , TurtleCommand (..) + ( TurtleCommand (..) , WorldCommand (..) + , run + , seqToT ) where import Control.Applicative @@ -12,8 +13,52 @@ import Graphics.WorldTurtle.Internal.Sequence -type SeqC a = SequenceCommand (AlmostVal ()) a +{- | A `WorldCommand` represents an instruction that affects the entire + animation canvas. + + This could be as simple as "make a turtle" or more complicated like + "run these 5 turtles in parallel." + Like `TurtleCommand`s, `WorldCommand`s can be executed in order 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. + + For how to achieve parallel animations + see "Graphics.WorldTurtle#parallel". +-} +newtype WorldCommand a = WorldCommand + { + seqW :: SequenceCommand a + } + +instance Functor WorldCommand where + fmap f (WorldCommand a) = WorldCommand $! fmap f a + +instance Applicative WorldCommand where + pure a = WorldCommand $ pure a + liftA2 f (WorldCommand a) (WorldCommand b) = WorldCommand $ liftA2 f a b + +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 MonadPlus WorldCommand + +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." @@ -39,7 +84,7 @@ -} newtype TurtleCommand a = TurtleCommand { - seqT :: Turtle -> SeqC a + seqT :: Turtle -> WorldCommand a } instance Functor TurtleCommand where @@ -54,51 +99,27 @@ (TurtleCommand a) >>= f = TurtleCommand $ \ t -> a t >>= \s -> seqT (f s) t instance MonadFail TurtleCommand where - fail t = TurtleCommand $ \ _ -> do - addPicture $ text t - failSequence - -{- | A `WorldCommand` represents an instruction that affects the entire - animation canvas. - - This could be as simple as "make a turtle" or more complicated like - "run these 5 turtles in parallel." - - Like `TurtleCommand`s, `WorldCommand`s can be executed in order 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. - - For how to achieve parallel animations - see "Graphics.WorldTurtle#parallel". --} -newtype WorldCommand a = WorldCommand - { - seqW :: SeqC a - } - -instance Functor WorldCommand where - fmap f (WorldCommand a) = WorldCommand $ fmap f a - -instance Applicative WorldCommand where - pure a = WorldCommand $ pure a - liftA2 f (WorldCommand a) (WorldCommand b) = WorldCommand $ liftA2 f a b - -instance Monad WorldCommand where - (WorldCommand a) >>= f = WorldCommand $ a >>= \s -> seqW (f s) - -instance Alternative WorldCommand where - empty = WorldCommand failSequence - (<|>) (WorldCommand a) (WorldCommand b) = WorldCommand $ alternateSequence a b - -instance Semigroup a => Semigroup (WorldCommand a) where - (WorldCommand a) <> (WorldCommand b) = WorldCommand $ combineSequence a b + fail t = TurtleCommand $ \ _ -> fail t -instance MonadPlus WorldCommand +-- | `run` takes a `TurtleCommand` and a `Turtle` to execute the command on. +-- The result of the computation is returned wrapped in a `WorldCommand`. +-- +-- For example, to create a turtle and get its @x@ `position` one might +-- write: +-- +-- > myCommand :: Turtle -> WorldCommand Float +-- > myCommand t = do +-- > (x, _) <- run position t +-- > return x +-- +-- Or to create a command that accepts a turtle and draws a right angle: +-- +-- > myCommand :: Turtle -> WorldCommand () +-- > myCommand = run $ forward 10 >> right 90 >> forward 10 +run :: TurtleCommand a -- ^ Command to execute + -> Turtle -- ^ Turtle to apply the command upon. + -> WorldCommand a -- ^ Result as a `WorldCommand` +run = seqT -instance MonadFail WorldCommand where - fail t = WorldCommand $ do - addPicture $ text t - failSequence +seqToT :: (Turtle -> SequenceCommand a) -> TurtleCommand a +seqToT f = TurtleCommand $ \ t -> WorldCommand $! f t
Graphics/WorldTurtle/Internal/Coords.hs view
@@ -22,7 +22,10 @@ -> Point -- Point /a/. -> Point -- Point /b/. -> Point -- new point some percentage value between /a/ and /b/. -lerp !l !a !b = ((1 P.- l) `mulSV` a) + (l `mulSV` b) +lerp !l !a !b = let (!ux, !uy) = (1 P.- l) `mulSV` a + (!vx, !vy) = l `mulSV` b + !n = (ux P.+ vx, uy P.+ vy) + in n -- | Return a valid heading value between (0, 360]. -- We want 360 to be 360 (full rotation).
Graphics/WorldTurtle/Internal/Sequence.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} module Graphics.WorldTurtle.Internal.Sequence ( Turtle , TSC , SequenceCommand - , AlmostVal + , defaultTSC + , processTurtle , renderTurtle , addPicture , simTime @@ -19,38 +20,30 @@ , animate , combineSequence , alternateSequence - , failSequence ) where import Graphics.WorldTurtle.Internal.Turtle -import Graphics.Gloss.Data.Picture (Picture, pictures) +import Graphics.Gloss.Data.Picture (Picture) -import Control.Monad.Cont -import Control.Monad.State +import Control.Applicative (empty) +import Control.Monad (when) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State.Strict import Control.Lens -import Data.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) +type TurtleState = State TSC --- | 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 +-- | Maybe Monad on top of the State Monad of form @SequenceCommand a@. +-- This represents a computation that can be "partial." I.E. we can only +-- animate so much of the scene with the time given. +type SequenceCommand a = MaybeT TurtleState a -- Careful of editing the Turtle comment below as it is public docs! -- Really "Turtle" is just a handle to internal TurtleData. It is a key that @@ -61,24 +54,20 @@ -- `Graphics.WorldTurtle.Commands.makeTurtle`. newtype Turtle = Turtle Int deriving (Eq, Ord) -data TSC b = TSC +data TSC = TSC { _pics :: ![Picture] -- ^ All pictures that make up the current canvas - , _exitCall :: SequenceCommand b b -- ^ Stop drawing call for animations , _totalSimTime :: !Float -- ^ Remaining available for animating - , _turtles :: Map Turtle TurtleData -- Collection of all turtles. + , _turtles :: !(Map Turtle TurtleData) -- Collection of all turtles. , _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 +-- | Generates default parameter arguments. +defaultTSC :: Float -> TSC defaultTSC givenTime = TSC - { _pics = [] + { _pics = mempty , _totalSimTime = givenTime - , _exitCall = error "Exit called but not defined in animation." , _turtles = Map.empty , _nextTurtleId = 0 } @@ -87,60 +76,54 @@ -- 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 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 -> SequenceCommand b () +setSimTime :: Float -- ^ Time to set. + -> SequenceCommand () setSimTime newTime = do let newTime' = max 0 newTime totalSimTime .= newTime' - when (newTime' <= 0) failSequence + when (newTime' <= 0) empty -- | Takes a value away form the current sim time and store the updated time. -- See `setSimTime`. -decrementSimTime :: Float -- ^ Value to subtract from store simulation time. - -> SequenceCommand b () -decrementSimTime duration = simTime >>= setSimTime . flip (-) duration +decrementSimTime :: Float -- ^ Value to subtract from store simulation time. + -> SequenceCommand () +decrementSimTime duration = simTime >>= \ t -> setSimTime (t - duration) -- | Given a picture, adds it to the picture list. addPicture :: Picture -- ^ Picture to add to our animation - -> SequenceCommand b () -addPicture p = pics %= (p :) - --- | 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 commands = callCC $ \exit -> do - exitCall .= exit Nothing - decrementSimTime 0 -- In case we are already at a time of 0. - Just <$> commands + -> SequenceCommand () +addPicture p = pics %= ($!) (p :) -processTurtle :: SequenceCommand (AlmostVal a) a - -> TSC (AlmostVal a) - -> (AlmostVal a, TSC (AlmostVal a)) +-- | Given a sequence and a State, returns the result of the computation and the +-- final state of the computation of form @(r, s)@. When @r@ is @Just@, then +-- the computation completed, otherwise the computation ended early due to +-- lack of time available (i.e. a partial animation). +processTurtle :: SequenceCommand a + -> TSC + -> (Maybe a, TSC) processTurtle commands tsc = - let drawS = runContT (exitCondition commands) return + let drawS = runMaybeT $ decrementSimTime 0 >> commands in runState drawS tsc -renderTurtle :: SequenceCommand (AlmostVal a) a -> Float -> Picture -renderTurtle c f = let (_, s) = processTurtle c (defaultTSC f) - in pictures $ s ^. pics ++ drawTurtles (s ^. turtles) +-- | 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) drawTurtles :: Map Turtle TurtleData -> [Picture] drawTurtles m = drawTurtle <$> Map.elems m -generateTurtle :: SequenceCommand b Turtle +generateTurtle :: SequenceCommand Turtle generateTurtle = do t <- Turtle <$> use nextTurtleId turtles %= Map.insert t defaultTurtle @@ -149,26 +132,28 @@ animate' :: Float -> Float - -> (Float -> SequenceCommand b a) - -> SequenceCommand b a -animate' !distance !turtleSpeed callback = - let !duration = distance / turtleSpeed - !d' = if isNaN duration || isInfinite duration then 0 else duration + -> (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 -animate :: Float -> (Float -> SequenceCommand b a) -> SequenceCommand b a -animate !duration callback = do +animate :: Float + -> (Float -> SequenceCommand a) + -> SequenceCommand a +animate duration callback = do timeRemaining <- simTime -- simulation time to go - let !availableTime = min timeRemaining duration + 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 + 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 + decrementSimTime availableTime -- Test to see if this is the end of our animation and if so exit early return t @@ -177,84 +162,54 @@ -- 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 + => 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 - -- If either attempt failed, we fail also. - when (isNothing aVal || isNothing bVal) failSequence - - -- Everything is hunky dory so we continue on into the next bind of the monad. - let (Just !aVal') = aVal - let (Just !bVal') = bVal - return $ aVal' <> bVal' + (aVal, bVal) <- runParallel a b + combo aVal bVal + where combo (Just x) (Just y) = return (x <> y) + combo _ _ = empty -- | Runs two items in sequence, returns the result of /a/ if /a/ passes, -- otherwise returns the results of /b/. The implication of this is that only -- the result of a will be returned while animating, and b when animation is -- finished. -alternateSequence :: SequenceCommand b a -- ^ Sequence /a/ to run. - -> SequenceCommand b a -- ^ Sequence /b/ to run. - -> SequenceCommand b a +alternateSequence :: SequenceCommand a -- ^ Sequence /a/ to run. + -> SequenceCommand a -- ^ Sequence /b/ to run. + -> SequenceCommand a alternateSequence a b = do - (!aVal, !bVal) <- runParallel a b - - -- If both values failed we fail also. - when (isNothing aVal && isNothing bVal) failSequence - - -- If A passes, return the value of A, otherwise return the value of B. - if isJust aVal - then let (Just !aVal') = aVal in return $! aVal' - else let (Just !bVal') = bVal in return $! bVal' + (aVal, bVal) <- runParallel a b + combo aVal bVal + where combo (Just x) _ = return x + combo _ (Just y) = return y + combo _ _ = empty -- | 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) +runParallel :: SequenceCommand a -- ^ Sequence /a/ to run. + -> SequenceCommand b -- ^ Sequence /b/ to run. + -> SequenceCommand (Maybe a, Maybe b) -- ^ New sequence of A and B which returns both results. runParallel a b = do - startSimTime <- use totalSimTime - parentExitCall <- use exitCall - -- Run A, and return back to this point when/if it fails. - aVal <- callCC $ \ exitFromA -> do - exitCall .= exitFromA Nothing - Just <$> a - - aSimTime <- use totalSimTime - - -- Run B, and return back to this point when/if it fails. - bVal <- callCC $ \ exitFromB -> do - exitCall .= exitFromB Nothing - totalSimTime .= startSimTime -- restart sim time back to initial. - Just <$> b + startSimTime <- use totalSimTime - bSimTime <- use totalSimTime + s <- lift get + -- Run the "A" animation + let (aVal, s') = processTurtle a s + let aSimTime = s' ^. totalSimTime + -- 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 the remaining time of the longest - -- running animation. - totalSimTime .= min aSimTime bSimTime - - exitCall .= parentExitCall -- Let us exit properly again! - + -- We take the remaining animation time to be the remaining time of the + -- longest running animation + lift $ put $ s'' & totalSimTime %~ min aSimTime + -- Now we must test the remaining sim time. The above calls might have -- succeeded while still exhausting our remaining time -- which as far as -- animating is concerned is the same as not succeeding at all! - decrementSimTime 0 - + decrementSimTime 0 return (aVal, bVal) - --- | Calls our early exit and fails the callback. No calculations will be --- performed beyond this call. -failSequence :: SequenceCommand b a -failSequence = do - ex <- use exitCall - _ <- 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 x) = (Nothing :: Maybe Void) - in absurd x
Graphics/WorldTurtle/Shapes.hs view
@@ -4,7 +4,7 @@ Description : WorldTurtle Copyright : (c) Archibald Neil MacDonald, 2020 License : BSD3 -Maintainer : FortOyer@hotmail.co.uk +Maintainer : archibaldnmac@gmail.com Stability : experimental Portability : POSIX @@ -33,7 +33,7 @@ -> Point -- ^ Ending point. -> Float -- ^ Line thickness. -> Picture -- ^ Produced line. -thickLine a b t = polygon [a1, a2, b2, b1] +thickLine !a !b !t = polygon [a1, a2, b2, b1] where !v = b P.- a !angle = P.argV v !perpAngle = angle - (pi/2) @@ -46,10 +46,10 @@ !b2 = b P.+ t'' P.+ t' outline_ :: Color -> Picture -outline_ !c = color c $ translate 0 (-1) $ scale 1.4 1.4 $ fill_ c +outline_ c = color c $ translate 0 (-1) $ scale 1.4 1.4 $ fill_ c fill_ :: Color -> Picture -fill_ !c = color c $ translate (-4) (-2) +fill_ c = color c $ translate (-4) (-2) $ pictures [ polygon [(0, 0), (4, 2), (1, 2)] -- left tail , polygon [(4, 2), (8, 0), (7, 2)] -- right tail
worldturtle.cabal view
@@ -1,42 +1,49 @@-cabal-version: 2.0 +cabal-version: 3.0 name: worldturtle -version: 0.2.0.0 -synopsis: Turtle graphics. +version: 0.2.2.0 +synopsis: LOGO-like Turtle graphics with a monadic interface. category: teaching -homepage: https://github.com/FortOyer/worldturtle-haskell#readme -bug-reports: https://github.com/FortOyer/worldturtle-haskell/issues +homepage: https://github.com/aneilmac/worldturtle-haskell#readme +bug-reports: https://github.com/aneilmac/worldturtle-haskell/issues author: Archibald Neil MacDonald -maintainer: FortOyer@hotmail.co.uk +maintainer: archibaldnmac@gmail.com copyright: 2020 Archibald Neil MacDonald -license: BSD3 +license: BSD-3-Clause license-file: LICENSE build-type: Simple -tested-with: GHC ==8.8.3 || ==8.10.3 +tested-with: GHC ==8.10.3 description: Have you ever heard of [Turtle Graphics](https://en.wikipedia.org/wiki/Turtle_graphics)? - . + If not, then think of a @turtle@ as a cursor you can program to draw! - . + Turtle graphics are a fantastic introduction to the world of programming and to the syntax of a new programming language. - . -  - . + +  + This module is a framework built on top of [gloss](https://hackage.haskell.org/package/gloss) to render turtles programmed in Haskell as animations. This is primarily aimed as a teaching tool to beginners - but also, it's cool to draw things! - . + See The API ref, "Graphics.WorldTurtle", for features! + It's easy to create a new project with stack: + + > stack new my-worldturtle-project aneilmac/worldturtle + > cd my-worldturtle-project + > stack build + > stack exec my-worldturtle-project + extra-doc-files: docs/images/*.gif extra-source-files: ChangeLog.md source-repository head type: git - location: https://github.com/FortOyer/worldturtle-haskell + location: https://github.com/aneilmac/worldturtle-haskell library exposed-modules: @@ -54,7 +61,7 @@ , gloss >=1.13.1 && < 1.14 , lens >=4.18.1 && < 4.20 , matrix >= 0.3.6 && < 0.4 - , mtl >=2.2.2 && < 2.3 + , transformers >=0.5 && < 0.6 default-language: Haskell2010 ghc-options: -O2