diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,8 @@ +1.1.1 (8 March 2014) +-------------------- + + - require `diagrams-core-1.1` and `diagrams-lib-1.1` + 1.1.0.1 (15 January 2014) ------------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2013, various (see headers of individual source files) +Copyright (c) 2011-2014, various (see headers of individual source files) All rights reserved. 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: 1.1.0.1 +version: 1.1.1 synopsis: Collection of user contributions to diagrams EDSL description: A collection of user contributions for diagrams, an embedded domain-specific language for generation @@ -15,7 +15,7 @@ cabal-version: >=1.10 extra-source-files: README.markdown, CHANGES.markdown, diagrams/*.svg, CONTRIBUTORS extra-doc-files: diagrams/*.svg -tested-with: GHC == 7.4.2, GHC == 7.6.1 +tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-contrib.git @@ -50,10 +50,10 @@ vector-space-points >= 0.1 && < 0.2, colour >= 2.3.1 && < 2.4, split >= 0.2.1 && < 0.3, - diagrams-core >= 1.0 && < 1.1, - diagrams-lib >= 1.0 && < 1.1, + diagrams-core >= 1.1 && < 1.2, + diagrams-lib >= 1.1 && < 1.2, arithmoi >= 0.4 && < 0.5, - lens >= 3.8 && < 4, + lens >= 3.8 && < 4.1, force-layout >= 0.3 && < 0.4, data-default >= 0.3 && < 0.6, MonadRandom >= 0.1.8 && < 0.2, @@ -81,6 +81,6 @@ test-framework-quickcheck2 >= 0.2 && < 0.4, base >= 4.2 && < 4.8, - diagrams-lib >= 1.0 && < 1.1 + diagrams-lib >= 1.1 && < 1.2 default-language: Haskell2010 diff --git a/src/Diagrams/Example/Logo.hs b/src/Diagrams/Example/Logo.hs --- a/src/Diagrams/Example/Logo.hs +++ b/src/Diagrams/Example/Logo.hs @@ -100,7 +100,7 @@ # lc orange # (withName "end" $ atop . place turtle . location) where - turtle = eqTriangle 1 # scaleY 1.3 # rotate (-135 :: Deg) + turtle = eqTriangle 1 # scaleY 1.3 # rotate (-135 @@ deg) # lw 0.1 ------------------------------------------------------------ diff --git a/src/Diagrams/Lens.hs b/src/Diagrams/Lens.hs --- a/src/Diagrams/Lens.hs +++ b/src/Diagrams/Lens.hs @@ -19,8 +19,7 @@ -- This module provides utilities for using "Control.Lens" with diagrams, -- including orphan instances for the 'Wrapped' class. module Diagrams.Lens - ( Wrapped' - , _P + ( _P -- * Diagrams.Align , _envelopeVMove , _alignedVMove @@ -46,8 +45,6 @@ , _lineVertices , _lineOffsets , _lineSegments - -- * Diagrams.TwoD.Types - , _toTurn ) where import Control.Applicative @@ -58,26 +55,8 @@ import Diagrams.Core.Style import Diagrams.Prelude -type Wrapped' s a = Wrapped s s a a - -instance Wrapped v v (Point v) (Point v) where - wrapped = _P - {-# INLINE wrapped #-} - -_P :: Iso s t (Point s) (Point t) -_P = iso P $ \(P x) -> x - --- $(concat <$> mapM makeWrapped --- [ ''Deg --- , ''R3 --- , ''Rad --- , ''Turn ---TODO: re-introduce - this is probably a bug in 'makeWrapped' --- , ''SubMap --- , ''Path --- , ''Point --- , ''QDiagram - --]) +_P :: Iso (Point v) (Point v') v v' +_P = iso (\(P x) -> x) P -- * Diagrams.Align @@ -250,10 +229,3 @@ (Trail' Line v) (Trail' Line v') [Segment Closed v] [Segment Closed v'] _lineSegments = iso lineSegments lineFromSegments - - --- * Diagrams.TwoD.Types - --- | 'toTurn' is an isomorphism from angles to 'Turn's. -_toTurn :: (Angle a, Angle a') => Iso a a' Turn Turn -_toTurn = iso toTurn fromTurn 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 @@ -23,7 +23,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 (alpha :: Turn)) 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)) $ @@ -74,8 +74,7 @@ then error "circleRadius: n needs to be at least 3" else \o -> outByIn * maximum [ envelopeS (e alpha) o | i <- [1..n] - , let alpha :: Turn - alpha = (fromIntegral i + 0.5) / fromIntegral n + , let alpha = (fromIntegral i + 0.5) / fromIntegral n @@ turn ] -- incircle radius: a / (2 * tan (tau/n)) -- outcircle radius: a / (2 * sin (tau /n)) @@ -88,4 +87,4 @@ -- It is, however, exact for circles, and there is no function that is safe for -- all diagrams and exact for circles. circleRadius :: (Monoid' m) => RadiusFunction b m -circleRadius o = maximum [ envelopeS (e (alpha :: Turn)) 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/Path/IteratedSubset.hs b/src/Diagrams/TwoD/Path/IteratedSubset.hs --- a/src/Diagrams/TwoD/Path/IteratedSubset.hs +++ b/src/Diagrams/TwoD/Path/IteratedSubset.hs @@ -80,12 +80,12 @@ refineSegment :: Trail' Line R2 -> Segment Closed R2 -> Maybe (Trail' Line R2) refineSegment t seg | tOff == zeroV || sOff == zeroV = Nothing - | otherwise = Just $ t # scale k # rotateBy r + | otherwise = Just $ t # scale k # rotate r where sOff = segOffset seg tOff = lineOffset t k = magnitude sOff / magnitude tOff - r = direction sOff - direction tOff + r = direction sOff ^-^ direction tOff ------------------------------------------------------------ -- Examples diff --git a/src/Diagrams/TwoD/Path/Metafont/Internal.hs b/src/Diagrams/TwoD/Path/Metafont/Internal.hs --- a/src/Diagrams/TwoD/Path/Metafont/Internal.hs +++ b/src/Diagrams/TwoD/Path/Metafont/Internal.hs @@ -238,17 +238,17 @@ offs = z1 .-. z0 w0 = case w0' of (Just (PathDirDir d)) -> d - _ -> offs # rotate (Turn t) + _ -> offs # rotate (t @@ turn) w1 = case w1' of (Just (PathDirDir d)) -> d - _ -> offs # rotate (Turn (negate p)) + _ -> offs # rotate (negate p @@ turn) -- | psi (l,r) calculates the turning angle between segments l and r, if -- each segment were a straight line connecting its endpoints. The endpoint of l -- is assumed to be the starting point of r; this is not checked. psi :: (MetafontSegment p j1, MetafontSegment p j1) -> Double psi (l,r) = normalizeTurns t where - (Turn t) = direction (mfSegmentOffset r) - direction (mfSegmentOffset l) + t = view turn $ direction (mfSegmentOffset r) ^-^ direction (mfSegmentOffset l) -- | lineDirs calculates the offset angles θ for a Line. Most of the work -- done by lineEqs and solveTriDiagonal, but lineDirs handles the separate cases @@ -261,7 +261,7 @@ lineDirs [s] | rightCurl s = solveTriDiagonal [a] [1,c] [0] [normalizeTurns t, r] where (a,c,r) = solveOneSeg s (PathDirDir dir) = s^.pj.d1.to fromJust - (Turn t) = direction dir - direction (s^.x2 .-. s^.x1) + t = view turn $ direction dir ^-^ direction (s^.x2 .-. s^.x1) lineDirs [s] | leftCurl s = reverse $ lineDirs [reverseSeg s] lineDirs s = error $ "lineDirs was called on something inappropriate. \ \It should be called on a list of segments with directions specified at both ends.\ @@ -286,7 +286,7 @@ (d0,c0,_) = solveOneSeg . reverseSeg $ s0 r0 = r0' (s0^.pj.d1.to fromJust) where r0' (PathDirDir d) = normalizeTurns t where - (Turn t) = direction d - direction (s0^.x2 .-. s0^.x1) + t = view turn $ direction d ^-^ direction (s0^.x2 .-. s0^.x1) r0' (PathDirCurl _) = negate $ d0 * psi (s0, ss!!1) s0 = head ss (an, cn, rn) = solveOneSeg (last ss) @@ -314,7 +314,7 @@ c' (PathDirCurl g) = beta s **3 * g / (alpha s **2) + 3 - alpha s r = r' (s^.pj.d2.to fromJust) where r' (PathDirDir d) = normalizeTurns t where - (Turn t) = direction d - direction (s^.x2 .-. s^.x1) + t = view turn $ direction d ^-^ direction (s^.x2 .-. s^.x1) r' (PathDirCurl _) = 0 -- | Take a segment whose endpoint directions have been fully @@ -341,21 +341,21 @@ where (u,v) = ctrlPts z0 w0 va vb w1 z1 offs = z1 .-. z0 - theta = direction w0 - direction offs - phi = direction offs - direction w1 - sinR = sin . op Rad + theta = direction w0 ^-^ direction offs + phi = direction offs ^-^ direction w1 + sinR = sin . view rad boundingTriangleExists = signum (sinR theta) == signum (sinR phi) - && signum (sinR theta) == signum (sinR (theta+phi)) + && signum (sinR theta) == signum (sinR (theta^+^phi)) va = case a of (TensionAmt ta) -> hobbyF theta phi / ta (TensionAtLeast ta) -> case boundingTriangleExists of - True -> min (sinR phi / sinR (theta + phi)) + True -> min (sinR phi / sinR (theta ^+^ phi)) (hobbyF theta phi / ta) False -> hobbyF theta phi / ta vb = case b of (TensionAmt tb) -> hobbyF phi theta / tb (TensionAtLeast tb) -> case boundingTriangleExists of - True -> min (sinR theta / sinR (theta + phi)) + True -> min (sinR theta / sinR (theta ^+^ phi)) (hobbyF phi theta / tb) False -> hobbyF phi theta / tb @@ -374,20 +374,22 @@ ctrlPts z0 w0 va vb w1 z1 = (u,v) where offs = z1 .-. z0 - theta, phi :: Rad - theta = direction w0 - direction offs - phi = direction offs - direction w1 + theta = direction w0 ^-^ direction offs + phi = direction offs ^-^ direction w1 u = z0 .+^ (offs # rotate theta # scale va) - v = z1 .-^ (offs # rotate (-phi) # scale vb) + v = z1 .-^ (offs # rotate (negateV phi) # scale vb) -- | Some weird function that computes some sort of scaling factor -- based on the turning angles between endpoints and direction -- vectors (again due to Hobby). -hobbyF :: Rad -> Rad -> Double -hobbyF (Rad theta) (Rad phi) = - (2 + sqrt 2 * (sin theta - sin phi / 16)*(sin phi - sin theta / 16)*(cos theta - cos phi)) - / - (3 * (1 + (sqrt 5 - 1)/2 * cos theta + (3 - sqrt 5)/2 * cos phi)) +hobbyF :: Angle -> Angle -> Double +hobbyF theta' phi' = let + theta = theta' ^. rad + phi = phi' ^. rad + in + (2 + sqrt 2 * (sin theta - sin phi / 16)*(sin phi - sin theta / 16)*(cos theta - cos phi)) + / + (3 * (1 + (sqrt 5 - 1)/2 * cos theta + (3 - sqrt 5)/2 * cos phi)) -- | Convert a fully specified MetafontSegment to a Diagrams Segment importSegment :: MetafontSegment () ControlJoin -> Segment Closed R2 diff --git a/src/Diagrams/TwoD/Path/Metafont/Parser.hs b/src/Diagrams/TwoD/Path/Metafont/Parser.hs --- a/src/Diagrams/TwoD/Path/Metafont/Parser.hs +++ b/src/Diagrams/TwoD/Path/Metafont/Parser.hs @@ -35,8 +35,8 @@ -- Joins -join :: Parser (PathJoin (Maybe PathDir) BasicJoin) -join = straightJoin <|> do +anyJoin :: Parser (PathJoin (Maybe PathDir) BasicJoin) +anyJoin = straightJoin <|> do d1' <- optionMaybe pathDir j' <- tenseLine <|> dotsJoin d2' <- optionMaybe pathDir @@ -99,7 +99,7 @@ -- Segments & Paths mfs :: Parser (MetafontSegment (Maybe PathDir) BasicJoin) -mfs = MFS <$> pt <*> join <*> lookAhead pt +mfs = MFS <$> pt <*> anyJoin <*> lookAhead pt matches :: Stream s m t => ParsecT s u m a -> ParsecT s u m Bool matches p = option False (p *> return True) 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 @@ -30,6 +30,7 @@ , penUp, penDown, penHop, closeCurrent ) where +import qualified Control.Lens as L import Control.Monad.Identity (Identity (..)) import qualified Control.Monad.State as ST @@ -97,7 +98,7 @@ -- | Get the current turtle angle, in degrees. heading :: Monad m => TurtleT m Double -heading = ST.gets ((\(Deg x) -> x) . T.heading) +heading = ST.gets (L.view deg . T.heading) -- | Sets the heading towards a given location. towards :: Monad m => P2 -> TurtleT m () 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 @@ -76,7 +76,7 @@ -- | Current position. This is updated everytime the turtle moves , penPos :: P2 -- | Orientation of the turtle in 2D space, given in degrees - , heading :: Deg + , heading :: Angle -- | Path traversed by the turtle so far, without any style or pen -- attributes changing , currTrail :: Located (Trail' Line R2) @@ -95,7 +95,7 @@ -- orientation of 0 degrees with its pen position down. The pen style is -- @defaultPenStyle@. startTurtle :: TurtleState -startTurtle = TurtleState True origin 0 (mempty `at` origin) defaultPenStyle [] +startTurtle = TurtleState True origin zeroV (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. @@ -131,7 +131,7 @@ -- | Turn the turtle by applying the given function to its current orientation -- (in degrees) -turnTurtle :: (Deg -> Deg) -- ^ Transformation to apply on current orientation +turnTurtle :: (Angle -> Angle) -- ^ Transformation to apply on current orientation -> TurtleState -- ^ Turtle to turn -> TurtleState -- ^ Resulting turtle turnTurtle f t@(TurtleState _ _ h _ _ _) = t { heading = f h } @@ -140,19 +140,19 @@ left :: Double -- ^ Degree of turn -> TurtleState -- ^ Turtle to turn -> TurtleState -- ^ Resulting turtle -left d = turnTurtle (+ (Deg d)) +left d = turnTurtle (^+^ (d @@ deg)) -- | Turn the turtle clockwise (right) right :: Double -- ^ Degree of turn -> TurtleState -- ^ Turtle to turn -> TurtleState -- ^ Resulting turtle -right d = turnTurtle (subtract (Deg d)) +right d = turnTurtle (^-^ (d @@ deg)) -- | Turn the turtle to the given orientation, in degrees setHeading :: Double -- ^ Degree of orientation -> TurtleState -- ^ Turtle to orient -> TurtleState -- ^ Resulting turtle -setHeading d = turnTurtle (const $ Deg d) +setHeading d = turnTurtle (const $ d @@ deg) -- | Sets the turtle orientation towards a given location. towards :: P2 -- ^ Point to orient turtle towards diff --git a/src/Diagrams/TwoD/Sunburst.hs b/src/Diagrams/TwoD/Sunburst.hs --- a/src/Diagrams/TwoD/Sunburst.hs +++ b/src/Diagrams/TwoD/Sunburst.hs @@ -57,29 +57,29 @@ -- Section data: Will be stored in nodes of a new rose tree and used to -- make each section of the sunburst partition. -- radius, ring width, start angle, end angle, number of sections, color. -data SData = SData Double Double Turn Turn Int (Colour Double) +data SData = SData Double Double Angle Angle Int (Colour Double) -- Make n sections (annular wedges) spanning a1 to a2. sections :: Renderable (Path R2) b - => Double -> Double -> Turn -> Turn -> Int -> (Colour Double) + => Double -> Double -> Angle -> Angle -> Int -> (Colour Double) -> Diagram b R2 sections r s a1 a2 n c = mconcat $ iterateN n (rotate theta) w where - theta = (a2 - a1) / (fromIntegral n) - w = annularWedge (s + r) r a1 (a1 + theta) + theta = (a2 ^-^ a1) ^/ (fromIntegral n) + w = annularWedge (s + r) r a1 (a1 ^+^ theta) # lc white # lw 0.008 # fc c -- Convert an arbitrary @Tree a@ to a @Tree SData@ storing the sections info -- in the nodes. If color list is shorter than depth of tree than the first -- color of the list is repeated. If the color list is empty, lightgray is used. -toTree :: Double -> Double-> [(Colour Double)] -> Tree a -> Turn -> Turn -> Tree SData +toTree :: Double -> Double-> [(Colour Double)] -> Tree a -> Angle -> Angle -> Tree SData toTree r s [] x q1 q2 = toTree r s (repeat lightgray) x q1 q2 toTree r s (c:cs) (Node _ ts) q1 q2 = Node (SData r s q1 q2 n c) ts' where n = length ts - dt = (q2 - q1) / (fromIntegral n) - qs = [q1 + ((fromIntegral i) * dt ) | i <- [0..n]] + dt = (q2 ^-^ q1) ^/ (fromIntegral n) + qs = [q1 ^+^ ((fromIntegral i) *^ dt ) | i <- [0..n]] fs = toTree (r + s) s (cs ++ [c]) ts' = zipWith3 fs ts (take (n-1) qs) (drop 1 qs) @@ -90,7 +90,7 @@ -- sections is treated the same way. sunburst' :: Renderable (Path R2) b => SunburstOpts -> Tree a -> Diagram b R2 sunburst' opts t - = sunB $ toTree r s cs t 0 1 + = sunB $ toTree r s cs t zeroV fullTurn where r = opts^.radius s = opts^.sectionWidth 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 @@ -84,10 +84,9 @@ && 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 + t' = t # forward x # left 90 + # forward x # left 90 + # forward x # left 90 # forward x (unp2 -> (startX, startY)) = penPos t (unp2 -> (endX, endY)) = penPos t' @@ -100,10 +99,9 @@ && 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 + t' = t # forward x # right 90 + # forward x # right 90 + # forward x # right 90 # forward x (unp2 -> (startX, startY)) = penPos t (unp2 -> (endX, endY)) = penPos t' @@ -162,7 +160,7 @@ TurtleState <$> arbitrary <*> arbitrary - <*> (Deg <$> arbitrary) + <*> ((@@deg) <$> arbitrary) <*> arbitrary <*> arbitrary <*> arbitrary @@ -193,7 +191,7 @@ -- Currently this only generates linear segments only instance Arbitrary (Segment Closed R2) where arbitrary = do - h <- Deg <$> arbitrary + h <- (@@deg) <$> arbitrary x <- r2 <$> arbitrary return $ rotate h (straight x)