diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,21 @@ +0.7: 9 August 2013 +------------------ + +* **New features** + + - New module `Diagrams.Color.HSV` with an `hsvBlend` function for + blending colors in HSV space. + + - Diagrams logo code is now in `Diagrams.Example.Logo`. + + - New symmetric layout algorithm for binary trees in + `Diagrams.TwoD.Layout.Tree`. + +* **Bug fixes** + + - Fix a bug in `Diagrams.TwoD.Path.Turtle` which sometimes caused + it to output a doubled path (#13). + 0.6.1 (23 March 2013) --------------------- diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,6 @@ +Joachim Breitner +Deepak Jois +Michael Sloan +Dominic Steinitz +Ryan Yates +Brent Yorgey 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.6.1 +version: 0.7 synopsis: Collection of user contributions to diagrams EDSL description: A collection of user contributions for diagrams, an embedded domain-specific language for generation @@ -13,15 +13,17 @@ category: Graphics build-type: Custom cabal-version: >=1.10 -extra-source-files: README.markdown, CHANGES.markdown, diagrams/*.svg -tested-with: GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.2, GHC == 7.6.1 +extra-source-files: README.markdown, CHANGES.markdown, diagrams/*.svg, CONTRIBUTORS +tested-with: GHC == 7.4.2, GHC == 7.6.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-contrib.git library ghc-options: -Wall - exposed-modules: Diagrams.Layout.Wrap, + exposed-modules: Diagrams.Color.HSV, + Diagrams.Example.Logo, + Diagrams.Layout.Wrap, Diagrams.TwoD.Apollonian, Diagrams.TwoD.Factorization, Diagrams.TwoD.Tilings, @@ -38,8 +40,8 @@ vector-space >= 0.7 && < 0.9, colour >= 2.3.1 && < 2.4, split >= 0.2.1 && < 0.3, - diagrams-core >= 0.6 && < 0.7, - diagrams-lib >= 0.6 && < 0.7, + diagrams-core >= 0.7 && < 0.8, + diagrams-lib >= 0.7 && < 0.8, arithmoi >= 0.4 && < 0.5, lens >= 3.8 && < 4, force-layout >= 0.2 && < 0.3, @@ -65,6 +67,6 @@ test-framework-quickcheck2 >= 0.2 && < 0.4, base >= 4.2 && < 4.7, - diagrams-lib >= 0.6 && < 0.7 + diagrams-lib >= 0.7 && < 0.8 default-language: Haskell2010 diff --git a/diagrams/diaLogo.svg b/diagrams/diaLogo.svg new file mode 100644 --- /dev/null +++ b/diagrams/diaLogo.svg @@ -0,0 +1,4 @@ + + +mG diff --git a/diagrams/fblEx.svg b/diagrams/fblEx.svg --- a/diagrams/fblEx.svg +++ b/diagrams/fblEx.svg @@ -1,4 +1,4 @@ -4362781 +112112311211234 diff --git a/diagrams/tree500.svg b/diagrams/tree500.svg new file mode 100644 --- /dev/null +++ b/diagrams/tree500.svg @@ -0,0 +1,4 @@ + + + diff --git a/src/Diagrams/Color/HSV.hs b/src/Diagrams/Color/HSV.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Color/HSV.hs @@ -0,0 +1,51 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Color.HSV +-- Copyright : (c) 2013 Brent Yorgey +-- License : BSD-style (see LICENSE) +-- Maintainer : byorgey@cis.upenn.edu +-- +-- Utilities for working with color in HSV space. +-- +-- Right now, the only utility is a function for blending colors in +-- HSV space. This has the effect of \"travelling around the color +-- wheel\", which can be especially nice when one wants to blend +-- smoothly from one color to another (blending in RGB space can tend +-- to travel across some icky brown/grey colors). +-- +----------------------------------------------------------------------------- + +module Diagrams.Color.HSV + ( hsvBlend + ) where + +import Data.Colour (Colour) +import Data.Colour.RGBSpace (uncurryRGB) +import Data.Colour.RGBSpace.HSV (hsv, hsvView) +import Data.Colour.SRGB (sRGB, toSRGB) +import Data.List (minimumBy) +import Data.Ord (comparing) +import Data.VectorSpace (Scalar, VectorSpace, lerp) + +-- | Blend two colors in HSV space---that is, linearly interpolate +-- between their hues, saturations, and values independently +-- (wrapping around appropriately in the case of hue). In +-- particular, @hsvBlend a c1 c2@ is like doing @(a-1)*c1 + a*c2@ in +-- HSV space. That is, a parameter of @0@ results in only the first +-- color; @1@ results in only the second color; and anything in +-- between results in a blend. +hsvBlend :: (Floating a, RealFrac a, VectorSpace a) + => Scalar a -> Colour a -> Colour a -> Colour a +hsvBlend t c1 c2 = uncurryRGB sRGB . hsv3 + $ (lerpWrap h1 h2 360 t, lerp s1 s2 t, lerp v1 v2 t) + where + [(h1,s1,v1), (h2,s2,v2)] = map (hsvView . toSRGB) [c1,c2] + hsv3 (h,s,v) = hsv h s v + +lerpWrap :: (RealFrac a, VectorSpace a) => a -> a -> a -> Scalar a -> a +lerpWrap a b m t = lerp a b' t `dmod` m + where + b' = minimumBy (comparing (abs . subtract a)) [b - m, b, b + m] + +dmod :: RealFrac a => a -> a -> a +dmod a m = a - m * fromIntegral (floor (a/m) :: Integer) diff --git a/src/Diagrams/Example/Logo.hs b/src/Diagrams/Example/Logo.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Example/Logo.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Example.Logo +-- Copyright : (c) 2011 Brent Yorgey +-- License : BSD-style (see LICENSE) +-- Maintainer : byorgey@cis.upenn.edu +-- +-- Source code for creating the diagrams logo. +-- +-- <> +-- +----------------------------------------------------------------------------- +module Diagrams.Example.Logo where + +-- > import Diagrams.Example.Logo +-- > diaLogo = logo + +import Diagrams.Coordinates ((&)) +import Diagrams.Prelude + +import Diagrams.TwoD.Layout.Tree +import Diagrams.TwoD.Path.Turtle + +import Control.Monad + +------------------------------------------------------------ +-- D +------------------------------------------------------------ + +d = (stroke $ + circle 2 # alignBR # translateX (-0.5) + <> (hcat' with { sep = 0.2 } . map (vcat' with {sep = 0.2}) + $ (replicate 2 (replicate 9 (reversePath $ circle 0.3)))) # alignBR) + # fc red + # lw 0 + +-- an icon-ish version of the d + +ico_d = (stroke $ + circle 2 # alignBR # translateX (-0.5) + <> (vcat' with {sep = 0.3} $ replicate 5 (reversePath $ circle 0.5)) # alignBR) + # fc red + # lw 0 + +------------------------------------------------------------ +-- I +------------------------------------------------------------ + +i = (circle 1 === strutY 0.5 === roundedRect 2 4 0.4) + # lw 0.05 + # lc blue + # fc yellow + +------------------------------------------------------------ +-- A +------------------------------------------------------------ + +sierpinski 1 = polygon with { polyType = PolyRegular 3 1 } +sierpinski n = t === (t ||| t) # centerX + where t = sierpinski (n-1) + +a1 = sierpinski (4 :: Integer) + # fc navy + # lw 0 + # scale (1/2) + +------------------------------------------------------------ +-- G +------------------------------------------------------------ + +grid = verts # centerXY <> horiz # centerXY + where verts = hcat' with {sep=0.5} $ replicate 20 (vrule 10) + horiz = rotateBy (1/4) verts + +gbkg = grid + # lc gray + # rotateBy (-1/20) + # clipBy p + # withEnvelope (p :: Path R2) + # lw 0.05 + where p = square 5 + +g = (text "G" # fontSize 4 # rotateBy (-1/20)) <> gbkg + +------------------------------------------------------------ +-- R +------------------------------------------------------------ + +r = sketchTurtle (setHeading 90 >> forward 5 >> right 90 + >> replicateM 5 (forward 0.9 >> right 36) + >> forward 0.9 >> left 135 >> forward 3 + ) + # reversePath + # stroke' with { vertexNames = [["end"]] } + # lw 0.3 + # lineJoin LineJoinRound + # lineCap LineCapRound + # lc orange + # (withName "end" $ atop . place turtle . location) + where + turtle = eqTriangle 1 # scaleY 1.3 # rotate (-135 :: Deg) + # lw 0.1 + +------------------------------------------------------------ +-- A +------------------------------------------------------------ + +aTree = BNode () f f + where f = BNode () (leaf ()) (leaf ()) + +a2 = renderTree (\_ -> circle 0.5 # fc purple) (~~) t'' # lw 0.1 + where Just t' = uniqueXLayout 1 2 aTree + t'' = forceLayoutTree t' + +------------------------------------------------------------ +-- M +------------------------------------------------------------ + +m = square 5 # lw 0.05 <> + text "m" + # fontSize 6 # italic # font "freeserif" # fc green + +------------------------------------------------------------ +-- S +------------------------------------------------------------ + +vs = map (uncurry (&)) [(5,5), (3,6), (1,5), (1,4), (3,3), (5,2), (4,0), (0,0.5)] +s = (mconcat (map (\v -> translate v (dot blue)) vs) <> + cubicSpline False vs # lw 0.20) + # scale 0.8 + +dot c = circle 0.4 # fc c # lw 0 + +------------------------------------------------------------ +-- Logo +------------------------------------------------------------ + +logo = (hcat' with {sep = 0.5} . map alignB $ [ d, i, a1, g, r, a2, m, s ]) + # centerXY diff --git a/src/Diagrams/TwoD/Layout/CirclePacking.hs b/src/Diagrams/TwoD/Layout/CirclePacking.hs --- a/src/Diagrams/TwoD/Layout/CirclePacking.hs +++ b/src/Diagrams/TwoD/Layout/CirclePacking.hs @@ -22,7 +22,7 @@ -- > [ decagon r | r <- [0.1,0.2..0.7] ] -- > -- > -- Just a approximation, diagram objects do not have an exact radius --- > radiusApproximation o = maximum [ radius (e (CircleFrac alpha)) o | alpha <- [0,0.1..1.0]] +-- > radiusApproximation o = maximum [ radius (e (alpha :: Turn)) o | alpha <- [0,0.1..1.0]] -- > -- > circlePackingExample = -- > position $ map (\(o,(x,y)) -> (p2 (x,y),o)) $ @@ -72,7 +72,8 @@ then error "circleRadius: n needs to be at least 3" else \o -> outByIn * maximum [ envelopeS (e alpha) o | i <- [1..n] - , let alpha = CircleFrac ((fromIntegral i + 0.5) / fromIntegral n) + , let alpha :: Turn + alpha = (fromIntegral i + 0.5) / fromIntegral n ] -- incircle radius: a / (2 * tan (tau/n)) -- outcircle radius: a / (2 * sin (tau /n)) @@ -85,4 +86,4 @@ -- It is, however, exact for circles, and there is no function that is safe for -- all diagrams and exact for circles. circleRadius :: RadiusFunction b m -circleRadius o = maximum [ envelopeS (e (CircleFrac alpha)) o | alpha <- [0,0.25,0.5,0.75]] +circleRadius o = maximum [ envelopeS (e (alpha :: Turn)) o | alpha <- [0,0.25,0.5,0.75]] 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 @@ -57,15 +57,30 @@ -- -- <> -- +-- Using a variant symmetric layout algorithm specifically for binary trees: +-- +-- > import Diagrams.TwoD.Layout.Tree +-- > +-- > drawT = maybe mempty (renderTree (const (circle 0.05 # fc black)) (~~)) +-- > . symmLayoutBin' with { slVSep = 0.5 } +-- > +-- > tree500 = drawT t # centerXY # pad 1.1 # sized (Width 4) +-- > where t = genTree 500 0.05 +-- > -- genTree 500 0.05 randomly generates trees of size 500 +/- 5%, +-- > -- definition not shown +-- +-- <> +-- -- Using force-based layout on a binary tree: -- -- > {-# LANGUAGE NoMonomorphismRestriction #-} -- > import Diagrams.Prelude -- > import Diagrams.TwoD.Layout.Tree -- > --- > t = BNode 1 (BNode 8 (leaf 7) (leaf 2)) (BNode 6 (leaf 3) (leaf 4)) +-- > t 0 = Empty +-- > t n = BNode n (t (n-1)) (t (n-1)) -- > --- > Just t' = uniqueXLayout 1 1 t +-- > Just t' = uniqueXLayout 1 1 (t 4) -- > -- > fblEx = renderTree (\n -> (text (show n) # fontSize 0.5 -- > <> circle 0.3 # fc white)) @@ -74,6 +89,7 @@ -- > # centerXY # pad 1.1 -- -- <> +-- module Diagrams.TwoD.Layout.Tree ( -- * Binary trees @@ -84,15 +100,17 @@ -- * Layout algorithms - -- ** Binary tree layout + -- ** Unique-x layout , uniqueXLayout - -- ** Symmetric rose tree layout + -- ** Symmetric layout -- $symmetric , symmLayout , symmLayout' + , symmLayoutBin + , symmLayoutBin' , SymmLayoutOpts(..) -- ** Force-directed layout @@ -233,49 +251,61 @@ -- | A tree with /relative/ positioning information. The Double -- at each node is the horizontal /offset/ from its parent. -type RelTree a = Tree (a, Double) +type Rel t a = t (a, Double) -- | Shift a RelTree horizontally. -moveTree :: Double -> RelTree a -> RelTree a +moveTree :: Double -> Rel Tree a -> Rel Tree a moveTree x' (Node (a, x) ts) = Node (a, x+x') ts -- | An /extent/ is a list of pairs, recording the leftmost and -- rightmost (absolute) horizontal positions of a tree at each -- depth. -type Extent = [(Double, Double)] +newtype Extent = Extent { getExtent :: [(Double, Double)] } +extent :: ([(Double, Double)] -> [(Double, Double)]) -> Extent -> Extent +extent f = Extent . f . getExtent + +consExtent :: (Double, Double) -> Extent -> Extent +consExtent = extent . (:) + -- | Shift an extent horizontally. moveExtent :: Double -> Extent -> Extent -moveExtent x = map ((+x) *** (+x)) +moveExtent x = (extent . map) ((+x) *** (+x)) -- | Reflect an extent about the vertical axis. flipExtent :: Extent -> Extent -flipExtent = map (\(p,q) -> (-q, -p)) +flipExtent = (extent . map) (\(p,q) -> (-q, -p)) -- | Merge two non-overlapping extents. mergeExtents :: Extent -> Extent -> Extent -mergeExtents [] qs = qs -mergeExtents ps [] = ps -mergeExtents ((p,_) : ps) ((_,q) : qs) = (p,q) : mergeExtents ps qs +mergeExtents (Extent e1) (Extent e2) = Extent $ mergeExtents' e1 e2 + where + mergeExtents' [] qs = qs + mergeExtents' ps [] = ps + mergeExtents' ((p,_) : ps) ((_,q) : qs) = (p,q) : mergeExtents' ps qs -mergeExtentList :: [Extent] -> Extent -mergeExtentList = foldr mergeExtents [] +instance Semigroup Extent where + (<>) = mergeExtents +instance Monoid Extent where + mempty = Extent [] + mappend = (<>) + -- | Determine the amount to shift in order to \"fit\" two extents -- next to one another. The first argument is the separation to -- leave between them. fit :: Double -> Extent -> Extent -> Double -fit hSep ps qs = maximum (0 : zipWith (\(_,p) (q,_) -> p - q + hSep) ps qs) +fit hSep (Extent ps) (Extent qs) = maximum (0 : zipWith (\(_,p) (q,_) -> p - q + hSep) ps qs) -- | Fit a list of subtree extents together using a left-biased -- algorithm. Compute a list of positions (relative to the leftmost -- subtree which is considered to have position 0). fitListL :: Double -> [Extent] -> [Double] -fitListL hSep = snd . mapAccumL fitOne [] +fitListL hSep = snd . mapAccumL fitOne mempty where fitOne acc e = let x = fit hSep acc e - in (mergeExtents acc (moveExtent x e), x) + in (acc <> moveExtent x e, x) -- | Fit a list of subtree extents together with a right bias. fitListR :: Double -> [Extent] -> [Double] @@ -289,15 +319,31 @@ -- | Actual recursive tree layout algorithm, which returns a tree -- layout as well as an extent. -symmLayoutR :: SymmLayoutOpts a -> Tree a -> (RelTree a, Extent) +symmLayoutR :: SymmLayoutOpts a -> Tree a -> (Rel Tree a, Extent) symmLayoutR opts (Node a ts) = (rt, ext) where (trees, extents) = unzip (map (symmLayoutR opts) ts) positions = fitList (slHSep opts) extents pTrees = zipWith moveTree positions trees pExtents = zipWith moveExtent positions extents - ext = slWidth opts a : mergeExtentList pExtents + ext = slWidth opts a `consExtent` mconcat pExtents rt = Node (a, 0) pTrees +-- | Symmetric tree layout algorithm specialized to binary trees. +-- Returns a tree layout as well as an extent. +symmLayoutBinR :: SymmLayoutOpts a -> BTree a -> (Maybe (Rel Tree a), Extent) +symmLayoutBinR _ Empty = (Nothing, mempty) +symmLayoutBinR opts (BNode a l r) = (Just rt, ext) + where (l', extL) = symmLayoutBinR opts l + (r', extR) = symmLayoutBinR opts r + positions = case (l', r') of + (Nothing, _) -> [0, slHSep opts / 2] + (_, Nothing) -> [-slHSep opts / 2, 0] + _ -> fitList (slHSep opts) [extL, extR] + pTrees = catMaybes $ zipWith (fmap . moveTree) positions [l',r'] + pExtents = zipWith moveExtent positions [extL, extR] + ext = slWidth opts a `consExtent` mconcat pExtents + rt = Node (a, 0) pTrees + -- | Options for controlling the symmetric tree layout algorithm. data SymmLayoutOpts a = SLOpts { slHSep :: Double -- ^ Minimum horizontal @@ -335,7 +381,34 @@ symmLayout' :: SymmLayoutOpts a -> Tree a -> Tree (a, P2) symmLayout' opts = unRelativize opts origin . fst . symmLayoutR opts -unRelativize :: SymmLayoutOpts a -> P2 -> RelTree a -> Tree (a, P2) +-- | Run the symmetric rose tree layout algorithm on a given tree +-- using default options, resulting in the same tree annotated with +-- node positions. +symmLayout :: Tree a -> Tree (a, P2) +symmLayout = symmLayout' def + +-- | Lay out a binary tree using a slight variant of the symmetric +-- layout algorithm. In particular, if a node has only a left child +-- but no right child (or vice versa), the child will be offset from +-- the parent horizontally by half the horizontal separation +-- parameter. Note that the result will be @Nothing@ if and only if +-- the input tree is @Empty@. +symmLayoutBin' :: SymmLayoutOpts a -> BTree a -> Maybe (Tree (a,P2)) +symmLayoutBin' opts = fmap (unRelativize opts origin) . fst . symmLayoutBinR opts + +-- | Lay out a binary tree using a slight variant of the symmetric +-- layout algorithm, using default options. In particular, if a +-- node has only a left child but no right child (or vice versa), +-- the child will be offset from the parent horizontally by half the +-- horizontal separation parameter. Note that the result will be +-- @Nothing@ if and only if the input tree is @Empty@. +symmLayoutBin :: BTree a -> Maybe (Tree (a,P2)) +symmLayoutBin = symmLayoutBin' def + +-- | Given a fixed location for the root, turn a tree with +-- \"relative\" positioning into one with absolute locations +-- associated to all the nodes. +unRelativize :: SymmLayoutOpts a -> P2 -> Rel Tree a -> Tree (a, P2) unRelativize opts curPt (Node (a,hOffs) ts) = Node (a, rootPt) (map (unRelativize opts (rootPt .+^ (vOffs *^ unit_Y))) ts) where rootPt = curPt .+^ (hOffs *^ unitX) @@ -343,12 +416,6 @@ + (maximum . map (snd . slHeight opts . fst . rootLabel) $ ts) + slVSep opts --- | Run the symmetric rose tree layout algorithm on a given tree --- using default options, resulting in the same tree annotated with --- node positions. -symmLayout :: Tree a -> Tree (a, P2) -symmLayout = symmLayout' def - -------------------------------------------------- -- Force-directed layout of rose trees @@ -489,3 +556,50 @@ renderNode a # moveTo p <> mconcat (map renderTreeR cs) <> mconcat (map (renderEdge (a,p) . rootLabel) cs) + + +-- > -- Critical size-limited Boltzmann generator for binary trees (used in example) +-- > +-- > import Control.Applicative +-- > import Control.Lens hiding (( # )) +-- > import Control.Monad.Random +-- > import Control.Monad.Reader +-- > import Control.Monad.State +-- > import Control.Monad.Trans.Maybe +-- > +-- > genTreeCrit :: ReaderT Int (StateT Int (MaybeT (Rand StdGen))) (BTree ()) +-- > genTreeCrit = do +-- > r <- getRandom +-- > if r <= (1/2 :: Double) +-- > then return Empty +-- > else atom >> (BNode () <$> genTreeCrit <*> genTreeCrit) +-- > +-- > atom :: ReaderT Int (StateT Int (MaybeT (Rand StdGen))) () +-- > atom = do +-- > targetSize <- ask +-- > curSize <- get +-- > when (curSize >= targetSize) mzero +-- > put (curSize + 1) +-- > +-- > genOneTree :: Int -> Int -> Double -> Maybe (BTree ()) +-- > genOneTree seed size eps = +-- > case mt of +-- > Nothing -> Nothing +-- > Just (t,sz) -> if sz >= minSz then Just t else Nothing +-- > +-- > where +-- > g = mkStdGen seed +-- > sizeWiggle = floor $ fromIntegral size * eps +-- > maxSz = size + sizeWiggle +-- > minSz = size - sizeWiggle +-- > mt = (evalRand ?? g) . runMaybeT . (runStateT ?? 0) . (runReaderT ?? maxSz) +-- > $ genTreeCrit +-- > +-- > genTree' :: Int -> Int -> Double -> BTree () +-- > genTree' seed size eps = +-- > case (genOneTree seed size eps) of +-- > Nothing -> genTree' (seed+1) size eps +-- > Just t -> t +-- > +-- > genTree :: Int -> Double -> BTree () +-- > genTree = genTree' 0 diff --git a/src/Diagrams/TwoD/Path/IteratedSubset.hs b/src/Diagrams/TwoD/Path/IteratedSubset.hs --- a/src/Diagrams/TwoD/Path/IteratedSubset.hs +++ b/src/Diagrams/TwoD/Path/IteratedSubset.hs @@ -44,6 +44,7 @@ ) where -- Diagrams.Core.Points needed for V (Point a) instance on GHC < 7.6 +import Diagrams.Coordinates ((&)) import Diagrams.Core.Points () import Diagrams.Prelude @@ -67,22 +68,23 @@ -- seed pattern. -- -- > import Diagrams.TwoD.Path.IteratedSubset --- > iterTrailEx = vcat' with { sep = 0.3 } . map strokeT . take 5 $ iterTrail koch +-- > iterTrailEx = vcat' with { sep = 0.3 } . map strokeLine . take 5 +-- > $ iterTrail koch -- -- <> -iterTrail :: Trail R2 -> [Trail R2] -iterTrail t = iterate (mconcat . mapMaybe (refineSegment t) . trailSegments) +iterTrail :: Trail' Line R2 -> [Trail' Line R2] +iterTrail t = iterate (mconcat . mapMaybe (refineSegment t) . lineSegments) (fromOffsets [unitX]) -- | Use a trail to \"refine\" a segment, returning a scaled and/or -- rotated copy of the trail with the same endpoint as the segment. -refineSegment :: Trail R2 -> Segment R2 -> Maybe (Trail R2) +refineSegment :: Trail' Line R2 -> Segment Closed R2 -> Maybe (Trail' Line R2) refineSegment t seg | tOff == 0 || sOff == 0 = Nothing | otherwise = Just $ t # scale k # rotateBy r where sOff = segOffset seg - tOff = trailOffset t + tOff = lineOffset t k = magnitude sOff / magnitude tOff r = direction sOff - direction tOff @@ -102,12 +104,12 @@ -- > import Diagrams.TwoD.Path.IteratedSubset -- > showTrail n t = hcat' with { sep = 0.2 } [ iters !! 1, iters !! n ] -- > # centerXY # pad 1.1 --- > where iters = map strokeT $ iterTrail t +-- > where iters = map strokeLine $ iterTrail t -- | Seed for the Koch curve (side of the famous Koch 'snowflake'). -- -- <> -koch :: (PathLike p, V p ~ R2) => p +koch :: (TrailLike t, V t ~ R2) => t koch = fromOffsets [unitX, unitX # rotateBy (1/6), unitX # rotateBy (-1/6), unitX] -- > kochD = showTrail 4 koch @@ -115,7 +117,7 @@ -- | Seed for the Lévy dragon curve. -- -- <> -levy :: (PathLike p, V p ~ R2) => p +levy :: (TrailLike t, V t ~ R2) => t levy = fromOffsets [unitY, unitX] -- > levyD = showTrail 9 levy @@ -124,7 +126,7 @@ -- of triangles. -- -- <> -zag :: (PathLike p, V p ~ R2) => p +zag :: (TrailLike t, V t ~ R2) => t zag = fromOffsets [unitX, (-0.5) & 1, unitX] -- > zagD = showTrail 5 zag @@ -133,7 +135,7 @@ -- curve. -- -- <> -sqUp :: (PathLike p, V p ~ R2) => p +sqUp :: (TrailLike t, V t ~ R2) => t sqUp = fromOffsets [unitX, unitY, unitX, unit_Y, unitX] -- > sqUpD = showTrail 3 sqUp @@ -142,7 +144,7 @@ -- rectilinear spiral patterns. -- -- <> -sqUpDown :: (PathLike p, V p ~ R2) => p +sqUpDown :: (TrailLike t, V t ~ R2) => t sqUpDown = fromOffsets [unitX, unitY, unitX, 2 *^ unit_Y, unitX, unitY, unitX] -- > sqUpDownD = showTrail 3 sqUpDown @@ -151,7 +153,7 @@ -- version. -- -- <> -sqUpDown' :: (PathLike p, V p ~ R2) => p +sqUpDown' :: (TrailLike t, V t ~ R2) => t sqUpDown' = cubicSpline False sqUpDown -- > sqUpDownD2 = showTrail 3 sqUpDown' @@ -173,7 +175,8 @@ snowflake :: Int -> Trail R2 snowflake n = iterateN 3 (rotateBy (-1/3)) edge # mconcat - # close + # glueLine + # wrapTrail where edge = iterTrail koch !! n -- > import Diagrams.TwoD.Path.IteratedSubset @@ -188,7 +191,7 @@ = sized (Width 4) . mconcat . zipWith lc (iterate (blend 0.1 white) blue) - . map strokeT + . map strokeLine . take 5 . iterTrail $ sqUpDown' @@ -200,7 +203,7 @@ -- Generating random iterated subset fractals -- | Parameters to generate an iterated subset fractal. -data IterTrailConfig = ITC { seed :: Trail R2 -- ^ The seed trail +data IterTrailConfig = ITC { seed :: Trail' Line R2 -- ^ The seed trail , color :: Colour Double -- ^ The line color to use , iters :: Int -- ^ Number of iterations } @@ -235,7 +238,7 @@ -- | Generate an iterated subset fractal based on the given parameters. drawITC :: Renderable (Path R2) b => IterTrailConfig -> Diagram b R2 -drawITC (ITC s c i) = (iterTrail s !! i) # strokeT # lc c +drawITC (ITC s c i) = (iterTrail s !! i) # strokeLine # lc c -- | Like 'drawITC', but also scales, centers, and pads the result so -- that it fits nicely inside a 4x4 box. diff --git a/src/Diagrams/TwoD/Path/Turtle/Internal.hs b/src/Diagrams/TwoD/Path/Turtle/Internal.hs --- a/src/Diagrams/TwoD/Path/Turtle/Internal.hs +++ b/src/Diagrams/TwoD/Path/Turtle/Internal.hs @@ -45,7 +45,6 @@ , getTurtlePath ) where -import Control.Arrow (second) import Debug.Trace (traceShow) import Diagrams.Prelude @@ -59,8 +58,8 @@ -- | 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 + { penStyle :: PenStyle -- ^ Style + , turtleTrail :: Located (Trail R2) -- ^ Path } deriving Show -- | Core turtle data type. A turtle needs to keep track of its current @@ -80,7 +79,7 @@ , heading :: Deg -- | Path traversed by the turtle so far, without any style or pen -- attributes changing - , currTrail :: (P2, Trail R2) + , currTrail :: Located (Trail' Line R2) -- | Current style of the pen , currPenStyle :: PenStyle -- | List of paths along with style information, traversed by the turtle @@ -96,17 +95,17 @@ -- orientation of 0 degrees with its pen position down. The pen style is -- @defaultPenStyle@. startTurtle :: TurtleState -startTurtle = TurtleState True origin 0 (origin, mempty) defaultPenStyle [] +startTurtle = TurtleState True origin 0 (mempty `at` origin) 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 - -> TurtleState -- ^ Turtle to move - -> TurtleState -- ^ Resulting turtle -moveTurtle s t@(TurtleState pd pos h (o, Trail xs _) _ _) = +moveTurtle :: Segment Closed R2 -- ^ Segment representing the path to travel + -> TurtleState -- ^ Turtle to move + -> TurtleState -- ^ Resulting turtle +moveTurtle s t@(TurtleState pd pos h tr _ _) = if pd -- Add segment to current trail and update position - then t { currTrail = (o, Trail newTrail False) + then t { currTrail = newTrail , penPos = newPenPos } -- Update position only @@ -114,7 +113,7 @@ where -- Rotate segment by orientation before adding to trail rotatedSeg = rotate h s - newTrail = rotatedSeg : xs + newTrail = mapLoc (<> fromSegments [rotatedSeg]) tr -- Calculate the new position along the segment newPenPos = pos .+^ segOffset rotatedSeg @@ -122,13 +121,13 @@ forward :: Double -- ^ Distance to move -> TurtleState -- ^ Turtle to move -> TurtleState -- ^ Resulting turtle -forward x = moveTurtle (Linear $ r2 (x,0)) +forward x = moveTurtle (straight $ r2 (x,0)) -- | Move the turtle backward by @x@ units backward :: Double -- ^ Distance to move -> TurtleState -- ^ Turtle to move -> TurtleState -- ^ Resulting turtle -backward x = moveTurtle (Linear $ r2 (negate x, 0)) +backward x = moveTurtle (straight $ r2 (negate x, 0)) -- | Turn the turtle by applying the given function to its current orientation -- (in degrees) @@ -187,15 +186,19 @@ -> TurtleState 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 +-- Closes the current path, to the starting position of the current +-- trail. Has no effect when the pen is up. closeCurrent :: TurtleState -> TurtleState closeCurrent t - | isPenDown t = t # setPenPos startPos # closeTrail # makeNewTrail + | isPenDown t = t # closeTTrail | otherwise = t - where startPos = fst . currTrail $ t - closeTrail t' = t' { currTrail = second close $ currTrail t } + where startPos = loc . currTrail $ t + closeTTrail t' = t' { penPos = startPos + , currTrail = mempty `at` startPos + , paths = addTrailToPath t' + (mapLoc (wrapTrail . closeLine) $ currTrail t) + } -- | Set the turtle X/Y position. -- @@ -243,25 +246,30 @@ -- | Creates a path from a turtle, ignoring the styles. getTurtlePath :: TurtleState -> Path R2 -getTurtlePath = mconcat . map turtlePathToPathLike . paths . penUp +getTurtlePath = mconcat . map turtlePathToTrailLike . paths . penUp -- * Helper functions -- Makes a "TurtlePath" from a "Turtle"’s @currTrail@ field makeTurtlePath :: TurtleState + -> Located (Trail R2) -> TurtlePath -makeTurtlePath t = TurtlePath (currPenStyle t) (currTrail t) +makeTurtlePath t tr = TurtlePath (currPenStyle t) tr -- Returns a list of paths, with current trail added to a "Turtle"’s @paths@ field -addCurrTrailToPath :: TurtleState - -> [TurtlePath] -addCurrTrailToPath t = if emptyTrail then paths t else makeTurtlePath t : paths t - where emptyTrail = (snd . currTrail) t == mempty +addTrailToPath :: TurtleState + -> Located (Trail R2) + -> [TurtlePath] +addTrailToPath t tr + | isTrailEmpty (unLoc tr) = paths t + | otherwise = makeTurtlePath t tr : paths t -- Starts a new trail and adds current trail to path makeNewTrail :: TurtleState -> TurtleState -makeNewTrail t = t { currTrail = (penPos t, mempty), paths = addCurrTrailToPath t } +makeNewTrail t = t { currTrail = mempty `at` penPos t + , paths = addTrailToPath t (mapLoc wrapTrail (currTrail t)) + } -- Modifies the current style after starting a new trail modifyCurrStyle :: (PenStyle -> PenStyle) @@ -269,9 +277,9 @@ -> TurtleState modifyCurrStyle f t = t # makeNewTrail # \t' -> t' { currPenStyle = (f . currPenStyle) t' } --- Creates any PathLike from a TurtlePath. -turtlePathToPathLike :: (V p ~ R2, PathLike p) => TurtlePath -> p -turtlePathToPathLike (TurtlePath _ (p, Trail xs c)) = pathLike p c (reverse xs) +-- Creates any TrailLike from a TurtlePath. +turtlePathToTrailLike :: (V t ~ R2, TrailLike t) => TurtlePath -> t +turtlePathToTrailLike (TurtlePath _ t) = trailLike t -- Creates a diagram from a TurtlePath using the provided styles turtlePathToStroke :: (Renderable (Path R2) b) => TurtlePath @@ -279,7 +287,7 @@ turtlePathToStroke t@(TurtlePath (PenStyle lineWidth_ lineColor_) _) = d where d = lc lineColor_ . lw lineWidth_ . - stroke $ turtlePathToPathLike t + stroke $ turtlePathToTrailLike t -- | Prints out turtle representation and returns it. Use for debugging traceTurtle :: TurtleState diff --git a/tests/Diagrams/TwoD/Path/Turtle/Tests.hs b/tests/Diagrams/TwoD/Path/Turtle/Tests.hs --- a/tests/Diagrams/TwoD/Path/Turtle/Tests.hs +++ b/tests/Diagrams/TwoD/Path/Turtle/Tests.hs @@ -1,17 +1,21 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Diagrams.TwoD.Path.Turtle.Tests ( tests ) where -import Control.Arrow ((***)) +import Control.Arrow ((***)) -import Test.Framework -import Test.Framework.Providers.QuickCheck2 -import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck -import Diagrams.Prelude -import Diagrams.TwoD.Path.Turtle.Internal +import Diagrams.Prelude +import Diagrams.TwoD.Path.Turtle.Internal tests :: [Test] tests = @@ -24,6 +28,7 @@ , 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 + , testProperty "closeCurrent only produces a single new path" closeCurrentSingle ] @@ -39,7 +44,7 @@ diffPos :: Int diffPos = round $ magnitude $ penPos t' .-. penPos t lenCurrTrail :: Int - lenCurrTrail = round $ flip arcLength 0.0001 . head . trailSegments . snd . currTrail $ t' + lenCurrTrail = round $ arcLength 0.0001 . last . lineSegments . unLoc . currTrail $ t' -- | The turtle moves forward by the right distance movesBackward :: TurtleState @@ -53,7 +58,7 @@ diffPos :: Int diffPos = round $ magnitude $ penPos t' .-. penPos t lenCurrTrail :: Int - lenCurrTrail = round $ flip arcLength 0.0001 . head . trailSegments . snd . currTrail $ t' + lenCurrTrail = round $ arcLength 0.0001 . last . lineSegments . unLoc . currTrail $ t' -- | The turtle moves forward and backward by the same distance and returns to -- the same position @@ -69,7 +74,7 @@ (unp2 -> (startX, startY)) = penPos t (unp2 -> (endX, endY)) = penPos t' totalSegmentsAdded = (uncurry (-)) . (getTrailLength *** getTrailLength) $ (t',t) - getTrailLength = (length . trailSegments . snd . currTrail) + getTrailLength = (length . lineSegments . unLoc . currTrail) -- | The turtle moves left four times and returns to the same position movesLeft :: TurtleState @@ -107,10 +112,9 @@ -- are added trailEmptyWhenPenUp :: TurtleState -> Property -trailEmptyWhenPenUp t = isPenDown t ==> trailIsEmpty +trailEmptyWhenPenUp t = isPenDown t ==> currEmpty t' 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. @@ -125,7 +129,7 @@ -- and @penHop@ is called. verifyPenHopWhenPenUp :: TurtleState -> Property -verifyPenHopWhenPenUp t = not (isPenDown t) && (null . trailSegments . snd . currTrail $ t) ==> (numPaths t') == (numPaths t) +verifyPenHopWhenPenUp t = (not (isPenDown t) && currEmpty t) ==> (numPaths t') == (numPaths t) where t' = t # forward 2.0 # penHop numPaths = length . paths @@ -133,9 +137,19 @@ -- | Verify that calling @closeCurrent@ updates the turtle position to the beginning to the trail verifyCloseCurrent :: TurtleState -> Property -verifyCloseCurrent t = (isPenDown t) && (null . trailSegments . snd . currTrail $ t) ==> (penPos t') == origin +verifyCloseCurrent t = (isPenDown t && currEmpty t) ==> (penPos t') == origin where t' = t # setPenPos origin # forward 2.0 # right 90 # forward 3.0 # closeCurrent + +-- | Verify that closeCurrent only produces a single new path (not two; see #13). +closeCurrentSingle :: TurtleState -> Property +closeCurrentSingle t = (isPenDown t) ==> ((length . paths $ t') == (succ . length . paths $ t)) + where + t' = t # closeCurrent + +currEmpty :: TurtleState -> Bool +currEmpty = null . lineSegments . unLoc . currTrail + -- | Arbitrary instance for the TurtleState type. -- -- FIXME this arbitrary instance can generate @@ -177,11 +191,17 @@ -- | Arbitrary instance of Segment -- -- Currently this only generates linear segments only -instance Arbitrary (Segment R2) where +instance Arbitrary (Segment Closed R2) where arbitrary = do h <- Deg <$> arbitrary x <- r2 <$> arbitrary - return $ rotate h (Linear x) + return $ rotate h (straight x) +instance Arbitrary (Trail' Line R2) where + arbitrary = lineFromSegments <$> arbitrary + +instance (Arbitrary a, Arbitrary (Point (V a))) => Arbitrary (Located a) where + arbitrary = at <$> arbitrary <*> arbitrary + instance Arbitrary (Trail R2) where - arbitrary = Trail <$> arbitrary <*> (return False) + arbitrary = wrapLine <$> arbitrary