diff --git a/CHANGES b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -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) diff --git a/CHANGES.markdown b/CHANGES.markdown new file mode 100644 --- /dev/null +++ b/CHANGES.markdown @@ -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) diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -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). diff --git a/diagrams-contrib.cabal b/diagrams-contrib.cabal --- a/diagrams-contrib.cabal +++ b/diagrams-contrib.cabal @@ -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 diff --git a/src/Diagrams/TwoD/Apollonian.hs b/src/Diagrams/TwoD/Apollonian.hs --- a/src/Diagrams/TwoD/Apollonian.hs +++ b/src/Diagrams/TwoD/Apollonian.hs @@ -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. -- . -- ----------------------------------------------------------------------------- -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) diff --git a/src/Diagrams/TwoD/Layout/Tree.hs b/src/Diagrams/TwoD/Layout/Tree.hs --- a/src/Diagrams/TwoD/Layout/Tree.hs +++ b/src/Diagrams/TwoD/Layout/Tree.hs @@ -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) 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 @@ -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 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,273 @@ +{-# 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 + +-- | 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/src/Diagrams/TwoD/Tilings.hs b/src/Diagrams/TwoD/Tilings.hs --- a/src/Diagrams/TwoD/Tilings.hs +++ b/src/Diagrams/TwoD/Tilings.hs @@ -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 diff --git a/tests/Diagrams/TwoD/Path/Turtle/Tests.hs b/tests/Diagrams/TwoD/Path/Turtle/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Diagrams/TwoD/Path/Turtle/Tests.hs @@ -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) diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -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 ]