diagrams-contrib 0.1.1.1 → 0.6

raw patch · 12 files changed

+774/−276 lines, 12 filesdep +HUnitdep +QuickCheckdep +lensdep ~basedep ~containersdep ~data-defaultPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, QuickCheck, lens, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependency ranges changed: base, containers, data-default, diagrams-lib, force-layout

API changes (from Hackage documentation)

Files

• CHANGES +0/−27
• CHANGES.markdown +55/−0
• README +0/−26
• README.markdown +32/−0
• diagrams-contrib.cabal +45/−14
• src/Diagrams/TwoD/Apollonian.hs +23/−24
• src/Diagrams/TwoD/Layout/Tree.hs +28/−20
• src/Diagrams/TwoD/Path/Turtle.hs +41/−85
• src/Diagrams/TwoD/Path/Turtle/Internal.hs +273/−0
• src/Diagrams/TwoD/Tilings.hs +80/−80
• tests/Diagrams/TwoD/Path/Turtle/Tests.hs +186/−0
• tests/TestSuite.hs +11/−0

@@ -1,27 +0,0 @@-0.1.1.1: 13 May 2012--  * bump mtl (< 2.2) and data-default (< 0.5) upper bounds--0.1.1.0: 16 March 2012--  * Add Andrew Kennedy's symmetric rose tree layout algorithm to-    Diagrams.TwoD.Layout.Tree--0.1.0.0: 9 March 2012--  Initial release, containing:--  * Diagrams.Layout.Wrap, for laying out diagrams "wrapped" inside an-    arbitrary region (Michael Sloan)--  * Diagrams.TwoD.Tilings, for generating various 2D regular tilings-    (Brent Yorgey)--  * Diagrams.TwoD.Apollonian, for generating Apollonian gaskets (Brent-    Yorgey)--  * Diagrams.TwoD.Layout.Tree, tree layout and drawing algorithms-    (Brent Yorgey)--  * Diagrams.TwoD.Path.Turtle, creation of 2D paths using a stateful-    "turtle" interface (Michael Sloan)

@@ -0,0 +1,55 @@+0.6: 11 December 2012+---------------------++* **New features**++    - New pure implementation of Turtle library, in `Turtle.Internals`++    - `Diagrams.TwoD.Layout.Tree`: ++	- New `renderTree'` function which gives+	  the edge-drawing function access to the values stored at the+	  nodes instead of just the node positions.++	- The type of `renderTree` is generalized to work with any+	  `QDiagram b R2 m`.++* **Bug fixes**++    - Tiling generation code in `Diagrams.TwoD.Tilings` wasn't actually+      checking whether vertexes had been already visited.+      +* **Dependency/version changes**++    - Switch from `fclabels` to `lens`++0.1.1.1: 13 May 2012+--------------------++* bump `mtl` (< 2.2) and `data-default` (< 0.5) upper bounds++0.1.1.0: 16 March 2012+----------------------++* Add Andrew Kennedy's symmetric rose tree layout algorithm to+    `Diagrams.TwoD.Layout.Tree`++0.1.0.0: 9 March 2012+---------------------++Initial release, containing:++* `Diagrams.Layout.Wrap`, for laying out diagrams "wrapped" inside an+    arbitrary region (Michael Sloan)++* `Diagrams.TwoD.Tilings`, for generating various 2D regular tilings+    (Brent Yorgey)++* `Diagrams.TwoD.Apollonian`, for generating Apollonian gaskets (Brent+    Yorgey)++* `Diagrams.TwoD.Layout.Tree`, tree layout and drawing algorithms+    (Brent Yorgey)++* `Diagrams.TwoD.Path.Turtle`, creation of 2D paths using a stateful+    "turtle" interface (Michael Sloan)

