Permalink
Browse files

Adding support for pen color and pen width

  • Loading branch information...
1 parent 24fdd8b commit 370564cbf0b756b41c420d38273b7979fddb5805 @deepakjois committed Apr 8, 2012
View
@@ -8,3 +8,4 @@ cabal-dev
logo.svg
tests/TestSuite
examples/Turtles
+examples/Temp*
@@ -1 +1 @@
-repeat 2000 [pu home seth random 361 fd 40 pd fd random 200]
+repeat 2000 [pu home seth random 361 setpencolor random 15 fd 40 pd fd random 200]
Oops, something went wrong.
@@ -21,7 +21,7 @@ module Diagrams.TwoD.Path.Turtle
-- * State accessors / setters
, heading, setHeading, towards
- , pos, setPos
+ , pos, setPos, setPenWidth, setPenColor
-- * Drawing control
, penUp, penDown, isDown
@@ -30,6 +30,7 @@ module Diagrams.TwoD.Path.Turtle
import qualified Control.Monad.State as ST
import Control.Monad.Identity (Identity(..))
+import Data.Colour(Colour)
import Diagrams.Prelude
import qualified Diagrams.TwoD.Path.Turtle.Internal as T
@@ -101,3 +102,11 @@ penDown = ST.modify T.penDown
-- | Queries whether the pen is currently drawing a path or not.
isDown :: Monad m => TurtleT m Bool
isDown = ST.gets T.isPenDown
+
+-- | Sets the pen color
+setPenColor :: Monad m => Colour Double -> TurtleT m ()
+setPenColor c = ST.modify $ T.setPenColor c
+
+-- | Sets the pen size
+setPenWidth :: Monad m => Double -> TurtleT m ()
+setPenWidth s = ST.modify $ T.setPenWidth s
@@ -173,7 +173,7 @@ penDown t
setPenPos :: P2 -- ^ Position to place true
-> Turtle -- ^ Turtle to position
-> Turtle -- ^ Resulting turtle
-setPenPos newPos t = t # makeNewTrail # \t' -> t' {penPos = newPos }
+setPenPos newPos t = t {penPos = newPos } # makeNewTrail
-- | Set a new pen width for turtle.
--
@@ -225,9 +225,7 @@ addCurrTrailToPath t = if emptyTrail then paths t else makeTurtlePath t : paths
-- Starts a new trail and adds current trail to path
makeNewTrail :: Turtle
-> Turtle
-makeNewTrail t
- | isPenDown t = t { currTrail = (penPos t, mempty), paths = addCurrTrailToPath t }
- | otherwise = t
+makeNewTrail t = t { currTrail = (penPos t, mempty), paths = addCurrTrailToPath t }
-- Modifies the current style after starting a new trail
modifyCurrStyle :: (PenStyle -> PenStyle)
@@ -1,29 +1,34 @@
module Logo.Builtins.Turtle (turtleBuiltins) where
+import Prelude hiding (tan)
import qualified Data.Map as M
import Control.Monad.Trans (lift)
import Diagrams.TwoD.Path.Turtle
import Diagrams.TwoD.Types (p2)
+import Data.Colour (Colour)
+import Data.Colour.Names
import Logo.Types
updateTurtle :: TurtleIO a -> LogoEvaluator a
updateTurtle = lift
-fd, bk, rt, lt, home, setxy, seth, pu, pd :: [LogoToken] -> LogoEvaluator LogoToken
+fd, bk, rt, lt, home, setxy, seth, pu, pd, setpensize, setpencolor :: [LogoToken] -> LogoEvaluator LogoToken
turtleBuiltins :: M.Map String LogoFunctionDef
turtleBuiltins = M.fromList
- [ ("fd", LogoFunctionDef 1 fd)
- , ("bk", LogoFunctionDef 1 bk)
- , ("rt", LogoFunctionDef 1 rt)
- , ("lt", LogoFunctionDef 1 lt)
- , ("home", LogoFunctionDef 0 home)
- , ("setxy", LogoFunctionDef 2 setxy)
- , ("seth", LogoFunctionDef 1 seth)
- , ("pu", LogoFunctionDef 0 pu)
- , ("pd", LogoFunctionDef 0 pd)
+ [ ("fd", LogoFunctionDef 1 fd)
+ , ("bk", LogoFunctionDef 1 bk)
+ , ("rt", LogoFunctionDef 1 rt)
+ , ("lt", LogoFunctionDef 1 lt)
+ , ("home", LogoFunctionDef 0 home)
+ , ("setxy", LogoFunctionDef 2 setxy)
+ , ("seth", LogoFunctionDef 1 seth)
+ , ("pu", LogoFunctionDef 0 pu)
+ , ("pd", LogoFunctionDef 0 pd)
+ , ("setpensize", LogoFunctionDef 1 setpensize)
+ , ("setpencolor", LogoFunctionDef 1 setpencolor)
]
fd (NumLiteral d : []) = do
@@ -79,3 +84,33 @@ pd [] = do
return $ StrLiteral ""
pd _ = error "Invalid arguments to pd"
+
+setpensize [NumLiteral d] = do
+ updateTurtle (setPenWidth d)
+ return $ StrLiteral ""
+
+setpensize _ = error "Invalid arguments to setpensize"
+
+setpencolor [NumLiteral d] = do
+ updateTurtle (setPenColor (numToColor . round $ d))
+ return $ StrLiteral ""
+ where
+ numToColor :: Int -> Colour Double
+ numToColor 0 = black
+ numToColor 1 = blue
+ numToColor 2 = green
+ numToColor 3 = cyan
+ numToColor 4 = red
+ numToColor 5 = magenta
+ numToColor 6 = yellow
+ numToColor 7 = white
+ numToColor 8 = brown
+ numToColor 9 = tan
+ numToColor 10 = forestgreen
+ numToColor 11 = aqua
+ numToColor 12 = salmon
+ numToColor 13 = purple
+ numToColor 14 = orange
+ numToColor 15 = grey
+
+setpencolor _ = error "Invalid arguments to setpencolor"

0 comments on commit 370564c

Please sign in to comment.