diagrams-contrib 1.1.1.2 → 1.1.1.3
raw patch · 13 files changed
+101/−68 lines, 13 filesdep ~diagrams-coredep ~diagrams-libdep ~lensnew-uploader
Dependency ranges changed: diagrams-core, diagrams-lib, lens, semigroups, vector-space-points
Files
- CHANGES.markdown +5/−0
- LICENSE +1/−1
- diagrams-contrib.cabal +8/−8
- src/Diagrams/Example/Logo.hs +1/−1
- src/Diagrams/Lens.hs +31/−3
- src/Diagrams/TwoD/Layout/CirclePacking.hs +4/−3
- src/Diagrams/TwoD/Path/IteratedSubset.hs +2/−2
- src/Diagrams/TwoD/Path/Metafont/Internal.hs +21/−23
- src/Diagrams/TwoD/Path/Metafont/Parser.hs +3/−3
- src/Diagrams/TwoD/Path/Turtle.hs +1/−2
- src/Diagrams/TwoD/Path/Turtle/Internal.hs +6/−6
- src/Diagrams/TwoD/Sunburst.hs +8/−8
- tests/Diagrams/TwoD/Path/Turtle/Tests.hs +10/−8
CHANGES.markdown view
@@ -1,3 +1,8 @@+1.1.1.3 (10 April 2014)+----------------------++ - Allow `semigroups-0.13`+ 1.1.1.2 (19 March 2014) ----------------------
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011-2014, various (see headers of individual source files)+Copyright (c) 2011-2013, various (see headers of individual source files) All rights reserved.
diagrams-contrib.cabal view
@@ -1,5 +1,5 @@ name: diagrams-contrib-version: 1.1.1.2+version: 1.1.1.3 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.3, GHC == 7.8.1+tested-with: GHC == 7.4.2, GHC == 7.6.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-contrib.git@@ -47,13 +47,13 @@ containers > 0.4 && < 0.6, split >= 0.2.1 && < 0.3, vector-space >= 0.7 && < 0.9,- vector-space-points >= 0.1 && < 0.3,+ vector-space-points >= 0.1 && < 0.2, colour >= 2.3.1 && < 2.4, split >= 0.2.1 && < 0.3,- diagrams-core >= 1.1 && < 1.2,- diagrams-lib >= 1.1 && < 1.2,+ diagrams-core >= 1.0 && < 1.1,+ diagrams-lib >= 1.0 && < 1.1, arithmoi >= 0.4 && < 0.5,- lens >= 3.8 && < 4.2,+ lens >= 3.8 && < 4, force-layout >= 0.3 && < 0.4, data-default >= 0.3 && < 0.6, MonadRandom >= 0.1.8 && < 0.2,@@ -61,7 +61,7 @@ parsec >= 3.1 && < 3.2, text >= 0.11 && < 1.2, data-default-class < 0.1,- semigroups >= 0.3.4 && < 0.13+ semigroups >= 0.3.4 && < 0.14 hs-source-dirs: src default-language: Haskell2010 @@ -81,6 +81,6 @@ test-framework-quickcheck2 >= 0.2 && < 0.4, base >= 4.2 && < 4.8,- diagrams-lib >= 1.1 && < 1.2+ diagrams-lib >= 1.0 && < 1.1 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,7 +19,8 @@ -- This module provides utilities for using "Control.Lens" with diagrams, -- including orphan instances for the 'Wrapped' class. module Diagrams.Lens- ( _P+ ( Wrapped'+ , _P -- * Diagrams.Align , _envelopeVMove , _alignedVMove@@ -45,6 +46,8 @@ , _lineVertices , _lineOffsets , _lineSegments+ -- * Diagrams.TwoD.Types+ , _toTurn ) where import Control.Applicative@@ -55,9 +58,27 @@ import Diagrams.Core.Style import Diagrams.Prelude -_P :: Iso (Point v) (Point v') v v'-_P = iso (\(P x) -> x) P+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+ --])+ -- * Diagrams.Align -- | A singleton 'Traversal' for an envelope vector, where modification of the@@ -229,3 +250,10 @@ (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,7 +74,8 @@ then error "circleRadius: n needs to be at least 3" else \o -> outByIn * maximum [ envelopeS (e alpha) o | i <- [1..n]- , let alpha = (fromIntegral i + 0.5) / fromIntegral n @@ turn+ , let alpha :: Turn+ alpha = (fromIntegral i + 0.5) / fromIntegral n ] -- incircle radius: a / (2 * tan (tau/n)) -- outcircle radius: a / (2 * sin (tau /n))@@ -87,4 +88,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 # rotate r+ | otherwise = Just $ t # scale k # rotateBy 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 (t @@ turn)+ _ -> offs # rotate (Turn t) w1 = case w1' of (Just (PathDirDir d)) -> d- _ -> offs # rotate (negate p @@ turn)+ _ -> offs # rotate (Turn (negate p)) -- | 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- t = view turn $ direction (mfSegmentOffset r) ^-^ direction (mfSegmentOffset l)+ (Turn t) = 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- t = view turn $ direction dir ^-^ direction (s^.x2 .-. s^.x1)+ (Turn t) = 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- t = view turn $ direction d ^-^ direction (s0^.x2 .-. s0^.x1)+ (Turn t) = 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- t = view turn $ direction d ^-^ direction (s^.x2 .-. s^.x1)+ (Turn t) = 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 . view rad+ theta = direction w0 - direction offs+ phi = direction offs - direction w1+ sinR = sin . op 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,22 +374,20 @@ ctrlPts z0 w0 va vb w1 z1 = (u,v) where offs = z1 .-. z0- theta = direction w0 ^-^ direction offs- phi = direction offs ^-^ direction w1+ theta, phi :: Rad+ theta = direction w0 - direction offs+ phi = direction offs - direction w1 u = z0 .+^ (offs # rotate theta # scale va)- v = z1 .-^ (offs # rotate (negateV phi) # scale vb)+ v = z1 .-^ (offs # rotate (-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 :: 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))+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)) -- | 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 -anyJoin :: Parser (PathJoin (Maybe PathDir) BasicJoin)-anyJoin = straightJoin <|> do+join :: Parser (PathJoin (Maybe PathDir) BasicJoin)+join = 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 <*> anyJoin <*> lookAhead pt+mfs = MFS <$> pt <*> join <*> 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,7 +30,6 @@ , penUp, penDown, penHop, closeCurrent ) where -import qualified Control.Lens as L import Control.Monad.Identity (Identity (..)) import qualified Control.Monad.State as ST @@ -98,7 +97,7 @@ -- | Get the current turtle angle, in degrees. heading :: Monad m => TurtleT m Double-heading = ST.gets (L.view deg . T.heading)+heading = ST.gets ((\(Deg x) -> x) . 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 :: Angle+ , heading :: Deg -- | 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 zeroV (mempty `at` origin) 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.@@ -131,7 +131,7 @@ -- | Turn the turtle by applying the given function to its current orientation -- (in degrees)-turnTurtle :: (Angle -> Angle) -- ^ Transformation to apply on current orientation+turnTurtle :: (Deg -> Deg) -- ^ 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 (^+^ (d @@ deg))+left d = turnTurtle (+ (Deg d)) -- | Turn the turtle clockwise (right) right :: Double -- ^ Degree of turn -> TurtleState -- ^ Turtle to turn -> TurtleState -- ^ Resulting turtle-right d = turnTurtle (^-^ (d @@ deg))+right d = turnTurtle (subtract (Deg d)) -- | 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 $ d @@ deg)+setHeading d = turnTurtle (const $ Deg d) -- | 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 Angle Angle Int (Colour Double)+data SData = SData Double Double Turn Turn Int (Colour Double) -- Make n sections (annular wedges) spanning a1 to a2. sections :: Renderable (Path R2) b- => Double -> Double -> Angle -> Angle -> Int -> (Colour Double)+ => Double -> Double -> Turn -> Turn -> 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 -> Angle -> Angle -> Tree SData+toTree :: Double -> Double-> [(Colour Double)] -> Tree a -> Turn -> Turn -> 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 zeroV fullTurn+ = sunB $ toTree r s cs t 0 1 where r = opts^.radius s = opts^.sectionWidth
tests/Diagrams/TwoD/Path/Turtle/Tests.hs view
@@ -84,9 +84,10 @@ && abs(endY - startY) < 0.0001 where x = 2.0- t' = t # forward x # left 90- # forward x # left 90- # forward x # left 90+ 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'@@ -99,9 +100,10 @@ && abs(endY - startY) < 0.0001 where x = 2.0- t' = t # forward x # right 90- # forward x # right 90- # forward x # right 90+ 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'@@ -160,7 +162,7 @@ TurtleState <$> arbitrary <*> arbitrary- <*> ((@@deg) <$> arbitrary)+ <*> (Deg <$> arbitrary) <*> arbitrary <*> arbitrary <*> arbitrary@@ -191,7 +193,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)