@@ -1,26 +0,0 @@-This package is a repository for user contributions to the diagrams-project (http://projects.haskell.org/diagrams): generation of-specialized diagrams, fun or instructive examples, half-baked ideas,-stuff which is not sufficiently polished or general to go in the-diagrams-lib package but is nonetheless worth sharing.  Any code is-welcome, as long as it conforms to a few simple standards:--  - Code must be released under a BSD3 license (see the LICENSE).--  - You must list yourself as the maintainer.--  - Try to keep external dependencies to a minimum; the goal is for-    diagrams-contrib to be easily installable by as many people as-    possible.  New dependencies will be considered on a case-by-case-    basis.  Dependencies involving the FFI will most likely be-    rejected.  If you have some cool code using diagrams which-    requires big external dependencies, you should release it as a-    separate package rather than including it in diagrams-contrib.--  - There should at minimum be a Haddock comment on the module itself,-    explaining the purpose, giving some examples of use, etc.--  - It must compile with no warnings under -Wall. This may seem a bit-    draconian, but you'll get over it.  If it makes you feel any-    better, you are welcome to turn off specific warnings for your-    module with an {-# OPTIONS_GHC -fno-warn-blah #-} pragma.

@@ -0,0 +1,32 @@+[![Build Status](https://secure.travis-ci.org/diagrams/diagrams-contrib.png)](http://travis-ci.org/diagrams/diagrams-contrib)++This package is a repository for user contributions to the+[diagrams project](http://projects.haskell.org/diagrams): generation+of specialized diagrams, fun or instructive examples, half-baked+ideas, stuff which is not sufficiently polished or general to go in+the [diagrams-lib](http://github.com/diagrams/diagrams-lib) package+but is nonetheless worth sharing.  Any code is welcome, as long as it+conforms to a few simple standards:++* Code must be released under a BSD3 license (see the LICENSE).++* You must list yourself as the maintainer.++* Try to keep external dependencies to a minimum; the goal is for+  diagrams-contrib to be easily installable by as many people as+  possible.  New dependencies will be considered on a case-by-case+  basis.  Dependencies involving the FFI will most likely be+  rejected.  If you have some cool code using diagrams which+  requires big external dependencies, you should release it as a+  separate package rather than including it in diagrams-contrib.++* There should at minimum be a Haddock comment on the module itself,+  explaining the purpose, giving some examples of use, *etc.*++* It must compile with no warnings under `-Wall`. This may seem a bit+  draconian, but you'll get over it.  If it makes you feel any+  better, you are welcome to turn off specific warnings for your+  module with an `{-# OPTIONS_GHC -fno-warn-blah #-}` pragma.++For more general information on contributing to the diagrams project,+see the [Contributing page on the diagrams wiki](http://www.haskell.org/haskellwiki/Diagrams/Contributing).

@@ -1,5 +1,5 @@ name:                diagrams-contrib-version:             0.1.1.1+version:             0.6 synopsis:            Collection of user contributions to diagrams EDSL description:         A collection of user contributions for diagrams,                      an embedded domain-specific language for generation @@ -8,31 +8,62 @@ license:             BSD3 license-file:        LICENSE author:              Various-maintainer:          diagrams-discuss@googlegroups.com+maintainer:          Various; see individual modules+Bug-reports:         http://github.com/diagrams/diagrams-contrib/issues category:            Graphics build-type:          Simple-cabal-version:       >=1.8-extra-source-files:  README, CHANGES-tested-with:         GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1+cabal-version:       >=1.10+extra-source-files:  README.markdown, CHANGES.markdown+tested-with:         GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.2, GHC == 7.6.1 Source-repository head-  type:     darcs-  location: http://patch-tag.com/r/byorgey/diagrams-contrib+  type:     git+  location: http://github.com/diagrams/diagrams-contrib.git  library+  ghc-options:         -Wall   exposed-modules:     Diagrams.Layout.Wrap,                        Diagrams.TwoD.Tilings,                        Diagrams.TwoD.Apollonian,                        Diagrams.TwoD.Layout.Tree,                        Diagrams.TwoD.Path.Turtle,-                       Diagrams.TwoD.Path.Turtle.Aliases-  build-depends:       base >= 4.2 && < 4.6,+                       Diagrams.TwoD.Path.Turtle.Aliases,+                       Diagrams.TwoD.Path.Turtle.Internal+  build-depends:       base >= 4.2 && < 4.7,                        mtl >= 2.0 && < 2.2,-                       containers ==0.4.*,+                       containers > 0.4 && < 0.6,                        vector-space >= 0.7 && < 0.9,                        colour >= 2.3.1 && < 2.4,-                       diagrams-lib ==0.5.*,+                       diagrams-lib >= 0.6 && < 0.7, -                       fclabels >= 1.0.4 && < 1.2,-                       force-layout >= 0.1 && < 0.2,-                       data-default >= 0.3 && < 0.5+                       lens >= 3.7 && < 4,+                       force-layout >= 0.2 && < 0.3,+                       data-default >= 0.3 && < 0.6   hs-source-dirs:      src+  default-language:    Haskell2010++test-suite turtle-tests+  type:                exitcode-stdio-1.0+  hs-source-dirs:      src tests+  Main-is:             TestSuite.hs+  ghc-options:         -Wall++  other-modules:       Diagrams.TwoD.Path.Turtle.Tests++  build-depends:       HUnit                      >= 1.2 && < 1.3,+                       QuickCheck                 >= 2.4 && < 2.6,+                       containers                 >= 0.3 && < 0.6,+                       test-framework             >= 0.4 && < 0.7,+                       test-framework-hunit       >= 0.2 && < 0.3,+                       test-framework-quickcheck2 >= 0.2 && < 0.3,+                       -- Copied from regular dependencies+                       base >= 4.2 && < 4.7,+                       mtl >= 2.0 && < 2.2,+                       containers >= 0.4 && < 0.6,+                       vector-space >= 0.7 && < 0.9,+                       colour >= 2.3.1 && < 2.4,+                       diagrams-lib >= 0.6 && < 0.7,++                       fclabels >= 1.0.4 && < 1.2,+                       force-layout >= 0.2 && < 0.3,+                       data-default >= 0.3 && < 0.6+  default-language:    Haskell2010

@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types +{-# LANGUAGE Rank2Types            , FlexibleContexts            , ViewPatterns   #-}@@ -16,30 +16,30 @@ -- tangent to all three.  This process can be repeated, generating a -- fractal circle packing. ----- See J. Lagarias, C. Mallows, and A. Wilks, "Beyond the Descartes--- circle theorem", Amer. Math. Monthly 109 (2002), 338--361.+-- See J. Lagarias, C. Mallows, and A. Wilks, \"Beyond the Descartes+-- circle theorem\", /Amer. Math. Monthly/ 109 (2002), 338--361. -- <http://arxiv.org/abs/math/0101066>. -- ----------------------------------------------------------------------------- -module Diagrams.TwoD.Apollonian +module Diagrams.TwoD.Apollonian        ( -- * Circles-         +          Circle(..), mkCircle, center, radius-                                       -         -- * Descartes' Theorem                                       ++         -- * Descartes' Theorem        , descartes, other, initialConfig-                    +          -- * Apollonian gasket generation-                    +        , apollonian-         +          -- * Diagram generation-         +        , drawCircle        , drawGasket        , apollonianGasket-         +        ) where  import Data.Complex@@ -48,7 +48,6 @@ import Diagrams.Prelude hiding (radius, center)  import Control.Arrow (second)-import Data.Colour   (transparent)  ------------------------------------------------------------ --  Circles@@ -56,14 +55,14 @@  -- | Representation for circles that lets us quickly compute an --   Apollonian gasket.-data Circle = Circle { bend :: Double   +data Circle = Circle { bend :: Double                        -- ^ The bend is the reciprocal of signed                        --   radius: a negative radius means the                        --   outside and inside of the circle are                        --   switched.  The bends of any four mutually                        --   tangent circles satisfy Descartes'                        --   Theorem.-                     , cb   :: Complex Double  +                     , cb   :: Complex Double                        -- ^ /Product/ of bend and center represented                        --   as a complex number.  Amazingly, these                        --   products also satisfy the equation of@@ -99,7 +98,7 @@   negate = liftF negate   abs = liftF abs   fromInteger n = Circle (fromInteger n) (fromInteger n)-  + instance Fractional Circle where   (/) = liftF2 (/)   recip = liftF recip@@ -115,7 +114,7 @@ ------------------------------------------------------------  -- | Descartes' Theorem states that if @b1@, @b2@, @b3@ and @b4@ are---   the bends of four mutually tangent circles, then +--   the bends of four mutually tangent circles, then -- --   @ --     b1^2 + b2^2 + b3^2 + b4^2 = 1/2 * (b1 + b2 + b3 + b4)^2.@@ -178,19 +177,19 @@ --   Stop the recursion when encountering a circle with an (unsigned) --   radius smaller than the threshold. apollonian :: Double -> [Circle] -> [Circle]-apollonian thresh cs +apollonian thresh cs   =  cs   ++ (concat . map (\(c,cs') -> apollonian' thresh (other cs' c) cs') . select $ cs)-  + apollonian' :: Double -> Circle -> [Circle] -> [Circle] apollonian' thresh cur others   | radius cur < thresh = []-  | otherwise = cur +  | otherwise = cur               : (concat $                    map (\(c, cs') -> apollonian' thresh-                                       (other (cur:cs') c) -                                       (cur:cs') -                       ) +                                       (other (cur:cs') c)+                                       (cur:cs')+                       )                        (select others)                 ) @@ -212,7 +211,7 @@ -- | Draw an Apollonian gasket: the first argument is the threshold; --   the recursion will stop upon reaching circles with radii less than --   it. The next three arguments are bends of three circles.-apollonianGasket :: (Renderable (Path R2) b) +apollonianGasket :: (Renderable (Path R2) b)                  => Double -> Double -> Double -> Double -> Diagram b R2 apollonianGasket thresh b1 b2 b3 = drawGasket . apollonian thresh $ (initialConfig b1 b2 b3) 

@@ -23,6 +23,7 @@ -- > {-# LANGUAGE NoMonomorphismRestriction #-} -- > import Diagrams.Prelude -- > import Diagrams.TwoD.Layout.Tree+-- > import Data.Tree -- > -- > t1 = Node 'A' [Node 'B' (map lf "CDE"), Node 'F' [Node 'G' (map lf "HIJ")]] -- >@@ -37,6 +38,7 @@ -- > {-# LANGUAGE NoMonomorphismRestriction #-} -- > import Diagrams.Prelude -- > import Diagrams.TwoD.Layout.Tree+-- > import Data.Tree -- > -- > tD = Node (rect 1 3) -- >        [ Node (circle 0.2) []@@ -99,6 +101,7 @@          -- * Rendering         , renderTree+       , renderTree'         ) where @@ -106,19 +109,19 @@  import           Control.Applicative import           Control.Arrow         (first, second, (***), (&&&))+import           Control.Lens import           Control.Monad.State  import           Data.Default import qualified Data.Foldable         as F+import           Data.Function         (on) import qualified Data.Map              as M-import           Data.Label            (mkLabels)-import qualified Data.Label            as L import           Data.List             (mapAccumL) import           Data.Maybe import qualified Data.Traversable      as T import           Data.Tree -import           Diagrams.Prelude      hiding (e)+import           Diagrams.Prelude      hiding (e, view)   @@ -155,15 +158,7 @@                }   deriving (Eq, Show) -mkLabels [''Pos]--incHoriz, up, down :: MonadState Pos m => m ()-incHoriz   = modify (L.modify horiz (+1))-up         = modLevel (subtract 1)-down       = modLevel (+1)--modLevel :: MonadState Pos m => (Int -> Int) -> m ()-modLevel f = modify (L.modify level f)+makeLenses ''Pos  pos2Point :: Double -> Double -> Pos -> P2 pos2Point cSep lSep (Pos l h) = p2 (fromIntegral h * cSep, -fromIntegral l * lSep)@@ -194,8 +189,11 @@           r' <- uniqueXLayout' r           up           return $ Just (Node (a,p) (catMaybes [l', r']))-        mkNode = get <* incHoriz+        mkNode = get <* (horiz += 1) +        down = level += 1+        up   = level -= 1+ -------------------------------------------------- -- "Symmetric" layout of rose trees. @@ -407,7 +405,7 @@ --   identifiers used in the 'Ensemble'. reconstruct :: Functor t => Ensemble R2 -> t (a, PID) -> t (a, P2) reconstruct e = (fmap . second)-                  (fromMaybe origin . fmap (L.get pos) . flip M.lookup (L.get particles e))+                  (fromMaybe origin . fmap (view pos) . flip M.lookup (e^.particles))  data ForceLayoutTreeOpts =   FLTOpts@@ -464,11 +462,21 @@  -- | Draw a tree annotated with node positions, given functions --   specifying how to draw nodes and edges.-renderTree :: (a -> Diagram b R2) -> (P2 -> P2 -> Diagram b R2)-           -> Tree (a, P2) -> Diagram b R2-renderTree renderNode renderEdge = alignT . centerX . renderTree'+renderTree :: Monoid' m+           => (a -> QDiagram b R2 m) -> (P2 -> P2 -> QDiagram b R2 m)+           -> Tree (a, P2) -> QDiagram b R2 m+renderTree n e = renderTree' n (e `on` snd)++-- | Draw a tree annotated with node positions, given functions+--   specifying how to draw nodes and edges.  Unlike 'renderTree',+--   this version gives the edge-drawing function access to the actual+--   values stored at the nodes rather than just their positions.+renderTree' :: Monoid' m+           => (a -> QDiagram b R2 m) -> ((a,P2) -> (a,P2) -> QDiagram b R2 m)+           -> Tree (a, P2) -> QDiagram b R2 m+renderTree' renderNode renderEdge = alignT . centerX . renderTreeR   where-    renderTree' (Node (a,p) cs) =+    renderTreeR (Node (a,p) cs) =          renderNode a # moveTo p-      <> mconcat (map renderTree' cs)-      <> mconcat (map (renderEdge p . snd . rootLabel) cs)+      <> mconcat (map renderTreeR cs)+      <> mconcat (map (renderEdge (a,p) . rootLabel) cs)

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module      :  Diagrams.TwoD.Path.Turtle@@ -19,146 +20,101 @@   , forward, backward, left, right      -- * State accessors / setters-  , heading, setHeading, towards-  , pos, setPos+  , heading, setHeading, towards, isDown+  , pos, setPos, setPenWidth, setPenColor      -- * Drawing control-  , penHop, penUp, penDown, isDown-  , closeCurrent+  , penUp, penDown, penHop, closeCurrent   ) where -import Diagrams.Prelude- import qualified Control.Monad.State as ST-import Control.Monad.Identity+import Control.Monad.Identity (Identity(..)) -type TurtleT = ST.StateT TState+import Diagrams.Prelude+import qualified Diagrams.TwoD.Path.Turtle.Internal as T -type Turtle = TurtleT Identity -data TState = TState Bool Deg (Path R2)---- Unexported utilities---- The path is stored backwards to make accumulation efficient.--- TODO: consider keeping the output backwards, and always update the position?--- This would make the "position" query more efficient.-getPath :: TState -> Path R2-getPath (TState d _ (Path xs))-  = Path . reverse-  $ map (\(p, (Trail ys c)) -> (p, Trail (reverse ys) c))-  $ if d then xs else tail xs---- Adds a segment to the accumulated path.-logoseg :: Monad m => (Segment R2) -> TurtleT m ()-logoseg seg = ST.modify-  (\(TState d ang p) ->-     TState d ang $ modifyTrail-       (\(Trail xs c) -> Trail (rotate ang seg:xs) c) p)--modifyAngle :: Monad m => (Deg -> Deg) -> TurtleT m ()-modifyAngle f = ST.modify (\(TState d a p) -> TState d (f a) p)--modifyPath :: (Path R2 -> Path R2) -> TState -> TState-modifyPath f (TState d ang p) = TState d ang $ f p+type TurtleT = ST.StateT T.Turtle -modifyTrail :: (Trail v -> Trail v) -> Path v -> Path v-modifyTrail f (Path ((p, t) : ps)) = Path $ (p, f t) : ps-modifyTrail _ p = p+type Turtle = TurtleT Identity  -- | A more general way to run the turtle. Returns a computation in the -- underlying monad @m@ yielding a path consisting of the traced trails-runTurtleT :: (Monad m, Functor m) => TurtleT m a -> m (Path R2)-runTurtleT t = getPath . snd-            <$> ST.runStateT t (TState True 0 (Path [(origin, Trail [] False)]))+runTurtleT :: (Monad m, Functor m, (Renderable (Path R2) b)) => TurtleT m a -> m (Diagram b R2)+runTurtleT t = T.getTurtleDiagram . snd+           <$> ST.runStateT t T.startTurtle  -- | Run the turtle, yielding a path consisting of the traced trails.-runTurtle :: Turtle a -> Path R2-runTurtle t = getPath . snd . ST.runState t-            $ TState True 0 (Path [(origin, Trail [] False)])+runTurtle :: (Renderable (Path R2) b) => Turtle a -> Diagram b R2+runTurtle = runIdentity . runTurtleT  -- Motion commands  -- | Move the turtle forward, along the current heading. forward :: Monad m => Double -> TurtleT m ()-forward  x = logoseg $ Linear (r2 (x,          0))+forward x = ST.modify $ T.forward x  -- | Move the turtle backward, directly away from the current heading. backward :: Monad m => Double -> TurtleT m ()-backward x = logoseg $ Linear (r2 ((negate x), 0))+backward x = ST.modify $ T.backward x  -- | Modify the current heading to the left by the specified angle in degrees. left :: Monad m => Double -> TurtleT m ()-left  a = modifyAngle (+        (Deg a))+left d = ST.modify $ T.left d  -- | Modify the current heading to the right by the specified angle in degrees. right :: Monad m => Double -> TurtleT m ()-right a = modifyAngle (subtract (Deg a))----- Based on "bezierFromSweepQ1" from Diagrams.TwoD.Arc-{--smoothTurn f s =-  where (x,y) = rotate s (1, 0)-        (u,v) = ((4-x)/3, (1-x)*(3-x)/(3*y))--bezierFromSweepQ1 :: Rad -> Segment R2-bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ Cubic p2 p1 p0-        p2       = reflectY p1--}+right d = ST.modify $ T.right d  -- State accessors / setters  -- | Set the current turtle angle, in degrees. setHeading :: Monad m => Double -> TurtleT m ()-setHeading a = modifyAngle (const (Deg a))+setHeading d = ST.modify $ T.setHeading d  -- | Get the current turtle angle, in degrees. heading :: Monad m => TurtleT m Double-heading = ST.gets (\(TState _ (Deg x) _) -> x)+heading = ST.gets ((\(Deg x) -> x) . T.heading)  -- | Sets the heading towards a given location. towards :: Monad m => P2 -> TurtleT m ()-towards pt = do-  p <- pos-  setHeading . (*360) . (/tau) . uncurry atan2 . unr2 $ pt .-. p+towards pt = ST.modify $ T.towards pt  -- | Set the current turtle X/Y position. setPos :: Monad m => P2 -> TurtleT m ()-setPos p = ST.modify helper- where-  helper (TState d a (Path ps))-    = TState d a $ Path $ (p, Trail [] False)-                          : if d then ps else tail ps+setPos p = ST.modify $ T.setPenPos p  -- | Get the current turtle X/Y position. pos ::  Monad m => TurtleT m P2-pos = ST.gets f-  where f (TState _ _ (Path ((p, t) : _))) = p .+^ trailOffset t-        f _ = error "Diagrams.TwoD.Path.Turtle.pos: no path.  Please report this as a bug."+pos = ST.gets T.penPos  -- Drawing control. --- | Starts a new path at the current location.-penHop :: Monad m => TurtleT m ()-penHop = pos >>= setPos- -- | Ends the current path, and enters into "penUp" mode penUp :: Monad m => TurtleT m ()-penUp   = penHop >> ST.modify (\(TState _ a p) -> TState False a p)+penUp   = ST.modify T.penUp  -- | Ends the current path, and enters into "penDown" mode penDown :: Monad m => TurtleT m ()-penDown = penHop >> ST.modify (\(TState _ a p) -> TState True a p)+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 (\(TState d _ _) -> d)+isDown = ST.gets T.isPenDown --- | Closes the current path, to the last penDown / setPosition--- Maintains current position - does this make sense?+-- | 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 = do-  p <- pos-  ST.modify $ modifyPath $ modifyTrail close-  setPos p+closeCurrent = ST.modify T.closeCurrent++-- | 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

@@ -0,0 +1,273 @@+{-# 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++-- | 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

@@ -1,5 +1,5 @@-{-# LANGUAGE TypeFamilies -           , FlexibleContexts +{-# LANGUAGE TypeFamilies+           , FlexibleContexts            , ScopedTypeVariables            , ViewPatterns            , CPP@@ -18,57 +18,57 @@ -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Tilings (-  +   -- * The ring Q[sqrt 2, sqrt 3]-  +     Q236, rt2, rt3, rt6-                  +   , toDouble-    +   , Q2, toR2, toP2-              -  -- * Regular polygons              -              -  , TilingPoly(..)              ++  -- * Regular polygons++  , TilingPoly(..)   , polySides, polyFromSides   , polyCos, polySin   , polyRotation, polyExtRotation-                  -  -- * Tilings                -                  -  -- ** Types                  ++  -- * Tilings++  -- ** Types   , Tiling(..)   , Edge, mkEdge-          +   , Polygon(..)-              +   -- ** Generation-    -  , TilingState(..), initTilingState  ++  , TilingState(..), initTilingState   , TilingM-    +   , generateTiling-    -  -- ** Pre-defined tilings  -    ++  -- ** Pre-defined tilings+   , t3, t4, t6   , mk3Tiling, t4612, t488, t31212-                            +   , t3636   , semiregular   , rot   , t3464, t33434, t33344, t33336L, t33336R-              -  -- * Diagrams  -    ++  -- * Diagrams+   , drawEdge   , drawPoly   , polyColor   , drawTiling   , drawTilingStyled-    +   ) where-    + import Control.Monad.State #if __GLASGOW_HASKELL__ >= 704 import Control.Monad.Writer hiding ((<>))@@ -102,9 +102,9 @@  -- | Convert a @Q236@ value to a @Double@. toDouble :: Q236 -> Double-toDouble (Q236 a b c d) = fromRational a -                        + fromRational b * sqrt 2 -                        + fromRational c * sqrt 3 +toDouble (Q236 a b c d) = fromRational a+                        + fromRational b * sqrt 2+                        + fromRational c * sqrt 3                         + fromRational d * sqrt 6  rt2, rt3, rt6 :: Q236@@ -123,13 +123,13 @@   abs (Q236 a b c d) = Q236 (abs a) (abs b) (abs c) (abs d)   fromInteger z = Q236 (fromInteger z) 0 0 0   signum = error "no signum for Q236"-  + instance AdditiveGroup Q236 where   zeroV = Q236 0 0 0 0-  (Q236 a1 b1 c1 d1) ^+^ (Q236 a2 b2 c2 d2) +  (Q236 a1 b1 c1 d1) ^+^ (Q236 a2 b2 c2 d2)     = Q236 (a1 + a2) (b1 + b2) (c1 + c2) (d1 + d2)   negateV (Q236 a b c d) = Q236 (-a) (-b) (-c) (-d)-  + instance VectorSpace Q236 where   type Scalar Q236 = Rational   s *^ (Q236 a b c d) = Q236 (s * a) (s * b) (s * c) (s * d)@@ -238,7 +238,7 @@  instance Eq Polygon where   (Polygon vs1) == (Polygon vs2) = sort vs1 == sort vs2-  + instance Ord Polygon where   compare = compare `on` (sort . polygonVertices) @@ -271,61 +271,61 @@                -> (Edge -> w)          -- ^ what to do with edges                -> (Polygon -> w)       -- ^ what to do with polygons                -> w-generateTiling t v d vPred e p +generateTiling t v d vPred e p   = evalState (execWriterT (generateTiling' t v d)) initTilingState where-    -  generateTiling' :: Tiling -> Q2 -> Q2 -> TilingM w ()  ++  generateTiling' :: Tiling -> Q2 -> Q2 -> TilingM w ()   generateTiling' t v d       -- stop if the current vertex fails the predicate     | not (vPred v) = return ()     | otherwise = do         ts <- get-        +         -- stop if we've seen this vertex before         when (v `S.notMember` visitedVertices ts) $ do-          -        -- otherwise, mark it as visited  -        modify (\ts -> ts { visitedVertices = v `S.insert` visitedVertices ts })-      -        -- get the neighboring vertices and the polygons surrounding-        -- this vertex, and filter out ones we've already generated-        let (neighbors, polys) = genNeighbors t v d-            edges  = S.fromList $ map (mkEdge v) neighbors-            edges' = edges `S.difference` visitedEdges ts-            polys' = polys `S.difference` visitedPolygons ts-            -        -- generate some edges and polygons-        F.mapM_ (tell . e) edges'-        F.mapM_ (tell . p) polys'-        -        -- remember that we generated them-        modify (\ts -> ts { visitedEdges = edges' `S.union` visitedEdges ts })-        modify (\ts -> ts { visitedPolygons = polys' `S.union` visitedPolygons ts })-      -        -- follow edges and continue recursively-        zipWithM_ (\d i -> generateTiling' (follow t i) (v ^+^ d) d) -          (map (^-^ v) $ neighbors) [0..] +          -- otherwise, mark it as visited+          modify (\ts -> ts { visitedVertices = v `S.insert` visitedVertices ts })++          -- get the neighboring vertices and the polygons surrounding+          -- this vertex, and filter out ones we've already generated+          let (neighbors, polys) = genNeighbors t v d+              edges  = S.fromList $ map (mkEdge v) neighbors+              edges' = edges `S.difference` visitedEdges ts+              polys' = polys `S.difference` visitedPolygons ts++          -- generate some edges and polygons+          F.mapM_ (tell . e) edges'+          F.mapM_ (tell . p) polys'++          -- remember that we generated them+          modify (\ts -> ts { visitedEdges = edges' `S.union` visitedEdges ts })+          modify (\ts -> ts { visitedPolygons = polys' `S.union` visitedPolygons ts })++          -- follow edges and continue recursively+          zipWithM_ (\d i -> generateTiling' (follow t i) (v ^+^ d) d)+            (map (^-^ v) $ neighbors) [0..]+ -- | Generate the neighboring vertices and polygons of a given vertex. genNeighbors :: Tiling -> Q2 -> Q2 -> ([Q2], S.Set Polygon) genNeighbors t v d = (neighbors, S.fromList polys) where-  (neighbors, polys) +  (neighbors, polys)     = unzip . snd-      $ mapAccumL +      $ mapAccumL           (\d' poly -> (polyRotation poly d', (v ^+^ d', genPolyVs poly v d')))           (negateV d)           (curConfig t)-  + -- | Generate the vertices of the given polygon, with one vertex at the given point --   and an adjacent vertex at the given offset.-genPolyVs :: TilingPoly +genPolyVs :: TilingPoly           -> Q2          -- ^ one vertex           -> Q2          -- ^ vector to second vertex           -> Polygon genPolyVs p v d = Polygon-                . scanl (^+^) v +                . scanl (^+^) v                 . take (polySides p - 1)-                . iterate (polyExtRotation p) +                . iterate (polyExtRotation p)                 $ d  ------------------------------------------------------------@@ -350,28 +350,28 @@  -- | Draw a tiling, with a given width and height and default colors --   for the polygons.-drawTiling :: (Renderable (Path R2) b, Backend b R2) +drawTiling :: (Renderable (Path R2) b, Backend b R2)            => Tiling -> Double -> Double -> Diagram b R2-drawTiling = -  drawTilingStyled +drawTiling =+  drawTilingStyled     (mempty # lw 0.02)-    (\p -> mempty +    (\p -> mempty            # lw 0-           # fc ( polyColor -                . polyFromSides -                . length +           # fc ( polyColor+                . polyFromSides+                . length                 . polygonVertices                 $ p                 )     )-  + -- | Draw a tiling with customizable styles for the polygons.  This is --   just an example, which you can use as the basis of your own --   tiling-drawing routine.-drawTilingStyled :: (Renderable (Path R2) b, Backend b R2) +drawTilingStyled :: (Renderable (Path R2) b, Backend b R2)                  => Style R2 -> (Polygon -> Style R2)                  -> Tiling -> Double -> Double -> Diagram b R2-drawTilingStyled eStyle pStyle t w h = +drawTilingStyled eStyle pStyle t w h =   mkDia $ generateTiling t (0,0) (1,0) inRect              -- draw the edges and polygons into separate@@ -389,7 +389,7 @@ ------------------------------------------------------------  -- Regular tilings-    + t3 :: Tiling t3 = Tiling (replicate 6 Triangle) (const t3) @@ -405,14 +405,14 @@ --   The argument is the number of sides of the polygons surrounding a vertex. mk3Tiling :: [Int] -> Tiling mk3Tiling (ps@[a,b,c])-      = Tiling +      = Tiling           (map polyFromSides ps)           (\i -> case i `mod` 3 of                    0 -> mk3Tiling (reverse ps)                    1 -> mk3Tiling [a,c,b]                    2 -> mk3Tiling [b,a,c]                    _ -> error "i `mod` 3 is not 0, 1,or 2! the sky is falling!"-          )           +          ) mk3Tiling _ = error "mk3Tiling may only be called on a list of length 3."  t4612 :: Tiling

@@ -0,0 +1,186 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ViewPatterns  #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Diagrams.TwoD.Path.Turtle.Tests+  ( tests+  ) where++import Control.Arrow ((***))++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++import Diagrams.Prelude+import Diagrams.TwoD.Path.Turtle.Internal++tests :: [Test]+tests =+  [ testProperty "Moves forward correctly" movesForward+  , testProperty "Moves backward correctly" movesBackward+  , testProperty "Moves backward and forward correctly" movesBackwardAndForward+  , 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 ==>+     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 :: 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 ==>+     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 :: 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+movesBackwardAndForward :: Turtle+                        -> Property+movesBackwardAndForward t = isPenDown t ==>+     abs(endX - startX) < 0.0001+  && abs(endY - startY) < 0.0001+  && totalSegmentsAdded == 2+ where+  x                          = 2.0+  t'                         = t # forward x # backward x+  (unp2 -> (startX, startY)) = penPos t+  (unp2 -> (endX, endY))     = penPos t'+  totalSegmentsAdded         = (uncurry (-)) . (getTrailLength *** getTrailLength) $ (t',t)+  getTrailLength             = (length . trailSegments . snd . currTrail)++-- | The turtle moves left four times and returns to the same position+movesLeft  :: Turtle+           -> Property+movesLeft t = isPenDown t ==>+     abs(endX - startX) < 0.0001+  && abs(endY - startY) < 0.0001+ where+  x                          = 2.0+  turn                       = 90+  t'                         = t # forward x # left turn+                                 # forward x # left turn+                                 # forward x # left turn+                                 # forward x+  (unp2 -> (startX, startY)) = penPos t+  (unp2 -> (endX, endY))     = penPos t'++-- | The turtle moves right four times and returns to the same position+movesRight  :: Turtle+            -> Property+movesRight t = isPenDown t ==>+     abs(endX - startX) < 0.0001+  && abs(endY - startY) < 0.0001+ where+  x                          = 2.0+  turn                       = 90+  t'                         = t # forward x # right turn+                                 # forward x # right turn+                                 # forward x # right turn+                                 # forward x+  (unp2 -> (startX, startY)) = penPos t+  (unp2 -> (endX, endY))     = penPos t'++-- | When the trail is empty, @currTrail@ always remains empty and no new paths+-- are added+trailEmptyWhenPenUp :: Turtle+                    -> Property+trailEmptyWhenPenUp t = isPenDown t ==> trailIsEmpty+ where+  t'           = t # penUp # forward 4 # backward 3+  trailIsEmpty = null . trailSegments . snd . currTrail $ t'++-- | 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+            <*> arbitrary+            <*> (Deg <$> arbitrary)+            <*> arbitrary+            <*> arbitrary+            <*> arbitrary++-- | Arbitrary instance for Diagrams type P2+instance Arbitrary P2 where+  arbitrary = p2 <$> arbitrary++-- | Arbitrary instance for TurtlePath+instance Arbitrary TurtlePath where+  arbitrary = TurtlePath <$> arbitrary <*> arbitrary++-- | Arbitrary instance of PenStyle+--+-- The color of the pen is chosen from black, blue or brown only+instance Arbitrary PenStyle where+  arbitrary = do+    penWidth_ <- arbitrary+    colorCode <- choose (1,3) :: Gen Int+    case colorCode of+      1 -> return $ PenStyle penWidth_  black+      2 -> return $ PenStyle penWidth_  blue+      3 -> return $ PenStyle penWidth_  brown+      _ -> error "Should not get here"++-- | Arbitrary instance of Segment+--+-- Currently this only generates linear segments only+instance Arbitrary (Segment R2)  where+  arbitrary = do+    h <- Deg <$> arbitrary+    x <- r2 <$> arbitrary+    return $ rotate h (Linear x)++instance Arbitrary (Trail R2) where+  arbitrary = Trail <$> arbitrary <*> (return False)

@@ -0,0 +1,11 @@+-- | Main module to run all tests.+--+module Main where++import Test.Framework (defaultMain, testGroup)++import qualified  Diagrams.TwoD.Path.Turtle.Tests++main :: IO ()+main = defaultMain+    [ testGroup "Diagrams.TwoD.Path.Turtle.Tests" Diagrams.TwoD.Path.Turtle.Tests.tests ]