packages feed

hs-logo 0.5 → 0.5.1

raw patch · 4 files changed

+334/−15 lines, 4 files

Files

hs-logo.cabal view
@@ -1,5 +1,5 @@ Name:                hs-logo-Version:             0.5+Version:             0.5.1 Synopsis:            Logo turtle graphics interpreter Description:         Interpreter for the Logo programming language,                      specialised for turtle graphics.@@ -27,6 +27,7 @@                      Logo.Builtins.Turtle                      Logo.Builtins.Arithmetic                      Logo.Builtins.Control+                     Diagrams.TwoD.Path.Turtle.Internal                      Diagrams.TwoD.Path.Turtle   Build-Depends:     base        >= 4.2    && <  4.6,                      containers  >= 0.3    && <  0.5,
src/Diagrams/TwoD/Path/Turtle.hs view
@@ -20,11 +20,11 @@   , forward, backward, left, right      -- * State accessors / setters-  , heading, setHeading, towards+  , heading, setHeading, towards, isDown   , pos, setPos, setPenWidth, setPenColor      -- * Drawing control-  , penUp, penDown, isDown+  , penUp, penDown, penHop, closeCurrent   ) where  import qualified Control.Monad.State as ST@@ -99,9 +99,18 @@ penDown :: Monad m => TurtleT m () penDown = ST.modify T.penDown +-- | Start a new trail at current position+penHop :: Monad m => TurtleT m ()+penHop = ST.modify T.penHop+ -- | Queries whether the pen is currently drawing a path or not. isDown :: Monad m => TurtleT m Bool isDown = ST.gets T.isPenDown++-- | Closes the current path , to the starting position of the current+-- trail. Has no effect when the pen position is up.+closeCurrent :: Monad m => TurtleT m ()+closeCurrent = ST.modify T.closeCurrent  -- | Sets the pen color setPenColor :: Monad m => Colour Double -> TurtleT m ()
+ src/Diagrams/TwoD/Path/Turtle/Internal.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Path.Turtle+-- Copyright   :  (c) 2011 Michael Sloan+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Michael Sloan <mgsloan at gmail>,  Deepak Jois <deepak.jois@gmail.com>+-- Authors     :  Michael Sloan <mgsloan at gmail>, Deepak Jois <deepak.jois@gmail.com>+--+-- A module consisting of core types and functions to represent and operate on+-- a \"turtle\".+--+-- More info about turtle graphics:+-- <http://en.wikipedia.org/wiki/Turtle_graphics>+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Path.Turtle.Internal+  (+    -- * Turtle data types and accessors+    Turtle(..), TurtlePath(..), PenStyle(..)++    -- * Motion commands+  , forward, backward, left, right++    -- * Pen style commands+  , setPenColor, setPenColour, setPenWidth++    -- * State setters+  , startTurtle, setHeading, towards+  , setPenPos++    -- * Drawing control+  , penUp, penDown, penHop, closeCurrent ++    -- * Debugging+  , traceTurtle++    -- * Diagram related+  , getTurtleDiagram+  ) where++import Debug.Trace (traceShow)+import Control.Arrow (second)++import Diagrams.Prelude+import Data.Colour hiding (atop)++-- | Style attributes associated with the turtle pen+data PenStyle = PenStyle+  { penWidth :: Double         -- ^ Width of pen. Default is 1.0+  , penColor :: Colour Double  -- ^ Color of pen. Default is @black@+  } deriving Show++-- | Turtle path type that captures a list of paths and the style attributes+-- associated with them+data TurtlePath = TurtlePath+  { penStyle    :: PenStyle        -- ^ Style+  , turtleTrail :: (P2, Trail R2)  -- ^ Path+  } deriving Show++-- | Core turtle data type. A turtle needs to keep track of its current+-- position, like its position, heading etc., and all the paths that it has+-- traversed so far.+--+-- We need to record a new path, everytime an attribute like style, pen position+-- etc changes, so that we can separately track styles for each portion of the+-- eventual path that the turtle took.+data Turtle = Turtle+  { -- | State of the pen. @False@ means that turtle movements will not draw+    -- anything+    isPenDown  :: Bool+     -- | Current position. This is updated everytime the turtle moves+  , penPos     :: P2+     -- | Orientation of the turtle in 2D space, given in degrees+  , heading    :: Deg+     -- | Path traversed by the turtle so far, without any style or pen+     -- attributes changing+  , currTrail  :: (P2, Trail R2)+     -- | Current style of the pen+  , currPenStyle  :: PenStyle+     -- | List of paths along with style information, traversed by the turtle+     -- previously+  , paths      :: [TurtlePath]+  } deriving Show++-- | Default pen style, with @penWidth@ set to 1.0 and @penColor@ set to black+defaultPenStyle :: PenStyle+defaultPenStyle = PenStyle 1.0 black++-- | The initial state of turtle. The turtle is located at the origin, at an+-- orientation of 0 degrees with its pen position down. The pen style is+-- @defaultPenStyle@.+startTurtle :: Turtle+startTurtle = Turtle True origin 0 (origin, mempty) defaultPenStyle []++-- | Draw a segment along the turtle’s path and update its position. If the pen+-- is up, only the position is updated.+moveTurtle :: Segment R2  -- ^ Segment representing the path to travel+           -> Turtle      -- ^ Turtle to move+           -> Turtle      -- ^ Resulting turtle+moveTurtle s t@(Turtle pd pos h (o, Trail xs _) _ _) =+ if pd+   -- Add segment to current trail and update position+   then t { currTrail = (o, Trail newTrail False)+          , penPos = newPenPos+          }+   -- Update position only+   else t { penPos = newPenPos }+ where+   -- Rotate segment by orientation before adding to trail+   rotatedSeg  =  rotate h s+   newTrail    =  rotatedSeg : xs+   -- Calculate the new position along the segment+   newPenPos   =  pos .+^ segOffset rotatedSeg++-- | Move the turtle forward by @x@ units+forward :: Double  -- ^ Distance to move+        -> Turtle  -- ^ Turtle to move+        -> Turtle  -- ^ Resulting turtle+forward x = moveTurtle (Linear $ r2 (x,0))++-- | Move the turtle backward by @x@ units+backward :: Double  -- ^ Distance to move+         -> Turtle  -- ^ Turtle to move+         -> Turtle  -- ^ Resulting turtle+backward x = moveTurtle (Linear $ r2 (negate x, 0))++-- | Turn the turtle by applying the given function to its current orientation+-- (in degrees)+turnTurtle :: (Deg -> Deg)  -- ^ Transformation to apply on current orientation+           -> Turtle        -- ^ Turtle to turn+           -> Turtle        -- ^ Resulting turtle+turnTurtle f t@(Turtle _ _ h _ _ _) = t { heading = f h  }++-- | Turn the turtle anti-clockwise (left)+left :: Double  -- ^ Degree of turn+     -> Turtle  -- ^ Turtle to turn+     -> Turtle  -- ^ Resulting turtle+left d = turnTurtle (+ (Deg d))++-- | Turn the turtle clockwise (right)+right :: Double  -- ^ Degree of turn+      -> Turtle  -- ^ Turtle to turn+      -> Turtle  -- ^ Resulting turtle+right d = turnTurtle (subtract (Deg d))++-- | Turn the turtle to the given orientation, in degrees+setHeading :: Double  -- ^ Degree of orientation+           -> Turtle  -- ^ Turtle to orient+           -> Turtle  -- ^ Resulting turtle+setHeading d = turnTurtle (const $ Deg d)++-- | Sets the turtle orientation towards a given location.+towards :: P2      -- ^ Point to orient turtle towards+        -> Turtle  -- ^ Turtle to orient+        -> Turtle  -- ^ Resulting turtle+towards p  = setHeading =<< (360 *) . (/ tau) . uncurry atan2 . unr2 . (p .-.) . penPos++-- | Puts the turtle pen in “Up” mode. Turtle movements will not draw anything+--+-- Does nothing if the pen was already up. Otherwise, it creates a turtle with+-- the current trail added to @paths@.+penUp :: Turtle  -- ^ Turtle to modify+      -> Turtle  -- ^ Resulting turtle+penUp t+ | isPenDown t = t # makeNewTrail #  \t' -> t' { isPenDown = False }+ | otherwise   = t++-- | Puts the turtle pen in “Down” mode. Turtle movements will cause drawing to+-- happen+--+-- Does nothing if the pen was already down. Otherwise, starts a new trail+-- starting at the current position.+penDown :: Turtle  -- ^ Turtle to modify+        -> Turtle  -- ^ Resulting turtle+penDown t+  | isPenDown t = t+  | otherwise   = t # makeNewTrail #  \t' -> t' { isPenDown = True }++-- Start a new trail at current position+penHop :: Turtle+         -> Turtle+penHop t = t # makeNewTrail++-- Closes the current path , to the starting position of the current+-- trail. Has no effect when the pen position is up+closeCurrent :: Turtle+             -> Turtle+closeCurrent t+  | isPenDown t = t # setPenPos startPos # closeTrail # makeNewTrail+  | otherwise   = t + where startPos = fst . currTrail $ t +       closeTrail t'  = t' { currTrail = second close $ currTrail t }++-- | Set the turtle X/Y position.+--+-- If pen is down and the current trail is non-empty, this will also add the+-- current trail to the @paths@ field.+setPenPos :: P2      -- ^ Position to place true+          -> Turtle  -- ^ Turtle to position+          -> Turtle  -- ^ Resulting turtle+setPenPos newPos t = t {penPos = newPos } # makeNewTrail++-- | Set a new pen width for turtle.+--+-- If pen is down, this adds the current trail to @paths@ and starts a new empty+-- trail.+setPenWidth :: Double -- ^ Width of Pen+            -> Turtle -- ^ Turtle to change+            -> Turtle -- ^ Resulting Turtle+setPenWidth w = modifyCurrStyle (\s -> s { penWidth = w })+-- | Set a new pen color for turtle.+--+-- If pen is down, this adds the current trail to @paths@ and starts a new empty+-- trail.+setPenColour :: Colour Double -- ^ Width of Pen+             -> Turtle        -- ^ Turtle to change+             -> Turtle        -- ^ Resulting Turtle+setPenColour c = modifyCurrStyle (\s -> s { penColor = c })++-- | alias of @setPenColour@+setPenColor :: Colour Double -- ^ Width of Pen+             -> Turtle        -- ^ Turtle to change+             -> Turtle        -- ^ Resulting Turtle+setPenColor = setPenColour++-- | Creates a diagram from a turtle+--+-- Applies the styles to each trails in @paths@ separately and combines them+-- into a single diagram+getTurtleDiagram :: (Renderable (Path R2) b) => Turtle+                 -> Diagram b R2+getTurtleDiagram t =+  position .+  map turtlePathToStroke .+  paths $ t # penUp -- Do a penUp to add @currTrail@ to @paths@++-- * Helper functions++-- Makes a "TurtlePath" from a "Turtle"’s @currTrail@ field+makeTurtlePath :: Turtle+               -> TurtlePath+makeTurtlePath t = TurtlePath (currPenStyle t) (currTrail t)++-- Returns a list of paths, with current trail added to a "Turtle"’s @paths@ field+addCurrTrailToPath :: Turtle+                   -> [TurtlePath]+addCurrTrailToPath t = if emptyTrail then paths t else makeTurtlePath t : paths t+ where emptyTrail = (snd . currTrail) t == mempty++-- Starts a new trail and adds current trail to path+makeNewTrail :: Turtle+             -> Turtle+makeNewTrail t = t { currTrail = (penPos t, mempty), paths = addCurrTrailToPath t  }++-- Modifies the current style after starting a new trail+modifyCurrStyle :: (PenStyle -> PenStyle)+                -> Turtle+                -> Turtle+modifyCurrStyle f t =  t # makeNewTrail # \t' -> t' { currPenStyle = (f . currPenStyle) t' }++-- Creates a diagram from a TurtlePath using the provided styles+turtlePathToStroke :: (Renderable (Path R2) b) => TurtlePath+                   -> (P2, Diagram b R2)+turtlePathToStroke (TurtlePath (PenStyle lineWidth_  lineColor_) (p,Trail xs c)) = (p,d)+ where d = lc lineColor_ .+           lw lineWidth_ .+           stroke $ pathFromTrail (Trail (reverse xs) c)++-- | Prints out turtle representation and returns it. Use for debugging+traceTurtle :: Turtle+            -> Turtle+traceTurtle t = traceShow t t
tests/Diagrams/TwoD/Path/Turtle/Tests.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ViewPatterns  #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Diagrams.TwoD.Path.Turtle.Tests   ( tests   ) where@@ -12,8 +13,7 @@ import Diagrams.Prelude import Diagrams.TwoD.Path.Turtle.Internal -import Debug.Trace-+tests :: [Test] tests =   [ testProperty "Moves forward correctly" movesForward   , testProperty "Moves backward correctly" movesBackward@@ -21,31 +21,39 @@   , testProperty "Moves left correctly" movesLeft   , testProperty "Moves right correctly" movesRight   , testProperty "Current trail is empty when pen is up" trailEmptyWhenPenUp+  , testProperty "penHop creates a new path when pen is down" verifyPenHopWhenPenDown+  , testProperty "penHop does not create new path when pen is up" verifyPenHopWhenPenUp +  , testProperty "closeCurrent works correctly when no trail has started and pen is down" verifyCloseCurrent   ] + -- | The turtle moves forward by the right distance movesForward :: Turtle              -> Property movesForward t =  isPenDown t ==>-     round diffPos      == round x  -- position is set correctly-  && round lenCurrTrail == round x  -- most recent trail has the right length+     diffPos      == round x  -- position is set correctly+  && lenCurrTrail == round x  -- most recent trail has the right length  where   x            = 2.0   t'           = t  # forward x-  diffPos      = magnitude $ penPos t' .-. penPos t-  lenCurrTrail = flip arcLength 0.0001 . head . trailSegments . snd . currTrail $ t'+  diffPos :: Int+  diffPos      = round $ magnitude $ penPos t' .-. penPos t+  lenCurrTrail :: Int+  lenCurrTrail = round $ flip arcLength 0.0001 . head . trailSegments . snd . currTrail $ t'  -- | The turtle moves forward by the right distance movesBackward :: Turtle              -> Property movesBackward t =  isPenDown t ==>-     round diffPos      == round x  -- position is set correctly-  && round lenCurrTrail == round x  -- most recent trail has the right length+     diffPos      == round x  -- position is set correctly+  && lenCurrTrail == round x  -- most recent trail has the right length  where   x            = 2.0   t'           = t  # backward x-  diffPos      = magnitude $ penPos t' .-. penPos t-  lenCurrTrail = flip arcLength 0.0001 . head . trailSegments . snd . currTrail $ t'+  diffPos :: Int+  diffPos      = round $ magnitude $ penPos t' .-. penPos t+  lenCurrTrail :: Int+  lenCurrTrail = round $ flip arcLength 0.0001 . head . trailSegments . snd . currTrail $ t'  -- | The turtle moves forward and backward by the same distance and returns to -- the same position@@ -104,11 +112,37 @@   t'           = t # penUp # forward 4 # backward 3   trailIsEmpty = null . trailSegments . snd . currTrail $ t' -instance Show Turtle where-  show t@(Turtle a b c _ _ _) = show (a,b,c)+-- | Verify that the turtle adds a trail to @paths@ when pen is down+-- and @penHop@ is called.+verifyPenHopWhenPenDown :: Turtle+                        -> Property+verifyPenHopWhenPenDown t = isPenDown t ==> (numPaths t') - (numPaths t) == 1+ where +  t' = t # forward 2.0 # penHop+  numPaths = length . paths +-- | Verify that the turtle does not add a trail to @paths@ when pen is up+-- and @penHop@ is called.+verifyPenHopWhenPenUp :: Turtle+                      -> Property+verifyPenHopWhenPenUp t = not (isPenDown t) && (null . trailSegments . snd . currTrail $ t) ==>  (numPaths t') == (numPaths t)+ where +  t' = t # forward 2.0 # penHop+  numPaths = length . paths +-- | Verify that calling @closeCurrent@ updates the turtle position to the beginning to the trail+verifyCloseCurrent :: Turtle+                   -> Property+verifyCloseCurrent t = (isPenDown t)  && (null . trailSegments . snd . currTrail $ t) ==> (penPos t') == origin+ where+  t' = t # setPenPos origin # forward 2.0 # right 90 # forward 3.0 # closeCurrent -- | Arbitrary instance for the Turtle type.+--+-- FIXME this arbitrary instance can generate+-- invalid turtle. For e.g. when pen is up, and+-- the current trail is not empty.+--+-- Currently we filter these out in the tests instance Arbitrary Turtle where    arbitrary =      Turtle <$> arbitrary@@ -137,6 +171,7 @@       1 -> return $ PenStyle penWidth_  black       2 -> return $ PenStyle penWidth_  blue       3 -> return $ PenStyle penWidth_  brown+      _ -> error "Should not get here"  -- | Arbitrary instance of Segment --