diff --git a/hs-logo.cabal b/hs-logo.cabal --- a/hs-logo.cabal +++ b/hs-logo.cabal @@ -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, diff --git a/src/Diagrams/TwoD/Path/Turtle.hs b/src/Diagrams/TwoD/Path/Turtle.hs --- a/src/Diagrams/TwoD/Path/Turtle.hs +++ b/src/Diagrams/TwoD/Path/Turtle.hs @@ -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 () diff --git a/src/Diagrams/TwoD/Path/Turtle/Internal.hs b/src/Diagrams/TwoD/Path/Turtle/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Path/Turtle/Internal.hs @@ -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 , Deepak Jois +-- Authors : Michael Sloan , Deepak Jois +-- +-- A module consisting of core types and functions to represent and operate on +-- a \"turtle\". +-- +-- More info about 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 diff --git a/tests/Diagrams/TwoD/Path/Turtle/Tests.hs b/tests/Diagrams/TwoD/Path/Turtle/Tests.hs --- a/tests/Diagrams/TwoD/Path/Turtle/Tests.hs +++ b/tests/Diagrams/TwoD/Path/Turtle/Tests.hs @@ -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 --