worldturtle (empty) → 0.1.0.0
raw patch · 15 files changed
+1214/−0 lines, 15 filesdep +basedep +containersdep +glosssetup-changedbinary-added
Dependencies added: base, containers, gloss, lens, mtl
Files
- ChangeLog.md +7/−0
- Graphics/WorldTurtle.hs +155/−0
- Graphics/WorldTurtle/Commands.hs +461/−0
- Graphics/WorldTurtle/Internal/Commands.hs +86/−0
- Graphics/WorldTurtle/Internal/Coords.hs +38/−0
- Graphics/WorldTurtle/Internal/Sequence.hs +260/−0
- Graphics/WorldTurtle/Internal/Turtle.hs +64/−0
- Graphics/WorldTurtle/Shapes.hs +57/−0
- LICENSE +26/−0
- Setup.hs +2/−0
- docs/images/basic_turtle_square.gif binary
- docs/images/parallel_circles_animated.gif binary
- docs/images/parallel_circles_animated_300.gif binary
- docs/images/parallel_serial_turtles.gif binary
- worldturtle.cabal +58/−0
+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Changelog for turtle-haskell + +## v0.1.0 + +Initial release. + +## Unreleased changes
+ Graphics/WorldTurtle.hs view
@@ -0,0 +1,155 @@+{-| +Module : Graphics.WorldTurtle +Description : WorldTurtle +Copyright : (c) Archibald Neil MacDonald, 2020 +License : BSD3 +Maintainer : FortOyer@hotmail.co.uk +Stability : experimental +Portability : POSIX + +"Graphics.WorldTurtle" is a module for writing and rendering turtle graphics +in Haskell. + +-} +module Graphics.WorldTurtle + ( + -- * Running the turtle + -- $running + TurtleCommand + , runTurtle + -- * Parallel animation + -- $parallel + , (<|>) + -- * Further documentation + , module Graphics.WorldTurtle.Commands + , module Graphics.WorldTurtle.Shapes + , module Graphics.Gloss.Data.Color + ) where + +import Control.Applicative ((<|>)) + +import Graphics.Gloss.Data.Color +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 Graphics.WorldTurtle.Commands +import Graphics.WorldTurtle.Internal.Sequence (renderTurtle) +import Graphics.WorldTurtle.Internal.Commands (TurtleCommand, seqT) +import Graphics.WorldTurtle.Shapes + +data World = World { elapsedTime :: !Float + , running :: !Bool + , state :: !G.ViewState + } + +{- | `runTurtle` takes a `TurtleCommand` and produces the animation in a new + window! + + The simplest way to run `runTurtle` is to execute it directly from + your main function like so: + + @ + main :: IO () + main = runTurtle yourOwnCoolCommand + @ + + While running, you can interact with the window in the following way: + + +------------------------------------------+-------------------+ + | Action | Interaction | + +==========================================+===================+ + | Pan the viewport. | Click and drag | + +------------------------------------------+-------------------+ + | Zoom in/out. |Mousewheel up/down | + +------------------------------------------+-------------------+ + | Reset the viewport to initial position. | Spacebar | + +------------------------------------------+-------------------+ + | Reset the animation. | @R@ key | + +------------------------------------------+-------------------+ + | Pause the animation. | @P@ key | + +------------------------------------------+-------------------+ + | Quit | Escape key | + +------------------------------------------+-------------------+ +-} +runTurtle :: TurtleCommand () -- ^ Command sequence to execute + -> IO () +runTurtle tc = G.play display white 30 defaultWorld iterateRender input timePass + where display = InWindow "World Turtle" (800, 600) (400, 300) + iterateRender w = G.applyViewPortToPicture + (G.viewStateViewPort $ state w) + $! renderTurtle (seqT tc) (elapsedTime w) + input e w + -- Reset key resets sim state (including unpausing). We + -- deliberately keep view state the same. + | isResetKey_ e = w { elapsedTime = 0, running = True } + -- Pause prevents any proceeding. + | isPauseKey_ e = w { running = not $ running w } + -- Let Gloss consume the command. + | otherwise = w { state = G.updateViewStateWithEvent e $ state w } + -- Increment simulation time if we are not paused. + timePass f w + | running w = w { elapsedTime = f + elapsedTime w } + | otherwise = w + +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 + +-- | Tests to see if a key-event is the reset key. +isResetKey_ :: G.Event -> Bool +isResetKey_ (G.EventKey (G.Char 'r') G.Down _ _) = True +isResetKey_ (G.EventKey (G.Char 'R') G.Down _ _) = True +isResetKey_ _ = False + +-- Tests to see if a key event is the pause key +isPauseKey_ :: G.Event -> Bool +isPauseKey_ (G.EventKey (G.Char 'p') G.Down _ _) = True +isPauseKey_ (G.EventKey (G.Char 'P') G.Down _ _) = True +isPauseKey_ _ = False + +{- $running + +It is easy to create and animate your turtle. You just pass your commands to +`runTurtle` like so: + +@ + import Control.Monad (replicateM_) + import Graphics.WorldTurtle + + myCommand :: TurtleCommand () + myCommand = do + t <- makeTurtle + replicateM_ 4 $ forward 90 t >> right 90 t + + main :: IO () + main = runTurtle myCommand +@ + +Which will produce this animation + + +-} + + +{- $parallel + + We already know that `TurtleCommand`s can be combined with `(>>)`, but the + alternative operation `(<|>)` can alo be used to combine two + `TurtleCommand`s. This has a special meaning: do both animations at the + same time! + +  + + Note that the result of @a \<|\> b@ is: + + >>> a <|> b + a + + when @a@ is not `Control.Monad.mzero`. +-}
+ Graphics/WorldTurtle/Commands.hs view
@@ -0,0 +1,461 @@+{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-| +Module : Graphics.WorldTurtle.Commands +Description : The commands used +Copyright : (c) Archibald Neil MacDonald, 2020 +License : BSD3 +Maintainer : FortOyer@hotmail.co.uk +Stability : experimental +Portability : POSIX + +This module is a collection of all the commands used to manipulate a turtle! + +-} +module Graphics.WorldTurtle.Commands + ( + -- * Setting up a turtle. + Turtle + , makeTurtle + , makeTurtle' + -- * Movement commands. + , P.Point + , forward + , fd + , backward + , bk + , left + , lt + , right + , rt + , Graphics.WorldTurtle.Commands.circle + , goto + , setPosition + , home + , setHeading + , setSpeed + -- * Styling commands. + , stamp + , representation + -- * Tell turtle's state. + , position + , heading + , speed + , penColor + , penDown + , penSize + , visible + -- * Drawing state. + , setPenColor + , setPenDown + , setPenSize + , setRepresentation + , setVisible + -- * Canvas commands. + , clear + -- * Common constants + , east + , north + , west + , south + ) where + +import Data.Maybe (fromMaybe) + +import Control.Lens +import Control.Monad + +import Graphics.WorldTurtle.Shapes + +import Graphics.WorldTurtle.Internal.Commands +import Graphics.WorldTurtle.Internal.Sequence + +import qualified Graphics.WorldTurtle.Internal.Turtle as T +import qualified Graphics.WorldTurtle.Internal.Coords as P + +import Graphics.Gloss.Data.Color (Color, black) + +import Graphics.Gloss.Data.Picture + +{- | +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 = runTurtle $ do + t <- makeTurtle + forward 90 t + @ + +The default turtle starts at position (0, 0) and is orientated @North@. + +-} +makeTurtle :: TurtleCommand Turtle +makeTurtle = TurtleCommand generateTurtle + +{-| 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 :: TurtleCommand () + myCommand = do + t1 <- makeTurtle' (0, 0) 0 green + t2 <- makeTurtle' (0, 0) 90 red + forward 90 t1 \<|\> forward 90 t2 + @ + + See `makeTurtle`. +-} +makeTurtle' :: Point -- ^ Initial position of the turtle. + -> Float -- ^ Initial heading of the turtle. + -> Color -- ^ Color of the turtle and the turtle's pen. + -> TurtleCommand Turtle -- ^ The generated turtle. +makeTurtle' p f c = TurtleCommand $ 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 + return turtle + +-- | Move the turtle backward by the specified @distance@, in the direction the +-- turtle is headed. +backward :: Float -- ^ Distance to move the turtle. + -> Turtle -- ^ The turtle to move. + -> TurtleCommand () +backward !d = forward (-d) + +-- | Shorthand for `backward`. +bk :: Float -> Turtle -> TurtleCommand () +bk = backward + +-- | Turn a turtle right by the given degrees amount. +right :: Float -- ^ Rotation amount to apply to turtle. + -> Turtle -- ^ The turtle to rotate. + -> TurtleCommand () +right !r = left (-r) + +-- | Shorthand for `right`. +rt :: Float -> Turtle -> TurtleCommand () +rt = right + +calculateNewPointF_ :: P.Point -- ^ Starting point + -> Float -- ^ Distance + -> 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 + +-- | Move the turtle forward by the specified @distance@, in the direction the +-- turtle is headed. +forward :: Float -- ^ Distance to move the turtle. + -> Turtle -- ^ The turtle to move. + -> TurtleCommand () +forward !d turtle = TurtleCommand $ 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 + when (t ^. T.penDown) $ do -- don't draw if pen isn't in down state + addPicture $ color (t ^. T.penColor) + $ thickLine startP midP (t ^. T.penSize) + -- Draw line from startPoint to midPoint. + turtLens_ turtle . T.position .= midP + -- Update the turtle to a new position + +-- | Shorthand for `forward`. +fd :: Float -> Turtle -> TurtleCommand () +fd = forward + +-- | Stamp a copy of the turtle shape onto the canvas at the current turtle +-- position. +stamp :: Turtle -- ^ The turtle with the shape to be copied. + -> TurtleCommand () +stamp turtle = TurtleCommand $ tData_ turtle >>= addPicture . T.drawTurtle + +-- | Turn a turtle left by the given degrees amount. +left :: Float -- ^ Rotation amount to apply to turtle. + -> Turtle -- ^ The turtle to rotate. + -> TurtleCommand () +left !r turtle = TurtleCommand $ do + t <- tData_ turtle + let r' = P.normalizeDirection r + animate' (P.degToRad r') (t ^. T.speed) $ \q -> do + let !h = t ^. T.heading + --let q' = if r > 0 then q else -q + let !newHeading = P.normalizeHeading $ h + q * r' + -- Get new heading via percentage + turtLens_ turtle . T.heading .= newHeading + +-- | Shorthand for `left`. +lt :: Float -> Turtle -> TurtleCommand () +lt = left + +-- | Draws an arc starting from a given starting point on the edge of the +-- circle. +drawCircle_ :: P.Point -- ^ Point on edge of circle to start from + -> Float -- ^ Radius of circle + -> Float -- ^ Absolute starting angle in degrees + -> Float -- ^ Rotation amount about radius in degrees + -> Float -- ^ Line thickness (penSize) + -> Color -- ^ Color of circle + -> Picture -- ^ Resulting circle +drawCircle_ !p !radius !startAngle !endAngle !pSize !pColor = + translate (fst p) (snd p) $ rotate (180 - startAngle) + $ translate (-radius) 0 + $ color pColor + $ rotate (if radius >= 0 then 0 else 180) + $ thickArc 0 (endAngle) radius pSize + +-- Calculates the next position of a turtle on a circle. +calculateNewPointC_ :: P.Point -- ^ Point on edge of circle + -> Float -- ^ Radius of circle + -> 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 * (cA - cS)) + !py = snd p - (radius * (sA - sS)) + !s = P.degToRad startAngle + !a = P.degToRad $ angle + startAngle + !cS = cos s + !sS = sin s + !cA = cos a + !sA = sin a + +-- | 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 +-- negative. +-- +-- The arc is drawn in an anticlockwise direction if the radius is positive, +-- otherwise, it is drawn in a clockwise direction. +circle :: Float -- ^ Radius of the circle. + -> Float -- ^ Angle to travel in degrees. + -- For example: @360@ for a full circle or @180@ for a + -- semicircle. + -> Turtle -- ^ Turtle to move in a circle. + -> TurtleCommand () +circle !radius !r turtle = TurtleCommand $ do + t <- tData_ turtle + let !r' = P.normalizeHeading r + animate' (radius * P.degToRad r') (t ^. T.speed) $ \ q -> do + let !startAngle = t ^. T.heading + 90 + let !p = t ^. T.position + let !angle = r' * q + when (t ^. T.penDown) $ do -- don't draw if pen isn't in down state + 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 $ startAngle - 90 + angle) + + let !p' = calculateNewPointC_ p radius startAngle angle + ts . T.position .= p' + +-- | Returns the turtle's current position. +-- Default (starting) position is @(0, 0)@. +position :: Turtle -- ^ Turtle to query. + -> TurtleCommand P.Point -- ^ Returned current point. +position = getter_ (0, 0) T.position + +-- | 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 :: Turtle + -> TurtleCommand () +home turtle = TurtleCommand $ do + let ts = turtLens_ turtle + 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. +goto :: P.Point -- ^ Position to warp to. + -> Turtle -- ^ Turtle to modify. + -> TurtleCommand () +goto point turtle = TurtleCommand $ do + t <- tData_ turtle + let startP = t ^. T.position + when (t ^. T.penDown) $ addPicture + $ color (t ^. T.penColor) + $ thickLine startP point (t ^. T.penSize) + turtLens_ turtle . T.position .= point + +-- | Alias of `goto`. +setPosition :: P.Point -> Turtle -> TurtleCommand () +setPosition = goto + +-- | Returns the turtle's heading. +-- +-- @0@ is along the positive x-axis, going anticlockwise. So: +-- +-- * East is @0@ degrees. +-- * North is @90@ degrees. +-- * West is @180@ degrees. +-- * South is @270@ degrees. +-- +-- The default heading is North (@90@ degrees). +heading :: Turtle -- ^ Turtle to query. + -> TurtleCommand Float -- ^ Returned heading as angle in degrees. +heading = getter_ 0 T.heading + +-- | Sets the turtle's heading. See `heading`. +setHeading :: Float -- ^ Heading to apply. + -> Turtle -- ^ Turtle to set. + -> TurtleCommand () +setHeading = setter_ T.heading + +-- | Returns the turtle's pen color. +-- The color of the turtle's pen.The default color is @black@. +penColor :: Turtle -- ^ Turtle to query. + -> TurtleCommand Color -- ^ Returned current pen color. +penColor = getter_ black T.penColor + +-- | Set the turtle's pen color. +-- See `penColor`. +setPenColor :: Color -- ^ New pen color to apply + -> Turtle -- ^ Turtle to modify. + -> TurtleCommand () +setPenColor = setter_ T.penColor + +-- | Returns whether the turtle's pen is down. +-- When the turtle's pen is down it will draw a line when it moves. +-- The default value is @true@. +penDown :: Turtle -- ^ Turtle to query. + -> 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. + -> Turtle -- ^ Turtle to modify. + -> TurtleCommand () +setPenDown = setter_ T.penDown + +-- | Returns the turtle's pen size. +-- Defaults to @2@. +penSize :: Turtle -- ^ Turtle to query. + -> TurtleCommand Float -- ^ Size of turtle's pen. +penSize = getter_ 0 T.penSize + +-- | Sets the turtle's pen size. +-- See `penSize`. +setPenSize :: Float -- ^ New size for turtle's pen. + -> Turtle -- ^ Turtle to modify. + -> TurtleCommand () +setPenSize = setter_ T.penSize + +-- | Returns whether the turtle is visible. +-- The default value is @true@. +visible :: Turtle -- ^ Turtle to query. + -> 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. + -> Turtle -- ^ Turtle to modify. + -> TurtleCommand () +setVisible = setter_ T.visible + +-- | Returns whether the turtle's current speed. +-- Speed is is @distance@ per second. +-- A speed of 0 is equivalent to no animation being performed and instant +-- drawing. +-- The default value is @200@. +speed :: Turtle -- ^ Turtle to query. + -> TurtleCommand Float +speed = getter_ 0 T.speed + +-- | Sets the turtle's speed. +-- See `speed`. +setSpeed :: Float -- ^ New speed. + -> Turtle -- ^ Turtle to modify. + -> TurtleCommand () +setSpeed = setter_ T.speed + +-- | Gets the turtle's representation as a Gloss `Picture`. +representation :: Turtle -- ^ Turtle to query. + -> TurtleCommand Picture +representation = getter_ blank T.representation + +{- | Sets the turtle's representation to a Gloss `Picture`. + See `representation`. + For example, to set the turtle as a red circle: + + @ + import Graphics.WorldTurtle + import qualified Graphics.Gloss.Data.Picture as G + + myCommand :: TurtleCommand () + myCommand = do + t <- makeTurtle + setPenColor red t + setRepresentation (G.color red $ G.circleSolid 10) t + forward 90 t + @ +-} +setRepresentation :: Picture + -> Turtle -- ^ Turtle to mutate. + -> TurtleCommand () +setRepresentation = setter_ T.representation + +-- | Clears all drawings form the canvas. Does not alter any turtle's state. +clear :: TurtleCommand () +clear = TurtleCommand $ pics .= [] + +-- | @90@ degrees. +north :: Float +north = 90 + +-- | @0@ degrees. +east :: Float +east = 0 + +-- | @180@ degrees. +west :: Float +west = 180 + +-- | @270@ degrees. +south :: Float +south = 270 + +{- + Here be dirty helper functions: +-} + +-- | 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. +turtLens_ :: Applicative f + => Turtle + -> (T.TurtleData -> f T.TurtleData) + -> TSC b + -> f (TSC b) +turtLens_ t = turtles . at t . _Just +{-# 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 -> Turtle -> TurtleCommand a +getter_ def l t = + TurtleCommand $ 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 +{-# 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 -> Turtle -> TurtleCommand () +setter_ l val t = + TurtleCommand $ turtLens_ t . l .= val +{-# INLINE setter_ #-}
+ Graphics/WorldTurtle/Internal/Commands.hs view
@@ -0,0 +1,86 @@+{-# OPTIONS_HADDOCK hide #-} +module Graphics.WorldTurtle.Internal.Commands + ( SeqC + , TurtleCommand (..) + ) where + +import Control.Applicative +import Control.Monad + +import Graphics.Gloss.Data.Picture (text) + +import Graphics.WorldTurtle.Internal.Sequence + +type SeqC a = SequenceCommand (AlmostVal ()) a + +{-| A `TurtleCommand` represents an instruction to execute. It could be as + simple as "draw a line" or more complicated like "draw 300 circles." + + `TurtleCommand`s can be executed in order by combining them using + the monadic operator `(>>)`. + + Here is an example of how to write a function that when given a + @size@ and a @turtle@, will return a new `TurtleCommand` which + will draw a square with a length and breadth of @size@ using @turtle@. + + @ + drawSquare :: Float -> Turtle -> TurtleCommand () + drawSquare size t = replicateM_ 4 $ forward size t >> right 90 t + @ + + This draws a square by doing the following in order: + + [@(1/4)@]: + + * Move forward by @size@ amount. + + * Turn right by @90@ degrees + + [@(2/4)@]: + + * Move forward by @size@ amount. + + * Turn right by @90@ degrees + + [@(3/4)@]: + + * Move forward by @size@ amount. + + * Turn right by @90@ degrees + + [@(4/4)@]: + + * Move forward by @size@ amount. + + * Turn right by @90@ degrees +-} +newtype TurtleCommand a = TurtleCommand + { + seqT :: SeqC a + } + +instance Functor TurtleCommand where + fmap f (TurtleCommand a) = TurtleCommand $ fmap f a + +instance Applicative TurtleCommand where + pure a = TurtleCommand $ pure a + liftA2 f (TurtleCommand a) (TurtleCommand b) = TurtleCommand $ liftA2 f a b + +instance Monad TurtleCommand where + (TurtleCommand a) >>= f = TurtleCommand $ a >>= \s -> seqT (f s) + +instance Alternative TurtleCommand where + empty = TurtleCommand failSequence + (<|>) (TurtleCommand a) (TurtleCommand b) = + TurtleCommand $ alternateSequence a b + +instance Semigroup a => Semigroup (TurtleCommand a) where + (TurtleCommand a) <> (TurtleCommand b) = + TurtleCommand $ combineSequence a b + +instance MonadPlus TurtleCommand + +instance MonadFail TurtleCommand where + fail t = TurtleCommand $ do + addPicture $ text t + failSequence
+ Graphics/WorldTurtle/Internal/Coords.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE BangPatterns #-} +module Graphics.WorldTurtle.Internal.Coords + ( module GPoint + , module GArithmetic + , module GVector + , module GAngle + , lerp + , normalizeHeading + , normalizeDirection + ) where + +import Prelude hiding ((-), (+)) +import qualified Prelude as P + +import Graphics.Gloss.Data.Point as GPoint +import Graphics.Gloss.Data.Point.Arithmetic as GArithmetic +import Graphics.Gloss.Data.Vector as GVector +import Graphics.Gloss.Geometry.Angle as GAngle + +lerp :: Float -> Point -> Point -> Point +lerp !l !a !b = ((1 P.- l) `mulSV` a) + (l `mulSV` b) + +-- | Return a valid heading value between (0, 360). +normalizeHeading :: Float -> Float +normalizeHeading !f + | f < 0 = normalizeHeading (f P.+ r) + | f > r = normalizeHeading (f P.- r) + | otherwise = f + where r = 360.0 + +-- | Return a valid heading value between (-180, 180). +normalizeDirection :: Float -> Float +normalizeDirection !f + | f < -r = normalizeHeading (f P.+ r) + | f > r = normalizeHeading (f P.- r) + | otherwise = f + where r = 180.0
+ Graphics/WorldTurtle/Internal/Sequence.hs view
@@ -0,0 +1,260 @@+{-# 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 (Eq, Ord) + +data TSC b = 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. + , _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 givenTime = TSC + { _pics = [] + , _totalSimTime = givenTime + , _exitCall = error "Exit called but not defined in animation." + , _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 b 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 newTime = do + let newTime' = max 0 newTime + totalSimTime .= newTime' + when (newTime' <= 0) 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 duration = simTime >>= setSimTime . (flip (-) 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 + +processTurtle :: SequenceCommand (AlmostVal a) a + -> TSC (AlmostVal a) + -> (AlmostVal a, TSC (AlmostVal a)) +processTurtle commands tsc = + let drawS = runContT (exitCondition commands) return + 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) + +drawTurtles :: Map Turtle TurtleData -> [Picture] +drawTurtles m = fmap drawTurtle $ Map.elems m + +generateTurtle :: SequenceCommand b Turtle +generateTurtle = do + t <- Turtle <$> use nextTurtleId + turtles %= Map.insert t defaultTurtle + nextTurtleId += 1 + return t + +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 + -- 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 + 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 + +-- | 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 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' + +-- | 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 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' + +-- | 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 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 + + bSimTime <- use 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. + totalSimTime .= min aSimTime bSimTime + + exitCall .= 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! + 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/Internal/Turtle.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE BangPatterns #-} +module Graphics.WorldTurtle.Internal.Turtle + ( TurtleData + , defaultTurtle + , drawTurtle + , heading + , position + , representation + , penDown + , speed + , Graphics.WorldTurtle.Internal.Turtle.scale + , penColor + , penSize + , visible + ) where + +import Control.Lens + +import Graphics.WorldTurtle.Shapes + +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Data.Picture +import qualified Graphics.Gloss.Data.Picture as G (scale) + +import qualified Graphics.WorldTurtle.Internal.Coords as P + +data TurtleData = TurtleData + { _heading :: !Float + , _position :: !P.Point + , _representation :: !Picture + , _penDown :: !Bool + , _speed :: !Float + , _scale :: !Float + , _penColor :: !Color + , _penSize :: !Float + , _visible :: !Bool + } + +$(makeLenses ''TurtleData) + +defaultTurtle :: TurtleData +defaultTurtle = TurtleData + { _heading = 90 + , _position = (0, 0) + , _representation = turtleArrow black blue + , _penDown = True + , _speed = 200 + , _scale = 1 + , _penColor = black + , _penSize = 2 + , _visible = True + } + +drawTurtle :: TurtleData -> Picture +drawTurtle t + | t ^. visible == False = blank + | otherwise = let (x, y) = _position t + s = _scale t + in translate x y + $ rotate (360 - t ^. heading) + $ G.scale s s + $ (t ^. representation)
+ Graphics/WorldTurtle/Shapes.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE BangPatterns #-} +{-| +Module : Graphics.WorldTurtle.Shapes +Description : WorldTurtle +Copyright : (c) Archibald Neil MacDonald, 2020 +License : BSD3 +Maintainer : FortOyer@hotmail.co.uk +Stability : experimental +Portability : POSIX + +This module exposes shapes not found in gloss but may be found to be worthwhile. + +-} +module Graphics.WorldTurtle.Shapes + ( turtleArrow + , thickLine + ) where + +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Data.Picture + +import qualified Graphics.WorldTurtle.Internal.Coords as P + +-- | Creates the default turtle polygon arrow with a given outline color and +-- fill color. +turtleArrow :: Color -- ^ Outline color + -> Color -- ^ Fill color + -> Picture -- ^ Arrow shape. +turtleArrow !o !f = rotate 90 $! pictures [outline_ o, fill_ f] + +-- | Draws a line from a start-point to an end-point with a given thickness. +thickLine :: Point -- ^ Starting point. + -> Point -- ^ Ending point. + -> Float -- ^ Line thickness. + -> Picture -- ^ Produced line. +thickLine a b t = polygon $ [a1, a2, b2, b1] + where !v = b P.- a + !angle = P.argV v + !perpAngle = angle - (pi/2) + !t2 = t / 2 + !t' = P.rotateV angle (t2, 0) + !t'' = P.rotateV perpAngle (t2, 0) + !a1 = a P.- t'' P.- t' + !a2 = a P.+ t'' P.- t' + !b1 = b P.- t'' P.+ t' + !b2 = b P.+ t'' P.+ t' + +outline_ :: Color -> Picture +outline_ !c = color c $ translate (0) (-1) $ scale 1.4 1.4 $ fill_ c + +fill_ :: Color -> Picture +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 + , polygon [(1, 2), (7, 2), (4, 8)] -- main triangle + ]
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2020 Archibald Neil MacDonald + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ docs/images/basic_turtle_square.gif view
binary file changed (absent → 10127 bytes)
+ docs/images/parallel_circles_animated.gif view
binary file changed (absent → 878862 bytes)
+ docs/images/parallel_circles_animated_300.gif view
binary file changed (absent → 233495 bytes)
+ docs/images/parallel_serial_turtles.gif view
binary file changed (absent → 103400 bytes)
+ worldturtle.cabal view
@@ -0,0 +1,58 @@+cabal-version: 2.0 + +name: worldturtle +version: 0.1.0.0 +synopsis: Turtle graphics. +category: teaching +homepage: https://github.com/FortOyer/worldturtle-haskell#readme +bug-reports: https://github.com/FortOyer/worldturtle-haskell/issues +author: Archibald Neil MacDonald +maintainer: FortOyer@hotmail.co.uk +copyright: 2020 Archibald Neil MacDonald +license: BSD3 +license-file: LICENSE +build-type: Simple +tested-with: GHC ==8.8.3 || ==8.10.3 + +description: + Have you ever heard of [Turtle Graphics](https://en.wikipedia.org//wiki//Turtle_graphics)? + . + No? Think of a @turtle@ as a cursor you can program to draw graphics! + . + 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 "Graphics.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! + +extra-doc-files: docs/images/*.gif +extra-source-files: ChangeLog.md + +source-repository head + type: git + location: https://github.com/FortOyer/worldturtle-haskell + +library + exposed-modules: + Graphics.WorldTurtle + Graphics.WorldTurtle.Commands + Graphics.WorldTurtle.Internal.Commands + Graphics.WorldTurtle.Internal.Coords + Graphics.WorldTurtle.Internal.Sequence + Graphics.WorldTurtle.Internal.Turtle + Graphics.WorldTurtle.Shapes + build-depends: + base >=4.7 && <5 + , containers >=0.6.2 && < 0.7 + , gloss >=1.13.1 && < 1.14 + , lens >=4.18.1 && < 4.20 + , mtl >=2.2.2 && < 2.3 + default-language: Haskell2010 + ghc-options: + -O2 + -Wall