diagrams-contrib 1.1.0.1 → 1.1.1
raw patch · 13 files changed
+71/−94 lines, 13 filesdep ~diagrams-coredep ~diagrams-libdep ~lens
Dependency ranges changed: diagrams-core, diagrams-lib, lens
Files
- CHANGES.markdown +5/−0
- LICENSE +1/−1
- diagrams-contrib.cabal +6/−6
- src/Diagrams/Example/Logo.hs +1/−1
- src/Diagrams/Lens.hs +3/−31
- src/Diagrams/TwoD/Layout/CirclePacking.hs +3/−4
- src/Diagrams/TwoD/Path/IteratedSubset.hs +2/−2
- src/Diagrams/TwoD/Path/Metafont/Internal.hs +23/−21
- src/Diagrams/TwoD/Path/Metafont/Parser.hs +3/−3
- src/Diagrams/TwoD/Path/Turtle.hs +2/−1
- src/Diagrams/TwoD/Path/Turtle/Internal.hs +6/−6
- src/Diagrams/TwoD/Sunburst.hs +8/−8
- tests/Diagrams/TwoD/Path/Turtle/Tests.hs +8/−10
CHANGES.markdown view
@@ -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) -------------------------
LICENSE view
@@ -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.
diagrams-contrib.cabal view
@@ -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
src/Diagrams/Example/Logo.hs view
@@ -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 ------------------------------------------------------------
src/Diagrams/Lens.hs view
@@ -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
src/Diagrams/TwoD/Layout/CirclePacking.hs view
@@ -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]]
src/Diagrams/TwoD/Path/IteratedSubset.hs view
@@ -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
src/Diagrams/TwoD/Path/Metafont/Internal.hs view
@@ -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
src/Diagrams/TwoD/Path/Metafont/Parser.hs view
@@ -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)
src/Diagrams/TwoD/Path/Turtle.hs view
@@ -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 ()
src/Diagrams/TwoD/Path/Turtle/Internal.hs view
@@ -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
src/Diagrams/TwoD/Sunburst.hs view
@@ -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
tests/Diagrams/TwoD/Path/Turtle/Tests.hs view
@@ -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)