From 0f80bd5c932320ead96af31c687e9d7a03a207de Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Fri, 23 May 2014 22:14:37 -0600 Subject: [PATCH 01/58] Generalize Angle to Angle v and Angle Double --- src/Diagrams/Angle.hs | 65 +++++++++++++++++--------------- src/Diagrams/Direction.hs | 5 ++- src/Diagrams/ThreeD/Camera.hs | 4 +- src/Diagrams/ThreeD/Transform.hs | 8 ++-- src/Diagrams/ThreeD/Types.hs | 6 +-- src/Diagrams/TwoD/Arc.hs | 14 +++---- src/Diagrams/TwoD/Arrow.hs | 4 +- src/Diagrams/TwoD/Arrowheads.hs | 14 +++---- src/Diagrams/TwoD/Polygons.hs | 14 +++---- src/Diagrams/TwoD/Transform.hs | 8 ++-- src/Diagrams/TwoD/Types.hs | 2 +- src/Diagrams/TwoD/Vector.hs | 2 +- 12 files changed, 76 insertions(+), 70 deletions(-) diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 5fba3f72..4010388c 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -1,5 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -16,7 +18,7 @@ module Diagrams.Angle ( Angle , rad, turn, deg - , fullTurn, fullCircle, angleRatio + , fullTurn, angleRatio , sinA, cosA, tanA, asinA, acosA, atanA, atan2A , (@@) , angleBetween @@ -29,78 +31,80 @@ import Data.Monoid hiding ((<>)) import Data.Semigroup import Data.VectorSpace +import Diagrams.Core.V + -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. -newtype Angle = Radians Double - deriving (Read, Show, Eq, Ord, Enum, AdditiveGroup) +newtype Angle v = Radians v + deriving (Read, Show, Eq, Ord, AdditiveGroup) -instance Semigroup Angle where +instance AdditiveGroup v => Semigroup (Angle v) where (<>) = (^+^) -instance Monoid Angle where +instance AdditiveGroup v => Monoid (Angle v) where mappend = (<>) - mempty = Radians 0 + mempty = Radians zeroV + +instance VectorSpace v => VectorSpace (Angle v) where + type Scalar (Angle v) = Scalar v + s *^ Radians t = Radians (s *^ t) -instance VectorSpace Angle where - type Scalar Angle = Double - s *^ Radians t = Radians (s*t) +deriving instance InnerSpace v => InnerSpace (Angle v) + +type instance V (Angle v) = V v -- | The radian measure of an @Angle@ @a@ can be accessed as @a -- ^. rad@. A new @Angle@ can be defined in radians as @pi \@\@ rad@. -rad :: Iso' Angle Double +rad :: Iso' (Angle v) v rad = iso (\(Radians r) -> r) Radians -- | The measure of an @Angle@ @a@ in full circles can be accessed as -- @a ^. turn@. A new @Angle@ of one-half circle can be defined in as -- @1/2 \@\@ turn@. -turn :: Iso' Angle Double -turn = iso (\(Radians r) -> r/2/pi) (Radians . (*(2*pi))) +turn :: (VectorSpace v, Floating (Scalar v)) => Iso' (Angle v) v +turn = iso (\(Radians r) -> r ^/ (2*pi)) (Radians . (^*(2*pi))) -- | The degree measure of an @Angle@ @a@ can be accessed as @a -- ^. deg@. A new @Angle@ can be defined in degrees as @180 \@\@ -- deg@. -deg :: Iso' Angle Double -deg = iso (\(Radians r) -> r/2/pi*360) (Radians . (*(2*pi/360))) +deg :: (VectorSpace v, Floating (Scalar v)) => Iso' (Angle v) v +deg = iso (\(Radians r) -> r ^/ (2*pi/360)) (Radians . (^*(2*pi/360))) -- | An angle representing one full turn. -fullTurn :: Angle +fullTurn :: (VectorSpace v, Floating (Scalar v), Num v) => Angle v fullTurn = 1 @@ turn --- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. -fullCircle :: Angle -fullCircle = fullTurn - -- | Calculate ratio between two angles. -angleRatio :: Angle -> Angle -> Double -angleRatio a b = (a^.rad) / (b^.rad) +angleRatio :: (InnerSpace v, Floating (Scalar v)) => Angle v -> Angle v -> Scalar v +angleRatio a b = (magnitude a) / (magnitude b) -- | The sine of the given @Angle@. -sinA :: Angle -> Double +sinA :: (Floating v) => Angle v -> v sinA (Radians r) = sin r -- | The cosine of the given @Angle@. -cosA :: Angle -> Double +cosA :: (Floating v) => Angle v -> v cosA (Radians r) = cos r -- | The tangent function of the given @Angle@. -tanA :: Angle -> Double +tanA :: (Floating v) => Angle v -> v tanA (Radians r) = tan r -- | The @Angle@ with the given sine. -asinA :: Double -> Angle +asinA :: (Floating v) => v -> Angle v asinA = Radians . asin -- | The @Angle@ with the given cosine. -acosA :: Double -> Angle +acosA :: (Floating v) => v -> Angle v acosA = Radians . acos -- | The @Angle@ with the given tangent. -atanA :: Double -> Angle +atanA :: (Floating v) => v -> Angle v atanA = Radians . atan -- | @atan2A n d@ is the @Angle with tangent @n/d@, unless d is 0, in -- which case it is ±π/2. -atan2A :: Double -> Double -> Angle +atan2A :: (RealFloat v) => v -> v -> Angle v atan2A n d = Radians $ atan2 n d -- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. @@ -115,7 +119,8 @@ a @@ i = review i a infixl 5 @@ -- | compute the positive angle between the two vectors in their common plane -angleBetween :: (InnerSpace v, Scalar v ~ Double) => v -> v -> Angle +-- | N.B.: currently discards the common plane information +angleBetween :: (InnerSpace v, Floating (Scalar v)) => v -> v -> Angle (Scalar v) angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad ------------------------------------------------------------ @@ -123,4 +128,4 @@ angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad -- | The class of types with at least one angle coordinate, called _theta. class HasTheta t where - _theta :: Lens' t Angle + _theta :: Lens' t (Angle (Scalar (V t))) diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index effb9cab..1380799e 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -33,6 +33,7 @@ import Diagrams.Core -- magnitude. @Direction@s can be used with 'fromDirection' and the -- lenses provided by its instances. newtype Direction v = Direction v + deriving (Read, Show, Eq, Ord) -- todo: special instances type instance V (Direction v) = v @@ -55,6 +56,6 @@ fromDirection :: (InnerSpace v, Floating (Scalar v)) => Direction v -> v fromDirection (Direction v) = normalized v -- | compute the positive angle between the two directions in their common plane -angleBetweenDirs :: (InnerSpace v, Scalar v ~ Double) => - Direction v -> Direction v -> Angle +angleBetweenDirs :: (InnerSpace v, Floating (Scalar v)) => + Direction v -> Direction v -> Angle (Scalar v) angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index 75b55cc6..9c474f8e 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -56,8 +56,8 @@ class Typeable l => CameraLens l where -- | A perspective projection data PerspectiveLens = PerspectiveLens - { _horizontalFieldOfView :: Angle -- ^ Horizontal field of view. - , _verticalFieldOfView :: Angle -- ^ Vertical field of view. + { _horizontalFieldOfView :: Angle Double -- ^ Horizontal field of view. + , _verticalFieldOfView :: Angle Double -- ^ Vertical field of view. } deriving Typeable diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 7616f394..c92cb395 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -73,7 +73,7 @@ import Data.VectorSpace -- Note that writing @aboutZ (1\/4)@, with no type annotation, will -- yield an error since GHC cannot figure out which sort of angle -- you want to use. -aboutZ :: Angle -> T3 +aboutZ :: Angle Double -> T3 aboutZ ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) theta = view rad ang @@ -83,7 +83,7 @@ aboutZ ang = fromLinear r (linv r) where -- | Like 'aboutZ', but rotates about the X axis, bringing positive y-values -- towards the positive z-axis. -aboutX :: Angle -> T3 +aboutX :: Angle Double -> T3 aboutX ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) theta = view rad ang @@ -93,7 +93,7 @@ aboutX ang = fromLinear r (linv r) where -- | Like 'aboutZ', but rotates about the Y axis, bringing postive -- x-values towards the negative z-axis. -aboutY :: Angle -> T3 +aboutY :: Angle Double -> T3 aboutY ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) theta = view rad ang @@ -106,7 +106,7 @@ aboutY ang = fromLinear r (linv r) where rotationAbout :: P3 -- ^ origin of rotation -> Direction R3 -- ^ direction of rotation axis - -> Angle -- ^ angle of rotation + -> Angle Double -- ^ angle of rotation -> T3 rotationAbout p d a = mconcat [translation (negateV t), diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index db6136ee..f67e8eca 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -142,11 +142,11 @@ instance HasZ P3 where -- triple (r,θ,φ), where θ is rotation about the Z axis, and φ is the -- angle from the Z axis. class Spherical t where - spherical :: Iso' t (Double, Angle, Angle) + spherical :: Iso' t (Scalar (V t), Angle (Scalar (V t)), Angle (Scalar (V t))) -- | Types which can be expressed in cylindrical 3D coordinates. class Cylindrical t where - cylindrical :: Iso' t (Double, Angle, Double) -- r, θ, z + cylindrical :: Iso' t (Scalar (V t), Angle (Scalar (V t)), Scalar (V t)) -- r, θ, z instance Cylindrical R3 where cylindrical = iso (\(R3 x y z) -> (sqrt (x^(2::Int)+y^(2::Int)), atanA (y/x), z)) @@ -175,7 +175,7 @@ instance HasTheta P3 where -- | The class of types with at least two angle coordinates, the -- second called _phi. class HasPhi t where - _phi :: Lens' t Angle + _phi :: Lens' t (Angle (Scalar (V t))) instance HasPhi R3 where _phi = spherical . _3 diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index f5018e89..f8362903 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -47,7 +47,7 @@ import Diagrams.Coordinates -- the positive y direction and sweeps counterclockwise through an -- angle @s@. The approximation is only valid for angles in the -- first quadrant. -bezierFromSweepQ1 :: Angle -> Segment Closed R2 +bezierFromSweepQ1 :: Angle Double -> Segment Closed R2 bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 where p0@(coords -> x :& y) = rotate (s ^/ 2) v c1 = ((4-x)/3) ^& ((1-x)*(3-x)/(3*y)) @@ -60,7 +60,7 @@ bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 -- negative y direction and sweep clockwise. When @s@ is less than -- 0.0001 the empty list results. If the sweep is greater than @fullTurn@ -- later segments will overlap earlier segments. -bezierFromSweep :: Angle -> [Segment Closed R2] +bezierFromSweep :: Angle Double -> [Segment Closed R2] bezierFromSweep s | s < zeroV = fmap reflectY . bezierFromSweep $ (negateV s) | s < 0.0001 @@ rad = [] @@ -92,7 +92,7 @@ the approximation error. -- is the 'Trail' of a radius one arc starting at @d@ and sweeping out -- the angle @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arcT :: Direction R2 -> Angle -> Trail R2 +arcT :: Direction R2 -> Angle Double -> Trail R2 arcT start sweep = trailFromSegments bs where bs = map (rotate $ start ^. _theta) . bezierFromSweep $ sweep @@ -101,7 +101,7 @@ arcT start sweep = trailFromSegments bs -- path of a radius one arc starting at @d@ and sweeping out the angle -- @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arc :: (TrailLike t, V t ~ R2) => Direction R2 -> Angle -> t +arc :: (TrailLike t, V t ~ R2) => Direction R2 -> Angle Double -> t arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ p2 (1,0)) -- | Given a radus @r@, a start direction @d@ and an angle @s@, @@ -113,7 +113,7 @@ arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ -- -- > arc'Ex = mconcat [ arc' r 0 (1/4 \@\@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 -arc' :: (TrailLike p, V p ~ R2) => Double -> Direction R2 -> Angle -> p +arc' :: (TrailLike p, V p ~ R2) => Double -> Direction R2 -> Angle Double -> p arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) $ p2 (abs r,0)) where ts = arcT start sweep @@ -129,7 +129,7 @@ arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -wedge :: (TrailLike p, V p ~ R2) => Double -> Direction R2 -> Angle -> p +wedge :: (TrailLike p, V p ~ R2) => Double -> Direction R2 -> Angle Double -> p wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine $ fromOffsets [r *^ fromDirection d] <> arc d s # scale r @@ -181,7 +181,7 @@ arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) -- > # fc blue -- > # centerXY # pad 1.1 annularWedge :: (TrailLike p, V p ~ R2) => - Double -> Double -> Direction R2 -> Angle -> p + Double -> Double -> Direction R2 -> Angle Double -> p annularWedge r1' r2' d1 s = trailLike . (`at` o) . glueTrail . wrapLine $ fromOffsets [(r1'-r2') *^ fromDirection d1] <> arc d1 s # scale r1' diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 38688f7b..7c3a298a 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -517,13 +517,13 @@ connect' opts n1 n2 = -- by angle. connectPerim :: (Renderable (Path R2) b, IsName n1, IsName n2) - => n1 -> n2 -> Angle -> Angle + => n1 -> n2 -> Angle Double -> Angle Double -> (Diagram b R2 -> Diagram b R2) connectPerim = connectPerim' def connectPerim' :: (Renderable (Path R2) b, IsName n1, IsName n2) - => ArrowOpts -> n1 -> n2 -> Angle -> Angle + => ArrowOpts -> n1 -> n2 -> Angle Double -> Angle Double -> (Diagram b R2 -> Diagram b R2) connectPerim' opts n1 n2 a1 a2 = withName n1 $ \sub1 -> diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index ee32e785..03e17695 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -98,7 +98,7 @@ closedPath = pathFromTrail . closeTrail -- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 \@\@ turn) & shaftStyle %~ lw none) -- > origin (r2 (0.001, 0)) -- > <> square 0.6 # alignL # lw none -arrowheadTriangle :: Angle -> ArrowHT +arrowheadTriangle :: Angle Double -> ArrowHT arrowheadTriangle theta = aHead where aHead len _ = (p, mempty) @@ -110,7 +110,7 @@ arrowheadTriangle theta = aHead -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. -arrowheadDart :: Angle -> ArrowHT +arrowheadDart :: Angle Double -> ArrowHT arrowheadDart theta len shaftWidth = (hd # scale size, jt) where hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] @@ -126,7 +126,7 @@ arrowheadDart theta len shaftWidth = (hd # scale size, jt) size = max 1 ((len - jLength) / (1.5)) -- | Isoceles triangle with curved concave base. Inkscape type 2. -arrowheadSpike :: Angle -> ArrowHT +arrowheadSpike :: Angle Double -> ArrowHT arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) where hd = snugL . closedPath $ l1 <> c <> l2 @@ -153,7 +153,7 @@ arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) phi = asinA (min 1 (y/r)) -- | Curved sides, linear concave base. Illustrator CS5 #3 -arrowheadThorn :: Angle -> ArrowHT +arrowheadThorn :: Angle Double -> ArrowHT arrowheadThorn theta len shaftWidth = (hd # scale size, jt) where hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop @@ -171,7 +171,7 @@ arrowheadThorn theta len shaftWidth = (hd # scale size, jt) size = max 1 ((len - jLength) / (1.5)) -- | Make a side for the thorn head. -curvedSide :: Angle -> Segment Closed R2 +curvedSide :: Angle Double -> Segment Closed R2 curvedSide theta = bezier3 ctrl1 ctrl2 end where v0 = unit_X @@ -228,7 +228,7 @@ headToTail hd = tl t = reflectX t' j = reflectX j' -arrowtailBlock :: Angle -> ArrowHT +arrowtailBlock :: Angle Double -> ArrowHT arrowtailBlock theta = aTail where aTail len _ = (t, mempty) @@ -239,7 +239,7 @@ arrowtailBlock theta = aTail x = magnitude a -- | The angle is where the top left corner intersects the circle. -arrowtailQuill :: Angle -> ArrowHT +arrowtailQuill :: Angle Double -> ArrowHT arrowtailQuill theta = aTail where aTail len shaftWidth = (t, j) diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index 7879e7bc..32940534 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -73,7 +73,7 @@ import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) import Diagrams.Util (tau, ( # )) -- | Method used to determine the vertices of a polygon. -data PolyType = PolyPolar [Angle] [Double] +data PolyType = PolyPolar [Angle Double] [Double] -- ^ A \"polar\" polygon. -- -- * The first argument is a list of /central/ @@ -90,7 +90,7 @@ data PolyType = PolyPolar [Angle] [Double] -- circle) can be constructed using a second -- argument of @(repeat r)@. - | PolySides [Angle] [Double] + | PolySides [Angle Double] [Double] -- ^ A polygon determined by the distance between -- successive vertices and the angles formed by -- each three successive vertices. In other @@ -181,7 +181,7 @@ polygon = trailLike . polyTrail -- | Generate the located trail of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'. -polyPolarTrail :: [Angle] -> [Double] -> Located (Trail R2) +polyPolarTrail :: [Angle Double] -> [Double] -> Located (Trail R2) polyPolarTrail [] _ = emptyTrail `at` origin polyPolarTrail _ [] = emptyTrail `at` origin polyPolarTrail ans (r:rs) = tr `at` p1 @@ -196,7 +196,7 @@ polyPolarTrail ans (r:rs) = tr `at` p1 -- | Generate the vertices of a polygon specified by side length and -- angles, and a starting point for the trail such that the origin -- is at the centroid of the vertices. See 'PolySides'. -polySidesTrail :: [Angle] -> [Double] -> Located (Trail R2) +polySidesTrail :: [Angle Double] -> [Double] -> Located (Trail R2) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) where ans' = scanl (^+^) zeroV ans @@ -224,18 +224,18 @@ orientPoints v xs = rotation a (zip3 (tail (cycle xs)) xs (last xs : init xs)) distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p) sndOf3 (_,b,_) = b - a :: Angle + a :: Angle Double a = minimumBy (comparing $ abs . view rad) . map (angleFromNormal . (.-. x)) $ [n1,n2] v' = normalized v - angleFromNormal :: R2 -> Angle + angleFromNormal :: R2 -> Angle Double angleFromNormal o | leftTurn o' v' = phi | otherwise = negateV phi where o' = normalized o theta = acos (v' <.> o') - phi :: Angle + phi :: Angle Double phi | theta <= tau/4 = tau/4 - theta @@ rad | otherwise = theta - tau/4 @@ rad diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 097fd500..a3ce01f8 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -67,7 +67,7 @@ import Control.Lens (review, (^.)) -- | Create a transformation which performs a rotation about the local -- origin by the given angle. See also 'rotate'. -rotation :: Angle -> T2 +rotation :: Angle Double -> T2 rotation ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) @@ -87,7 +87,7 @@ rotation ang = fromLinear r (linv r) -- will yield an error since GHC cannot figure out which sort of -- angle you want to use. In this common situation you can use -- 'rotateBy', which interprets its argument as a number of turns. -rotate :: (Transformable t, V t ~ R2) => Angle -> t -> t +rotate :: (Transformable t, V t ~ R2) => Angle Double -> t -> t rotate = transform . rotation -- | A synonym for 'rotate', interpreting its argument in units of @@ -98,12 +98,12 @@ rotateBy = transform . rotation . review turn -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). -rotationAbout :: P2 -> Angle -> T2 +rotationAbout :: P2 -> Angle Double -> T2 rotationAbout p angle = conjugate (translation (origin .-. p)) (rotation angle) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. -rotateAbout :: (Transformable t, V t ~ R2) => P2 -> Angle -> t -> t +rotateAbout :: (Transformable t, V t ~ R2) => P2 -> Angle Double -> t -> t rotateAbout p angle = rotate angle `under` translation (origin .-. p) -- Scaling ------------------------------------------------- diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 61a29779..6e157c65 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -250,7 +250,7 @@ instance HasTheta P2 where -- | Types which can be expressed in polar 2D coordinates, as a magnitude and an angle. class Polar t where - polar :: Iso' t (Double, Angle) + polar :: Iso' t (Scalar (V t), Angle (Scalar (V t))) instance Polar R2 where polar = diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 7ae5396a..b13ee34e 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -55,7 +55,7 @@ xDir = direction unitX -- | A unit vector at a specified angle counterclockwise from the -- positive X axis. -e :: Angle -> R2 +e :: Angle Double -> R2 e a = unitX & _theta .~ a -- | @perp v@ is perpendicular to and has the same magnitude as @v@. From 825f519d1856a1f35ae8151c79e4d90c28ab521c Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Wed, 28 May 2014 10:07:46 -0600 Subject: [PATCH 02/58] Checkpoint --- diagrams-lib.cabal | 4 ++++ src/Diagrams/Angle.hs | 9 ++++++++- src/Diagrams/Coordinates.hs | 10 ++++++---- src/Diagrams/Direction.hs | 6 ++++++ src/Diagrams/ThreeD/Types.hs | 11 ----------- src/Diagrams/TwoD/Arrowheads.hs | 1 + src/Diagrams/TwoD/Types.hs | 32 +++++++++++++++++--------------- src/Diagrams/TwoD/Vector.hs | 32 +++++++++++++++++--------------- 8 files changed, 59 insertions(+), 46 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 51f9bc4e..c02d2a5a 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -117,3 +117,7 @@ Library Build-depends: ghc-prim Hs-source-dirs: src default-language: Haskell2010 + -- default-extensions: FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies + other-extensions: BangPatterns, CPP, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, ExistentialQuantification, GADTs, + GeneralizedNewtypeDeriving, NoMonomorphismRestriction, Rank2Types, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeOperators, + TypeSynonymInstances, UndecidableInstances, ViewPatterns \ No newline at end of file diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 4010388c..cd772e9d 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -1,8 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Angle @@ -23,6 +23,7 @@ module Diagrams.Angle , (@@) , angleBetween , HasTheta(..) + , HasPhi(..) ) where import Control.Lens (Iso', Lens', iso, review, (^.)) @@ -129,3 +130,9 @@ angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad -- | The class of types with at least one angle coordinate, called _theta. class HasTheta t where _theta :: Lens' t (Angle (Scalar (V t))) + +-- | The class of types with at least two angle coordinates, the +-- second called _phi. +class HasPhi t where + _phi :: Lens' t (Angle (Scalar (V t))) + diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index 11065a61..25b167ae 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -21,8 +21,10 @@ module Diagrams.Coordinates where import Control.Lens (Lens') +import Data.VectorSpace import Diagrams.Core.Points +import Diagrams.Core.V -- | A pair of values, with a convenient infix (left-associative) -- data constructor. @@ -112,17 +114,17 @@ instance Coordinates v => Coordinates (Point v) where -- | The class of types with at least one coordinate, called _x. class HasX t where - _x :: Lens' t Double + _x :: Lens' t (Scalar (V t)) -- | The class of types with at least two coordinates, the second called _y. class HasY t where - _y :: Lens' t Double + _y :: Lens' t (Scalar (V t)) -- | The class of types with at least three coordinates, the third called _z. class HasZ t where - _z :: Lens' t Double + _z :: Lens' t (Scalar (V t)) -- | The class of types with a single length coordinate _r. _r is -- magnitude of a vector, or the distance from the origin of a point. class HasR t where - _r :: Lens' t Double + _r :: Lens' t (Scalar (V t)) diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index 1380799e..e05a7a64 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -40,6 +40,12 @@ type instance V (Direction v) = v instance (Transformable v, V (Direction v) ~ V v) => Transformable (Direction v) where transform t (Direction v) = Direction (transform t v) +instance (HasTheta v, V (Direction v) ~ V v) => HasTheta (Direction v) where + _theta = _Dir . _theta + +instance (HasPhi v, V (Direction v) ~ V v) => HasPhi (Direction v) where + _phi = _Dir . _phi + -- | _Dir is provided to allow efficient implementations of functions -- in particular vector-spaces, but should be used with care as it -- exposes too much information. diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index f67e8eca..307180f2 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -172,11 +172,6 @@ instance HasTheta R3 where instance HasTheta P3 where _theta = cylindrical . _2 --- | The class of types with at least two angle coordinates, the --- second called _phi. -class HasPhi t where - _phi :: Lens' t (Angle (Scalar (V t))) - instance HasPhi R3 where _phi = spherical . _3 @@ -188,9 +183,3 @@ instance Cylindrical P3 where instance Spherical P3 where spherical = _relative origin . spherical - -instance HasTheta (Direction R3) where - _theta = _Dir . _theta - -instance HasPhi (Direction R3) where - _phi = _Dir . _phi diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 03e17695..e611a93d 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -234,6 +234,7 @@ arrowtailBlock theta = aTail aTail len _ = (t, mempty) where t = rect len (len * x) # alignR + a' :: R2 a' = rotate theta unitX a = a' ^-^ (reflectY a') x = magnitude a diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 6e157c65..63f5462f 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -24,7 +25,8 @@ module Diagrams.TwoD.Types R2(..), r2, unr2, mkR2, r2Iso , P2, p2, mkP2, unp2, p2Iso , T2 - + , R2Basis + , LikeR2 ) where import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, (^.), _1, _2) @@ -117,15 +119,15 @@ instance Read R2 where amp_prec = 7 -- | Construct a 2D vector from a pair of components. See also '&'. -r2 :: (Double, Double) -> R2 -r2 (x,y) = R2 x y +r2 :: (HasBasis v, Basis v ~ R2Basis) => (Scalar v, Scalar v) -> v +r2 (x,y) = recompose [(XB,x),(YB,y)] -- | Convert a 2D vector back into a pair of components. See also 'coords'. -unr2 :: R2 -> (Double, Double) -unr2 (R2 x y) = (x,y) +unr2 :: (HasBasis v, Basis v ~ R2Basis) => v -> (Scalar v, Scalar v) +unr2 v = (decompose' v XB, decompose' v YB) -- | Curried form of `r2`. -mkR2 :: Double -> Double -> R2 +mkR2 :: (HasBasis v, Basis v ~ R2Basis) => Scalar v -> Scalar v -> v mkR2 = curry r2 -- | Lens wrapped isomorphisms for R2. @@ -172,9 +174,6 @@ instance Coordinates R2 where x ^& y = R2 x y coords (R2 x y) = x :& y -r2Iso :: Iso' R2 (Double, Double) -r2Iso = iso unr2 r2 - instance HasX R2 where _x = r2Iso . _1 @@ -187,8 +186,8 @@ instance HasTheta R2 where instance HasR R2 where _r = polar._1 -instance HasTheta (Direction R2) where - _theta = _Dir . _theta +r2Iso :: (HasBasis v, Basis v ~ R2Basis) => Iso' v (Scalar v, Scalar v) +r2Iso = iso unr2 r2 -- | Points in R^2. This type is intentionally abstract. -- @@ -216,15 +215,15 @@ instance HasTheta (Direction R2) where type P2 = Point R2 -- | Construct a 2D point from a pair of coordinates. See also '^&'. -p2 :: (Double, Double) -> P2 +p2 :: (HasBasis v, Basis v ~ R2Basis) => (Scalar v, Scalar v) -> Point v p2 = P . r2 -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. -unp2 :: P2 -> (Double, Double) +unp2 :: (HasBasis v, Basis v ~ R2Basis) => Point v -> (Scalar v, Scalar v) unp2 (P v) = unr2 v -- | Curried form of `p2`. -mkP2 :: Double -> Double -> P2 +mkP2 :: (HasBasis v, Basis v ~ R2Basis) => Scalar v -> Scalar v -> Point v mkP2 = curry p2 -- | Transformations in R^2. @@ -233,7 +232,7 @@ type T2 = Transformation R2 instance Transformable R2 where transform = apply -p2Iso :: Iso' P2 (Double, Double) +p2Iso :: (HasBasis v, Basis v ~ R2Basis) => Iso' (Point v) (Scalar v, Scalar v) p2Iso = iso unp2 p2 instance HasX P2 where @@ -259,3 +258,6 @@ instance Polar R2 where instance Polar P2 where polar = _relative origin . polar + +type LikeR2 v = (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) + diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index b13ee34e..8967f290 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Vector @@ -26,45 +26,47 @@ module Diagrams.TwoD.Vector import Control.Lens ((&), (.~)) import Data.VectorSpace +import Data.Basis +import Diagrams.Core.V import Diagrams.Angle import Diagrams.Direction import Diagrams.TwoD.Types import Diagrams.Coordinates -- | The unit vector in the positive X direction. -unitX :: R2 -unitX = 1 ^& 0 +unitX :: (LikeR2 v) => v +unitX = mkR2 1 0 -- | The unit vector in the positive Y direction. -unitY :: R2 -unitY = 0 ^& 1 +unitY :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) => v +unitY = mkR2 0 1 -- | The unit vector in the negative X direction. -unit_X :: R2 -unit_X = (-1) ^& 0 +unit_X :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) => v +unit_X = mkR2 (-1) 0 -- | The unit vector in the negative Y direction. -unit_Y :: R2 -unit_Y = 0 ^& (-1) +unit_Y :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) => v +unit_Y = mkR2 0 (-1) -- | The origin of the direction AffineSpace. For all d, @d .-. xDir -- = d^._theta@. -xDir :: Direction R2 +xDir :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) => Direction v xDir = direction unitX -- | A unit vector at a specified angle counterclockwise from the -- positive X axis. -e :: Angle Double -> R2 +e :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis, HasTheta v) => Angle (Scalar (V v)) -> v e a = unitX & _theta .~ a -- | @perp v@ is perpendicular to and has the same magnitude as @v@. -- In particular @perp v == rotateBy (1/4) v@. -perp :: R2 -> R2 -perp (coords -> x :& y) = (-y) ^& x +perp :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) => v -> v +perp (unr2 -> (x,y)) = mkR2 (-y) x -- | @leftTurn v1 v2@ tests whether the direction of @v2@ is a left -- turn from @v1@ (that is, if the direction of @v2@ can be obtained -- from that of @v1@ by adding an angle 0 <= theta <= tau/2). -leftTurn :: R2 -> R2 -> Bool +leftTurn :: (HasBasis v, Num (Scalar v), Ord (Scalar v), Basis v ~ R2Basis, InnerSpace v) => v -> v -> Bool leftTurn v1 v2 = (v1 <.> perp v2) < 0 From bcb48c9e133e40b875f5327c57ccbc7b7159bbc8 Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Wed, 28 May 2014 13:06:45 -0600 Subject: [PATCH 03/58] Checkpoint (non-compiling) --- src/Diagrams/Tangent.hs | 21 ++- src/Diagrams/TwoD/Arc.hs | 20 +-- src/Diagrams/TwoD/Curvature.hs | 27 +-- src/Diagrams/TwoD/Ellipse.hs | 11 +- src/Diagrams/TwoD/Segment.hs | 4 +- src/Diagrams/TwoD/Size.hs | 45 ++--- src/Diagrams/TwoD/Transform.hs | 102 +++++++----- src/Diagrams/TwoD/Transform/ScaleInv.hs | 36 ++-- src/Diagrams/TwoD/Types.hs | 213 +++--------------------- src/Diagrams/TwoD/Vector.hs | 18 +- 10 files changed, 182 insertions(+), 315 deletions(-) diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs index 0b3ed1c1..1b25846f 100644 --- a/src/Diagrams/Tangent.hs +++ b/src/Diagrams/Tangent.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} ----------------------------------------------------------------------------- -- | @@ -22,6 +23,7 @@ module Diagrams.Tangent , normalAtStart , normalAtEnd , Tangent(..) + , MoreLikeR2 ) where @@ -33,8 +35,7 @@ import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment import Diagrams.Trail -import Diagrams.TwoD.Types (R2) -import Diagrams.TwoD.Vector (perp) +import Diagrams.TwoD.Vector (perp, LikeR2) ------------------------------------------------------------ -- Tangent @@ -156,6 +157,8 @@ instance ( InnerSpace v -- Normal ------------------------------------------------------------ +type MoreLikeR2 v = (LikeR2 v, InnerSpace v, Floating (Scalar v)) + -- | Compute the (unit) normal vector to a segment or trail at a -- particular parameter. -- @@ -169,22 +172,22 @@ instance ( InnerSpace v -- -- See the instances listed for the 'Tangent' newtype for more. normalAtParam - :: (Codomain (Tangent t) ~ R2, Parametric (Tangent t)) - => t -> Scalar (V t) -> R2 + :: (MoreLikeR2 (Codomain (Tangent t)), Parametric (Tangent t)) + => t -> Scalar (V t) -> Codomain (Tangent t) normalAtParam t p = normize (t `tangentAtParam` p) -- | Compute the normal vector at the start of a segment or trail. normalAtStart - :: (Codomain (Tangent t) ~ R2, EndValues (Tangent t)) - => t -> R2 + :: (MoreLikeR2 (Codomain (Tangent t)), EndValues (Tangent t)) + => t -> Codomain (Tangent t) normalAtStart = normize . tangentAtStart -- | Compute the normal vector at the end of a segment or trail. normalAtEnd - :: (Codomain (Tangent t) ~ R2, EndValues (Tangent t)) - => t -> R2 + :: (MoreLikeR2 (Codomain (Tangent t)), EndValues (Tangent t)) + => t -> Codomain (Tangent t) normalAtEnd = normize . tangentAtEnd -- | Construct a normal vector from a tangent. -normize :: R2 -> R2 +normize :: (MoreLikeR2 v) => v -> v normize = negateV . perp . normalized diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index f8362903..fafd9790 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns, ConstraintKinds, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arc @@ -47,7 +47,7 @@ import Diagrams.Coordinates -- the positive y direction and sweeps counterclockwise through an -- angle @s@. The approximation is only valid for angles in the -- first quadrant. -bezierFromSweepQ1 :: Angle Double -> Segment Closed R2 +bezierFromSweepQ1 :: (ExtraLikeR2 v) => Angle (Scalar v) -> Segment Closed v bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 where p0@(coords -> x :& y) = rotate (s ^/ 2) v c1 = ((4-x)/3) ^& ((1-x)*(3-x)/(3*y)) @@ -60,7 +60,7 @@ bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 -- negative y direction and sweep clockwise. When @s@ is less than -- 0.0001 the empty list results. If the sweep is greater than @fullTurn@ -- later segments will overlap earlier segments. -bezierFromSweep :: Angle Double -> [Segment Closed R2] +bezierFromSweep :: (ExtraLikeR2 v) => Angle (Scalar v) -> [Segment Closed v] bezierFromSweep s | s < zeroV = fmap reflectY . bezierFromSweep $ (negateV s) | s < 0.0001 @@ rad = [] @@ -92,7 +92,7 @@ the approximation error. -- is the 'Trail' of a radius one arc starting at @d@ and sweeping out -- the angle @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arcT :: Direction R2 -> Angle Double -> Trail R2 +arcT :: (ExtraLikeR2 v) => Direction v -> Angle (Scalar v) -> Trail v arcT start sweep = trailFromSegments bs where bs = map (rotate $ start ^. _theta) . bezierFromSweep $ sweep @@ -101,7 +101,7 @@ arcT start sweep = trailFromSegments bs -- path of a radius one arc starting at @d@ and sweeping out the angle -- @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arc :: (TrailLike t, V t ~ R2) => Direction R2 -> Angle Double -> t +arc :: (ExtraLikeR2 v, TrailLike t, V t ~ v) => Direction v -> Angle (Scalar v) -> t arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ p2 (1,0)) -- | Given a radus @r@, a start direction @d@ and an angle @s@, @@ -113,7 +113,7 @@ arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ -- -- > arc'Ex = mconcat [ arc' r 0 (1/4 \@\@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 -arc' :: (TrailLike p, V p ~ R2) => Double -> Direction R2 -> Angle Double -> p +arc' :: (ExtraLikeR2 v, TrailLike p, V p ~ v) => Scalar v -> Direction v -> Angle (Scalar v) -> p arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) $ p2 (abs r,0)) where ts = arcT start sweep @@ -129,7 +129,7 @@ arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -wedge :: (TrailLike p, V p ~ R2) => Double -> Direction R2 -> Angle Double -> p +wedge :: (ExtraLikeR2 v, TrailLike p, V p ~ v) => Scalar v -> Direction v -> Angle (Scalar v) -> p wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine $ fromOffsets [r *^ fromDirection d] <> arc d s # scale r @@ -146,7 +146,7 @@ wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine -- > arcBetweenEx = mconcat -- > [ arcBetween origin (p2 (2,1)) ht | ht <- [-0.2, -0.1 .. 0.2] ] -- > # centerXY # pad 1.1 -arcBetween :: (TrailLike t, V t ~ R2) => P2 -> P2 -> Double -> t +arcBetween :: (ExtraLikeR2 v, TrailLike t, V t ~ v) => Point v -> Point v -> Scalar v -> t arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) where h = abs ht @@ -180,8 +180,8 @@ arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -annularWedge :: (TrailLike p, V p ~ R2) => - Double -> Double -> Direction R2 -> Angle Double -> p +annularWedge :: (ExtraLikeR2 v, TrailLike p, V p ~ v) => + Scalar v -> Scalar v -> Direction v -> Angle (Scalar v) -> p annularWedge r1' r2' d1 s = trailLike . (`at` o) . glueTrail . wrapLine $ fromOffsets [(r1'-r2') *^ fromDirection d1] <> arc d1 s # scale r1' diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs index 35c64312..ed1b6836 100644 --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs, ConstraintKinds #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Curvature @@ -17,6 +17,7 @@ module Diagrams.TwoD.Curvature , radiusOfCurvature , squaredCurvature , squaredRadiusOfCurvature + , YetMoreLikeR2 ) where import Data.Monoid.Inf @@ -29,6 +30,8 @@ import Diagrams.Segment import Diagrams.Tangent import Diagrams.TwoD.Types +type YetMoreLikeR2 v = (MoreLikeR2 v, Scalar (Scalar v) ~ Scalar v, RealFloat (Scalar v), VectorSpace (Scalar v)) + -- | Curvature measures how curved the segment is at a point. One intuition -- for the concept is how much you would turn the wheel when driving a car -- along the curve. When the wheel is held straight there is zero curvature. @@ -103,28 +106,30 @@ import Diagrams.TwoD.Types -- > vpr = r2 (normalized vp ^* r) -- > -- -curvature :: Segment Closed R2 -- ^ Segment to measure on. - -> Double -- ^ Parameter to measure at. - -> PosInf Double -- ^ Result is a @PosInf@ value where @PosInfty@ represents - -- infinite curvature or zero radius of curvature. +curvature :: (YetMoreLikeR2 v) + => Segment Closed v -- ^ Segment to measure on. + -> Scalar v -- ^ Parameter to measure at. + -> PosInf (Scalar v) -- ^ Result is a @PosInf@ value where @PosInfty@ represents + -- infinite curvature or zero radius of curvature. curvature s = toPosInf . second sqrt . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 -- | With @squaredCurvature@ we can compute values in spaces that do not support -- 'sqrt' and it is just as useful for relative ordering of curvatures or looking -- for zeros. -squaredCurvature :: Segment Closed R2 -> Double -> PosInf Double +squaredCurvature :: (YetMoreLikeR2 v) => Segment Closed v -> Scalar v -> PosInf (Scalar v) squaredCurvature s = toPosInf . first (join (*)) . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 -- | Reciprocal of @curvature@. -radiusOfCurvature :: Segment Closed R2 -- ^ Segment to measure on. - -> Double -- ^ Parameter to measure at. - -> PosInf Double -- ^ Result is a @PosInf@ value where @PosInfty@ represents - -- infinite radius of curvature or zero curvature. +radiusOfCurvature :: (YetMoreLikeR2 v) + => Segment Closed v -- ^ Segment to measure on. + -> Scalar v -- ^ Parameter to measure at. + -> PosInf (Scalar v) -- ^ Result is a @PosInf@ value where @PosInfty@ represents + -- infinite radius of curvature or zero curvature. radiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . second sqrt . curvaturePair (fmap unr2 s) -- | Reciprocal of @squaredCurvature@ -squaredRadiusOfCurvature :: Segment Closed R2 -> Double -> PosInf Double +squaredRadiusOfCurvature :: (YetMoreLikeR2 v) => Segment Closed v -> Scalar v -> PosInf (Scalar v) squaredRadiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . first (join (*)) . curvaturePair (fmap unr2 s) diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index 988e4112..6a21baa4 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances, ConstraintKinds #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Ellipse @@ -33,20 +33,21 @@ import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (xDir) import Diagrams.Util +import Data.VectorSpace -- | A circle of radius 1, with center at the origin. -unitCircle :: (TrailLike t, V t ~ R2) => t +unitCircle :: (TrailLike t, ExtraLikeR2 (V t)) => t unitCircle = trailLike $ glueTrail (arcT xDir fullTurn) `at` (p2 (1,0)) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). -circle :: (TrailLike t, V t ~ R2, Transformable t) => Double -> t +circle :: (TrailLike t, ExtraLikeR2 (V t), Transformable t) => Scalar (V t) -> t circle d = unitCircle # scale d -- | @ellipse e@ constructs an ellipse with eccentricity @e@ by -- scaling the unit circle in the X direction. The eccentricity must -- be within the interval [0,1). -ellipse :: (TrailLike t, V t ~ R2, Transformable t) => Double -> t +ellipse :: (TrailLike t, ExtraLikeR2 (V t), Transformable t) => Scalar (V t) -> t ellipse e | e >= 0 && e < 1 = scaleX (sqrt (1 - e*e)) unitCircle | otherwise = error "Eccentricity of ellipse must be >= 0 and < 1." @@ -54,5 +55,5 @@ ellipse e -- | @ellipseXY x y@ creates an axis-aligned ellipse, centered at the -- origin, with radius @x@ along the x-axis and radius @y@ along the -- y-axis. -ellipseXY :: (TrailLike t, V t ~ R2, Transformable t) => Double -> Double -> t +ellipseXY :: (TrailLike t, ExtraLikeR2 (V t), Transformable t) => Scalar (V t) -> Scalar (V t) -> t ellipseXY x y = unitCircle # scaleX x # scaleY y diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index 1f3327dd..6737654b 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -43,10 +43,10 @@ import Diagrams.Util traces is sorted in increasing order. -} -instance Traced (Segment Closed R2) where +instance Traced (Segment Closed v) where getTrace = getTrace . mkFixedSeg . (`at` origin) -instance Traced (FixedSegment R2) where +instance Traced (FixedSegment v) where {- Given lines defined by p0 + t0 * v0 and p1 + t1 * v1, their point of intersection in 2D is given by diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index 942c1575..c71d9a1c 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies, ConstraintKinds #-} {-# OPTIONS_GHC -funbox-strict-fields #-} ----------------------------------------------------------------------------- @@ -37,43 +37,47 @@ import Diagrams.TwoD.Vector import Control.Applicative (liftA2, (<$>)) import Control.Arrow ((&&&), (***)) import Data.Hashable (Hashable) +import Data.VectorSpace import GHC.Generics (Generic) +type Numeric d = (Ord d, Num d, RealFloat d) +type KindaLikeR2 v = (LikeR2 v, Numeric (Scalar v)) + ------------------------------------------------------------ -- Computing diagram sizes ------------------------------------------------------------ -- | Compute the width of an enveloped object. -width :: (Enveloped a, V a ~ R2) => a -> Double +width :: (Enveloped a, KindaLikeR2 (V a)) => a -> Scalar (V a) width = maybe 0 (negate . uncurry (-)) . extentX -- | Compute the height of an enveloped object. -height :: (Enveloped a, V a ~ R2) => a -> Double +height :: (Enveloped a, KindaLikeR2 (V a)) => a -> Scalar (V a) height = maybe 0 (negate . uncurry (-)) . extentY -- | Compute the width and height of an enveloped object. -size2D :: (Enveloped a, V a ~ R2) => a -> (Double, Double) +size2D :: (Enveloped a, KindaLikeR2 (V a)) => a -> (Scalar (V a), Scalar (V a)) size2D = width &&& height -- | Compute the size of an enveloped object as a 'SizeSpec2D' value. -sizeSpec2D :: (Enveloped a, V a ~ R2) => a -> SizeSpec2D +sizeSpec2D :: (Enveloped a, KindaLikeR2 (V a)) => a -> SizeSpec2D (Scalar (V a)) sizeSpec2D = uncurry Dims . size2D -- | Compute the absolute x-coordinate range of an enveloped object in -- R2, in the form (lo,hi). Return @Nothing@ for objects with an -- empty envelope. -extentX :: (Enveloped a, V a ~ R2) => a -> Maybe (Double, Double) +extentX :: (Enveloped a, KindaLikeR2 (V a)) => a -> Maybe (Scalar (V a), Scalar (V a)) extentX d = (\f -> (-f unit_X, f unitX)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the absolute y-coordinate range of an enveloped object in -- R2, in the form (lo,hi). -extentY :: (Enveloped a, V a ~ R2) => a -> Maybe (Double, Double) +extentY :: (Enveloped a, KindaLikeR2 (V a)) => a -> Maybe (Scalar (V a), Scalar (V a)) extentY d = (\f -> (-f unit_Y, f unitY)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the point at the center (in the x- and y-directions) of a -- enveloped object. Return the origin for objects with an empty -- envelope. -center2D :: (Enveloped a, V a ~ R2) => a -> P2 +center2D :: (Enveloped a, KindaLikeR2 (V a)) => a -> Point (V a) center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) where mm = uncurry (liftA2 (,)) mid = (/2) . uncurry (+) @@ -83,26 +87,26 @@ center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) ------------------------------------------------------------ -- | A specification of a (requested) rectangular size. -data SizeSpec2D = Width !Double -- ^ Specify an explicit +data SizeSpec2D d = Width !d -- ^ Specify an explicit -- width. The height should be -- determined automatically (so -- as to preserve aspect ratio). - | Height !Double -- ^ Specify an explicit + | Height !d -- ^ Specify an explicit -- height. The width should be -- determined automatically (so -- as to preserve aspect ratio). - | Dims !Double !Double -- ^ An explicit specification + | Dims !d !d -- ^ An explicit specification -- of a width and height. | Absolute -- ^ Absolute size: use whatever -- size an object already has; -- do not rescale. deriving (Eq, Ord, Show, Generic) -instance Hashable SizeSpec2D +instance Hashable d => Hashable (SizeSpec2D d) -- | Create a size specification from a possibly-specified width and -- height. -mkSizeSpec :: Maybe Double -> Maybe Double -> SizeSpec2D +mkSizeSpec :: Maybe d -> Maybe d -> SizeSpec2D d mkSizeSpec Nothing Nothing = Absolute mkSizeSpec (Just w) Nothing = Width w mkSizeSpec Nothing (Just h) = Height h @@ -111,7 +115,7 @@ mkSizeSpec (Just w) (Just h) = Dims w h -- | @requiredScaleT spec sz@ returns a transformation (a uniform scale) -- which can be applied to something of size @sz@ to make it fit the -- requested size @spec@, without changing the aspect ratio. -requiredScaleT :: SizeSpec2D -> (Double, Double) -> Transformation R2 +requiredScaleT :: (KindaLikeR2 v, Scalar v ~ d) => SizeSpec2D d -> (d, d) -> Transformation v requiredScaleT spec size = scaling (requiredScale spec size) -- | @requiredScale spec sz@ returns a scaling factor necessary to @@ -120,7 +124,7 @@ requiredScaleT spec size = scaling (requiredScale spec size) -- specification of both dimensions may not be honored if the aspect -- ratios do not match; in that case the scaling will be as large as -- possible so that the object still fits within the requested size. -requiredScale :: SizeSpec2D -> (Double, Double) -> Double +requiredScale :: (Numeric d) => SizeSpec2D d -> (d, d) -> d requiredScale Absolute _ = 1 requiredScale (Width wSpec) (w,_) | wSpec == 0 || w == 0 = 1 @@ -137,20 +141,21 @@ requiredScale (Dims wSpec hSpec) (w,h) = s -- | Uniformly scale any enveloped object so that it fits within the -- given size. -sized :: (Transformable a, Enveloped a, V a ~ R2) - => SizeSpec2D -> a -> a +sized :: (Transformable a, Enveloped a, KindaLikeR2 (V a)) + => SizeSpec2D (Scalar (V a)) -> a -> a sized spec a = transform (requiredScaleT spec (size2D a)) a -- | Uniformly scale an enveloped object so that it \"has the same -- size as\" (fits within the width and height of) some other -- object. -sizedAs :: ( Transformable a, Enveloped a, V a ~ R2 - , Enveloped b, V b ~ R2) +sizedAs :: ( Transformable a, Enveloped a, Enveloped b + , KindaLikeR2 (V a), V a ~ V b + ) => b -> a -> a sizedAs other = sized (sizeSpec2D other) -- | Make width and height of `SizeSpec2D` into a tuple. -sizePair :: SizeSpec2D -> (Double, Double) +sizePair :: (Num d) => SizeSpec2D d -> (d, d) sizePair (Width w') = (w',w') sizePair (Height h') = (h',h') sizePair (Dims w' h') = (w',h') diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index a3ce01f8..fc02760c 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns, ConstraintKinds, TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform @@ -47,6 +47,7 @@ module Diagrams.TwoD.Transform -- * Utilities , onBasis + , ReallyLikeR2, ExtraLikeR2 ) where import Diagrams.Core @@ -61,18 +62,25 @@ import Diagrams.Coordinates import Data.AdditiveGroup import Data.AffineSpace import Data.Semigroup +import Data.VectorSpace import Control.Lens (review, (^.)) +type ReallyLikeR2 v = (R2Ish v, RealFloat (Scalar v), VectorSpace (Scalar v), HasTheta v, V v ~ v, Scalar (Scalar v) ~ Scalar v, Decomposition v ~ (FinalCoord v :& FinalCoord v), PrevDim v ~ FinalCoord v, Coordinates v, FinalCoord v ~ Scalar v) +type ExtraLikeR2 v = (ReallyLikeR2 v, Transformable v, InnerSpace v) + +type T = Transformation +type P = Point + -- Rotation ------------------------------------------------ -- | Create a transformation which performs a rotation about the local -- origin by the given angle. See also 'rotate'. -rotation :: Angle Double -> T2 +rotation :: (ReallyLikeR2 v) => Angle (Scalar v) -> T v rotation ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) theta = ang^.rad - rot th (coords -> x :& y) = (cos th * x - sin th * y) ^& (sin th * x + cos th * y) + rot th (unr2 -> (x,y)) = mkR2 (cos th * x - sin th * y) (sin th * x + cos th * y) -- | Rotate about the local origin by the given angle. Positive angles -- correspond to counterclockwise rotation, negative to @@ -87,164 +95,170 @@ rotation ang = fromLinear r (linv r) -- will yield an error since GHC cannot figure out which sort of -- angle you want to use. In this common situation you can use -- 'rotateBy', which interprets its argument as a number of turns. -rotate :: (Transformable t, V t ~ R2) => Angle Double -> t -> t +rotate :: (ReallyLikeR2 (V t), Transformable t) => Angle (Scalar (V t)) -> t -> t rotate = transform . rotation -- | A synonym for 'rotate', interpreting its argument in units of -- turns; it can be more convenient to write @rotateBy (1\/4)@ than -- @'rotate' (1\/4 \@\@ 'turn')@. -rotateBy :: (Transformable t, V t ~ R2) => Double -> t -> t +rotateBy :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t rotateBy = transform . rotation . review turn -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). -rotationAbout :: P2 -> Angle Double -> T2 +rotationAbout :: (ReallyLikeR2 v) => P v -> Angle (Scalar v) -> T v rotationAbout p angle = conjugate (translation (origin .-. p)) (rotation angle) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. -rotateAbout :: (Transformable t, V t ~ R2) => P2 -> Angle Double -> t -> t +rotateAbout :: (ReallyLikeR2 (V t), Transformable t) => P (V t) -> Angle (Scalar (V t)) -> t -> t rotateAbout p angle = rotate angle `under` translation (origin .-. p) -- Scaling ------------------------------------------------- -- | Construct a transformation which scales by the given factor in -- the x (horizontal) direction. -scalingX :: Double -> T2 +scalingX :: (ReallyLikeR2 v) => Scalar v -> T v scalingX c = fromLinear s s - where s = (\(R2 x y) -> R2 (x*c) y) <-> (\(R2 x y) -> R2 (x/c) y) + where s = (\(unr2 -> (x,y)) -> mkR2 (x*c) y) <-> (\(unr2 -> (x,y)) -> mkR2 (x/c) y) -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. -scaleX :: (Transformable t, V t ~ R2) => Double -> t -> t +scaleX :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t scaleX = transform . scalingX -- | Construct a transformation which scales by the given factor in -- the y (vertical) direction. -scalingY :: Double -> T2 +scalingY :: (ReallyLikeR2 v) => Scalar v -> T v scalingY c = fromLinear s s - where s = (\(R2 x y) -> R2 x (y*c)) <-> (\(R2 x y) -> R2 x (y/c)) + where s = (\(unr2 -> (x,y)) -> mkR2 x (y*c)) <-> (\(unr2 -> (x,y)) -> mkR2 x (y/c)) -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. -scaleY :: (Transformable t, V t ~ R2) => Double -> t -> t +scaleY :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t scaleY = transform . scalingY -- | @scaleToX w@ scales a diagram in the x (horizontal) direction by -- whatever factor required to make its width @w@. @scaleToX@ -- should not be applied to diagrams with a width of 0, such as -- 'vrule'. -scaleToX :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t +scaleToX :: (ReallyLikeR2 (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t scaleToX w d = scaleX (w / width d) d -- | @scaleToY h@ scales a diagram in the y (vertical) direction by -- whatever factor required to make its height @h@. @scaleToY@ -- should not be applied to diagrams with a height of 0, such as -- 'hrule'. -scaleToY :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t +scaleToY :: (ReallyLikeR2 (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t scaleToY h d = scaleY (h / height d) d -- | @scaleUToX w@ scales a diagram /uniformly/ by whatever factor -- required to make its width @w@. @scaleUToX@ should not be -- applied to diagrams with a width of 0, such as 'vrule'. -scaleUToX :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t +scaleUToX :: (ReallyLikeR2 (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t scaleUToX w d = scale (w / width d) d -- | @scaleUToY h@ scales a diagram /uniformly/ by whatever factor -- required to make its height @h@. @scaleUToY@ should not be applied -- to diagrams with a height of 0, such as 'hrule'. -scaleUToY :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t +scaleUToY :: (ReallyLikeR2 (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t scaleUToY h d = scale (h / height d) d -- Translation --------------------------------------------- -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. -translationX :: Double -> T2 -translationX x = translation (x ^& 0) +translationX :: (ReallyLikeR2 v) => Scalar v -> T v +translationX x = translation (mkR2 x 0) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. -translateX :: (Transformable t, V t ~ R2) => Double -> t -> t +translateX :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t translateX = transform . translationX -- | Construct a transformation which translates by the given distance -- in the y (vertical) direction. -translationY :: Double -> T2 -translationY y = translation (0 ^& y) +translationY :: (ReallyLikeR2 v) => Scalar v -> T v +translationY y = translation (mkR2 0 y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. -translateY :: (Transformable t, V t ~ R2) => Double -> t -> t +translateY :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t translateY = transform . translationY -- Reflection ---------------------------------------------- -- | Construct a transformation which flips a diagram from left to -- right, i.e. sends the point (x,y) to (-x,y). -reflectionX :: T2 +reflectionX :: (ReallyLikeR2 v) => T v reflectionX = scalingX (-1) -- | Flip a diagram from left to right, i.e. send the point (x,y) to -- (-x,y). -reflectX :: (Transformable t, V t ~ R2) => t -> t +reflectX :: (ReallyLikeR2 (V t), Transformable t) => t -> t reflectX = transform reflectionX -- | Construct a transformation which flips a diagram from top to -- bottom, i.e. sends the point (x,y) to (x,-y). -reflectionY :: T2 +reflectionY :: (ReallyLikeR2 v) => T v reflectionY = scalingY (-1) -- | Flip a diagram from top to bottom, i.e. send the point (x,y) to -- (x,-y). -reflectY :: (Transformable t, V t ~ R2) => t -> t +reflectY :: (ReallyLikeR2 (V t), Transformable t) => t -> t reflectY = transform reflectionY -- | @reflectionAbout p v@ is a reflection in the line determined by -- the point @p@ and vector @v@. -reflectionAbout :: P2 -> R2 -> T2 +reflectionAbout :: (ReallyLikeR2 v) => P v -> v -> T v reflectionAbout p v = conjugate (rotation (negateV $ v^._theta) <> translation (origin .-. p)) reflectionY -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. -reflectAbout :: (Transformable t, V t ~ R2) => P2 -> R2 -> t -> t +reflectAbout :: (ReallyLikeR2 (V t), Transformable t) => P (V t) -> (V t) -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Shears -------------------------------------------------- +-- auxiliary functions for shearingX/shearingY +sh :: (ReallyLikeR2 v, s ~ Scalar v) => (s -> s -> s -> s) -> (s -> s -> s -> s) -> s -> v -> v +sh f g k (unr2 -> (x,y)) = mkR2 (f k x y) (g k x y) + +sh' :: (ReallyLikeR2 v, s ~ Scalar v) => (s -> s -> s -> s) -> (s -> s -> s -> s) -> s -> v -> v +sh' f g k = swap . sh f g k . swap + +swap :: (ReallyLikeR2 v) => v -> v +swap (unr2 -> (x,y)) = mkR2 y x + -- | @shearingX d@ is the linear transformation which is the identity on -- y coordinates and sends @(0,1)@ to @(d,1)@. -shearingX :: Double -> T2 -shearingX d = fromLinear (sh d <-> sh (-d)) - (sh' d <-> sh' (-d)) - where sh k (R2 x y) = R2 (x+k*y) y - sh' k = swap . sh k . swap - swap (R2 x y) = R2 y x +shearingX :: (ReallyLikeR2 v) => Scalar v -> T v +shearingX d = fromLinear (sh f g d <-> sh f g (-d)) + (sh' f g d <-> sh' f g (-d)) + where f k x y = (x+k*y); g k x y = y -- | @shearX d@ performs a shear in the x-direction which sends -- @(0,1)@ to @(d,1)@. -shearX :: (Transformable t, V t ~ R2) => Double -> t -> t +shearX :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t shearX = transform . shearingX -- | @shearingY d@ is the linear transformation which is the identity on -- x coordinates and sends @(1,0)@ to @(1,d)@. -shearingY :: Double -> T2 -shearingY d = fromLinear (sh d <-> sh (-d)) - (sh' d <-> sh' (-d)) - where sh k (R2 x y) = R2 x (y+k*x) - sh' k = swap . sh k . swap - swap (R2 x y) = R2 y x +shearingY :: (ReallyLikeR2 v) => Scalar v -> T v +shearingY d = fromLinear (sh f g d <-> sh f g (-d)) + (sh' f g d <-> sh' f g (-d)) + where f k x y = x; g k x y = (y+k*x) -- | @shearY d@ performs a shear in the y-direction which sends -- @(1,0)@ to @(1,d)@. -shearY :: (Transformable t, V t ~ R2) => Double -> t -> t +shearY :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t shearY = transform . shearingY -- | Get the matrix equivalent of the linear transform, -- (as a pair of columns) and the translation vector. This -- is mostly useful for implementing backends. -onBasis :: Transformation R2 -> ((R2, R2), R2) +onBasis :: (ReallyLikeR2 v) => T v -> ((v, v), v) onBasis t = ((x, y), v) where (x:y:[], v) = T.onBasis t diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 41e11396..cb4932fb 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies ,StandaloneDeriving , ConstraintKinds , AllowAmbiguousTypes, ScopedTypeVariables, InstanceSigs #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform.ScaleInv @@ -17,11 +17,13 @@ module Diagrams.TwoD.Transform.ScaleInv ( ScaleInv(..) , scaleInvObj, scaleInvDir, scaleInvLoc - , scaleInv, scaleInvPrim ) + , scaleInv, scaleInvPrim, ExtraLikeR2 ) where import Control.Lens (makeLenses, view) +import Data.AdditiveGroup import Data.AffineSpace ((.-.)) +import Data.VectorSpace import Data.Semigroup import Data.Typeable @@ -64,30 +66,36 @@ import Diagrams.TwoD.Types data ScaleInv t = ScaleInv { _scaleInvObj :: t - , _scaleInvDir :: R2 - , _scaleInvLoc :: P2 + , _scaleInvDir :: V t + , _scaleInvLoc :: Point (V t) } - deriving (Show, Typeable) + deriving (Typeable) + +deriving instance (Show t, Show (V t)) => Show (ScaleInv t) makeLenses ''ScaleInv -- | Create a scale-invariant object pointing in the given direction, -- located at the origin. -scaleInv :: t -> R2 -> ScaleInv t +scaleInv :: (AdditiveGroup (V t)) => t -> V t -> ScaleInv t scaleInv t d = ScaleInv t d origin -type instance V (ScaleInv t) = R2 +type instance V (ScaleInv t) = V t -instance (V t ~ R2, HasOrigin t) => HasOrigin (ScaleInv t) where +instance (HasOrigin t) => HasOrigin (ScaleInv t) where moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) -instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where +instance (ExtraLikeR2 (V t), Transformable t) => Transformable (ScaleInv t) where + transform :: Transformation (V (ScaleInv t)) -> ScaleInv t -> ScaleInv t transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where + angle :: Angle (Scalar (V (ScaleInv t))) angle = angleBetween (transform tr v) v - rot :: (Transformable t, V t ~ R2) => t -> t + rot :: (V k ~ V t, Transformable k) => k -> k rot = rotateAbout l angle + l' :: Point (V (ScaleInv t)) l' = transform tr l + trans :: (V k ~ V t, Transformable k) => k -> k trans = translate (l' .-. l) {- Proof that the above satisfies the monoid action laws. @@ -149,7 +157,7 @@ instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where -} -instance (Renderable t b, V t ~ R2) => Renderable (ScaleInv t) b where +instance (ExtraLikeR2 (V t), Renderable t b) => Renderable (ScaleInv t) b where render b = render b . view scaleInvObj -- | Create a diagram from a single scale-invariant primitive. The @@ -167,6 +175,6 @@ instance (Renderable t b, V t ~ R2) => Renderable (ScaleInv t) b where -- scale-invariant things will be used only as \"decorations\" (/e.g./ -- arrowheads) which should not affect the envelope, trace, and -- query. -scaleInvPrim :: (Transformable t, Typeable t, Renderable t b, V t ~ R2, Monoid m) - => t -> R2 -> QDiagram b R2 m +scaleInvPrim :: (Transformable t, Typeable t, ExtraLikeR2 (V t), Renderable t b, Monoid m) + => t -> V t -> QDiagram b (V t) m scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 63f5462f..2ce8cdd2 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -22,11 +22,10 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space - R2(..), r2, unr2, mkR2, r2Iso - , P2, p2, mkP2, unp2, p2Iso - , T2 + r2, unr2, mkR2, r2Iso + , p2, mkP2, unp2, p2Iso , R2Basis - , LikeR2 + , R2Ish ) where import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, (^.), _1, _2) @@ -43,107 +42,8 @@ import Data.MemoTrie (HasTrie (..)) import Data.VectorSpace import Data.Data ------------------------------------------------------------- --- 2D Euclidean space - --- | The two-dimensional Euclidean vector space R^2. This type is --- intentionally abstract. --- --- * To construct a vector, use 'r2', or '^&' (from "Diagrams.Coordinates"): --- --- @ --- r2 (3,4) :: R2 --- 3 ^& 4 :: R2 --- @ --- --- Note that "Diagrams.Coordinates" is not re-exported by --- "Diagrams.Prelude" and must be explicitly imported. --- --- * To construct the vector from the origin to a point @p@, use --- @p 'Data.AffineSpace..-.' 'origin'@. --- --- * To convert a vector @v@ into the point obtained by following --- @v@ from the origin, use @'origin' 'Data.AffineSpace..+^' v@. --- --- * To convert a vector back into a pair of components, use 'unv2' --- or 'coords' (from "Diagrams.Coordinates"). These are typically --- used in conjunction with the @ViewPatterns@ extension: --- --- @ --- foo (unr2 -> (x,y)) = ... --- foo (coords -> x :& y) = ... --- @ - -data R2 = R2 {-# UNPACK #-} !Double - {-# UNPACK #-} !Double - deriving (Eq, Ord, Typeable, Data) - -instance AdditiveGroup R2 where - zeroV = R2 0 0 - R2 x1 y1 ^+^ R2 x2 y2 = R2 (x1 + x2) (y1 + y2) - negateV (R2 x y) = R2 (-x) (-y) - -instance Num R2 where - (+) = (^+^) - R2 x1 y1 * R2 x2 y2 = R2 (x1 * x2) (y1 * y2) -- this is sort of bogus - (-) = (^-^) - negate = negateV - abs (R2 x y) = R2 (abs x) (abs y) - signum (R2 x y) = R2 (signum x) (signum y) - fromInteger i = R2 i' i' - where i' = fromInteger i - -instance Fractional R2 where - R2 x1 y1 / R2 x2 y2 = R2 (x1/x2) (y1/y2) - recip (R2 x y) = R2 (recip x) (recip y) - fromRational r = R2 r' r' - where r' = fromRational r - -instance Show R2 where - showsPrec p (R2 x y) = showParen (p >= 7) $ - showCoord x . showString " ^& " . showCoord y - where - showCoord c | c < 0 = showParen True (shows c) - | otherwise = shows c - -instance Read R2 where - readsPrec d r = readParen (d > app_prec) - (\rr -> [ (R2 x y, r''') - | (x,r') <- readsPrec (amp_prec + 1) rr - , ("^&",r'') <- lex r' - , (y,r''') <- readsPrec (amp_prec + 1) r'' - ]) - r - where - app_prec = 10 - amp_prec = 7 - --- | Construct a 2D vector from a pair of components. See also '&'. -r2 :: (HasBasis v, Basis v ~ R2Basis) => (Scalar v, Scalar v) -> v -r2 (x,y) = recompose [(XB,x),(YB,y)] - --- | Convert a 2D vector back into a pair of components. See also 'coords'. -unr2 :: (HasBasis v, Basis v ~ R2Basis) => v -> (Scalar v, Scalar v) -unr2 v = (decompose' v XB, decompose' v YB) - --- | Curried form of `r2`. -mkR2 :: (HasBasis v, Basis v ~ R2Basis) => Scalar v -> Scalar v -> v -mkR2 = curry r2 - --- | Lens wrapped isomorphisms for R2. -instance Wrapped R2 where - type Unwrapped R2 = (Double, Double) - _Wrapped' = iso unr2 r2 - {-# INLINE _Wrapped' #-} - -instance Rewrapped R2 R2 - -type instance V R2 = R2 - -instance VectorSpace R2 where - type Scalar R2 = Double - s *^ R2 x y = R2 (s*x) (s*y) +-- | Basis for 2D Euclidean space data R2Basis = XB | YB deriving (Eq, Ord, Enum) instance HasTrie R2Basis where @@ -153,111 +53,38 @@ instance HasTrie R2Basis where untrie (R2Trie _x y) YB = y enumerate (R2Trie x y) = [(XB,x),(YB,y)] -instance HasBasis R2 where - type Basis R2 = R2Basis - basisValue XB = R2 1 0 - basisValue YB = R2 0 1 - - decompose (R2 x y) = [(XB, x), (YB, y)] +type R2Ish v = (HasBasis v, Basis v ~ R2Basis) - decompose' (R2 x _) (XB) = x - decompose' (R2 _ y) (YB) = y - -instance InnerSpace R2 where - (R2 x1 y1) <.> (R2 x2 y2) = x1*x2 + y1*y2 - -instance Coordinates R2 where - type FinalCoord R2 = Double - type PrevDim R2 = Double - type Decomposition R2 = Double :& Double - - x ^& y = R2 x y - coords (R2 x y) = x :& y - -instance HasX R2 where - _x = r2Iso . _1 - -instance HasY R2 where - _y = r2Iso . _2 +-- | Construct a 2D vector from a pair of components. See also '&'. +r2 :: (R2Ish v) => (Scalar v, Scalar v) -> v +r2 (x,y) = recompose [(XB,x),(YB,y)] -instance HasTheta R2 where - _theta = polar._2 +-- | Convert a 2D vector back into a pair of components. See also 'coords'. +unr2 :: (R2Ish v) => v -> (Scalar v, Scalar v) +unr2 v = (decompose' v XB, decompose' v YB) -instance HasR R2 where - _r = polar._1 +-- | Curried form of `r2`. +mkR2 :: (R2Ish v) => Scalar v -> Scalar v -> v +mkR2 = curry r2 -r2Iso :: (HasBasis v, Basis v ~ R2Basis) => Iso' v (Scalar v, Scalar v) +r2Iso :: (R2Ish v) => Iso' v (Scalar v, Scalar v) r2Iso = iso unr2 r2 --- | Points in R^2. This type is intentionally abstract. --- --- * To construct a point, use 'p2', or '^&' (see --- "Diagrams.Coordinates"): --- --- @ --- p2 (3,4) :: P2 --- 3 ^& 4 :: P2 --- @ --- --- * To construct a point from a vector @v@, use @'origin' 'Data.AffineSpace..+^' v@. --- --- * To convert a point @p@ into the vector from the origin to @p@, --- use @p 'Data.AffineSpace..-.' 'origin'@. --- --- * To convert a point back into a pair of coordinates, use 'unp2', --- or 'coords' (from "Diagrams.Coordinates"). It's common to use --- these in conjunction with the @ViewPatterns@ extension: --- --- @ --- foo (unp2 -> (x,y)) = ... --- foo (coords -> x :& y) = ... --- @ -type P2 = Point R2 - -- | Construct a 2D point from a pair of coordinates. See also '^&'. -p2 :: (HasBasis v, Basis v ~ R2Basis) => (Scalar v, Scalar v) -> Point v +p2 :: (R2Ish v) => (Scalar v, Scalar v) -> Point v p2 = P . r2 -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. -unp2 :: (HasBasis v, Basis v ~ R2Basis) => Point v -> (Scalar v, Scalar v) +unp2 :: (R2Ish v) => Point v -> (Scalar v, Scalar v) unp2 (P v) = unr2 v -- | Curried form of `p2`. -mkP2 :: (HasBasis v, Basis v ~ R2Basis) => Scalar v -> Scalar v -> Point v +mkP2 :: (R2Ish v) => Scalar v -> Scalar v -> Point v mkP2 = curry p2 --- | Transformations in R^2. -type T2 = Transformation R2 - -instance Transformable R2 where - transform = apply - -p2Iso :: (HasBasis v, Basis v ~ R2Basis) => Iso' (Point v) (Scalar v, Scalar v) +p2Iso :: (R2Ish v) => Iso' (Point v) (Scalar v, Scalar v) p2Iso = iso unp2 p2 -instance HasX P2 where - _x = p2Iso . _1 - -instance HasY P2 where - _y = p2Iso . _2 - -instance HasR P2 where - _r = _relative origin . _r - -instance HasTheta P2 where - _theta = _relative origin . _theta - -- | Types which can be expressed in polar 2D coordinates, as a magnitude and an angle. class Polar t where polar :: Iso' t (Scalar (V t), Angle (Scalar (V t))) - -instance Polar R2 where - polar = - iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) - (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) - -instance Polar P2 where - polar = _relative origin . polar - -type LikeR2 v = (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) - diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 8967f290..2327adb4 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -21,6 +21,8 @@ module Diagrams.TwoD.Vector -- * 2D vector utilities , perp, leftTurn + -- * Synonym for R2 things + , LikeR2 ) where import Control.Lens ((&), (.~)) @@ -34,39 +36,41 @@ import Diagrams.Direction import Diagrams.TwoD.Types import Diagrams.Coordinates +type LikeR2 v = (R2Ish v, Num (Scalar v)) + -- | The unit vector in the positive X direction. unitX :: (LikeR2 v) => v unitX = mkR2 1 0 -- | The unit vector in the positive Y direction. -unitY :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) => v +unitY :: (LikeR2 v) => v unitY = mkR2 0 1 -- | The unit vector in the negative X direction. -unit_X :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) => v +unit_X :: (LikeR2 v) => v unit_X = mkR2 (-1) 0 -- | The unit vector in the negative Y direction. -unit_Y :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) => v +unit_Y :: (LikeR2 v) => v unit_Y = mkR2 0 (-1) -- | The origin of the direction AffineSpace. For all d, @d .-. xDir -- = d^._theta@. -xDir :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) => Direction v +xDir :: (LikeR2 v) => Direction v xDir = direction unitX -- | A unit vector at a specified angle counterclockwise from the -- positive X axis. -e :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis, HasTheta v) => Angle (Scalar (V v)) -> v +e :: (LikeR2 v, HasTheta v) => Angle (Scalar (V v)) -> v e a = unitX & _theta .~ a -- | @perp v@ is perpendicular to and has the same magnitude as @v@. -- In particular @perp v == rotateBy (1/4) v@. -perp :: (HasBasis v, Num (Scalar v), Basis v ~ R2Basis) => v -> v +perp :: (LikeR2 v) => v -> v perp (unr2 -> (x,y)) = mkR2 (-y) x -- | @leftTurn v1 v2@ tests whether the direction of @v2@ is a left -- turn from @v1@ (that is, if the direction of @v2@ can be obtained -- from that of @v1@ by adding an angle 0 <= theta <= tau/2). -leftTurn :: (HasBasis v, Num (Scalar v), Ord (Scalar v), Basis v ~ R2Basis, InnerSpace v) => v -> v -> Bool +leftTurn :: (LikeR2 v, Ord (Scalar v), InnerSpace v) => v -> v -> Bool leftTurn v1 v2 = (v1 <.> perp v2) < 0 From 2d7a1a0168b237cd26e91b66f1cbde7021c3ee0e Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Wed, 28 May 2014 13:17:37 -0600 Subject: [PATCH 04/58] Forgot a file --- src/Diagrams/TwoD/Double/Types.hs | 218 ++++++++++++++++++++++++++++++ 1 file changed, 218 insertions(+) create mode 100644 src/Diagrams/TwoD/Double/Types.hs diff --git a/src/Diagrams/TwoD/Double/Types.hs b/src/Diagrams/TwoD/Double/Types.hs new file mode 100644 index 00000000..7b6f4d71 --- /dev/null +++ b/src/Diagrams/TwoD/Double/Types.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Types +-- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Basic types for two-dimensional Euclidean space. +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Types.Double + ( -- * 2D Euclidean space + R2(..), r2, unr2, mkR2, r2Iso + , P2, p2, mkP2, unp2, p2Iso + , T2 + , R2Basis + , LikeR2 + ) where + +import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, (^.), _1, _2) + + +import Diagrams.Angle +import Diagrams.Direction +import Diagrams.Coordinates +import Diagrams.Core +import Diagrams.TwoD.Types + +import Data.AffineSpace.Point +import Data.Basis +import Data.MemoTrie (HasTrie (..)) +import Data.VectorSpace + +import Data.Data +------------------------------------------------------------ +-- 2D Euclidean space + +-- | The two-dimensional Euclidean vector space R^2. This type is +-- intentionally abstract, but uses Doubles as the scalar type. +-- +-- * To construct a vector, use 'r2', or '^&' (from "Diagrams.Coordinates"): +-- +-- @ +-- r2 (3,4) :: R2 +-- 3 ^& 4 :: R2 +-- @ +-- +-- Note that "Diagrams.Coordinates" is not re-exported by +-- "Diagrams.Prelude" and must be explicitly imported. +-- +-- * To construct the vector from the origin to a point @p@, use +-- @p 'Data.AffineSpace..-.' 'origin'@. +-- +-- * To convert a vector @v@ into the point obtained by following +-- @v@ from the origin, use @'origin' 'Data.AffineSpace..+^' v@. +-- +-- * To convert a vector back into a pair of components, use 'unv2' +-- or 'coords' (from "Diagrams.Coordinates"). These are typically +-- used in conjunction with the @ViewPatterns@ extension: +-- +-- @ +-- foo (unr2 -> (x,y)) = ... +-- foo (coords -> x :& y) = ... +-- @ + +data R2 = R2 {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + deriving (Eq, Ord, Typeable, Data) + +instance AdditiveGroup R2 where + zeroV = R2 0 0 + R2 x1 y1 ^+^ R2 x2 y2 = R2 (x1 + x2) (y1 + y2) + negateV (R2 x y) = R2 (-x) (-y) + +instance Num R2 where + (+) = (^+^) + R2 x1 y1 * R2 x2 y2 = R2 (x1 * x2) (y1 * y2) -- this is sort of bogus + (-) = (^-^) + negate = negateV + abs (R2 x y) = R2 (abs x) (abs y) + signum (R2 x y) = R2 (signum x) (signum y) + fromInteger i = R2 i' i' + where i' = fromInteger i + +instance Fractional R2 where + R2 x1 y1 / R2 x2 y2 = R2 (x1/x2) (y1/y2) + recip (R2 x y) = R2 (recip x) (recip y) + fromRational r = R2 r' r' + where r' = fromRational r + +instance Show R2 where + showsPrec p (R2 x y) = showParen (p >= 7) $ + showCoord x . showString " ^& " . showCoord y + where + showCoord c | c < 0 = showParen True (shows c) + | otherwise = shows c + +instance Read R2 where + readsPrec d r = readParen (d > app_prec) + (\rr -> [ (R2 x y, r''') + | (x,r') <- readsPrec (amp_prec + 1) rr + , ("^&",r'') <- lex r' + , (y,r''') <- readsPrec (amp_prec + 1) r'' + ]) + r + where + app_prec = 10 + amp_prec = 7 + +-- | Lens wrapped isomorphisms for R2. +instance Wrapped R2 where + type Unwrapped R2 = (Double, Double) + _Wrapped' = iso unr2 r2 + {-# INLINE _Wrapped' #-} + +instance Rewrapped R2 R2 + +type instance V R2 = R2 + +instance VectorSpace R2 where + type Scalar R2 = Double + s *^ R2 x y = R2 (s*x) (s*y) + +instance HasBasis R2 where + type Basis R2 = R2Basis + basisValue XB = R2 1 0 + basisValue YB = R2 0 1 + + decompose (R2 x y) = [(XB, x), (YB, y)] + + decompose' (R2 x _) (XB) = x + decompose' (R2 _ y) (YB) = y + +instance InnerSpace R2 where + (R2 x1 y1) <.> (R2 x2 y2) = x1*x2 + y1*y2 + +instance Coordinates R2 where + type FinalCoord R2 = Double + type PrevDim R2 = Double + type Decomposition R2 = Double :& Double + + x ^& y = R2 x y + coords (R2 x y) = x :& y + +instance HasX R2 where + _x = r2Iso . _1 + +instance HasY R2 where + _y = r2Iso . _2 + +instance HasTheta R2 where + _theta = polar._2 + +instance HasR R2 where + _r = polar._1 + +-- | Points in R^2. This type is intentionally abstract. +-- +-- * To construct a point, use 'p2', or '^&' (see +-- "Diagrams.Coordinates"): +-- +-- @ +-- p2 (3,4) :: P2 +-- 3 ^& 4 :: P2 +-- @ +-- +-- * To construct a point from a vector @v@, use @'origin' 'Data.AffineSpace..+^' v@. +-- +-- * To convert a point @p@ into the vector from the origin to @p@, +-- use @p 'Data.AffineSpace..-.' 'origin'@. +-- +-- * To convert a point back into a pair of coordinates, use 'unp2', +-- or 'coords' (from "Diagrams.Coordinates"). It's common to use +-- these in conjunction with the @ViewPatterns@ extension: +-- +-- @ +-- foo (unp2 -> (x,y)) = ... +-- foo (coords -> x :& y) = ... +-- @ +type P2 = Point R2 + +-- | Transformations in R^2. +type T2 = Transformation R2 + +instance Transformable R2 where + transform = apply + +instance HasX P2 where + _x = p2Iso . _1 + +instance HasY P2 where + _y = p2Iso . _2 + +instance HasR P2 where + _r = _relative origin . _r + +instance HasTheta P2 where + _theta = _relative origin . _theta + +instance Polar R2 where + polar = + iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) + (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) + +instance Polar P2 where + polar = _relative origin . polar From 06f05367666dd8cbdad3b7c34853f4f0297cc86c Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Sat, 31 May 2014 15:44:17 -0600 Subject: [PATCH 05/58] Mostly finished refactoring (still needs language/import cleanups before merge, plus review) --- diagrams-lib.cabal | 3 + src/Diagrams/Angle.hs | 10 +- src/Diagrams/Animation.hs | 9 +- src/Diagrams/Coordinates.hs | 42 +++- src/Diagrams/Points.hs | 7 +- src/Diagrams/Tangent.hs | 14 +- src/Diagrams/ThreeD/Align.hs | 65 +++--- src/Diagrams/ThreeD/Attributes.hs | 1 + src/Diagrams/ThreeD/Camera.hs | 57 ++--- src/Diagrams/ThreeD/Deform.hs | 19 +- src/Diagrams/ThreeD/Light.hs | 23 ++- src/Diagrams/ThreeD/Shapes.hs | 36 ++-- src/Diagrams/ThreeD/Transform.hs | 66 +++--- src/Diagrams/ThreeD/Types.hs | 143 +++---------- src/Diagrams/ThreeD/Types/Double.hs | 113 ++++++++++ src/Diagrams/ThreeD/Vector.hs | 14 +- src/Diagrams/TwoD.hs | 1 + src/Diagrams/TwoD/Adjust.hs | 22 +- src/Diagrams/TwoD/Align.hs | 42 ++-- src/Diagrams/TwoD/Arc.hs | 16 +- src/Diagrams/TwoD/Arrow.hs | 147 +++++++------ src/Diagrams/TwoD/Arrowheads.hs | 59 +++--- src/Diagrams/TwoD/Attributes.hs | 194 ++++++++++-------- src/Diagrams/TwoD/Combinators.hs | 51 ++--- src/Diagrams/TwoD/Curvature.hs | 11 +- src/Diagrams/TwoD/Deform.hs | 13 +- src/Diagrams/TwoD/Ellipse.hs | 8 +- src/Diagrams/TwoD/Image.hs | 33 +-- src/Diagrams/TwoD/Model.hs | 24 +-- src/Diagrams/TwoD/Offset.hs | 165 ++++++++------- src/Diagrams/TwoD/Path.hs | 63 +++--- src/Diagrams/TwoD/Polygons.hs | 53 ++--- src/Diagrams/TwoD/Segment.hs | 6 +- src/Diagrams/TwoD/Shapes.hs | 50 ++--- src/Diagrams/TwoD/Size.hs | 25 +-- src/Diagrams/TwoD/Text.hs | 58 +++--- src/Diagrams/TwoD/Transform.hs | 71 +++---- src/Diagrams/TwoD/Transform/ScaleInv.hs | 8 +- src/Diagrams/TwoD/Types.hs | 11 +- .../TwoD/{Double/Types.hs => Types/Double.hs} | 15 +- src/Diagrams/TwoD/Vector.hs | 21 +- 41 files changed, 940 insertions(+), 849 deletions(-) create mode 100644 src/Diagrams/ThreeD/Types/Double.hs rename src/Diagrams/TwoD/{Double/Types.hs => Types/Double.hs} (93%) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index c02d2a5a..7c29bbcf 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -55,6 +55,7 @@ Library Diagrams.Query, Diagrams.TwoD, Diagrams.TwoD.Types, + Diagrams.TwoD.Types.Double, Diagrams.TwoD.Align, Diagrams.TwoD.Arrow, Diagrams.TwoD.Arrowheads, @@ -85,6 +86,7 @@ Library Diagrams.ThreeD.Shapes, Diagrams.ThreeD.Transform, Diagrams.ThreeD.Types, + Diagrams.ThreeD.Types.Double, Diagrams.ThreeD.Vector, Diagrams.ThreeD, Diagrams.Animation, @@ -116,6 +118,7 @@ Library if impl(ghc < 7.6) Build-depends: ghc-prim Hs-source-dirs: src + ghc-options: -Wall -Werror default-language: Haskell2010 -- default-extensions: FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies other-extensions: BangPatterns, CPP, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, ExistentialQuantification, GADTs, diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index cd772e9d..31cb0497 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -26,13 +26,14 @@ module Diagrams.Angle , HasPhi(..) ) where -import Control.Lens (Iso', Lens', iso, review, (^.)) +import Control.Lens (Iso', Lens', iso, review) import Data.Monoid hiding ((<>)) import Data.Semigroup import Data.VectorSpace import Diagrams.Core.V +import Diagrams.Points -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. @@ -136,3 +137,10 @@ class HasTheta t where class HasPhi t where _phi :: Lens' t (Angle (Scalar (V t))) +-- Point instances +instance (HasTheta v, v ~ V v) => HasTheta (Point v) where + _theta = _pIso . _theta + +instance (HasPhi v, v ~ V v) => HasPhi (Point v) where + _phi = _pIso . _phi + diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs index a1cac8ce..647f91c5 100644 --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Animation @@ -109,18 +110,18 @@ animEnvelope' r a = withEnvelope (simulate r a) <$> a -- -- Uses 30 samples per time unit by default; to adjust this number -- see 'animRect''. -animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2 +animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ v, R2Ish v , Monoid' m) - => QAnimation b R2 m -> t + => QAnimation b v m -> t animRect = animRect' 30 -- | Like 'animRect', but with an adjustible sample rate. The first -- parameter is the number of samples per time unit to use. Lower -- rates will be faster but less accurate; higher rates are more -- accurate but slower. -animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2 +animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ v, R2Ish v , Monoid' m) - => Rational -> QAnimation b R2 m -> t + => Rational -> QAnimation b v m -> t animRect' r anim | null results = rect 1 1 | otherwise = boxFit (foldMap boundingBox results) (rect 1 1) diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index 25b167ae..8d1050bb 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -23,17 +23,10 @@ module Diagrams.Coordinates import Control.Lens (Lens') import Data.VectorSpace -import Diagrams.Core.Points +import Diagrams.Points +import Data.AffineSpace.Point import Diagrams.Core.V --- | A pair of values, with a convenient infix (left-associative) --- data constructor. -data a :& b = a :& b - deriving (Eq, Ord, Show) - -infixl 7 :& - - -- | Types which are instances of the @Coordinates@ class can be -- constructed using '^&' (for example, a three-dimensional vector -- could be constructed by @1 ^& 6 ^& 3@), and deconstructed using @@ -78,6 +71,22 @@ class Coordinates c where infixl 7 ^& +-- | A pair of values, with a convenient infix (left-associative) +-- data constructor. +data a :& b = a :& b + deriving (Eq, Ord, Show) + +infixl 7 :& + +-- Instance for :& (the buck stops here) +instance Coordinates (a :& b) where + type FinalCoord (a :& b) = b + type PrevDim (a :& b) = a + type Decomposition (a :& b) = a :& b + x ^& y = x :& y + coords (x :& y) = x :& y + + -- Some standard instances for plain old tuples instance Coordinates (a,b) where @@ -85,7 +94,7 @@ instance Coordinates (a,b) where type PrevDim (a,b) = a type Decomposition (a,b) = a :& b - x ^& y = (x,y) + x ^& y = (x,y) coords (x,y) = x :& y instance Coordinates (a,b,c) where @@ -128,3 +137,16 @@ class HasZ t where -- magnitude of a vector, or the distance from the origin of a point. class HasR t where _r :: Lens' t (Scalar (V t)) + +instance (HasX v, v ~ V v) => HasX (Point v) where + _x = _pIso . _x + +instance (HasY v, v ~ V v) => HasY (Point v) where + _y = _pIso . _y + +instance (HasZ v, v ~ V v) => HasZ (Point v) where + _z = _pIso . _z + +instance (HasR v, v ~ V v) => HasR (Point v) where + _r = _pIso . _r + diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs index 7bf3ff7b..5efcbafa 100644 --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -20,17 +20,22 @@ module Diagrams.Points -- * Point-related utilities , centroid , pointDiagram - + , _pIso ) where import Diagrams.Core (pointDiagram) import Diagrams.Core.Points import Control.Arrow ((&&&)) +import Control.Lens (Iso', iso) import Data.AffineSpace.Point import Data.VectorSpace +-- Point v <-> v +_pIso :: Iso' (Point v) v +_pIso = iso unPoint P + -- | The centroid of a set of /n/ points is their sum divided by /n/. centroid :: (VectorSpace v, Fractional (Scalar v)) => [Point v] -> Point v centroid = P . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unPoint diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs index 1b25846f..303c4c42 100644 --- a/src/Diagrams/Tangent.hs +++ b/src/Diagrams/Tangent.hs @@ -23,7 +23,6 @@ module Diagrams.Tangent , normalAtStart , normalAtEnd , Tangent(..) - , MoreLikeR2 ) where @@ -35,7 +34,8 @@ import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment import Diagrams.Trail -import Diagrams.TwoD.Vector (perp, LikeR2) +import Diagrams.TwoD.Vector (perp) +import Diagrams.TwoD.Types (R2Ish) ------------------------------------------------------------ -- Tangent @@ -157,8 +157,6 @@ instance ( InnerSpace v -- Normal ------------------------------------------------------------ -type MoreLikeR2 v = (LikeR2 v, InnerSpace v, Floating (Scalar v)) - -- | Compute the (unit) normal vector to a segment or trail at a -- particular parameter. -- @@ -172,22 +170,22 @@ type MoreLikeR2 v = (LikeR2 v, InnerSpace v, Floating (Scalar v)) -- -- See the instances listed for the 'Tangent' newtype for more. normalAtParam - :: (MoreLikeR2 (Codomain (Tangent t)), Parametric (Tangent t)) + :: (R2Ish (Codomain (Tangent t)), Parametric (Tangent t)) => t -> Scalar (V t) -> Codomain (Tangent t) normalAtParam t p = normize (t `tangentAtParam` p) -- | Compute the normal vector at the start of a segment or trail. normalAtStart - :: (MoreLikeR2 (Codomain (Tangent t)), EndValues (Tangent t)) + :: (R2Ish (Codomain (Tangent t)), EndValues (Tangent t)) => t -> Codomain (Tangent t) normalAtStart = normize . tangentAtStart -- | Compute the normal vector at the end of a segment or trail. normalAtEnd - :: (MoreLikeR2 (Codomain (Tangent t)), EndValues (Tangent t)) + :: (R2Ish (Codomain (Tangent t)), EndValues (Tangent t)) => t -> Codomain (Tangent t) normalAtEnd = normize . tangentAtEnd -- | Construct a normal vector from a tangent. -normize :: (MoreLikeR2 v) => v -> v +normize :: (R2Ish v) => v -> v normize = negateV . perp . normalized diff --git a/src/Diagrams/ThreeD/Align.hs b/src/Diagrams/ThreeD/Align.hs index 67b1ddf0..0e9c262c 100644 --- a/src/Diagrams/ThreeD/Align.hs +++ b/src/Diagrams/ThreeD/Align.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Align @@ -49,63 +50,63 @@ import Data.VectorSpace -- | Translate the diagram along unitX so that all points have -- positive x-values. -alignXMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignXMin :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a alignXMin = align (negateV unitX) snugXMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugXMin = snug (negateV unitX) -- | Translate the diagram along unitX so that all points have -- negative x-values. -alignXMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignXMax :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a alignXMax = align unitX snugXMax :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugXMax = snug unitX -- | Translate the diagram along unitY so that all points have -- negative y-values. -alignYMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignYMax :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a alignYMax = align unitY -- | Move the origin along unitY until it touches the edge of the -- diagram. snugYMax:: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugYMax = snug unitY -- | Translate the diagram along unitY so that all points have -- positive y-values. -alignYMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignYMin :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a alignYMin = align (negateV unitY) snugYMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugYMin = snug (negateV unitY) -- | Translate the diagram along unitZ so that all points have -- negative z-values. -alignZMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignZMax :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a alignZMax = align unitZ -- | Move the origin along unitZ until it touches the edge of the -- diagram. snugZMax:: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugZMax = snug unitZ -- | Translate the diagram along unitZ so that all points have -- positive z-values. -alignZMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignZMin :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a alignZMin = align (negateV unitZ) -- | Move the origin along unit_Z until it touches the edge of the -- diagram. snugZMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugZMin = snug (negateV unitZ) -- | @alignX@ and @snugX@ move the local origin along unitX as follows: @@ -120,90 +121,90 @@ snugZMin = snug (negateV unitZ) -- -- * @snugX@ works the same way. -alignX :: (Alignable a, HasOrigin a, V a ~ R3) => Double -> a -> a +alignX :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a alignX = alignBy unitX -- | See the documentation for 'alignX'. snugX :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => Double -> a -> a + HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a snugX = snugBy unitX -- | Like 'alignX', but moving the local origin vertically, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignY :: (Alignable a, HasOrigin a, V a ~ R3) => Double -> a -> a +alignY :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a alignY = alignBy unitY snugY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => Double -> a -> a + HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a snugY = snugBy unitY -- | Like 'alignX', but moving the local origin in the Z direction, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignZ :: (Alignable a, HasOrigin a, V a ~ R3) => Double -> a -> a +alignZ :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a alignZ = alignBy unitZ snugZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => Double -> a -> a + HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a snugZ = snugBy unitZ -- | Center the local origin along the X-axis. -centerX :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerX :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a centerX = alignBy unitX 0 snugCenterX :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugCenterX = snugBy unitX 0 -- | Center the local origin along the Y-axis. -centerY :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerY :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a centerY = alignBy unitY 0 snugCenterY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugCenterY = snugBy unitY 0 -- | Center the local origin along the Z-axis. -centerZ :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerZ :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a centerZ = alignBy unitZ 0 snugCenterZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugCenterZ = snugBy unitZ 0 -- | Center along both the X- and Y-axes. -centerXY :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerXY :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a centerXY = centerX . centerY snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugCenterXY = snugCenterX . snugCenterY -- | Center along both the X- and Z-axes. -centerXZ :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerXZ :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a centerXZ = centerX . centerZ snugCenterXZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugCenterXZ = snugCenterX . snugCenterZ -- | Center along both the Y- and Z-axes. -centerYZ :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerYZ :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a centerYZ = centerZ . centerY snugCenterYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugCenterYZ = snugCenterZ . snugCenterY -- | Center an object in three dimensions. centerXYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a centerXYZ = centerX . centerY . centerZ snugCenterXYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a + HasOrigin a, V a ~ v, R3Ish v) => a -> a snugCenterXYZ = snugCenterX . snugCenterY . snugCenterZ diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs index 52c013ef..469c9937 100644 --- a/src/Diagrams/ThreeD/Attributes.hs +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Attributes diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index 9c474f8e..58f54176 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, ConstraintKinds, UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -33,6 +33,7 @@ import Control.Lens (makeLenses) import Data.Cross import Data.Monoid import Data.Typeable +import Data.VectorSpace import Diagrams.Angle import Diagrams.Core @@ -43,69 +44,73 @@ import Diagrams.ThreeD.Vector -- Parameterize Camera on the lens type, so that Backends can express which -- lenses they handle. data Camera l = Camera - { camLoc :: P3 - , forward :: R3 - , up :: R3 + { camLoc :: Point (V l) + , forward :: V l + , up :: V l , lens :: l } deriving Typeable -class Typeable l => CameraLens l where +class (Typeable l, Typeable (V l)) => CameraLens l where -- | The natural aspect ratio of the projection. - aspect :: l -> Double + aspect :: l -> Scalar (V l) -- | A perspective projection -data PerspectiveLens = PerspectiveLens - { _horizontalFieldOfView :: Angle Double -- ^ Horizontal field of view. - , _verticalFieldOfView :: Angle Double -- ^ Vertical field of view. +data PerspectiveLens v = PerspectiveLens + { _horizontalFieldOfView :: Angle (Scalar v) -- ^ Horizontal field of view. + , _verticalFieldOfView :: Angle (Scalar v) -- ^ Vertical field of view. } deriving Typeable makeLenses ''PerspectiveLens -instance CameraLens PerspectiveLens where +type instance V (PerspectiveLens v) = v + +instance (R3Ish v) => CameraLens (PerspectiveLens v) where aspect (PerspectiveLens h v) = angleRatio h v -- | An orthographic projection -data OrthoLens = OrthoLens - { _orthoWidth :: Double -- ^ Width - , _orthoHeight :: Double -- ^ Height +data OrthoLens v = OrthoLens + { _orthoWidth :: Scalar v -- ^ Width + , _orthoHeight :: Scalar v -- ^ Height } deriving Typeable makeLenses ''OrthoLens -instance CameraLens OrthoLens where +type instance V (OrthoLens v) = v + +instance (R3Ish v) => CameraLens (OrthoLens v) where aspect (OrthoLens h v) = h / v -type instance V (Camera l) = R3 +type instance V (Camera l) = V l -instance Transformable (Camera l) where +instance (R3Ish (V l)) => Transformable (Camera l) where transform t (Camera p f u l) = Camera (transform t p) (transform t f) (transform t u) l -instance Renderable (Camera l) NullBackend where +instance (R3Ish (V l)) => Renderable (Camera l) NullBackend where render _ _ = mempty -- | A camera at the origin facing along the negative Z axis, with its -- up-axis coincident with the positive Y axis. The field of view is -- chosen to match a 50mm camera on 35mm film. Note that Cameras take -- up no space in the Diagram. -mm50Camera :: (Backend b R3, Renderable (Camera PerspectiveLens) b) => Diagram b R3 +mm50Camera :: (R3Ish v, Backend b v, Renderable (Camera (PerspectiveLens v)) b) => Diagram b v mm50Camera = facing_ZCamera mm50 -- | 'facing_ZCamera l' is a camera at the origin facing along the -- negative Z axis, with its up-axis coincident with the positive Y -- axis, with the projection defined by l. -facing_ZCamera :: (CameraLens l, Backend b R3, Renderable (Camera l) b) => - l -> Diagram b R3 +facing_ZCamera :: (R3Ish v, V l ~ v, CameraLens l, Backend b v, Renderable (Camera l) b) => + l -> Diagram b v facing_ZCamera l = mkQD (Prim $ Camera origin unit_Z unitY l) mempty mempty mempty (Query . const . Any $ False) -mm50, mm50Wide, mm50Narrow :: PerspectiveLens +mm50, mm50Wide, mm50Narrow :: (R3Ish v) => PerspectiveLens v -- | mm50 has the field of view of a 50mm lens on standard 35mm film, -- hence an aspect ratio of 3:2. @@ -119,18 +124,18 @@ mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) -- aspect ratio of 4:3, for VGA and similar computer resulotions. mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) -camForward :: Camera l -> Direction R3 +camForward :: (R3Ish v, v ~ V l) => Camera l -> Direction v camForward = direction . forward -camUp :: Camera l -> Direction R3 +camUp :: (R3Ish v, v ~ V l) => Camera l -> Direction v camUp = direction . up -camRight :: Camera l -> Direction R3 +camRight :: (R3Ish v, v ~ V l) => Camera l -> Direction v camRight c = direction right where right = cross3 (forward c) (up c) -camLens :: Camera l -> l +camLens :: (R3Ish v, v ~ V l) => Camera l -> l camLens = lens -camAspect :: CameraLens l => Camera l -> Double +camAspect :: (R3Ish v, v ~ V l) => CameraLens l => Camera l -> Scalar v camAspect = aspect . camLens diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs index 3fb13d30..f684e306 100644 --- a/src/Diagrams/ThreeD/Deform.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} module Diagrams.ThreeD.Deform where import Control.Lens @@ -8,32 +9,32 @@ import Diagrams.Coordinates import Diagrams.ThreeD.Types -- | The parallel projection onto the plane x=0 -parallelX0 :: Deformation R3 +parallelX0 :: (R3Ish v) => Deformation v parallelX0 = Deformation (& _x .~ 0) -- | The perspective division onto the plane x=1 along lines going -- through the origin. -perspectiveX1 :: Deformation R3 +perspectiveX1 :: (R3Ish v) => Deformation v perspectiveX1 = Deformation (\p -> let x = p^._x in p & _x .~ 1 & _y //~ x & _z //~ x ) -- | The parallel projection onto the plane y=0 -parallelY0 :: Deformation R3 +parallelY0 :: (R3Ish v) => Deformation v parallelY0 = Deformation (& _y .~ 0) -- | The perspective division onto the plane y=1 along lines going -- through the origin. -perspectiveY1 :: Deformation R3 +perspectiveY1 :: (R3Ish v) => Deformation v perspectiveY1 = Deformation (\p -> let y = p^._y in p & _x //~ y & _y .~ 1 & _z //~ y ) -- | The parallel projection onto the plane z=0 -parallelZ0 :: Deformation R3 +parallelZ0 :: (R3Ish v) => Deformation v parallelZ0 = Deformation (& _z .~ 0) -- | The perspective division onto the plane z=1 along lines going -- through the origin. -perspectiveZ1 :: Deformation R3 +perspectiveZ1 :: (R3Ish v) => Deformation v perspectiveZ1 = Deformation (\p -> let z = p^._z in p & _x //~ z & _y //~ z & _z .~ 1 ) @@ -41,11 +42,11 @@ perspectiveZ1 = Deformation (\p -> let z = p^._z in -- axis. X coördinates stay fixed, while Y coördinates are compressed -- with increasing distance. @asDeformation (translation unitX) <> -- parallelX0 <> frustrumX = perspectiveX1@ -facingX :: Deformation R3 +facingX :: (R3Ish v) => Deformation v facingX = Deformation (\v -> v & _y //~ (v^._x) & _z //~ (v^._x)) -facingY :: Deformation R3 +facingY :: (R3Ish v) => Deformation v facingY = Deformation (\v -> v & _x //~ (v^._y) & _z //~ (v^._y)) -facingZ :: Deformation R3 +facingZ :: (R3Ish v) => Deformation v facingZ = Deformation (\v -> v & _x //~ (v^._z) & _y //~ (v^._z)) diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs index 28cbfda2..962e8492 100644 --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -24,33 +25,33 @@ import Diagrams.Core import Diagrams.Direction import Diagrams.ThreeD.Types -data PointLight = PointLight P3 (Colour Double) +data PointLight v = PointLight (Point v) (Colour Double) deriving Typeable -data ParallelLight = ParallelLight R3 (Colour Double) +data ParallelLight v = ParallelLight v (Colour Double) deriving Typeable -type instance V PointLight = R3 -type instance V ParallelLight = R3 +type instance V (PointLight v) = v +type instance V (ParallelLight v) = v -instance Transformable PointLight where +instance (R3Ish v) => Transformable (PointLight v) where transform t (PointLight p c) = PointLight (transform t p) c -instance Transformable ParallelLight where +instance (R3Ish v) => Transformable (ParallelLight v) where transform t (ParallelLight v c) = ParallelLight (transform t v) c -- | Construct a Diagram with a single PointLight at the origin, which -- takes up no space. -pointLight :: (Backend b R3, Renderable PointLight b) +pointLight :: (Backend b v, Renderable (PointLight v) b, R3Ish v) => Colour Double -- ^ The color of the light - -> Diagram b R3 + -> Diagram b v pointLight c = mkQD (Prim $ PointLight origin c) mempty mempty mempty (Query . const . Any $ False) -- | Construct a Diagram with a single ParallelLight, which takes up no space. -parallelLight :: (Backend b R3, Renderable ParallelLight b) - => Direction R3 -- ^ The direction in which the light travels. +parallelLight :: (Backend b v, Renderable (ParallelLight v) b, R3Ish v) + => Direction v -- ^ The direction in which the light travels. -> Colour Double -- ^ The color of the light. - -> Diagram b R3 + -> Diagram b v parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c) mempty mempty mempty (Query . const . Any $ False) diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index e524068c..3479cfb5 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies, ConstraintKinds, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Shapes @@ -34,19 +34,19 @@ import Diagrams.Solve import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector -data Ellipsoid = Ellipsoid T3 +data Ellipsoid v = Ellipsoid (Transformation v) deriving Typeable -type instance V Ellipsoid = R3 +type instance V (Ellipsoid v) = v -instance Transformable Ellipsoid where +instance (R3Ish v) => Transformable (Ellipsoid v) where transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) -instance Renderable Ellipsoid NullBackend where +instance (R3Ish v) => Renderable (Ellipsoid v) NullBackend where render _ _ = mempty -- | A sphere of radius 1 with its center at the origin. -sphere :: (Backend b R3, Renderable Ellipsoid b) => Diagram b R3 +sphere :: (R3Ish v, Backend b v, Renderable (Ellipsoid v) b) => Diagram b v sphere = mkQD (Prim $ Ellipsoid mempty) (mkEnvelope sphereEnv) (mkTrace sphereTrace) @@ -60,20 +60,20 @@ sphere = mkQD (Prim $ Ellipsoid mempty) p' = p .-. origin sphereQuery v = Any $ magnitudeSq (v .-. origin) <= 1 -data Box = Box T3 +data Box v = Box (Transformation v) deriving (Typeable) -type instance V Box = R3 +type instance V (Box v) = v -instance Transformable Box where +instance (R3Ish v) => Transformable (Box v) where transform t1 (Box t2) = Box (t1 <> t2) -instance Renderable Box NullBackend where +instance (R3Ish v) => Renderable (Box v) NullBackend where render _ _ = mempty -- | A cube with side length 1, in the positive octant, with one -- vertex at the origin. -cube :: (Backend b R3, Renderable Box b) => Diagram b R3 +cube :: (R3Ish v, Backend b v, Renderable (Box v) b) => Diagram b v cube = mkQD (Prim $ Box mempty) (mkEnvelope boxEnv) (mkTrace boxTrace) @@ -96,21 +96,21 @@ cube = mkQD (Prim $ Box mempty) (x, y, z) = unp3 u boxQuery = Any . range -data Frustum = Frustum Double Double T3 +data Frustum v = Frustum (Scalar v) (Scalar v) (Transformation v) deriving (Typeable) -type instance V Frustum = R3 +type instance V (Frustum v) = v -instance Transformable Frustum where +instance (R3Ish v) => Transformable (Frustum v) where transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) -instance Renderable Frustum NullBackend where +instance (R3Ish v) => Renderable (Frustum v) NullBackend where render _ _ = mempty -- | A frustum of a right circular cone. It has height 1 oriented -- along the positive z axis, and radii r0 and r1 at Z=0 and Z=1. -- 'cone' and 'cylinder' are special cases. -frustum :: (Backend b R3, Renderable Frustum b) => Double -> Double -> Diagram b R3 +frustum :: (R3Ish v, Backend b v, Renderable (Frustum v) b) => (Scalar v) -> (Scalar v) -> Diagram b v frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) (mkEnvelope frEnv) (mkTrace frTrace) @@ -153,10 +153,10 @@ frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) -- | A cone with its base centered on the origin, with radius 1 at the -- base, height 1, and it's apex on the positive Z axis. -cone :: (Backend b R3, Renderable Frustum b) => Diagram b R3 +cone :: (R3Ish v, Backend b v, Renderable (Frustum v) b) => Diagram b v cone = frustum 1 0 -- | A circular cylinder of radius 1 with one end cap centered on the -- origin, and extending to Z=1. -cylinder :: (Backend b R3, Renderable Frustum b) => Diagram b R3 +cylinder :: (R3Ish v, Backend b v, Renderable (Frustum v) b) => Diagram b v cylinder = frustum 1 1 diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index c92cb395..ac3e1128 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns , ConstraintKinds, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Transform @@ -73,7 +73,7 @@ import Data.VectorSpace -- Note that writing @aboutZ (1\/4)@, with no type annotation, will -- yield an error since GHC cannot figure out which sort of angle -- you want to use. -aboutZ :: Angle Double -> T3 +aboutZ :: (R3Ish v) => Angle (Scalar v) -> Transformation v aboutZ ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) theta = view rad ang @@ -83,7 +83,7 @@ aboutZ ang = fromLinear r (linv r) where -- | Like 'aboutZ', but rotates about the X axis, bringing positive y-values -- towards the positive z-axis. -aboutX :: Angle Double -> T3 +aboutX :: (R3Ish v) => Angle (Scalar v) -> Transformation v aboutX ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) theta = view rad ang @@ -93,7 +93,7 @@ aboutX ang = fromLinear r (linv r) where -- | Like 'aboutZ', but rotates about the Y axis, bringing postive -- x-values towards the negative z-axis. -aboutY :: Angle Double -> T3 +aboutY :: (R3Ish v) => Angle (Scalar v) -> Transformation v aboutY ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) theta = view rad ang @@ -103,11 +103,11 @@ aboutY ang = fromLinear r (linv r) where -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. -rotationAbout :: - P3 -- ^ origin of rotation - -> Direction R3 -- ^ direction of rotation axis - -> Angle Double -- ^ angle of rotation - -> T3 +rotationAbout :: (R3Ish v) => + Point v -- ^ origin of rotation + -> Direction v -- ^ direction of rotation axis + -> Angle (Scalar v) -- ^ angle of rotation + -> Transformation v rotationAbout p d a = mconcat [translation (negateV t), fromLinear r (linv r), @@ -115,7 +115,7 @@ rotationAbout p d a r = rot theta <-> rot (-theta) theta = view rad a w = fromDirection d - rot :: Double -> R3 -> R3 + -- rot :: Scalar v -> v -> v rot th v = v ^* cos th ^+^ cross3 w v ^* sin th ^+^ w ^* ((w <.> v) * (1 - cos th)) @@ -128,12 +128,12 @@ rotationAbout p d a -- without tilting, it will be, otherwise if only tilting is -- necessary, no panning will occur. The tilt will always be between -- ± 1/4 turn. -pointAt :: Direction R3 -> Direction R3 -> Direction R3 -> T3 +pointAt :: (R3Ish v) => Direction v -> Direction v -> Direction v -> Transformation v pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) -- | pointAt' has the same behavior as 'pointAt', but takes vectors -- instead of directions. -pointAt' :: R3 -> R3 -> R3 -> T3 +pointAt' :: (R3Ish v) => v -> v -> v -> Transformation v pointAt' about initial final = tilt <> pan where inPanPlane = final ^-^ project final initial panAngle = angleBetween initial inPanPlane @@ -146,103 +146,103 @@ pointAt' about initial final = tilt <> pan where -- | Construct a transformation which scales by the given factor in -- the x direction. -scalingX :: Double -> T3 +scalingX :: (R3Ish v) => Scalar v -> Transformation v scalingX c = fromLinear s s where s = (_x *~ c) <-> (_x //~ c) -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. -scaleX :: (Transformable t, V t ~ R3) => Double -> t -> t +scaleX :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t scaleX = transform . scalingX -- | Construct a transformation which scales by the given factor in -- the y direction. -scalingY :: Double -> T3 +scalingY :: (R3Ish v) => Scalar v -> Transformation v scalingY c = fromLinear s s where s = (_y *~ c) <-> (_y //~ c) -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. -scaleY :: (Transformable t, V t ~ R3) => Double -> t -> t +scaleY :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t scaleY = transform . scalingY -- | Construct a transformation which scales by the given factor in -- the z direction. -scalingZ :: Double -> T3 +scalingZ :: (R3Ish v) => Scalar v -> Transformation v scalingZ c = fromLinear s s where s = (_z *~ c) <-> (_z //~ c) -- | Scale a diagram by the given factor in the z direction. To scale -- uniformly, use 'scale'. -scaleZ :: (Transformable t, V t ~ R3) => Double -> t -> t +scaleZ :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t scaleZ = transform . scalingZ -- Translation ---------------------------------------- -- | Construct a transformation which translates by the given distance -- in the x direction. -translationX :: Double -> T3 +translationX :: (R3Ish v) => Scalar v -> Transformation v translationX x = translation (x ^& 0 ^& 0) -- | Translate a diagram by the given distance in the x -- direction. -translateX :: (Transformable t, V t ~ R3) => Double -> t -> t +translateX :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t translateX = transform . translationX -- | Construct a transformation which translates by the given distance -- in the y direction. -translationY :: Double -> T3 +translationY :: (R3Ish v) => Scalar v -> Transformation v translationY y = translation (0 ^& y ^& 0) -- | Translate a diagram by the given distance in the y -- direction. -translateY :: (Transformable t, V t ~ R3) => Double -> t -> t +translateY :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t translateY = transform . translationY -- | Construct a transformation which translates by the given distance -- in the z direction. -translationZ :: Double -> T3 +translationZ :: (R3Ish v) => Scalar v -> Transformation v translationZ z = translation (0 ^& 0 ^& z) -- | Translate a diagram by the given distance in the y -- direction. -translateZ :: (Transformable t, V t ~ R3) => Double -> t -> t +translateZ :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t translateZ = transform . translationZ -- Reflection ---------------------------------------------- -- | Construct a transformation which flips a diagram across x=0, -- i.e. sends the point (x,y,z) to (-x,y,z). -reflectionX :: T3 +reflectionX :: (R3Ish v) => Transformation v reflectionX = scalingX (-1) -- | Flip a diagram across x=0, i.e. send the point (x,y,z) to (-x,y,z). -reflectX :: (Transformable t, V t ~ R3) => t -> t +reflectX :: (R3Ish v, Transformable t, V t ~ v) => t -> t reflectX = transform reflectionX -- | Construct a transformation which flips a diagram across y=0, -- i.e. sends the point (x,y,z) to (x,-y,z). -reflectionY :: T3 +reflectionY :: (R3Ish v) => Transformation v reflectionY = scalingY (-1) -- | Flip a diagram across y=0, i.e. send the point (x,y,z) to -- (x,-y,z). -reflectY :: (Transformable t, V t ~ R3) => t -> t +reflectY :: (R3Ish v, Transformable t, V t ~ v) => t -> t reflectY = transform reflectionY -- | Construct a transformation which flips a diagram across z=0, -- i.e. sends the point (x,y,z) to (x,y,-z). -reflectionZ :: T3 +reflectionZ :: (R3Ish v) => Transformation v reflectionZ = scalingZ (-1) -- | Flip a diagram across z=0, i.e. send the point (x,y,z) to -- (x,y,-z). -reflectZ :: (Transformable t, V t ~ R3) => t -> t +reflectZ :: (R3Ish v, Transformable t, V t ~ v) => t -> t reflectZ = transform reflectionZ -- | @reflectionAbout p v@ is a reflection across the plane through -- the point @p@ and normal to vector @v@. -reflectionAbout :: P3 -> R3 -> T3 +reflectionAbout :: (R3Ish v) => Point v -> v -> Transformation v reflectionAbout p v = conjugate (translation (origin .-. p)) reflect where reflect = fromLinear t (linv t) @@ -251,7 +251,7 @@ reflectionAbout p v = -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. -reflectAbout :: (Transformable t, V t ~ R3) => P3 -> R3 -> t -> t +reflectAbout :: (R3Ish v, Transformable t, V t ~ v) => Point v -> v -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Utilities ---------------------------------------- @@ -259,6 +259,6 @@ reflectAbout p v = transform (reflectionAbout p v) -- | Get the matrix equivalent of an affine transform, as a triple of -- columns paired with the translation vector. This is mostly -- useful for implementing backends. -onBasis :: T3 -> ((R3, R3, R3), R3) +onBasis :: (R3Ish v) => Transformation v -> ((v, v, v), v) onBasis t = ((x, y, z), v) where (x:y:z:[], v) = T.onBasis t diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 307180f2..f232819a 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -6,6 +6,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} ----------------------------------------------------------------------------- -- | @@ -20,124 +21,67 @@ module Diagrams.ThreeD.Types ( -- * 3D Euclidean space - R3(..), r3, unr3, mkR3 - , P3, p3, unp3, mkP3 - , T3 + r3, unr3, mkR3 + , p3, unp3, mkP3 , r3Iso, p3Iso - + , R3Ish -- * other coördinate systems , Spherical(..), Cylindrical(..), HasPhi(..) ) where -import Control.Lens (Iso', Lens', iso, over - , _1, _2, _3, (^.)) +import Control.Lens (Iso', iso) import Diagrams.Core import Diagrams.Angle -import Diagrams.Direction -import Diagrams.TwoD.Types (R2) import Diagrams.Coordinates +import Diagrams.Points import Data.AffineSpace.Point import Data.Basis import Data.Cross import Data.VectorSpace +import Data.Typeable ------------------------------------------------------------ -- 3D Euclidean space --- | The three-dimensional Euclidean vector space R^3. -data R3 = R3 !Double !Double !Double - deriving (Eq, Ord, Show, Read) +type R3Basis = Either () (Either () ()) + +-- Basic R3 types -r3Iso :: Iso' R3 (Double, Double, Double) +type ScalarR3Ish d = (Ord d, Scalar d ~ d, InnerSpace d, RealFloat d) +type R3Ish v = (HasBasis v, Basis v ~ R3Basis, Coordinates v, Coordinates (PrevDim v), PrevDim (PrevDim v) ~ Scalar v, FinalCoord (PrevDim v) ~ Scalar v, FinalCoord v ~ Scalar v, Decomposition v ~ (Scalar v :& Scalar v :& Scalar v), v ~ V v, Typeable v, ScalarR3Ish (Scalar v), Transformable v, InnerSpace v, HasCross3 v, HasX v, HasY v, HasZ v, HasTheta v, Cylindrical v) + +r3Iso :: (R3Ish v) => Iso' v (Scalar v, Scalar v, Scalar v) r3Iso = iso unr3 r3 -- | Construct a 3D vector from a triple of components. -r3 :: (Double, Double, Double) -> R3 -r3 (x,y,z) = R3 x y z +r3 :: (R3Ish v) => (Scalar v, Scalar v, Scalar v) -> v +r3 (x,y,z) = x ^& y ^& z -- | Curried version of `r3`. -mkR3 :: Double -> Double -> Double -> R3 -mkR3 = R3 +mkR3 :: (R3Ish v) => Scalar v -> Scalar v -> Scalar v -> v +mkR3 x y z = x ^& y ^& z -- | Convert a 3D vector back into a triple of components. -unr3 :: R3 -> (Double, Double, Double) -unr3 (R3 x y z) = (x,y,z) - -instance AdditiveGroup R3 where - zeroV = R3 0 0 0 - R3 x1 y1 z1 ^+^ R3 x2 y2 z2 = R3 (x1 + x2) (y1 + y2) (z1 + z2) - negateV (R3 x y z) = R3 (-x) (-y) (-z) - -type instance V R3 = R3 - -instance VectorSpace R3 where - type Scalar R3 = Double - (*^) = over r3Iso . (*^) - -instance HasBasis R3 where - type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) - basisValue = r3 . basisValue - decompose = decompose . unr3 - decompose' = decompose' . unr3 - -instance InnerSpace R3 where - (R3 x1 y1 z1) <.> (R3 x2 y2 z2) = x1*x2 + y1*y2 + z1*z2 - -instance Coordinates R3 where - type FinalCoord R3 = Double - type PrevDim R3 = R2 - type Decomposition R3 = Double :& Double :& Double - - (coords -> x :& y) ^& z = R3 x y z - coords (R3 x y z) = x :& y :& z - --- | Points in R^3. -type P3 = Point R3 +unr3 :: (R3Ish v) => v -> (Scalar v, Scalar v, Scalar v) +unr3 (coords -> (coords -> x :& y) :& z) = (x,y,z) -- | Construct a 3D point from a triple of coordinates. -p3 :: (Double, Double, Double) -> P3 +p3 :: (R3Ish v) => (Scalar v, Scalar v, Scalar v) -> Point v p3 = P . r3 -- | Convert a 3D point back into a triple of coordinates. -unp3 :: P3 -> (Double, Double, Double) +unp3 :: (R3Ish v) => Point v -> (Scalar v, Scalar v, Scalar v) unp3 = unr3 . unPoint -p3Iso :: Iso' P3 (Double, Double, Double) +p3Iso :: (R3Ish v) => Iso' (Point v) (Scalar v, Scalar v, Scalar v) p3Iso = iso unp3 p3 -- | Curried version of `r3`. -mkP3 :: Double -> Double -> Double -> P3 +mkP3 :: (R3Ish v) => Scalar v -> Scalar v -> Scalar v -> Point v mkP3 x y z = p3 (x, y, z) --- | Transformations in R^3. -type T3 = Transformation R3 - -instance Transformable R3 where - transform = apply - -instance HasCross3 R3 where - cross3 u v = r3 $ cross3 (unr3 u) (unr3 v) - -instance HasX R3 where - _x = r3Iso . _1 - -instance HasX P3 where - _x = p3Iso . _1 - -instance HasY R3 where - _y = r3Iso . _2 - -instance HasY P3 where - _y = p3Iso . _2 - -instance HasZ R3 where - _z = r3Iso . _3 - -instance HasZ P3 where - _z = p3Iso . _3 - -- | Types which can be expressed in spherical 3D coordinates, as a -- triple (r,θ,φ), where θ is rotation about the Z axis, and φ is the -- angle from the Z axis. @@ -148,38 +92,9 @@ class Spherical t where class Cylindrical t where cylindrical :: Iso' t (Scalar (V t), Angle (Scalar (V t)), Scalar (V t)) -- r, θ, z -instance Cylindrical R3 where - cylindrical = iso (\(R3 x y z) -> (sqrt (x^(2::Int)+y^(2::Int)), atanA (y/x), z)) - (\(r,θ,z) -> R3 (r*cosA θ) (r*sinA θ) z) - -instance Spherical R3 where - spherical = iso - (\v@(R3 x y z) -> (magnitude v, atanA (y/x), atanA (v^._r/z))) - (\(r,θ,φ) -> R3 (r*cosA θ*sinA φ) (r*sinA θ*sinA φ) (r*cosA φ)) - --- We'd like to write: instance Spherical t => HasR t --- But GHC can't work out that the instance won't overlap. Just write them explicitly: - -instance HasR R3 where - _r = spherical . _1 - -instance HasR P3 where - _r = spherical . _1 - -instance HasTheta R3 where - _theta = cylindrical . _2 - -instance HasTheta P3 where - _theta = cylindrical . _2 - -instance HasPhi R3 where - _phi = spherical . _3 - -instance HasPhi P3 where - _phi = spherical . _3 +instance (Cylindrical v, v ~ V v) => Cylindrical (Point v) where + cylindrical = _pIso . cylindrical -instance Cylindrical P3 where - cylindrical = _relative origin . cylindrical +instance (Spherical v, v ~ V v) => Spherical (Point v) where + spherical = _pIso . spherical -instance Spherical P3 where - spherical = _relative origin . spherical diff --git a/src/Diagrams/ThreeD/Types/Double.hs b/src/Diagrams/ThreeD/Types/Double.hs new file mode 100644 index 00000000..8cf6c7b9 --- /dev/null +++ b/src/Diagrams/ThreeD/Types/Double.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns, DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Types.Double +-- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Basic types for three-dimensional Euclidean space using Double. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Types.Double + ( -- * 3D Euclidean space + R3(..), P3, T3 + ) where + +import Control.Lens (iso, over, _1, _2, _3, (^.)) + +import Diagrams.Core +import Diagrams.Angle +import Diagrams.TwoD.Types.Double(R2) +import Diagrams.ThreeD.Types +import Diagrams.Coordinates + +import Data.Basis +import Data.Cross +import Data.Typeable +import Data.VectorSpace + +------------------------------------------------------------ +-- 3D Euclidean space + +-- | The three-dimensional Euclidean vector space R^3. +data R3 = R3 !Double !Double !Double + deriving (Eq, Ord, Show, Read, Typeable) + +instance AdditiveGroup R3 where + zeroV = R3 0 0 0 + R3 x1 y1 z1 ^+^ R3 x2 y2 z2 = R3 (x1 + x2) (y1 + y2) (z1 + z2) + negateV (R3 x y z) = R3 (-x) (-y) (-z) + +type instance V R3 = R3 + +instance VectorSpace R3 where + type Scalar R3 = Double + (*^) = over r3Iso . (*^) + +instance HasBasis R3 where + type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) + basisValue = r3 . basisValue + decompose = decompose . unr3 + decompose' = decompose' . unr3 + +instance InnerSpace R3 where + (R3 x1 y1 z1) <.> (R3 x2 y2 z2) = x1*x2 + y1*y2 + z1*z2 + +instance Coordinates R3 where + type FinalCoord R3 = Double + type PrevDim R3 = R2 + type Decomposition R3 = Double :& Double :& Double + + (coords -> x :& y) ^& z = R3 x y z + coords (R3 x y z) = x :& y :& z + +-- | Points in R^3. +type P3 = Point R3 + +-- | Transformations in R^3. +type T3 = Transformation R3 + +instance Transformable R3 where + transform = apply + +instance HasCross3 R3 where + cross3 u v = r3 $ cross3 (unr3 u) (unr3 v) + +instance HasX R3 where + _x = r3Iso . _1 + +instance HasY R3 where + _y = r3Iso . _2 + +instance HasZ R3 where + _z = r3Iso . _3 + +instance Cylindrical R3 where + cylindrical = iso (\(R3 x y z) -> (sqrt (x^(2::Int)+y^(2::Int)), atanA (y/x), z)) + (\(r,θ,z) -> R3 (r*cosA θ) (r*sinA θ) z) + +instance Spherical R3 where + spherical = iso + (\v@(R3 x y z) -> (magnitude v, atanA (y/x), atanA (v^._r/z))) + (\(r,θ,φ) -> R3 (r*cosA θ*sinA φ) (r*sinA θ*sinA φ) (r*cosA φ)) + +-- We'd like to write: instance Spherical t => HasR t +-- But GHC can't work out that the instance won't overlap. Just write them explicitly: +instance HasR R3 where + _r = spherical . _1 + +instance HasTheta R3 where + _theta = cylindrical . _2 + +instance HasPhi R3 where + _phi = spherical . _3 diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 975188b5..46b8aea3 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts , TypeFamilies - , ViewPatterns + , ViewPatterns, ConstraintKinds #-} ----------------------------------------------------------------------------- -- | @@ -22,25 +22,25 @@ import Diagrams.ThreeD.Types -- | The unit vector in the positive X direction. -unitX :: R3 +unitX :: (R3Ish v) => v unitX = 1 ^& 0 ^& 0 -- | The unit vector in the positive Y direction. -unitY :: R3 +unitY :: (R3Ish v) => v unitY = 0 ^& 1 ^& 0 -- | The unit vector in the positive Z direction. -unitZ :: R3 +unitZ :: (R3Ish v) => v unitZ = 0 ^& 0 ^& 1 -- | The unit vector in the negative X direction. -unit_X :: R3 +unit_X :: (R3Ish v) => v unit_X = (-1) ^& 0 ^& 0 -- | The unit vector in the negative Y direction. -unit_Y :: R3 +unit_Y :: (R3Ish v) => v unit_Y = 0 ^& (-1) ^& 0 -- | The unit vector in the negative Z direction. -unit_Z :: R3 +unit_Z :: (R3Ish v) => v unit_Z = 0 ^& 0 ^& (-1) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index d63d95a5..c43c858a 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -289,6 +289,7 @@ import Diagrams.TwoD.Size import Diagrams.TwoD.Text import Diagrams.TwoD.Transform import Diagrams.TwoD.Types +import Diagrams.TwoD.Types.Double import Diagrams.TwoD.Vector import Diagrams.Util (tau) diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs index aa73d552..808e46c9 100644 --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -26,13 +27,14 @@ import Diagrams.TwoD.Attributes (lineWidthA, lineTextureA) import Diagrams.TwoD.Size (SizeSpec2D (..), center2D, requiredScale, size2D) import Diagrams.TwoD.Text (fontSizeA) -import Diagrams.TwoD.Types (R2, T2, p2) +import Diagrams.TwoD.Types (R2Ish, p2) import Diagrams.Util (( # )) import Control.Lens (Lens', (&), (.~), (^.)) import Data.AffineSpace ((.-.)) import Data.Default.Class import Data.Semigroup +import Data.VectorSpace (Scalar) -- | Set default attributes of a 2D diagram (in case they have not -- been set): @@ -48,7 +50,7 @@ import Data.Semigroup -- * line join miter -- -- * Miter limit 10 -setDefault2DAttributes :: Semigroup m => QDiagram b R2 m -> QDiagram b R2 m +setDefault2DAttributes :: (Semigroup m, R2Ish v) => QDiagram b v m -> QDiagram b v m setDefault2DAttributes d = d # lineWidthA def # lineTextureA def # fontSizeA def # lineCap def # lineJoin def # lineMiterLimitA def @@ -60,10 +62,10 @@ setDefault2DAttributes d = d # lineWidthA def # lineTextureA def # fontSizeA def -- inverse of which can be used, say, to translate output/device -- coordinates back into local diagram coordinates), and the -- modified diagram itself. -adjustDiaSize2D :: Monoid' m - => Lens' (Options b R2) SizeSpec2D - -> b -> Options b R2 -> QDiagram b R2 m - -> (Options b R2, T2, QDiagram b R2 m) +adjustDiaSize2D :: (Monoid' m, R2Ish v) + => Lens' (Options b v) (SizeSpec2D (Scalar v)) + -> b -> Options b v -> QDiagram b v m + -> (Options b v, Transformation v, QDiagram b v m) adjustDiaSize2D szL _ opts d = ( case spec of Dims _ _ -> opts @@ -97,10 +99,10 @@ adjustDiaSize2D szL _ opts d = -- to the diagram (the inverse of which can be used, say, to -- translate output/device coordinates back into local diagram -- coordinates), and the modified diagram itself. -adjustDia2D :: Monoid' m - => Lens' (Options b R2) SizeSpec2D - -> b -> Options b R2 -> QDiagram b R2 m - -> (Options b R2, T2, QDiagram b R2 m) +adjustDia2D :: (Monoid' m, R2Ish v) + => Lens' (Options b v) (SizeSpec2D (Scalar v)) + -> b -> Options b v -> QDiagram b v m + -> (Options b v, Transformation v, QDiagram b v m) adjustDia2D szL b opts d = adjustDiaSize2D szL b opts (d # setDefault2DAttributes) diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs index 1d5ddd86..6f08b2b7 100644 --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Align @@ -50,46 +52,46 @@ import Data.VectorSpace -- | Align along the left edge, i.e. translate the diagram in a -- horizontal direction so that the local origin is on the left edge -- of the envelope. -alignL :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a +alignL :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a alignL = align (negateV unitX) snugL :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a + HasOrigin a, V a ~ v, R2Ish v) => a -> a snugL = snug (negateV unitX) -- | Align along the right edge. -alignR :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a +alignR :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a alignR = align unitX snugR :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a + HasOrigin a, V a ~ v, R2Ish v) => a -> a snugR = snug unitX -- | Align along the top edge. -alignT :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a +alignT :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a alignT = align unitY snugT:: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a + HasOrigin a, V a ~ v, R2Ish v) => a -> a snugT = snug unitY -- | Align along the bottom edge. -alignB :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a +alignB :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a alignB = align (negateV unitY) snugB :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a + HasOrigin a, V a ~ v, R2Ish v) => a -> a snugB = snug (negateV unitY) -alignTL, alignTR, alignBL, alignBR :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a +alignTL, alignTR, alignBL, alignBR :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a alignTL = alignT . alignL alignTR = alignT . alignR alignBL = alignB . alignL alignBR = alignB . alignR snugTL, snugTR, snugBL, snugBR - :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a, V a ~ R2) + :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a, V a ~ v, R2Ish v) => a -> a snugTL = snugT . snugL snugTR = snugT . snugR @@ -108,44 +110,44 @@ snugBR = snugB . snugR -- -- * @snugX@ works the same way. -alignX :: (Alignable a, HasOrigin a, V a ~ R2) => Double -> a -> a +alignX :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => Scalar v -> a -> a alignX = alignBy unitX -- | See the documentation for 'alignX'. snugX :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => Double -> a -> a + HasOrigin a, V a ~ v, R2Ish v) => Scalar v -> a -> a snugX = snugBy unitX -- | Like 'alignX', but moving the local origin vertically, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignY :: (Alignable a, HasOrigin a, V a ~ R2) => Double -> a -> a +alignY :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => Scalar v -> a -> a alignY = alignBy unitY snugY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => Double -> a -> a + HasOrigin a, V a ~ v, R2Ish v) => Scalar v -> a -> a snugY = snugBy unitY -- | Center the local origin along the X-axis. -centerX :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a +centerX :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a centerX = alignBy unitX 0 snugCenterX :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a + HasOrigin a, V a ~ v, R2Ish v) => a -> a snugCenterX = snugBy unitX 0 -- | Center the local origin along the Y-axis. -centerY :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a +centerY :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a centerY = alignBy unitY 0 snugCenterY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a + HasOrigin a, V a ~ v, R2Ish v) => a -> a snugCenterY = snugBy unitY 0 -- | Center along both the X- and Y-axes. -centerXY :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a +centerXY :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a centerXY = center snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a + HasOrigin a, V a ~ v, R2Ish v) => a -> a snugCenterXY = snugCenter diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index fafd9790..0d565a18 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -47,7 +47,7 @@ import Diagrams.Coordinates -- the positive y direction and sweeps counterclockwise through an -- angle @s@. The approximation is only valid for angles in the -- first quadrant. -bezierFromSweepQ1 :: (ExtraLikeR2 v) => Angle (Scalar v) -> Segment Closed v +bezierFromSweepQ1 :: (R2Ish v) => Angle (Scalar v) -> Segment Closed v bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 where p0@(coords -> x :& y) = rotate (s ^/ 2) v c1 = ((4-x)/3) ^& ((1-x)*(3-x)/(3*y)) @@ -60,7 +60,7 @@ bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 -- negative y direction and sweep clockwise. When @s@ is less than -- 0.0001 the empty list results. If the sweep is greater than @fullTurn@ -- later segments will overlap earlier segments. -bezierFromSweep :: (ExtraLikeR2 v) => Angle (Scalar v) -> [Segment Closed v] +bezierFromSweep :: (R2Ish v) => Angle (Scalar v) -> [Segment Closed v] bezierFromSweep s | s < zeroV = fmap reflectY . bezierFromSweep $ (negateV s) | s < 0.0001 @@ rad = [] @@ -92,7 +92,7 @@ the approximation error. -- is the 'Trail' of a radius one arc starting at @d@ and sweeping out -- the angle @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arcT :: (ExtraLikeR2 v) => Direction v -> Angle (Scalar v) -> Trail v +arcT :: (R2Ish v) => Direction v -> Angle (Scalar v) -> Trail v arcT start sweep = trailFromSegments bs where bs = map (rotate $ start ^. _theta) . bezierFromSweep $ sweep @@ -101,7 +101,7 @@ arcT start sweep = trailFromSegments bs -- path of a radius one arc starting at @d@ and sweeping out the angle -- @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arc :: (ExtraLikeR2 v, TrailLike t, V t ~ v) => Direction v -> Angle (Scalar v) -> t +arc :: (R2Ish v, TrailLike t, V t ~ v) => Direction v -> Angle (Scalar v) -> t arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ p2 (1,0)) -- | Given a radus @r@, a start direction @d@ and an angle @s@, @@ -113,7 +113,7 @@ arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ -- -- > arc'Ex = mconcat [ arc' r 0 (1/4 \@\@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 -arc' :: (ExtraLikeR2 v, TrailLike p, V p ~ v) => Scalar v -> Direction v -> Angle (Scalar v) -> p +arc' :: (R2Ish v, TrailLike p, V p ~ v) => Scalar v -> Direction v -> Angle (Scalar v) -> p arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) $ p2 (abs r,0)) where ts = arcT start sweep @@ -129,7 +129,7 @@ arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -wedge :: (ExtraLikeR2 v, TrailLike p, V p ~ v) => Scalar v -> Direction v -> Angle (Scalar v) -> p +wedge :: (R2Ish v, TrailLike p, V p ~ v) => Scalar v -> Direction v -> Angle (Scalar v) -> p wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine $ fromOffsets [r *^ fromDirection d] <> arc d s # scale r @@ -146,7 +146,7 @@ wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine -- > arcBetweenEx = mconcat -- > [ arcBetween origin (p2 (2,1)) ht | ht <- [-0.2, -0.1 .. 0.2] ] -- > # centerXY # pad 1.1 -arcBetween :: (ExtraLikeR2 v, TrailLike t, V t ~ v) => Point v -> Point v -> Scalar v -> t +arcBetween :: (R2Ish v, TrailLike t, V t ~ v) => Point v -> Point v -> Scalar v -> t arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) where h = abs ht @@ -180,7 +180,7 @@ arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -annularWedge :: (ExtraLikeR2 v, TrailLike p, V p ~ v) => +annularWedge :: (R2Ish v, TrailLike p, V p ~ v) => Scalar v -> Scalar v -> Direction v -> Angle (Scalar v) -> p annularWedge r1' r2' d1 s = trailLike . (`at` o) . glueTrail . wrapLine $ fromOffsets [(r1'-r2') *^ fromDirection d1] diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 7c3a298a..186a51a4 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | @@ -104,6 +105,7 @@ import Control.Lens (Lens', Setter', Traversal', makeLensesWith, view, (%~), (&), (.~), (^.)) import Data.AffineSpace +import Data.Data (Data) import Data.Default.Class import Data.Functor ((<$>)) import Data.Maybe (fromMaybe) @@ -131,25 +133,25 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unit_X) import Diagrams.Util (( # )) -data ArrowOpts +data ArrowOpts v = ArrowOpts - { _arrowHead :: ArrowHT - , _arrowTail :: ArrowHT - , _arrowShaft :: Trail R2 - , _headGap :: Measure R2 - , _tailGap :: Measure R2 - , _headStyle :: Style R2 - , _headLength :: Measure R2 - , _tailStyle :: Style R2 - , _tailLength :: Measure R2 - , _shaftStyle :: Style R2 + { _arrowHead :: ArrowHT v + , _arrowTail :: ArrowHT v + , _arrowShaft :: Trail v + , _headGap :: Measure v + , _tailGap :: Measure v + , _headStyle :: Style v + , _headLength :: Measure v + , _tailStyle :: Style v + , _tailLength :: Measure v + , _shaftStyle :: Style v } -- | Straight line arrow shaft. -straightShaft :: Trail R2 +straightShaft :: (R2Ish v) => Trail v straightShaft = trailFromOffsets [unitX] -instance Default ArrowOpts where +instance (R2Ish v) => Default (ArrowOpts v) where def = ArrowOpts { _arrowHead = dart , _arrowTail = noTail @@ -168,50 +170,50 @@ instance Default ArrowOpts where makeLensesWith (lensRules & generateSignatures .~ False) ''ArrowOpts -- | A shape to place at the head of the arrow. -arrowHead :: Lens' ArrowOpts ArrowHT +arrowHead :: Lens' (ArrowOpts v) (ArrowHT v) -- | A shape to place at the tail of the arrow. -arrowTail :: Lens' ArrowOpts ArrowHT +arrowTail :: Lens' (ArrowOpts v) (ArrowHT v) -- | The trail to use for the arrow shaft. -arrowShaft :: Lens' ArrowOpts (Trail R2) +arrowShaft :: Lens' (ArrowOpts v) (Trail v) -- | Distance to leave between the head and the target point. -headGap :: Lens' ArrowOpts (Measure R2) +headGap :: Lens' (ArrowOpts v) (Measure v) -- | Distance to leave between the starting point and the tail. -tailGap :: Lens' ArrowOpts (Measure R2) +tailGap :: Lens' (ArrowOpts v) (Measure v) -- | Set both the @headGap@ and @tailGap@ simultaneously. -gaps :: Traversal' ArrowOpts (Measure R2) +gaps :: Traversal' (ArrowOpts v) (Measure v) gaps f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap) -- | Same as gaps, provided for backward compatiiblity. -gap :: Traversal' ArrowOpts (Measure R2) +gap :: Traversal' (ArrowOpts v) (Measure v) gap = gaps -- | Style to apply to the head. @headStyle@ is modified by using the lens -- combinator @%~@ to change the current style. For example, to change -- an opaque black arrowhead to translucent orange: -- @(with & headStyle %~ fc orange . opacity 0.75)@. -headStyle :: Lens' ArrowOpts (Style R2) +headStyle :: Lens' (ArrowOpts v) (Style v) -- | Style to apply to the tail. See `headStyle`. -tailStyle :: Lens' ArrowOpts (Style R2) +tailStyle :: Lens' (ArrowOpts v) (Style v) -- | Style to apply to the shaft. See `headStyle`. -shaftStyle :: Lens' ArrowOpts (Style R2) +shaftStyle :: Lens' (ArrowOpts v) (Style v) -- | The length from the start of the joint to the tip of the head. -headLength :: Lens' ArrowOpts (Measure R2) +headLength :: Lens' (ArrowOpts v) (Measure v) -- | The length of the tail plus its joint. -tailLength :: Lens' ArrowOpts (Measure R2) +tailLength :: Lens' (ArrowOpts v) (Measure v) -- | Set both the @headLength@ and @tailLength@ simultaneously. -lengths :: Traversal' ArrowOpts (Measure R2) +lengths :: Traversal' (ArrowOpts v) (Measure v) lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts ^. headLength) <*> f (opts ^. tailLength) @@ -221,41 +223,41 @@ lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts -- defined. Or @... (with & headTexture .~ solid blue@ to set the head -- color to blue. For more general control over the style of arrowheads, -- see 'headStyle'. -headTexture :: Setter' ArrowOpts Texture +headTexture :: (R2Ish v) => Setter' (ArrowOpts v) (Texture v) headTexture = headStyle . styleFillTexture -- | A lens for setting or modifying the texture of an arrow -- tail. -tailTexture :: Setter' ArrowOpts Texture +tailTexture :: (R2Ish v) => Setter' (ArrowOpts v) (Texture v) tailTexture = tailStyle . styleFillTexture -- | A lens for setting or modifying the texture of an arrow -- shaft. -shaftTexture :: Setter' ArrowOpts Texture +shaftTexture :: (R2Ish v) => Setter' (ArrowOpts v) (Texture v) shaftTexture = shaftStyle . styleLineTexture -- Set the default shaft style of an `ArrowOpts` record by applying the -- default style after all other styles have been applied. -- The semigroup stucture of the lw attribute will insure that the default -- is only used if it has not been set in @opts@. -shaftSty :: ArrowOpts -> Style R2 +shaftSty :: (R2Ish v) => ArrowOpts v -> Style v shaftSty opts = opts^.shaftStyle -- Set the default head style. See `shaftSty`. -headSty :: ArrowOpts -> Style R2 +headSty :: (R2Ish v) => ArrowOpts v -> Style v headSty opts = fc black (opts^.headStyle) -- Set the default tail style. See `shaftSty`. -tailSty :: ArrowOpts -> Style R2 +tailSty :: (R2Ish v) => ArrowOpts v -> Style v tailSty opts = fc black (opts^.tailStyle) -fromMeasure :: Double -> Double -> Measure R2 -> Double +fromMeasure :: (Data d, Ord d, Fractional d) => d -> d -> MeasureX d -> d fromMeasure g n m = u where Output u = toOutput g n m -- | Calculate the length of the portion of the horizontal line that passes -- through the origin and is inside of p. -xWidth :: (Traced t, V t ~ R2) => t -> Double +xWidth :: (R2Ish v) => (Traced t, V t ~ v) => t -> Scalar v xWidth p = a + b where a = fromMaybe 0 (magnitude <$> traceV origin unitX p) @@ -263,7 +265,7 @@ xWidth p = a + b -- | Get the line color from the shaft to use as the fill color for the joint. -- And set the opacity of the shaft to the current opacity. -colorJoint :: Style R2 -> Style R2 +colorJoint :: (R2Ish v) => Style v -> Style v colorJoint sStyle = let c = fmap getLineTexture . getAttr $ sStyle o = fmap getOpacity . getAttr $ sStyle @@ -275,17 +277,14 @@ colorJoint sStyle = (Just t, Just o') -> opacity o' . fillTexture t $ mempty -- | Get line width from a style. -widthOfJoint :: Style v -> Double -> Double -> Double -widthOfJoint sStyle gToO nToO = - maybe (fromMeasure gToO nToO (Output 1)) -- Should be same as default line width - (fromMeasure gToO nToO) - (fmap getLineWidth . getAttr $ sStyle) +widthOfJoint :: forall v. (R2Ish v) => Style v -> Scalar v -> Scalar v -> Scalar v +widthOfJoint sStyle gToO nToO = maybe (fromMeasure gToO nToO (Output 1)) (fromMeasure gToO nToO) (fmap getLineWidth . (getAttr :: Style v -> Maybe (LineWidth v)) $ sStyle) -- | Combine the head and its joint into a single scale invariant diagram -- and move the origin to the attachment point. Return the diagram -- and its width. -mkHead :: Renderable (Path R2) b => - Double -> ArrowOpts -> Double -> Double -> (Diagram b R2, Double) +mkHead :: (R2Ish v, Renderable (Path v) b) => + Scalar v -> ArrowOpts v -> Scalar v -> Scalar v -> (Diagram b v, Scalar v) mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 , hWidth + jWidth) where @@ -297,8 +296,8 @@ mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) -- | Just like mkHead only the attachment point is on the right. -mkTail :: Renderable (Path R2) b => - Double -> ArrowOpts -> Double -> Double -> (Diagram b R2, Double) +mkTail :: (R2Ish v, Renderable (Path v) b) => + Scalar v -> ArrowOpts v -> Scalar v -> Scalar v -> (Diagram b v, Scalar v) mkTail size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 , tWidth + jWidth) where @@ -312,7 +311,7 @@ mkTail size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 -- | Make a trail with the same angles and offset as an arrow with tail width -- tw, head width hw and shaft of tr, such that the magnituted of the shaft -- offset is size. Used for calculating the offset of an arrow. -spine :: Trail R2 -> Double -> Double -> Double -> Trail R2 +spine :: (R2Ish v) => Trail v -> Scalar v -> Scalar v -> Scalar v -> Trail v spine tr tw hw size = tS <> tr # scale size <> hS where tSpine = trailFromOffsets [(normalized . tangentAtStart) $ tr] # scale tw @@ -322,7 +321,7 @@ spine tr tw hw size = tS <> tr # scale size <> hS -- | Calculate the amount required to scale a shaft trail so that an arrow with -- head width hw and tail width tw has offset t. -scaleFactor :: Trail R2 -> Double -> Double -> Double -> Double +scaleFactor :: (R2Ish v) => Trail v -> Scalar v -> Scalar v -> Scalar v -> Scalar v scaleFactor tr tw hw t -- Let tv be a vector representing the tail width, i.e. a vector @@ -353,7 +352,7 @@ scaleFactor tr tw hw t -- Calculate the approximate envelope of a horizontal arrow -- as if the arrow were made only of a shaft. -arrowEnv :: ArrowOpts -> Double -> Envelope R2 +arrowEnv :: (R2Ish v) => ArrowOpts v -> Scalar v -> Envelope v arrowEnv opts len = getEnvelope horizShaft where horizShaft = shaft # rotate (negateV v ^. _theta) # scale (len / m) @@ -364,14 +363,14 @@ arrowEnv opts len = getEnvelope horizShaft -- | @arrow len@ creates an arrow of length @len@ with default -- parameters, starting at the origin and ending at the point -- @(len,0)@. -arrow :: Renderable (Path R2) b => Double -> Diagram b R2 +arrow :: (R2Ish v, Renderable (Path v) b) => Scalar v -> Diagram b v arrow len = arrow' def len -- | @arrow' opts len@ creates an arrow of length @len@ using the -- given options, starting at the origin and ending at the point -- @(len,0)@. In particular, it scales the given 'arrowShaft' so -- that the entire arrow has length @len@. -arrow' :: Renderable (Path R2) b => ArrowOpts -> Double -> Diagram b R2 +arrow' :: (R2Ish v, Renderable (Path v) b) => ArrowOpts v -> Scalar v -> Diagram b v arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- Currently arrows have an empty envelope and trace. @@ -458,7 +457,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- | @arrowBetween s e@ creates an arrow pointing from @s@ to @e@ -- with default parameters. -arrowBetween :: Renderable (Path R2) b => P2 -> P2 -> Diagram b R2 +arrowBetween :: (R2Ish v, Renderable (Path v) b) => Point v -> Point v -> Diagram b v arrowBetween = arrowBetween' def -- | @arrowBetween' opts s e@ creates an arrow pointing from @s@ to @@ -466,18 +465,18 @@ arrowBetween = arrowBetween' def -- rotates @arrowShaft@ to go between @s@ and @e@, taking head, -- tail, and gaps into account. arrowBetween' - :: Renderable (Path R2) b => - ArrowOpts -> P2 -> P2 -> Diagram b R2 + :: (R2Ish v, Renderable (Path v) b) => + ArrowOpts v -> Point v -> Point v -> Diagram b v arrowBetween' opts s e = arrowAt' opts s (e .-. s) -- | Create an arrow starting at s with length and direction determined by -- the vector v. -arrowAt :: Renderable (Path R2) b => P2 -> R2 -> Diagram b R2 +arrowAt :: (R2Ish v, Renderable (Path v) b) => Point v -> v -> Diagram b v arrowAt s v = arrowAt' def s v arrowAt' - :: Renderable (Path R2) b => - ArrowOpts -> P2 -> R2 -> Diagram b R2 + :: (R2Ish v, Renderable (Path v) b) => + ArrowOpts v -> Point v -> v -> Diagram b v arrowAt' opts s v = arrow' opts len # rotate dir # moveTo s where @@ -487,26 +486,26 @@ arrowAt' opts s v = arrow' opts len -- | @arrowV v@ creates an arrow with the direction and magnitude of -- the vector @v@ (with its tail at the origin), using default -- parameters. -arrowV :: Renderable (Path R2) b => R2 -> Diagram b R2 +arrowV :: (R2Ish v, Renderable (Path v) b) => v -> Diagram b v arrowV = arrowV' def -- | @arrowV' v@ creates an arrow with the direction and magnitude of -- the vector @v@ (with its tail at the origin). arrowV' - :: Renderable (Path R2) b - => ArrowOpts -> R2 -> Diagram b R2 + :: (R2Ish v, Renderable (Path v) b) + => ArrowOpts v -> v -> Diagram b v arrowV' opts = arrowAt' opts origin -- | Connect two diagrams with a straight arrow. connect - :: (Renderable (Path R2) b, IsName n1, IsName n2) - => n1 -> n2 -> (Diagram b R2 -> Diagram b R2) + :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + => n1 -> n2 -> (Diagram b v -> Diagram b v) connect = connect' def -- | Connect two diagrams with an arbitrary arrow. connect' - :: (Renderable (Path R2) b, IsName n1, IsName n2) - => ArrowOpts -> n1 -> n2 -> (Diagram b R2 -> Diagram b R2) + :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + => ArrowOpts v -> n1 -> n2 -> (Diagram b v -> Diagram b v) connect' opts n1 n2 = withName n1 $ \sub1 -> withName n2 $ \sub2 -> @@ -516,15 +515,15 @@ connect' opts n1 n2 = -- | Connect two diagrams at point on the perimeter of the diagrams, choosen -- by angle. connectPerim - :: (Renderable (Path R2) b, IsName n1, IsName n2) - => n1 -> n2 -> Angle Double -> Angle Double - -> (Diagram b R2 -> Diagram b R2) + :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + => n1 -> n2 -> Angle (Scalar v) -> Angle (Scalar v) + -> (Diagram b v -> Diagram b v) connectPerim = connectPerim' def connectPerim' - :: (Renderable (Path R2) b, IsName n1, IsName n2) - => ArrowOpts -> n1 -> n2 -> Angle Double -> Angle Double - -> (Diagram b R2 -> Diagram b R2) + :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + => ArrowOpts v -> n1 -> n2 -> Angle (Scalar v) -> Angle (Scalar v) + -> (Diagram b v -> Diagram b v) connectPerim' opts n1 n2 a1 a2 = withName n1 $ \sub1 -> withName n2 $ \sub2 -> @@ -538,19 +537,19 @@ connectPerim' opts n1 n2 a1 a2 = -- drawn so that it stops at the boundaries of the diagrams, using traces -- to find the intersection points. connectOutside - :: (Renderable (Path R2) b, IsName n1, IsName n2) - => n1 -> n2 -> (Diagram b R2 -> Diagram b R2) + :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + => n1 -> n2 -> (Diagram b v -> Diagram b v) connectOutside = connectOutside' def connectOutside' - :: (Renderable (Path R2) b, IsName n1, IsName n2) - => ArrowOpts -> n1 -> n2 -> (Diagram b R2 -> Diagram b R2) + :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + => ArrowOpts v -> n1 -> n2 -> (Diagram b v -> Diagram b v) connectOutside' opts n1 n2 = withName n1 $ \b1 -> withName n2 $ \b2 -> let v = location b2 .-. location b1 - midpoint = location b1 .+^ (v/2) - s' = fromMaybe (location b1) $ traceP midpoint (-v) b1 + midpoint = location b1 .+^ (v ^/ 2) + s' = fromMaybe (location b1) $ traceP midpoint (negateV v) b1 e' = fromMaybe (location b2) $ traceP midpoint v b2 in atop (arrowBetween' opts s' e') diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index e611a93d..3950a840 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arrowheads @@ -81,9 +82,9 @@ import Diagrams.Util (( # )) ----------------------------------------------------------------------------- -type ArrowHT = Double -> Double -> (Path R2, Path R2) +type ArrowHT v = Scalar v -> Scalar v -> (Path v, Path v) -closedPath :: (Floating (Scalar v), Ord (Scalar v), InnerSpace v) => Trail v -> Path v +closedPath :: (R2Ish v) => (Floating (Scalar v), Ord (Scalar v), InnerSpace v) => Trail v -> Path v closedPath = pathFromTrail . closeTrail -- Heads ------------------------------------------------------------------ @@ -98,7 +99,7 @@ closedPath = pathFromTrail . closeTrail -- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 \@\@ turn) & shaftStyle %~ lw none) -- > origin (r2 (0.001, 0)) -- > <> square 0.6 # alignL # lw none -arrowheadTriangle :: Angle Double -> ArrowHT +arrowheadTriangle :: (R2Ish v) => Angle (Scalar v) -> ArrowHT v arrowheadTriangle theta = aHead where aHead len _ = (p, mempty) @@ -110,14 +111,14 @@ arrowheadTriangle theta = aHead -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. -arrowheadDart :: Angle Double -> ArrowHT +arrowheadDart :: (R2Ish v) => Angle (Scalar v) -> ArrowHT v arrowheadDart theta len shaftWidth = (hd # scale size, jt) where hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] jt = pathFromTrail . glueTrail $ j <> reflectY j - j = closeTrail $ fromOffsets [(-jLength ^& 0), (0 ^& shaftWidth / 2)] + j = closeTrail $ fromOffsets [((-jLength) ^& 0), (0 ^& (shaftWidth / 2))] v = rotate theta unitX - (t1, t2) = (unit_X ^+^ v, (-0.5 ^& 0) ^-^ v) + (t1, t2) = (unit_X ^+^ v, ((-0.5) ^& 0) ^-^ v) [b1, b2] = map (reflectY . negateV) [t1, t2] psi = pi - (direction . negateV $ t2) ^. _theta.rad jLength = shaftWidth / (2 * tan psi) @@ -126,7 +127,7 @@ arrowheadDart theta len shaftWidth = (hd # scale size, jt) size = max 1 ((len - jLength) / (1.5)) -- | Isoceles triangle with curved concave base. Inkscape type 2. -arrowheadSpike :: Angle Double -> ArrowHT +arrowheadSpike :: (R2Ish v) => Angle (Scalar v) -> ArrowHT v arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) where hd = snugL . closedPath $ l1 <> c <> l2 @@ -153,17 +154,17 @@ arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) phi = asinA (min 1 (y/r)) -- | Curved sides, linear concave base. Illustrator CS5 #3 -arrowheadThorn :: Angle Double -> ArrowHT +arrowheadThorn :: (R2Ish v) => Angle (Scalar v) -> ArrowHT v arrowheadThorn theta len shaftWidth = (hd # scale size, jt) where hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop hTop = closeTrail . trailFromSegments $ [c, l] jt = pathFromTrail . glueTrail $ j <> reflectY j - j = closeTrail $ fromOffsets [(-jLength ^& 0), (0 ^& shaftWidth / 2)] + j = closeTrail $ fromOffsets [((-jLength) ^& 0), (0 ^& (shaftWidth / 2))] c = curvedSide theta v = rotate theta unitX l = reverseSegment . straight $ t - t = v ^-^ (-0.5 ^& 0) + t = v ^-^ ((-0.5) ^& 0) psi = fullTurn ^/ 2 ^-^ (negateV t ^. _theta) jLength = shaftWidth / (2 * tanA psi) @@ -171,7 +172,7 @@ arrowheadThorn theta len shaftWidth = (hd # scale size, jt) size = max 1 ((len - jLength) / (1.5)) -- | Make a side for the thorn head. -curvedSide :: Angle Double -> Segment Closed R2 +curvedSide :: (R2Ish v) => Angle (Scalar v) -> Segment Closed v curvedSide theta = bezier3 ctrl1 ctrl2 end where v0 = unit_X @@ -182,34 +183,34 @@ curvedSide theta = bezier3 ctrl1 ctrl2 end -- Standard heads --------------------------------------------------------- -- | A line the same width as the shaft. -lineHead :: ArrowHT +lineHead :: (R2Ish v) => ArrowHT v lineHead s w = (square 1 # scaleX s # scaleY w # alignL, mempty) -noHead :: ArrowHT +noHead :: (R2Ish v) => ArrowHT v noHead _ _ = (mempty, mempty) -- | <> -- > triEx = drawHead tri -tri :: ArrowHT +tri :: (R2Ish v) => ArrowHT v tri = arrowheadTriangle (1/3 @@ turn) -- | <> -- > spikeEx = drawHead spike -spike :: ArrowHT +spike :: (R2Ish v) => ArrowHT v spike = arrowheadSpike (3/8 @@ turn) -- | <> -- > thornEx = drawHead thorn -thorn :: ArrowHT +thorn :: (R2Ish v) => ArrowHT v thorn = arrowheadThorn (3/8 @@ turn) -- | <> -- > dartEx = drawHead dart -dart :: ArrowHT +dart :: (R2Ish v) => ArrowHT v dart = arrowheadDart (2/5 @@ turn) -- Tails ------------------------------------------------------------------ @@ -219,7 +220,7 @@ dart = arrowheadDart (2/5 @@ turn) -- | Utility function to convert any arrowhead to an arrowtail, i.e. -- attached at the start of the trail. -headToTail :: ArrowHT -> ArrowHT +headToTail :: (R2Ish v) => ArrowHT v -> ArrowHT v headToTail hd = tl where tl size shaftWidth = (t, j) @@ -228,19 +229,19 @@ headToTail hd = tl t = reflectX t' j = reflectX j' -arrowtailBlock :: Angle Double -> ArrowHT +arrowtailBlock :: forall v. (R2Ish v) => Angle (Scalar v) -> ArrowHT v arrowtailBlock theta = aTail where aTail len _ = (t, mempty) where t = rect len (len * x) # alignR - a' :: R2 + a' :: v a' = rotate theta unitX a = a' ^-^ (reflectY a') x = magnitude a -- | The angle is where the top left corner intersects the circle. -arrowtailQuill :: Angle Double -> ArrowHT +arrowtailQuill :: (R2Ish v) => Angle (Scalar v) -> ArrowHT v arrowtailQuill theta = aTail where aTail len shaftWidth = (t, j) @@ -264,44 +265,44 @@ arrowtailQuill theta = aTail -- Standard tails --------------------------------------------------------- -- | A line the same width as the shaft. -lineTail :: ArrowHT +lineTail :: (R2Ish v) => ArrowHT v lineTail s w = (square 1 # scaleY w # scaleX s # alignR, mempty) -noTail :: ArrowHT +noTail :: (R2Ish v) => ArrowHT v noTail _ _ = (mempty, mempty) -- | <> -- > tri'Ex = drawTail tri' -tri' :: ArrowHT +tri' :: (R2Ish v) => ArrowHT v tri' = headToTail tri -- | <> -- > spike'Ex = drawTail spike' -spike' :: ArrowHT +spike' :: (R2Ish v) => ArrowHT v spike' = headToTail spike -- | <> -- > thorn'Ex = drawTail thorn' -thorn' :: ArrowHT +thorn' :: (R2Ish v) => ArrowHT v thorn' = headToTail thorn -- | <> -- > dart'Ex = drawTail dart' -dart' :: ArrowHT +dart' :: (R2Ish v) => ArrowHT v dart' = headToTail dart -- | <> -- > quillEx = drawTail quill -quill :: ArrowHT +quill :: (R2Ish v) => ArrowHT v quill = arrowtailQuill (2/5 @@ turn) -- | <> -- > blockEx = drawTail block -block :: ArrowHT +block :: (R2Ish v) => ArrowHT v block = arrowtailBlock (7/16 @@ turn) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 87cd3c8b..13d46185 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -88,10 +89,11 @@ import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup +import Data.VectorSpace -- | Standard 'Measures'. none, ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, - tiny, verySmall, small, normal, large, veryLarge, huge :: Measure R2 + tiny, verySmall, small, normal, large, veryLarge, huge :: (Floating d) => MeasureX d none = Output 0 ultraThin = Normalized 0.0005 `atLeast` Output 0.5 veryThin = Normalized 0.001 `atLeast` Output 0.5 @@ -115,48 +117,50 @@ huge = Normalized 0.10 -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. -newtype LineWidth = LineWidth (Last (Measure R2)) - deriving (Typeable, Data, Semigroup) -instance AttributeClass LineWidth +newtype LineWidth v = LineWidth (Last (Measure v)) + deriving (Typeable, Semigroup) -type instance V LineWidth = R2 +deriving instance (Data (Scalar v), Data v) => Data (LineWidth v) +instance (Typeable v) => AttributeClass (LineWidth v) -instance Transformable LineWidth where +type instance V (LineWidth v) = v + +instance (R2Ish v) => Transformable (LineWidth v) where transform t (LineWidth (Last w)) = - LineWidth (Last (transform t w)) + LineWidth (Last (transform (scaling (avgScale t)) w)) -instance Default LineWidth where +instance (R2Ish v) => Default (LineWidth v) where def = LineWidth (Last medium) -getLineWidth :: LineWidth -> Measure R2 +getLineWidth :: (R2Ish v) => LineWidth v -> Measure v getLineWidth (LineWidth (Last w)) = w -- | Set the line (stroke) width. -lineWidth :: (HasStyle a, V a ~ R2) => Measure R2 -> a -> a +lineWidth :: (R2Ish v, HasStyle a, V a ~ v) => Measure v -> a -> a lineWidth = applyGTAttr . LineWidth . Last -- | Apply a 'LineWidth' attribute. -lineWidthA :: (HasStyle a, V a ~ R2) => LineWidth -> a -> a +lineWidthA :: (R2Ish v, HasStyle a, V a ~ v) => LineWidth v -> a -> a lineWidthA = applyGTAttr -- | Default for 'lineWidth'. -lw :: (HasStyle a, V a ~ R2) => Measure R2 -> a -> a +lw :: (R2Ish v, HasStyle a, V a ~ v) => Measure v -> a -> a lw = lineWidth -- | A convenient synonym for 'lineWidth (Global w)'. -lwG :: (HasStyle a, V a ~ R2) => Double -> a -> a +lwG :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a lwG w = lineWidth (Global w) -- | A convenient synonym for 'lineWidth (Normalized w)'. -lwN :: (HasStyle a, V a ~ R2) => Double -> a -> a +lwN :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a lwN w = lineWidth (Normalized w) -- | A convenient synonym for 'lineWidth (Output w)'. -lwO :: (HasStyle a, V a ~ R2) => Double -> a -> a +lwO :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a lwO w = lineWidth (Output w) -- | A convenient sysnonym for 'lineWidth (Local w)'. -lwL :: (HasStyle a, V a ~ R2) => Double -> a -> a +lwL :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a lwL w = lineWidth (Local w) ----------------------------------------------------------------- @@ -164,49 +168,57 @@ lwL w = lineWidth (Local w) ----------------------------------------------------------------- -- | Create lines that are dashing... er, dashed. -data Dashing = Dashing [Measure R2] (Measure R2) - deriving (Typeable, Data, Eq) +data Dashing v = Dashing [Measure v] (Measure v) + deriving (Typeable) + +deriving instance (Data (Scalar v), Data v) => Data (Dashing v) +deriving instance Eq (Scalar v) => Eq (Dashing v) + +newtype DashingA v = DashingA (Last (Dashing v)) + deriving (Typeable, Semigroup) + +deriving instance (Data (Scalar v), Data v) => Data (DashingA v) +deriving instance Eq (Scalar v) => Eq (DashingA v) -newtype DashingA = DashingA (Last Dashing) - deriving (Typeable, Data, Semigroup, Eq) -instance AttributeClass DashingA +instance (Typeable v) => AttributeClass (DashingA v) -type instance V DashingA = R2 +type instance V (DashingA v) = v -instance Transformable DashingA where +instance (R2Ish v) => Transformable (DashingA v) where transform t (DashingA (Last (Dashing w v))) = DashingA (Last (Dashing r s)) where - r = map (transform t) w - s = transform t v + t' = scaling (avgScale t) + r = map (transform t') w + s = transform t' v -getDashing :: DashingA -> Dashing +getDashing :: (R2Ish v) => DashingA v -> Dashing v getDashing (DashingA (Last d)) = d -- | Set the line dashing style. -dashing :: (HasStyle a, V a ~ R2) => - [Measure R2] -- ^ A list specifying alternate lengths of on +dashing :: (R2Ish v, HasStyle a, V a ~ v) => + [Measure v] -- ^ A list specifying alternate lengths of on -- and off portions of the stroke. The empty -- list indicates no dashing. - -> Measure R2 -- ^ An offset into the dash pattern at which the + -> Measure v -- ^ An offset into the dash pattern at which the -- stroke should start. -> a -> a dashing ds offs = applyGTAttr (DashingA (Last (Dashing ds offs))) -- | A convenient synonym for 'dashing (Global w)'. -dashingG :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingG :: (R2Ish v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a dashingG w v = dashing (map Global w) (Global v) -- | A convenient synonym for 'dashing (Normalized w)'. -dashingN :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingN :: (R2Ish v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a dashingN w v = dashing (map Normalized w) (Normalized v) -- | A convenient synonym for 'dashing (Output w)'. -dashingO :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingO :: (R2Ish v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a dashingO w v = dashing (map Output w) (Output v) -- | A convenient sysnonym for 'dashing (Local w)'. -dashingL :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingL :: (R2Ish v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a dashingL w v = dashing (map Local w) (Local v) -- | A gradient stop contains a color and fraction (usually between 0 and 1) @@ -230,86 +242,86 @@ stopFraction :: Lens' GradientStop Double data SpreadMethod = GradPad | GradReflect | GradRepeat -- | Linear Gradient -data LGradient = LGradient +data LGradient v = LGradient { _lGradStops :: [GradientStop] - , _lGradStart :: P2 - , _lGradEnd :: P2 - , _lGradTrans :: T2 + , _lGradStart :: Point v + , _lGradEnd :: Point v + , _lGradTrans :: Transformation v , _lGradSpreadMethod :: SpreadMethod } makeLensesWith (lensRules & generateSignatures .~ False) ''LGradient -- | A list of stops (colors and fractions). -lGradStops :: Lens' LGradient [GradientStop] +lGradStops :: (R2Ish v) => Lens' (LGradient v) [GradientStop] -- | A transformation to be applied to the gradient. Usually this field will -- start as the identity transform and capture the transforms that are applied -- to the gradient. -lGradTrans :: Lens' LGradient T2 +lGradTrans :: (R2Ish v) => Lens' (LGradient v) (Transformation v) -- | The starting point for the first gradient stop. The coordinates are in -- 'Local' units and the default is (-0.5, 0). -lGradStart :: Lens' LGradient P2 +lGradStart :: (R2Ish v) => Lens' (LGradient v) (Point v) -- | The ending point for the last gradient stop.The coordinates are in -- 'Local' units and the default is (0.5, 0). -lGradEnd :: Lens' LGradient P2 +lGradEnd :: (R2Ish v) => Lens' (LGradient v) (Point v) -- | For setting the spread method. -lGradSpreadMethod :: Lens' LGradient SpreadMethod +lGradSpreadMethod :: (R2Ish v) => Lens' (LGradient v) SpreadMethod -- | Radial Gradient -data RGradient = RGradient +data RGradient v = RGradient { _rGradStops :: [GradientStop] - , _rGradCenter0 :: P2 - , _rGradRadius0 :: Double - , _rGradCenter1 :: P2 - , _rGradRadius1 :: Double - , _rGradTrans :: T2 + , _rGradCenter0 :: Point v + , _rGradRadius0 :: Scalar v + , _rGradCenter1 :: Point v + , _rGradRadius1 :: Scalar v + , _rGradTrans :: Transformation v , _rGradSpreadMethod :: SpreadMethod } makeLensesWith (lensRules & generateSignatures .~ False) ''RGradient -- | A list of stops (colors and fractions). -rGradStops :: Lens' RGradient [GradientStop] +rGradStops :: (R2Ish v) => Lens' (RGradient v) [GradientStop] -- | The center point of the inner circle. -rGradCenter0 :: Lens' RGradient P2 +rGradCenter0 :: (R2Ish v) => Lens' (RGradient v) (Point v) -- | The radius of the inner cirlce in 'Local' coordinates. -rGradRadius0 :: Lens' RGradient Double +rGradRadius0 :: (R2Ish v) => Lens' (RGradient v) (Scalar v) -- | The center of the outer circle. -rGradCenter1 :: Lens' RGradient P2 +rGradCenter1 :: (R2Ish v) => Lens' (RGradient v) (Point v) -- | The radius of the outer circle in 'Local' coordinates. -rGradRadius1 :: Lens' RGradient Double +rGradRadius1 :: (R2Ish v) => Lens' (RGradient v) (Scalar v) -- | A transformation to be applied to the gradient. Usually this field will -- start as the identity transform and capture the transforms that are applied -- to the gradient. -rGradTrans :: Lens' RGradient T2 +rGradTrans :: (R2Ish v) => Lens' (RGradient v) (Transformation v) -- | For setting the spread method. -rGradSpreadMethod :: Lens' RGradient SpreadMethod +rGradSpreadMethod :: (R2Ish v) => Lens' (RGradient v) SpreadMethod -- | A Texture is either a color 'SC', linear gradient 'LG', or radial gradient 'RG'. -- An object can have only one texture which is determined by the 'Last' -- semigroup structure. -data Texture = SC SomeColor | LG LGradient | RG RGradient +data Texture v = SC SomeColor | LG (LGradient v) | RG (RGradient v) deriving (Typeable) makePrisms ''Texture -- | Convert a solid colour into a texture. -solid :: Color a => a -> Texture +solid :: (R2Ish v) => Color a => a -> Texture v solid = SC . SomeColor -- | A default is provided so that linear gradients can easily be created using -- lenses. For example, @lg = defaultLG & lGradStart .~ (0.25 ^& 0.33)@. Note that -- no default value is provided for @lGradStops@, this must be set before -- the gradient value is used, otherwise the object will appear transparent. -defaultLG :: Texture +defaultLG :: (R2Ish v) => Texture v defaultLG = LG (LGradient { _lGradStops = [] , _lGradStart = mkP2 (-0.5) 0 @@ -322,7 +334,7 @@ defaultLG = LG (LGradient -- lenses. For example, @rg = defaultRG & rGradRadius1 .~ 0.25@. Note that -- no default value is provided for @rGradStops@, this must be set before -- the gradient value is used, otherwise the object will appear transparent. -defaultRG :: Texture +defaultRG :: (R2Ish v) => Texture v defaultRG = RG (RGradient { _rGradStops = [] , _rGradCenter0 = mkP2 0 0 @@ -341,15 +353,15 @@ mkStops = map (\(x, y, z) -> GradientStop (SomeColor (withOpacity x z)) y) -- | Make a linear gradient texture from a stop list, start point, end point, -- and 'SpreadMethod'. The 'lGradTrans' field is set to the identity -- transfrom, to change it use the 'lGradTrans' lens. -mkLinearGradient :: [GradientStop] -> P2 -> P2 -> SpreadMethod -> Texture +mkLinearGradient :: (R2Ish v) => [GradientStop] -> Point v -> Point v -> SpreadMethod -> Texture v mkLinearGradient stops start end spreadMethod = LG (LGradient stops start end mempty spreadMethod) -- | Make a radial gradient texture from a stop list, radius, start point, -- end point, and 'SpreadMethod'. The 'rGradTrans' field is set to the identity -- transfrom, to change it use the 'rGradTrans' lens. -mkRadialGradient :: [GradientStop] -> P2 -> Double - -> P2 -> Double -> SpreadMethod -> Texture +mkRadialGradient :: (R2Ish v) => [GradientStop] -> Point v -> Scalar v + -> Point v -> Scalar v -> SpreadMethod -> Texture v mkRadialGradient stops c0 r0 c1 r1 spreadMethod = RG (RGradient stops c0 r0 c1 r1 mempty spreadMethod) @@ -357,15 +369,15 @@ mkRadialGradient stops c0 r0 c1 r1 spreadMethod -- textures always override parent textures. -- More precisely, the semigroup structure on line texture attributes -- is that of 'Last'. -newtype LineTexture = LineTexture (Last Texture) +newtype LineTexture v = LineTexture (Last (Texture v)) deriving (Typeable, Semigroup) -instance AttributeClass LineTexture +instance (Typeable v) => AttributeClass (LineTexture v) -type instance V LineTexture = R2 +type instance V (LineTexture v) = v -- Only gradients get transformed. The transform is applied to the gradients -- transform field. Colors are left unchanged. -instance Transformable LineTexture where +instance (R2Ish v) => Transformable (LineTexture v) where transform t (LineTexture (Last texture)) = LineTexture (Last tx) where tx = texture & lgt . rgt @@ -373,22 +385,22 @@ instance Transformable LineTexture where rgt = _RG . rGradTrans %~ f f = transform t -instance Default LineTexture where +instance Default (LineTexture v) where def = LineTexture (Last (SC (SomeColor (black :: Colour Double)))) -getLineTexture :: LineTexture -> Texture +getLineTexture :: (R2Ish v) => LineTexture v -> Texture v getLineTexture (LineTexture (Last t)) = t -lineTexture :: (HasStyle a, V a ~ R2) => Texture-> a -> a +lineTexture :: (R2Ish v, HasStyle a, V a ~ v) => Texture v -> a -> a lineTexture = applyTAttr . LineTexture . Last -lineTextureA :: (HasStyle a, V a ~ R2) => LineTexture -> a -> a +lineTextureA :: (R2Ish v, HasStyle a, V a ~ v) => LineTexture v -> a -> a lineTextureA = applyTAttr -mkLineTexture :: Texture -> LineTexture +mkLineTexture :: (R2Ish v) => Texture v -> LineTexture v mkLineTexture = LineTexture . Last -styleLineTexture :: Setter' (Style v) Texture +styleLineTexture :: (R2Ish v) => Setter' (Style v) (Texture v) styleLineTexture = sets modifyLineTexture where modifyLineTexture f s @@ -404,41 +416,41 @@ styleLineTexture = sets modifyLineTexture -- 'AlphaColour'), but this can sometimes create problems for type -- inference, so the 'lc' and 'lcA' variants are provided with more -- concrete types. -lineColor :: (Color c, HasStyle a, V a ~ R2) => c -> a -> a +lineColor :: (R2Ish v, Color c, HasStyle a, V a ~ v) => c -> a -> a lineColor = lineTexture . SC . SomeColor -- | A synonym for 'lineColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). See comment in 'lineColor' about backends. -lc :: (HasStyle a, V a ~ R2) => Colour Double -> a -> a +lc :: (R2Ish v, HasStyle a, V a ~ v) => Colour Double -> a -> a lc = lineColor -- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). See comment in 'lineColor' -- about backends. -lcA :: (HasStyle a, V a ~ R2) => AlphaColour Double -> a -> a +lcA :: (R2Ish v, HasStyle a, V a ~ v) => AlphaColour Double -> a -> a lcA = lineColor -- | Apply a linear gradient. -lineLGradient :: (HasStyle a, V a ~ R2) => LGradient -> a -> a +lineLGradient :: (R2Ish v, HasStyle a, V a ~ v) => LGradient v -> a -> a lineLGradient g = lineTexture (LG g) -- | Apply a radial gradient. -lineRGradient :: (HasStyle a, V a ~ R2) => RGradient -> a -> a +lineRGradient :: (R2Ish v, HasStyle a, V a ~ v) => RGradient v -> a -> a lineRGradient g = lineTexture (RG g) -- | The texture with which objects are filled. -- The semigroup structure on fill texture attributes -- is that of 'Recommed . Last'. -newtype FillTexture = FillTexture (Recommend (Last Texture)) +newtype FillTexture v = FillTexture (Recommend (Last (Texture v))) deriving (Typeable, Semigroup) -instance AttributeClass FillTexture +instance (Typeable v) => AttributeClass (FillTexture v) -type instance V FillTexture = R2 +type instance V (FillTexture v) = v -- Only gradients get transformed. The transform is applied to the gradients -- transform field. Colors are left unchanged. -instance Transformable FillTexture where +instance (R2Ish v) => Transformable (FillTexture v) where transform _ tx@(FillTexture (Recommend _)) = tx transform t (FillTexture (Commit (Last texture))) = FillTexture (Commit (Last tx)) where @@ -447,20 +459,20 @@ instance Transformable FillTexture where rgt = _RG . rGradTrans %~ f f = transform t -instance Default FillTexture where +instance (R2Ish v) => Default (FillTexture v) where def = FillTexture (Recommend (Last (SC (SomeColor (transparent :: AlphaColour Double))))) -getFillTexture :: FillTexture -> Texture +getFillTexture :: (R2Ish v) => FillTexture v -> Texture v getFillTexture (FillTexture tx) = getLast . getRecommend $ tx -fillTexture :: (HasStyle a, V a ~ R2) => Texture -> a -> a +fillTexture :: (R2Ish v, HasStyle a, V a ~ v) => Texture v -> a -> a fillTexture = applyTAttr . FillTexture . Commit . Last -mkFillTexture :: Texture -> FillTexture +mkFillTexture :: (R2Ish v) => Texture v -> FillTexture v mkFillTexture = FillTexture . Commit . Last -styleFillTexture :: Setter' (Style v) Texture +styleFillTexture :: (R2Ish v) => Setter' (Style v) (Texture v) styleFillTexture = sets modifyFillTexture where modifyFillTexture f s @@ -475,31 +487,31 @@ styleFillTexture = sets modifyFillTexture -- type (so it can be used with either 'Colour' or 'AlphaColour'), -- but this can sometimes create problems for type inference, so the -- 'fc' and 'fcA' variants are provided with more concrete types. -fillColor :: (Color c, HasStyle a, V a ~ R2) => c -> a -> a +fillColor :: (R2Ish v, Color c, HasStyle a, V a ~ v) => c -> a -> a fillColor = fillTexture . SC . SomeColor -- | Set a \"recommended\" fill color, to be used only if no explicit -- calls to 'fillColor' (or 'fc', or 'fcA') are used. -- See comment after 'fillColor' about backends. -recommendFillColor :: (Color c, HasStyle a, V a ~ R2) => c -> a -> a +recommendFillColor :: (R2Ish v, Color c, HasStyle a, V a ~ v) => c -> a -> a recommendFillColor = applyTAttr . FillTexture . Recommend . Last . SC . SomeColor -- | A synonym for 'fillColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). See comment after 'fillColor' about backends. -fc :: (HasStyle a, V a ~ R2) => Colour Double -> a -> a +fc :: (R2Ish v, HasStyle a, V a ~ v) => Colour Double -> a -> a fc = fillColor -- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). See comment after 'fillColor' about backends. -fcA :: (HasStyle a, V a ~ R2) => AlphaColour Double -> a -> a +fcA :: (R2Ish v, HasStyle a, V a ~ v) => AlphaColour Double -> a -> a fcA = fillColor ------------------------------------------------------------ data FillTextureLoops v = FillTextureLoops instance Typeable v => SplitAttribute (FillTextureLoops v) where - type AttrType (FillTextureLoops v) = FillTexture + type AttrType (FillTextureLoops v) = FillTexture v type PrimType (FillTextureLoops v) = Path v primOK _ = all (isLoop . unLoc) . pathTrails diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index c4e5bb55..207b34da 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Combinators @@ -78,7 +79,7 @@ infixl 6 ||| -- combined diagram is the same as the local origin of the first. -- @(===)@ is associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. -(===) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a +(===) :: (Juxtaposable a, V a ~ v, R2Ish v, Semigroup a) => a -> a -> a (===) = beside (negateV unitY) -- | Place two diagrams (or other juxtaposable objects) horizontally @@ -87,7 +88,7 @@ infixl 6 ||| -- is the same as the local origin of the first. @(|||)@ is -- associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. -(|||) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a +(|||) :: (Juxtaposable a, V a ~ v, R2Ish v, Semigroup a) => a -> a -> a (|||) = beside unitX -- | Lay out a list of juxtaposable objects in a row from left to right, @@ -101,15 +102,15 @@ infixl 6 ||| -- "Diagrams.TwoD.Align" before applying 'hcat'. -- -- * For non-axis-aligned layout, see 'cat'. -hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) +hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) => [a] -> a hcat = hcat' def -- | A variant of 'hcat' taking an extra 'CatOpts' record to control -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. -hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) - => CatOpts R2 -> [a] -> a +hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) + => CatOpts v -> [a] -> a hcat' = cat' unitX -- | Lay out a list of juxtaposable objects in a column from top to @@ -123,15 +124,15 @@ hcat' = cat' unitX -- "Diagrams.TwoD.Align" before applying 'vcat'. -- -- * For non-axis-aligned layout, see 'cat'. -vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) +vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) => [a] -> a vcat = vcat' def -- | A variant of 'vcat' taking an extra 'CatOpts' record to control -- the spacing. See the 'cat'' documentation for a description of the -- possibilities. -vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) - => CatOpts R2 -> [a] -> a +vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) + => CatOpts v -> [a] -> a vcat' = cat' (negateV unitY) -- | @strutR2 v@ is a two-dimensional diagram which produces no @@ -140,7 +141,7 @@ vcat' = cat' (negateV unitY) -- local origin at its center. If you don't care about the trace -- then there's no difference between @strutR2@ and the more general -- 'strut'. -strutR2 :: (Backend b R2, Monoid' m) => R2 -> QDiagram b R2 m +strutR2 :: (Backend b v, Monoid' m, R2Ish v) => v -> QDiagram b v m strutR2 v = phantom seg where seg = FLinear (origin .+^ 0.5 *^ v) (origin .+^ (-0.5) *^ v) @@ -148,13 +149,13 @@ strutR2 v = phantom seg -- | @strutX w@ is an empty diagram with width @w@, height 0, and a -- centered local origin. Note that @strutX (-w)@ behaves the same as -- @strutX w@. -strutX :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m +strutX :: (Backend b v, Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m strutX d = strut (d ^& 0) -- | @strutY h@ is an empty diagram with height @h@, width 0, and a -- centered local origin. Note that @strutY (-h)@ behaves the same as -- @strutY h@. -strutY :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m +strutY :: (Backend b v, Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m strutY d = strut (0 ^& d) -- | @padX s@ \"pads\" a diagram in the x-direction, expanding its @@ -164,8 +165,8 @@ strutY d = strut (0 ^& d) -- centered horizontally the padding may appear \"uneven\". If this -- is not desired, the origin can be centered (using 'centerX') -- before applying @padX@. -padX :: ( Backend b R2, Monoid' m ) - => Double -> QDiagram b R2 m -> QDiagram b R2 m +padX :: ( Backend b v, Monoid' m, R2Ish v ) + => Scalar v -> QDiagram b v m -> QDiagram b v m padX s d = withEnvelope (d # scaleX s) d -- | @padY s@ \"pads\" a diagram in the y-direction, expanding its @@ -175,8 +176,8 @@ padX s d = withEnvelope (d # scaleX s) d -- so if the origin is not centered vertically the padding may appear -- \"uneven\". If this is not desired, the origin can be centered -- (using 'centerY') before applying @padY@. -padY :: ( Backend b R2, Monoid' m ) - => Double -> QDiagram b R2 m -> QDiagram b R2 m +padY :: ( Backend b v, Monoid' m, R2Ish v ) + => Scalar v -> QDiagram b v m -> QDiagram b v m padY s d = withEnvelope (d # scaleY s) d -- | @extrudeLeft s@ \"extrudes\" a diagram in the negative x-direction, @@ -184,7 +185,7 @@ padY s d = withEnvelope (d # scaleY s) d -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeLeft :: Monoid' m => Double -> QDiagram b R2 m -> QDiagram b R2 m +extrudeLeft :: (Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m -> QDiagram b v m extrudeLeft s | s >= 0 = extrudeEnvelope $ unitX ^* negate s | otherwise = intrudeEnvelope $ unitX ^* negate s @@ -194,7 +195,7 @@ extrudeLeft s -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeRight :: Monoid' m => Double -> QDiagram b R2 m -> QDiagram b R2 m +extrudeRight :: (Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m -> QDiagram b v m extrudeRight s | s >= 0 = extrudeEnvelope $ unitX ^* s | otherwise = intrudeEnvelope $ unitX ^* s @@ -204,7 +205,7 @@ extrudeRight s -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeBottom :: Monoid' m => Double -> QDiagram b R2 m -> QDiagram b R2 m +extrudeBottom :: (Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m -> QDiagram b v m extrudeBottom s | s >= 0 = extrudeEnvelope $ unitY ^* negate s | otherwise = intrudeEnvelope $ unitY ^* negate s @@ -214,7 +215,7 @@ extrudeBottom s -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeTop :: Monoid' m => Double -> QDiagram b R2 m -> QDiagram b R2 m +extrudeTop :: (Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m -> QDiagram b v m extrudeTop s | s >= 0 = extrudeEnvelope $ unitY ^* s | otherwise = intrudeEnvelope $ unitY ^* s @@ -224,19 +225,19 @@ extrudeTop s -- .+^ v@. Useful for selecting the rectangular portion of a -- diagram which should actually be \"viewed\" in the final render, -- if you don't want to see the entire diagram. -view :: ( Backend b R2, Monoid' m ) - => P2 -> R2 -> QDiagram b R2 m -> QDiagram b R2 m -view p (coords -> w :& h) = withEnvelope (rect w h # alignBL # moveTo p :: D R2) +view :: forall v b m. ( Backend b v, Monoid' m, R2Ish v ) + => Point v -> v -> QDiagram b v m -> QDiagram b v m +view p (coords -> w :& h) = withEnvelope (rect w h # alignBL # moveTo p :: D v) -- | Construct a bounding rectangle for an enveloped object, that is, -- the smallest axis-aligned rectangle which encloses the object. -boundingRect :: ( Enveloped t, Transformable t, TrailLike t, Monoid t, V t ~ R2 - , Enveloped a, V a ~ R2 +boundingRect :: ( Enveloped t, Transformable t, TrailLike t, Monoid t, V t ~ v + , Enveloped a, V a ~ v, R2Ish v ) => a -> t boundingRect = (`boxFit` rect 1 1) . boundingBox -- | \"Set the background color\" of a diagram. That is, place a -- diagram atop a bounding rectangle of the given color. -bg :: (Renderable (Path R2) b) => Colour Double -> Diagram b R2 -> Diagram b R2 +bg :: (R2Ish v, Renderable (Path v) b) => Colour Double -> Diagram b v -> Diagram b v bg c d = d <> boundingRect d # lineWidth (Output 0) # fc c diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs index ed1b6836..09031749 100644 --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -17,7 +17,6 @@ module Diagrams.TwoD.Curvature , radiusOfCurvature , squaredCurvature , squaredRadiusOfCurvature - , YetMoreLikeR2 ) where import Data.Monoid.Inf @@ -30,8 +29,6 @@ import Diagrams.Segment import Diagrams.Tangent import Diagrams.TwoD.Types -type YetMoreLikeR2 v = (MoreLikeR2 v, Scalar (Scalar v) ~ Scalar v, RealFloat (Scalar v), VectorSpace (Scalar v)) - -- | Curvature measures how curved the segment is at a point. One intuition -- for the concept is how much you would turn the wheel when driving a car -- along the curve. When the wheel is held straight there is zero curvature. @@ -106,7 +103,7 @@ type YetMoreLikeR2 v = (MoreLikeR2 v, Scalar (Scalar v) ~ Scalar v, RealFloat (S -- > vpr = r2 (normalized vp ^* r) -- > -- -curvature :: (YetMoreLikeR2 v) +curvature :: (R2Ish v) => Segment Closed v -- ^ Segment to measure on. -> Scalar v -- ^ Parameter to measure at. -> PosInf (Scalar v) -- ^ Result is a @PosInf@ value where @PosInfty@ represents @@ -116,12 +113,12 @@ curvature s = toPosInf . second sqrt . curvaturePair (fmap unr2 s) -- TODO: Use -- | With @squaredCurvature@ we can compute values in spaces that do not support -- 'sqrt' and it is just as useful for relative ordering of curvatures or looking -- for zeros. -squaredCurvature :: (YetMoreLikeR2 v) => Segment Closed v -> Scalar v -> PosInf (Scalar v) +squaredCurvature :: (R2Ish v) => Segment Closed v -> Scalar v -> PosInf (Scalar v) squaredCurvature s = toPosInf . first (join (*)) . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 -- | Reciprocal of @curvature@. -radiusOfCurvature :: (YetMoreLikeR2 v) +radiusOfCurvature :: (R2Ish v) => Segment Closed v -- ^ Segment to measure on. -> Scalar v -- ^ Parameter to measure at. -> PosInf (Scalar v) -- ^ Result is a @PosInf@ value where @PosInfty@ represents @@ -129,7 +126,7 @@ radiusOfCurvature :: (YetMoreLikeR2 v) radiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . second sqrt . curvaturePair (fmap unr2 s) -- | Reciprocal of @squaredCurvature@ -squaredRadiusOfCurvature :: (YetMoreLikeR2 v) => Segment Closed v -> Scalar v -> PosInf (Scalar v) +squaredRadiusOfCurvature :: (R2Ish v) => Segment Closed v -> Scalar v -> PosInf (Scalar v) squaredRadiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . first (join (*)) . curvaturePair (fmap unr2 s) diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs index c324ce69..5718ec6e 100644 --- a/src/Diagrams/TwoD/Deform.hs +++ b/src/Diagrams/TwoD/Deform.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} module Diagrams.TwoD.Deform where import Control.Lens @@ -8,29 +9,29 @@ import Diagrams.Coordinates import Diagrams.TwoD.Types -- | The parallel projection onto the line x=0 -parallelX0 :: Deformation R2 +parallelX0 :: (R2Ish v) => Deformation v parallelX0 = Deformation (& _x .~ 0) -- | The perspective division onto the line x=1 along lines going -- through the origin. -perspectiveX1 :: Deformation R2 +perspectiveX1 :: (R2Ish v) => Deformation v perspectiveX1 = Deformation (\p -> p & _y //~ (p^._x) & _x .~ 1) -- | The parallel projection onto the line y=0 -parallelY0 :: Deformation R2 +parallelY0 :: (R2Ish v) => Deformation v parallelY0 = Deformation (& _y .~ 0) -- | The perspective division onto the line y=1 along lines going -- through the origin. -perspectiveY1 :: Deformation R2 +perspectiveY1 :: (R2Ish v) => Deformation v perspectiveY1 = Deformation (\p -> p & _x //~ (p^._y) & _y .~ 1) -- | The viewing transform for a viewer facing along the positive X -- axis. X coördinates stay fixed, while Y coördinates are compressed -- with increasing distance. @asDeformation (translation unitX) <> -- parallelX0 <> frustrumX = perspectiveX1@ -facingX :: Deformation R2 +facingX :: (R2Ish v) => Deformation v facingX = Deformation (\v -> v & _y //~ (v^._x)) -facingY :: Deformation R2 +facingY :: (R2Ish v) => Deformation v facingY = Deformation (\v -> v & _x //~ (v^._y)) diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index 6a21baa4..d29ad9d2 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -36,18 +36,18 @@ import Diagrams.Util import Data.VectorSpace -- | A circle of radius 1, with center at the origin. -unitCircle :: (TrailLike t, ExtraLikeR2 (V t)) => t +unitCircle :: (TrailLike t, R2Ish (V t)) => t unitCircle = trailLike $ glueTrail (arcT xDir fullTurn) `at` (p2 (1,0)) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). -circle :: (TrailLike t, ExtraLikeR2 (V t), Transformable t) => Scalar (V t) -> t +circle :: (TrailLike t, R2Ish (V t), Transformable t) => Scalar (V t) -> t circle d = unitCircle # scale d -- | @ellipse e@ constructs an ellipse with eccentricity @e@ by -- scaling the unit circle in the X direction. The eccentricity must -- be within the interval [0,1). -ellipse :: (TrailLike t, ExtraLikeR2 (V t), Transformable t) => Scalar (V t) -> t +ellipse :: (TrailLike t, R2Ish (V t), Transformable t) => Scalar (V t) -> t ellipse e | e >= 0 && e < 1 = scaleX (sqrt (1 - e*e)) unitCircle | otherwise = error "Eccentricity of ellipse must be >= 0 and < 1." @@ -55,5 +55,5 @@ ellipse e -- | @ellipseXY x y@ creates an axis-aligned ellipse, centered at the -- origin, with radius @x@ along the x-axis and radius @y@ along the -- y-axis. -ellipseXY :: (TrailLike t, ExtraLikeR2 (V t), Transformable t) => Scalar (V t) -> Scalar (V t) -> t +ellipseXY :: (TrailLike t, R2Ish (V t), Transformable t) => Scalar (V t) -> Scalar (V t) -> t ellipseXY x y = unitCircle # scaleX x # scaleY y diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs index 0fe4d6d7..ddcdd99a 100644 --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -4,6 +4,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Image @@ -14,7 +16,7 @@ -- Importing external images into diagrams. -- Usage: To create a diagram from an embedded image with width 1 and height -- set according to the aspect ratio: 'image img # scaleUToX 1` --- where 'img' is a 'DImage Embedded' +-- where 'img' is a 'DImage v Embedded' ----------------------------------------------------------------------------- module Diagrams.TwoD.Image @@ -39,7 +41,6 @@ import Data.Colour (AlphaColour) import Diagrams.Core import Diagrams.Attributes (colorToSRGBA) -import Diagrams.Path import Diagrams.TwoD.Path import Diagrams.TwoD.Shapes import Diagrams.TwoD.Types @@ -61,30 +62,30 @@ data ImageData :: * -> * where -- Will typically be created by @loadImageEmb@ or @loadImageExt@ which, -- will handle setting the width and heigh to the actual width and height -- of the image. -data DImage :: * -> * where - DImage :: ImageData t -> Int -> Int -> T2 -> DImage t +data DImage :: * -> * -> * where + DImage :: ImageData t -> Int -> Int -> Transformation v -> DImage v t deriving Typeable -type instance V (DImage a) = R2 +type instance V (DImage v a) = v -instance Transformable (DImage a) where +instance (R2Ish v) => Transformable (DImage v a) where transform t1 (DImage iD w h t2) = DImage iD w h (t1 <> t2) -instance HasOrigin (DImage a) where +instance (R2Ish v) => HasOrigin (DImage v a) where moveOriginTo p = translate (origin .-. p) -- | Make a 'DImage' into a 'Diagram'. -image :: (Typeable a, Renderable (DImage a) b) => DImage a -> Diagram b R2 +image :: (Typeable a, Renderable (DImage v a) b, R2Ish v) => DImage v a -> Diagram b v image img = mkQD (Prim (img)) (getEnvelope r) (getTrace r) mempty (Query $ \p -> Any (isInsideEvenOdd p r)) where - r :: Path R2 + -- r :: Path v r = rect (fromIntegral w) (fromIntegral h) DImage _ w h _ = img -- | Use JuicyPixels to read an image in any format and wrap it in a 'DImage'. -- The width and height of the image are set to their actual values. -loadImageEmb :: FilePath -> IO (Either String (DImage Embedded)) +loadImageEmb :: (R2Ish v) => FilePath -> IO (Either String (DImage v Embedded)) loadImageEmb path = do dImg <- readImage path return $ case dImg of @@ -97,7 +98,7 @@ loadImageEmb path = do -- | Check that a file exists, and use JuicyPixels to figure out -- the right size, but save a reference to the image instead -- of the raster data -loadImageExt :: FilePath -> IO (Either String (DImage External)) +loadImageExt :: (R2Ish v) => FilePath -> IO (Either String (DImage v External)) loadImageExt path = do dImg <- readImage path return $ case dImg of @@ -110,16 +111,16 @@ loadImageExt path = do -- | Make an "unchecked" image reference; have to specify a -- width and height. Unless the aspect ratio of the external -- image is the w :: h, then the image will be distorted. -uncheckedImageRef :: FilePath -> Int -> Int -> DImage External +uncheckedImageRef :: (R2Ish v) => FilePath -> Int -> Int -> DImage v External uncheckedImageRef path w h = DImage (ImageRef path) w h mempty -- | Crate a diagram from raw raster data. -rasterDia :: Renderable (DImage Embedded) b - => (Int -> Int -> AlphaColour Double) -> Int -> Int -> Diagram b R2 +rasterDia :: (Renderable (DImage v Embedded) b, R2Ish v) + => (Int -> Int -> AlphaColour Double) -> Int -> Int -> Diagram b v rasterDia f w h = image $ raster f w h -- | Create an image "from scratch" by specifying the pixel data -raster :: (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage Embedded +raster :: (R2Ish v) => (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage v Embedded raster f w h = DImage (ImageRaster (ImageRGBA8 img)) w h mempty where img = generateImage g w h @@ -132,5 +133,5 @@ fromAlphaColour c = PixelRGBA8 r g b a (r', g', b', a') = colorToSRGBA c int x = round (255 * x) -instance Renderable (DImage a) NullBackend where +instance (R2Ish v) => Renderable (DImage v a) NullBackend where render _ _ = mempty diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs index d2a30e56..37b23dda 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, ConstraintKinds, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Model @@ -36,7 +36,7 @@ import Control.Arrow (second) import Data.AffineSpace ((.-.)) import Data.Default.Class import Data.Semigroup -import Data.VectorSpace ((^*)) +import Data.VectorSpace ((^*),Scalar) import qualified Data.Map as M @@ -47,25 +47,25 @@ import Data.Colour.Names -- Marking the origin ------------------------------------------------------------ -data OriginOpts = OriginOpts { _oColor :: Colour Double - , _oScale :: Double - , _oMinSize :: Double +data OriginOpts d = OriginOpts { _oColor :: Colour Double + , _oScale :: d + , _oMinSize :: d } makeLenses ''OriginOpts -instance Default OriginOpts where +instance (Fractional d) => Default (OriginOpts d) where def = OriginOpts red (1/50) 0.001 -- | Mark the origin of a diagram by placing a red dot 1/50th its size. -showOrigin :: (Renderable (Path R2) b, Backend b R2, Monoid' m) - => QDiagram b R2 m -> QDiagram b R2 m +showOrigin :: (Renderable (Path v) b, R2Ish v, Backend b v, Monoid' m) + => QDiagram b v m -> QDiagram b v m showOrigin = showOrigin' def -- | Mark the origin of a diagram, with control over colour and scale -- of marker dot. -showOrigin' :: (Renderable (Path R2) b, Backend b R2, Monoid' m) - => OriginOpts -> QDiagram b R2 m -> QDiagram b R2 m +showOrigin' :: (Renderable (Path v) b, R2Ish v, Backend b v, Monoid' m) + => OriginOpts (Scalar v) -> QDiagram b v m -> QDiagram b v m showOrigin' oo d = o <> d where o = stroke (circle sz) # fc (oo^.oColor) @@ -78,8 +78,8 @@ showOrigin' oo d = o <> d -- Labeling named points ------------------------------------------------------------ -showLabels :: (Renderable Text b, Backend b R2, Semigroup m) - => QDiagram b R2 m -> QDiagram b R2 Any +showLabels :: (Renderable (Text v) b, R2Ish v, Backend b v, Semigroup m) + => QDiagram b v m -> QDiagram b v Any showLabels d = ( mconcat . map (\(n,p) -> text (show n) # translate (p .-. origin)) diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index ba5f8361..4c267570 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -3,6 +3,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Offset @@ -65,12 +67,12 @@ import Diagrams.TwoD.Path () import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (perp) -unitPerp :: R2 -> R2 +unitPerp :: (R2Ish v) => v -> v unitPerp = normalized . perp -perpAtParam :: Segment Closed R2 -> Double -> R2 -perpAtParam (Linear (OffsetClosed a)) _ = -unitPerp a -perpAtParam s@(Cubic _ _ _) t = -unitPerp a +perpAtParam :: (R2Ish v) => Segment Closed v -> Scalar v -> v +perpAtParam (Linear (OffsetClosed a)) _ = negateV $ unitPerp a +perpAtParam s@(Cubic _ _ _) t = negateV $ unitPerp a where (Cubic a _ _) = snd $ splitAtParam s t @@ -103,59 +105,63 @@ perpAtParam s@(Cubic _ _ _) t = -unitPerp a -- | Options for specifying line join and segment epsilon for an offset -- involving multiple segments. -data OffsetOpts = OffsetOpts +data OffsetOpts d = OffsetOpts { _offsetJoin :: LineJoin - , _offsetMiterLimit :: Double - , _offsetEpsilon :: Double - } deriving (Eq, Show) + , _offsetMiterLimit :: d + , _offsetEpsilon :: d + } + +deriving instance Eq d => Eq (OffsetOpts d) +deriving instance Show d => Show (OffsetOpts d) makeLensesWith (lensRules & generateSignatures .~ False) ''OffsetOpts -- | Specifies the style of join for between adjacent offset segments. -offsetJoin :: Lens' OffsetOpts LineJoin +offsetJoin :: Lens' (OffsetOpts d) LineJoin -- | Specifies the miter limit for the join. -offsetMiterLimit :: Lens' OffsetOpts Double +offsetMiterLimit :: Lens' (OffsetOpts d) d -- | Epsilon perimeter for 'offsetSegment'. -offsetEpsilon :: Lens' OffsetOpts Double +offsetEpsilon :: Lens' (OffsetOpts d) d -- | The default offset options use the default 'LineJoin' ('LineJoinMiter'), a -- miter limit of 10, and epsilon factor of 0.01. -instance Default OffsetOpts where +instance (Fractional d) => Default (OffsetOpts d) where def = OffsetOpts def 10 0.01 -- | Options for specifying how a 'Trail' should be expanded. -data ExpandOpts = ExpandOpts +data ExpandOpts d = ExpandOpts { _expandJoin :: LineJoin - , _expandMiterLimit :: Double + , _expandMiterLimit :: d , _expandCap :: LineCap - , _expandEpsilon :: Double + , _expandEpsilon :: d } deriving (Eq, Show) makeLensesWith (lensRules & generateSignatures .~ False) ''ExpandOpts -- | Specifies the style of join for between adjacent offset segments. -expandJoin :: Lens' ExpandOpts LineJoin +expandJoin :: Lens' (ExpandOpts d) LineJoin -- | Specifies the miter limit for the join. -expandMiterLimit :: Lens' ExpandOpts Double +expandMiterLimit :: Lens' (ExpandOpts d) d -- | Specifies how the ends are handled. -expandCap :: Lens' ExpandOpts LineCap +expandCap :: Lens' (ExpandOpts d) LineCap -- | Epsilon perimeter for 'offsetSegment'. -expandEpsilon :: Lens' ExpandOpts Double +expandEpsilon :: Lens' (ExpandOpts d) d -- | The default 'ExpandOpts' is the default 'LineJoin' ('LineJoinMiter'), -- miter limit of 10, default 'LineCap' ('LineCapButt'), and epsilon factor -- of 0.01. -instance Default ExpandOpts where +instance (Fractional d) => Default (ExpandOpts d) where def = ExpandOpts def 10 def 0.01 -offsetSegment :: Double -- ^ Epsilon factor that when multiplied to the +offsetSegment :: (R2Ish v) + => Scalar v -- ^ Epsilon factor that when multiplied to the -- absolute value of the radius gives a -- value that represents the maximum -- allowed deviation from the true offset. In @@ -163,20 +169,20 @@ offsetSegment :: Double -- ^ Epsilon factor that when multiplied to the -- should be bounded by arcs that are plus or -- minus epsilon factor from the radius of curvature of -- the offset. - -> Double -- ^ Offset from the original segment, positive is + -> Scalar v -- ^ Offset from the original segment, positive is -- on the right of the curve, negative is on the -- left. - -> Segment Closed R2 -- ^ Original segment - -> Located (Trail R2) -- ^ Resulting located (at the offset) trail. + -> Segment Closed v -- ^ Original segment + -> Located (Trail v) -- ^ Resulting located (at the offset) trail. offsetSegment _ r s@(Linear (OffsetClosed a)) = trailFromSegments [s] `at` origin .+^ va - where va = -r *^ unitPerp a + where va = (-r) *^ unitPerp a offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va where t = trailFromSegments (go (radiusOfCurvature s 0.5)) -- Perpendiculars to handles. - va = -r *^ unitPerp a - vc = -r *^ unitPerp (c ^-^ b) + va = (-r) *^ unitPerp a + vc = (-r) *^ unitPerp (c ^-^ b) -- Split segments. ss = (\(x,y) -> [x,y]) $ splitAtParam s 0.5 subdivided = concatMap (trailSegments . unLoc . offsetSegment epsilon r) ss @@ -209,7 +215,7 @@ offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va -- > import Diagrams.TwoD.Offset -- > --- > showExample :: Segment Closed R2 -> Diagram SVG R2 +-- > showExample :: (R2Ish v) => Segment Closed v -> Diagram SVG v -- > showExample s = pad 1.1 . centerXY $ d # lc blue # lw 0.1 <> d' # lw 0.1 -- > where -- > d = stroke . fromSegments $ [s] @@ -218,7 +224,7 @@ offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va -- > -- > colors = cycle [green, red] -- > --- > cubicOffsetExample :: Diagram SVG R2 +-- > cubicOffsetExample :: (R2Ish v) => Diagram SVG v -- > cubicOffsetExample = hcat . map showExample $ -- > [ bezier3 (10 ^& 0) ( 5 ^& 18) (10 ^& 20) -- > , bezier3 ( 0 ^& 20) ( 10 ^& 10) ( 5 ^& 10) @@ -236,9 +242,9 @@ bindLoc f = join' . mapLoc f where join' (viewLoc -> (p,a)) = translate (p .-. origin) a --- While we build offsets and expansions we will use the [Located (Segment Closed R2)] --- and [Located (Trail R2)] intermediate representations. -locatedTrailSegments :: (InnerSpace v, OrderedField (Scalar v)) +-- While we build offsets and expansions we will use the [Located (Segment Closed v)] +-- and [Located (Trail v)] intermediate representations. +locatedTrailSegments :: (R2Ish v, InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [Located (Segment Closed v)] locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailVertices t) @@ -260,12 +266,13 @@ locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailVertices t) -- -- <> -- -offsetTrail' :: OffsetOpts - -> Double -- ^ Radius of offset. A negative value gives an offset on - -- the left for a line and on the inside for a counter-clockwise - -- loop. - -> Located (Trail R2) - -> Located (Trail R2) +offsetTrail' :: (R2Ish v) + => OffsetOpts (Scalar v) + -> Scalar v -- ^ Radius of offset. A negative value gives an offset on + -- the left for a line and on the inside for a counter-clockwise + -- loop. + -> Located (Trail v) + -> Located (Trail v) offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r ends . offset $ t where eps = opts^.offsetEpsilon @@ -277,17 +284,17 @@ offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r end isLoop = withTrail (const False) (const True) (unLoc t) -- | Offset a 'Trail' with the default options and a given radius. See 'offsetTrail''. -offsetTrail :: Double -> Located (Trail R2) -> Located (Trail R2) +offsetTrail :: (R2Ish v) => Scalar v -> Located (Trail v) -> Located (Trail v) offsetTrail = offsetTrail' def -- | Offset a 'Path' by applying 'offsetTrail'' to each trail in the path. -offsetPath' :: OffsetOpts -> Double -> Path R2 -> Path R2 +offsetPath' :: (R2Ish v) => OffsetOpts (Scalar v) -> Scalar v -> Path v -> Path v offsetPath' opts r = mconcat . map (bindLoc (trailLike . offsetTrail' opts r) . (`at` origin)) . op Path -- | Offset a 'Path' with the default options and given radius. See 'offsetPath''. -offsetPath :: Double -> Path R2 -> Path R2 +offsetPath :: (R2Ish v) => Scalar v -> Path v -> Path v offsetPath = offsetPath' def -- TODO: Include arrowheads on examples to indicate direction so the "left" and @@ -296,10 +303,10 @@ offsetPath = offsetPath' def -- > import Diagrams.TwoD.Offset -- > import Data.Default.Class -- > --- > corner :: Located (Trail R2) +-- > corner :: (R2Ish v) => Located (Trail v) -- > corner = fromVertices (map p2 [(0, 0), (10, 0), (5, 6)]) `at` origin -- > --- > offsetTrailExample :: Diagram SVG R2 +-- > offsetTrailExample :: (R2Ish v) => Diagram SVG v -- > offsetTrailExample = pad 1.1 . centerXY . lw 0.2 . hcat' (def & sep .~ 1 ) -- > . map (uncurry showStyle) -- > $ [ (LineJoinMiter, "LineJoinMiter") @@ -311,7 +318,7 @@ offsetPath = offsetPath' def -- > <> trailLike (offsetTrail' (def & offsetJoin .~ j) 2 corner) # lc green) -- > === (strutY 3 <> text s # font "Helvetica" # bold) -- > --- > offsetTrailLeftExample :: Diagram SVG R2 +-- > offsetTrailLeftExample :: (R2Ish v) => Diagram SVG v -- > offsetTrailLeftExample = pad 1.1 . centerXY . lw 0.2 -- > $ (trailLike c # lc blue) -- > <> (lc green . trailLike @@ -319,7 +326,7 @@ offsetPath = offsetPath' def -- > where -- > c = reflectY corner -- > --- > offsetTrailOuterExample :: Diagram SVG R2 +-- > offsetTrailOuterExample :: (R2Ish v) => Diagram SVG v -- > offsetTrailOuterExample = pad 1.1 . centerXY . lw 0.2 -- > $ (trailLike c # lc blue) -- > <> (lc green . trailLike @@ -327,7 +334,7 @@ offsetPath = offsetPath' def -- > where -- > c = hexagon 5 -withTrailL :: (Located (Trail' Line v) -> r) -> (Located (Trail' Loop v) -> r) -> Located (Trail v) -> r +withTrailL :: (R2Ish v) => (Located (Trail' Line v) -> r) -> (Located (Trail' Loop v) -> r) -> Located (Trail v) -> r withTrailL f g l = withTrail (f . (`at` p)) (g . (`at` p)) (unLoc l) where p = loc l @@ -345,19 +352,20 @@ withTrailL f g l = withTrail (f . (`at` p)) (g . (`at` p)) (unLoc l) -- -- <> -- -expandTrail' :: ExpandOpts - -> Double -- ^ Radius of offset. Only non-negative values allowed. +expandTrail' :: (R2Ish v) + => ExpandOpts (Scalar v) + -> Scalar v -- ^ Radius of offset. Only non-negative values allowed. -- For a line this gives a loop of the offset. For a -- loop this gives two loops, the outer counter-clockwise -- and the inner clockwise. - -> Located (Trail R2) - -> Path R2 + -> Located (Trail v) + -> Path v expandTrail' o r t | r < 0 = error "expandTrail' with negative radius" -- TODO: consider just reversing the path instead of this error. | otherwise = withTrailL (pathFromLocTrail . expandLine o r) (expandLoop o r) t -expandLine :: ExpandOpts -> Double -> Located (Trail' Line R2) -> Located (Trail R2) +expandLine :: (R2Ish v) => ExpandOpts (Scalar v) -> Scalar v -> Located (Trail' Line v) -> Located (Trail v) expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) where eps = opts^.expandEpsilon @@ -369,7 +377,7 @@ expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) e = atEnd t cap = fromLineCap (opts^.expandCap) -expandLoop :: ExpandOpts -> Double -> Located (Trail' Loop R2) -> Path R2 +expandLoop :: (R2Ish v) => ExpandOpts (Scalar v) -> Scalar v -> Located (Trail' Loop v) -> Path v expandLoop opts r (mapLoc wrapLoop -> t) = (trailLike $ f r) <> (trailLike . reverseDomain . f $ -r) where eps = opts^.expandEpsilon @@ -379,23 +387,23 @@ expandLoop opts r (mapLoc wrapLoop -> t) = (trailLike $ f r) <> (trailLike . rev ends = (\(a:as) -> as ++ [a]) . trailVertices $ t -- | Expand a 'Trail' with the given radius and default options. See 'expandTrail''. -expandTrail :: Double -> Located (Trail R2) -> Path R2 +expandTrail :: (R2Ish v) => Scalar v -> Located (Trail v) -> Path v expandTrail = expandTrail' def -- | Expand a 'Path' using 'expandTrail'' on each trail in the path. -expandPath' :: ExpandOpts -> Double -> Path R2 -> Path R2 +expandPath' :: (R2Ish v) => ExpandOpts (Scalar v) -> Scalar v -> Path v -> Path v expandPath' opts r = mconcat . map (bindLoc (expandTrail' opts r) . (`at` origin)) . op Path -- | Expand a 'Path' with the given radius and default options. See 'expandPath''. -expandPath :: Double -> Path R2 -> Path R2 +expandPath :: (R2Ish v) => Scalar v -> Path v -> Path v expandPath = expandPath' def -- > import Diagrams.TwoD.Offset -- > import Data.Default.Class -- > --- > expandTrailExample :: Diagram SVG R2 +-- > expandTrailExample :: (R2Ish v) => Diagram SVG v -- > expandTrailExample = pad 1.1 . centerXY . hcat' (def & sep .~ 1) -- > . map (uncurry showStyle) -- > $ [ (LineCapButt, "LineCapButt") @@ -411,7 +419,7 @@ expandPath = expandPath' def -- > # lw 0 # fc green) -- > === (strutY 3 <> text s # font "Helvetica" # bold) -- > --- > expandLoopExample :: Diagram SVG R2 +-- > expandLoopExample :: (R2Ish v) => Diagram SVG v -- > expandLoopExample = pad 1.1 . centerXY $ ((strokeLocT t # lw 0.2 # lc white) -- > <> (stroke t' # lw 0 # fc green)) -- > where @@ -428,8 +436,8 @@ expandPath = expandPath' def -- caps takes the radius and the start and end points of the original line and -- the offset trails going out and coming back. The result is a new list of -- trails with the caps included. -caps :: (Double -> P2 -> P2 -> P2 -> Trail R2) - -> Double -> P2 -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Located (Trail R2) +caps :: (R2Ish v) => (Scalar v -> Point v -> Point v -> Point v -> Trail v) + -> Scalar v -> Point v -> Point v -> Located (Trail v) -> Located (Trail v) -> Located (Trail v) caps cap r s e fs bs = mapLoc glueTrail $ mconcat [ cap r s (atStart bs) (atStart fs) , unLoc fs @@ -438,35 +446,35 @@ caps cap r s e fs bs = mapLoc glueTrail $ mconcat ] `at` atStart bs -- | Take a LineCap style and give a function for building the cap from -fromLineCap :: LineCap -> Double -> P2 -> P2 -> P2 -> Trail R2 +fromLineCap :: (R2Ish v) => LineCap -> Scalar v -> Point v -> Point v -> Point v -> Trail v fromLineCap c = case c of LineCapButt -> capCut LineCapRound -> capArc LineCapSquare -> capSquare -- | Builds a cap that directly connects the ends. -capCut :: Double -> P2 -> P2 -> P2 -> Trail R2 +capCut :: (R2Ish v) => Scalar v -> Point v -> Point v -> Point v -> Trail v capCut _r _c a b = fromSegments [straight (b .-. a)] -- | Builds a cap with a square centered on the end. -capSquare :: Double -> P2 -> P2 -> P2 -> Trail R2 +capSquare :: (R2Ish v) => Scalar v -> Point v -> Point v -> Point v -> Trail v capSquare _r c a b = unLoc $ fromVertices [ a, a .+^ v, b .+^ v, b ] where v = perp (a .-. c) -- | Builds an arc to fit with a given radius, center, start, and end points. -- A Negative r means a counter-clockwise arc -capArc :: Double -> P2 -> P2 -> P2 -> Trail R2 +capArc :: (R2Ish v) => Scalar v -> Point v -> Point v -> Point v -> Trail v capArc r c a b = trailLike . moveTo c $ fs where fs | r < 0 = scale (-r) $ arcVCW (a .-. c) (b .-. c) | otherwise = scale r $ arcV (a .-. c) (b .-. c) -- Arc helpers -arcV :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t +arcV :: (R2Ish v) => (TrailLike t, V t ~ v) => v -> v -> t arcV u v = arc (direction u) (angleBetween v u) -arcVCW :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t +arcVCW :: (R2Ish v) => (TrailLike t, V t ~ v) => v -> v -> t arcVCW u v = arc (direction u) (negateV $ angleBetween v u) -- | Join together a list of located trails with the given join style. The @@ -477,14 +485,15 @@ arcVCW u v = arc (direction u) (negateV $ angleBetween v u) -- Note: this is not a general purpose join and assumes that we are joining an -- offset trail. For instance, a fixed radius arc will not fit between arbitrary -- trails without trimming or extending. -joinSegments :: Double - -> (Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2) +joinSegments :: (R2Ish v) + => Scalar v + -> (Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v) -> Bool - -> Double - -> Double - -> [Point R2] - -> [Located (Trail R2)] - -> Located (Trail R2) + -> Scalar v + -> Scalar v + -> [Point v] + -> [Located (Trail v)] + -> Located (Trail v) joinSegments _ _ _ _ _ _ [] = mempty `at` origin joinSegments _ _ _ _ _ [] _ = mempty `at` origin joinSegments epsilon j isLoop ml r es ts@(t:_) = t' @@ -499,7 +508,7 @@ joinSegments epsilon j isLoop ml r es ts@(t:_) = t' -- | Take a join style and give the join function to be used by joinSegments. fromLineJoin - :: LineJoin -> Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 + :: (R2Ish v) => LineJoin -> Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v fromLineJoin j = case j of LineJoinMiter -> joinSegmentIntersect LineJoinRound -> joinSegmentArc @@ -509,7 +518,7 @@ fromLineJoin j = case j of -- how useful it is graphically, I mostly had it as it was useful for debugging {- -- | Join with segments going back to the original corner. -joinSegmentCut :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentCut :: (R2Ish v) => Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v joinSegmentCut _ _ e a b = fromSegments [ straight (e .-. atEnd a) , straight (atStart b .-. e) @@ -519,18 +528,18 @@ joinSegmentCut _ _ e a b = fromSegments -- | Join by directly connecting the end points. On an inside corner this -- creates negative space for even-odd fill. Here is where we would want to -- use an arc or something else in the future. -joinSegmentClip :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentClip :: (R2Ish v) => Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v joinSegmentClip _ _ _ a b = fromSegments [straight $ atStart b .-. atEnd a] -- | Join with a radius arc. On an inside corner this will loop around the interior -- of the offset trail. With a winding fill this will not be visible. -joinSegmentArc :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentArc :: (R2Ish v) => Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v joinSegmentArc _ r e a b = capArc r e (atEnd a) (atStart b) -- | Join to the intersection of the incoming trails projected tangent to their ends. -- If the intersection is beyond the miter limit times the radius, stop at the limit. joinSegmentIntersect - :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 + :: (R2Ish v) => Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v joinSegmentIntersect miterLimit r e a b = if cross < 0.000001 then clip @@ -546,7 +555,7 @@ joinSegmentIntersect miterLimit r e a b = where t = straight (miter vb) `at` pb va = unitPerp (pa .-. e) - vb = -unitPerp (pb .-. e) + vb = negateV $ unitPerp (pb .-. e) pa = atEnd a pb = atStart b miter v = (abs (miterLimit * r)) *^ v diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index f75403b7..9d1973a9 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -79,14 +80,14 @@ import Diagrams.Util (tau) -- XXX can the efficiency of this be improved? See the comment in -- Diagrams.Path on the Enveloped instance for Trail. -instance Traced (Trail R2) where +instance (R2Ish v) => Traced (Trail v) where getTrace = withLine $ foldr (\seg bds -> moveOriginBy (negateV . atEnd $ seg) bds <> getTrace seg) mempty . lineSegments -instance Traced (Path R2) where +instance (R2Ish v) => Traced (Path v) where getTrace = F.foldMap getTrace . op Path ------------------------------------------------------------ @@ -157,11 +158,11 @@ instance Default (StrokeOpts a) where -- inferring the type of @stroke@. The solution is to give a type -- signature to expressions involving @stroke@, or (recommended) -- upgrade GHC (the bug is fixed in 7.0.2 onwards). -stroke :: Renderable (Path R2) b - => Path R2 -> Diagram b R2 +stroke :: (R2Ish v, Renderable (Path v) b) + => Path v -> Diagram b v stroke = stroke' (def :: StrokeOpts ()) -instance Renderable (Path R2) b => TrailLike (QDiagram b R2 Any) where +instance (R2Ish v, Renderable (Path v) b) => TrailLike (QDiagram b v Any) where trailLike = stroke . trailLike -- | A variant of 'stroke' that takes an extra record of options to @@ -171,7 +172,7 @@ instance Renderable (Path R2) b => TrailLike (QDiagram b R2 Any) where -- -- 'StrokeOpts' is an instance of 'Default', so @stroke' ('with' & -- ... )@ syntax may be used. -stroke' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Path R2 -> Diagram b R2 +stroke' :: (R2Ish v, Renderable (Path v) b, IsName a) => StrokeOpts a -> Path v -> Diagram b v stroke' opts path | null (pLines ^. _Wrapped') = mkP pLoops | null (pLoops ^. _Wrapped') = mkP pLines @@ -196,51 +197,51 @@ stroke' opts path -- The solution is to give a type signature to expressions involving -- @strokeTrail@, or (recommended) upgrade GHC (the bug is fixed in 7.0.2 -- onwards). -strokeTrail :: (Renderable (Path R2) b) => Trail R2 -> Diagram b R2 +strokeTrail :: (R2Ish v, Renderable (Path v) b) => Trail v -> Diagram b v strokeTrail = stroke . pathFromTrail -- | Deprecated synonym for 'strokeTrail'. -strokeT :: (Renderable (Path R2) b) => Trail R2 -> Diagram b R2 +strokeT :: (R2Ish v, Renderable (Path v) b) => Trail v -> Diagram b v strokeT = strokeTrail -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. -strokeTrail' :: (Renderable (Path R2) b, IsName a) - => StrokeOpts a -> Trail R2 -> Diagram b R2 +strokeTrail' :: (R2Ish v, Renderable (Path v) b, IsName a) + => StrokeOpts a -> Trail v -> Diagram b v strokeTrail' opts = stroke' opts . pathFromTrail -- | Deprecated synonym for 'strokeTrail''. -strokeT' :: (Renderable (Path R2) b, IsName a) - => StrokeOpts a -> Trail R2 -> Diagram b R2 +strokeT' :: (R2Ish v, Renderable (Path v) b, IsName a) + => StrokeOpts a -> Trail v -> Diagram b v strokeT' = strokeTrail' -- | A composition of 'strokeT' and 'wrapLine' for conveniently -- converting a line directly into a diagram. -strokeLine :: (Renderable (Path R2) b) => Trail' Line R2 -> Diagram b R2 +strokeLine :: (R2Ish v, Renderable (Path v) b) => Trail' Line v -> Diagram b v strokeLine = strokeT . wrapLine -- | A composition of 'strokeT' and 'wrapLoop' for conveniently -- converting a loop directly into a diagram. -strokeLoop :: (Renderable (Path R2) b) => Trail' Loop R2 -> Diagram b R2 +strokeLoop :: (R2Ish v, Renderable (Path v) b) => Trail' Loop v -> Diagram b v strokeLoop = strokeT . wrapLoop -- | A convenience function for converting a @Located Trail@ directly -- into a diagram; @strokeLocTrail = stroke . trailLike@. -strokeLocTrail :: (Renderable (Path R2) b) => Located (Trail R2) -> Diagram b R2 +strokeLocTrail :: (R2Ish v, Renderable (Path v) b) => Located (Trail v) -> Diagram b v strokeLocTrail = stroke . trailLike -- | Deprecated synonym for 'strokeLocTrail'. -strokeLocT :: (Renderable (Path R2) b) => Located (Trail R2) -> Diagram b R2 +strokeLocT :: (R2Ish v, Renderable (Path v) b) => Located (Trail v) -> Diagram b v strokeLocT = strokeLocTrail -- | A convenience function for converting a @Located@ line directly -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. -strokeLocLine :: (Renderable (Path R2) b) => Located (Trail' Line R2) -> Diagram b R2 +strokeLocLine :: (R2Ish v, Renderable (Path v) b) => Located (Trail' Line v) -> Diagram b v strokeLocLine = stroke . trailLike . mapLoc wrapLine -- | A convenience function for converting a @Located@ loop directly -- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@. -strokeLocLoop :: (Renderable (Path R2) b) => Located (Trail' Loop R2) -> Diagram b R2 +strokeLocLoop :: (R2Ish v, Renderable (Path v) b) => Located (Trail' Loop v) -> Diagram b v strokeLocLoop = stroke . trailLike . mapLoc wrapLoop ------------------------------------------------------------ @@ -249,7 +250,7 @@ strokeLocLoop = stroke . trailLike . mapLoc wrapLoop -runFillRule :: FillRule -> P2 -> Path R2 -> Bool +runFillRule :: (R2Ish v) => FillRule -> Point v -> Path v -> Bool runFillRule Winding = isInsideWinding runFillRule EvenOdd = isInsideEvenOdd @@ -269,7 +270,7 @@ getFillRule (FillRuleA (Last r)) = r fillRule :: HasStyle a => FillRule -> a -> a fillRule = applyAttr . FillRuleA . Last -cross :: R2 -> R2 -> Double +cross :: (R2Ish v) => v -> v -> Scalar v cross (coords -> x :& y) (coords -> x' :& y') = x * y' - y * x' -- XXX link to more info on this @@ -278,7 +279,7 @@ cross (coords -> x :& y) (coords -> x' :& y') = x * y' - y * x' -- by testing whether the point's /winding number/ is nonzero. Note -- that @False@ is /always/ returned for /open/ paths, regardless of -- the winding number. -isInsideWinding :: P2 -> Path R2 -> Bool +isInsideWinding :: (R2Ish v) => Point v -> Path v -> Bool isInsideWinding p = (/= 0) . crossings p -- | Test whether the given point is inside the given (closed) path, @@ -286,17 +287,17 @@ isInsideWinding p = (/= 0) . crossings p -- x direction crosses the path an even (outside) or odd (inside) -- number of times. Note that @False@ is /always/ returned for -- /open/ paths, regardless of the number of crossings. -isInsideEvenOdd :: P2 -> Path R2 -> Bool +isInsideEvenOdd :: (R2Ish v) => Point v -> Path v -> Bool isInsideEvenOdd p = odd . crossings p -- | Compute the sum of /signed/ crossings of a path as we travel in the -- positive x direction from a given point. -crossings :: P2 -> Path R2 -> Int +crossings :: (R2Ish v) => Point v -> Path v -> Int crossings p = F.sum . map (trailCrossings p) . op Path -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. -trailCrossings :: P2 -> Located (Trail R2) -> Int +trailCrossings :: (R2Ish v) => Point v -> Located (Trail v) -> Int -- non-loop trails have no inside or outside, so don't contribute crossings trailCrossings _ t | not (isLoop (unLoc t)) = 0 @@ -342,16 +343,16 @@ trailCrossings p@(unp2 -> (x,y)) tr -- concatenation, so applying multiple clipping paths is sensible. -- The clipping region is the intersection of all the applied -- clipping paths. -newtype Clip = Clip [Path R2] +newtype Clip v = Clip [Path v] deriving (Typeable, Semigroup) makeWrapped ''Clip -instance AttributeClass Clip +instance (Typeable v) => AttributeClass (Clip v) -type instance V Clip = R2 +type instance V (Clip v) = v -instance Transformable Clip where +instance (R2Ish v) => Transformable (Clip v) where transform t (Clip ps) = Clip (transform t ps) -- | Clip a diagram by the given path: @@ -360,7 +361,7 @@ instance Transformable Clip where -- path will be drawn. -- -- * The envelope of the diagram is unaffected. -clipBy :: (HasStyle a, V a ~ R2) => Path R2 -> a -> a +clipBy :: (R2Ish v, HasStyle a, V a ~ v) => Path v -> a -> a clipBy = applyTAttr . Clip . (:[]) -- | Clip a diagram to the given path setting its envelope to the @@ -368,7 +369,7 @@ clipBy = applyTAttr . Clip . (:[]) -- trace consists of those parts of the original diagram's trace -- which fall within the clipping path, or parts of the path's trace -- within the original diagram. -clipTo :: (Renderable (Path R2) b) => Path R2 -> Diagram b R2 -> Diagram b R2 +clipTo :: (R2Ish v, Renderable (Path v) b) => Path v -> Diagram b v -> Diagram b v clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d where envP = appEnvelope . getEnvelope $ p @@ -388,5 +389,5 @@ clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d -- | Clip a diagram to the clip path taking the envelope and trace of the clip -- path. -clipped :: (Renderable (Path R2) b) => Path R2 -> Diagram b R2 -> Diagram b R2 +clipped :: (R2Ish v, Renderable (Path v) b) => Path v -> Diagram b v -> Diagram b v clipped p = (withTrace p) . (withEnvelope p) . (clipBy p) diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index 32940534..31b7c22d 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -73,7 +74,7 @@ import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) import Diagrams.Util (tau, ( # )) -- | Method used to determine the vertices of a polygon. -data PolyType = PolyPolar [Angle Double] [Double] +data PolyType d = PolyPolar [Angle d] [d] -- ^ A \"polar\" polygon. -- -- * The first argument is a list of /central/ @@ -90,7 +91,7 @@ data PolyType = PolyPolar [Angle Double] [Double] -- circle) can be constructed using a second -- argument of @(repeat r)@. - | PolySides [Angle Double] [Double] + | PolySides [Angle d] [d] -- ^ A polygon determined by the distance between -- successive vertices and the angles formed by -- each three successive vertices. In other @@ -115,13 +116,13 @@ data PolyType = PolyPolar [Angle Double] [Double] -- angles and /n-1/ edge lengths. Extra angles or -- lengths are ignored. - | PolyRegular Int Double + | PolyRegular Int d -- ^ A regular polygon with the given number of -- sides (first argument) and the given radius -- (second argument). -- | Determine how a polygon should be oriented. -data PolyOrientation = NoOrient -- ^ No special orientation; the first +data PolyOrientation v = NoOrient -- ^ No special orientation; the first -- vertex will be at (1,0). -- This is the default. | OrientH -- ^ Orient /horizontally/, so the @@ -130,39 +131,39 @@ data PolyOrientation = NoOrient -- ^ No special orientation; the first | OrientV -- ^ Orient /vertically/, so the -- leftmost edge is parallel to the -- y-axis. - | OrientTo R2 -- ^ Orient so some edge is + | OrientTo v -- ^ Orient so some edge is -- /facing/ /in/ /the/ /direction/ -- /of/, that is, perpendicular -- to, the given vector. deriving (Eq, Ord, Show, Read) -- | Options for specifying a polygon. -data PolygonOpts = PolygonOpts - { _polyType :: PolyType - , _polyOrient :: PolyOrientation - , _polyCenter :: P2 +data PolygonOpts v = PolygonOpts + { _polyType :: PolyType (Scalar v) + , _polyOrient :: PolyOrientation v + , _polyCenter :: Point v } makeLensesWith (generateSignatures .~ False $ lensRules) ''PolygonOpts -- | Specification for the polygon's vertices. -polyType :: Lens' PolygonOpts PolyType +polyType :: Lens' (PolygonOpts v) (PolyType (Scalar v)) -- | Should a rotation be applied to the polygon in order to orient it in a -- particular way? -polyOrient :: Lens' PolygonOpts PolyOrientation +polyOrient :: Lens' (PolygonOpts v) (PolyOrientation v) -- | Should a translation be applied to the polygon in order to place the center -- at a particular location? -polyCenter :: Lens' PolygonOpts P2 +polyCenter :: Lens' (PolygonOpts v) (Point v) -- | The default polygon is a regular pentagon of radius 1, centered -- at the origin, aligned to the x-axis. -instance Default PolygonOpts where +instance (R2Ish v) => Default (PolygonOpts v) where def = PolygonOpts (PolyRegular 5 1) OrientH origin -- | Generate a polygon. See 'PolygonOpts' for more information. -polyTrail :: PolygonOpts -> Located (Trail R2) +polyTrail :: (R2Ish v) => PolygonOpts v -> Located (Trail v) polyTrail po = transform ori tr where tr = case po^.polyType of @@ -176,12 +177,12 @@ polyTrail po = transform ori tr NoOrient -> mempty -- | Generate the polygon described by the given options. -polygon :: (TrailLike t, V t ~ R2) => PolygonOpts -> t +polygon :: (R2Ish v, TrailLike t, V t ~ v) => PolygonOpts v -> t polygon = trailLike . polyTrail -- | Generate the located trail of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'. -polyPolarTrail :: [Angle Double] -> [Double] -> Located (Trail R2) +polyPolarTrail :: (R2Ish v) => [Angle (Scalar v)] -> [Scalar v] -> Located (Trail v) polyPolarTrail [] _ = emptyTrail `at` origin polyPolarTrail _ [] = emptyTrail `at` origin polyPolarTrail ans (r:rs) = tr `at` p1 @@ -196,7 +197,7 @@ polyPolarTrail ans (r:rs) = tr `at` p1 -- | Generate the vertices of a polygon specified by side length and -- angles, and a starting point for the trail such that the origin -- is at the centroid of the vertices. See 'PolySides'. -polySidesTrail :: [Angle Double] -> [Double] -> Located (Trail R2) +polySidesTrail :: (R2Ish v) => [Angle (Scalar v)] -> [Scalar v] -> Located (Trail v) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) where ans' = scanl (^+^) zeroV ans @@ -205,7 +206,7 @@ polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) tr = closeTrail . trailFromOffsets $ offsets -- | Generate the vertices of a regular polygon. See 'PolyRegular'. -polyRegularTrail :: Int -> Double -> Located (Trail R2) +polyRegularTrail :: (R2Ish v) => Int -> Scalar v -> Located (Trail v) polyRegularTrail n r = polyPolarTrail (take (n-1) . repeat $ fullTurn ^/ fromIntegral n) (repeat r) @@ -214,28 +215,28 @@ polyRegularTrail n r = polyPolarTrail -- generates the smallest rotation such that one of the segments -- adjacent to the vertex furthest in the direction of @v@ is -- perpendicular to @v@. -orient :: R2 -> Located (Trail R2) -> T2 +orient :: (R2Ish v) => v -> Located (Trail v) -> Transformation v orient v = orientPoints v . trailVertices -orientPoints :: R2 -> [P2] -> T2 +orientPoints :: (R2Ish v) => v -> [Point v] -> Transformation v orientPoints v xs = rotation a where (n1,x,n2) = maximumBy (comparing (distAlong v . sndOf3)) (zip3 (tail (cycle xs)) xs (last xs : init xs)) distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p) sndOf3 (_,b,_) = b - a :: Angle Double + -- a :: Angle (Scalar v) a = minimumBy (comparing $ abs . view rad) . map (angleFromNormal . (.-. x)) $ [n1,n2] v' = normalized v - angleFromNormal :: R2 -> Angle Double + -- angleFromNormal :: v -> Angle (Scalar v) angleFromNormal o | leftTurn o' v' = phi | otherwise = negateV phi where o' = normalized o theta = acos (v' <.> o') - phi :: Angle Double + -- phi :: Angle (Scalar v) phi | theta <= tau/4 = tau/4 - theta @@ rad | otherwise = theta - tau/4 @@ rad @@ -317,13 +318,13 @@ data StarOpts = StarFun (Int -> Int) -- | Create a generalized /star/ /polygon/. The 'StarOpts' are used -- to determine in which order the given vertices should be -- connected. The intention is that the second argument of type --- @[P2]@ could be generated by a call to 'polygon', 'regPoly', or +-- @[Point v]@ could be generated by a call to 'polygon', 'regPoly', or -- the like, since a list of vertices is 'TrailLike'. But of course --- the list can be generated any way you like. A @'Path' 'R2'@ is +-- the list can be generated any way you like. A @'Path' 'v'@ is -- returned (instead of any 'TrailLike') because the resulting path -- may have more than one component, for example if the vertices are -- to be connected in several disjoint cycles. -star :: StarOpts -> [P2] -> Path R2 +star :: (R2Ish v) => StarOpts -> [Point v] -> Path v star sOpts vs = graphToPath $ mkGraph f vs where f = case sOpts of StarFun g -> g diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index 6737654b..7689d18b 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Orphan Traced instances for Segment Closed R2 and FixedSegment R2. @@ -43,10 +45,10 @@ import Diagrams.Util traces is sorted in increasing order. -} -instance Traced (Segment Closed v) where +instance (R2Ish v) => Traced (Segment Closed v) where getTrace = getTrace . mkFixedSeg . (`at` origin) -instance Traced (FixedSegment v) where +instance (R2Ish v) => Traced (FixedSegment v) where {- Given lines defined by p0 + t0 * v0 and p1 + t1 * v1, their point of intersection in 2D is given by diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index 0b973c7e..77a61ab7 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -64,6 +65,7 @@ import Diagrams.Util import Control.Lens (makeLenses, op, (&), (.~), (^.), (<>~)) import Data.Default.Class import Data.Semigroup +import Data.VectorSpace -- | Create a centered horizontal (L-R) line of the given length. -- @@ -71,7 +73,7 @@ import Data.Semigroup -- -- > hruleEx = vcat' (with & sep .~ 0.2) (map hrule [1..5]) -- > # centerXY # pad 1.1 -hrule :: (TrailLike t, V t ~ R2) => Double -> t +hrule :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` (p2 (-d/2,0)) -- | Create a centered vertical (T-B) line of the given length. @@ -80,14 +82,14 @@ hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` (p2 (-d/2,0) -- -- > vruleEx = hcat' (with & sep .~ 0.2) (map vrule [1, 1.2 .. 2]) -- > # centerXY # pad 1.1 -vrule :: (TrailLike t, V t ~ R2) => Double -> t +vrule :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t vrule d = trailLike $ trailFromSegments [straight $ r2 (0, (-d))] `at` (p2 (0,d/2)) -- | A square with its center at the origin and sides of length 1, -- oriented parallel to the axes. -- -- <> -unitSquare :: (TrailLike t, V t ~ R2) => t +unitSquare :: (TrailLike t, V t ~ v, R2Ish v) => t unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2) & polyOrient .~ OrientH) @@ -97,7 +99,7 @@ unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2) -- length, oriented parallel to the axes. -- -- <> -square :: (TrailLike t, Transformable t, V t ~ R2) => Double -> t +square :: (TrailLike t, Transformable t, V t ~ v, R2Ish v) => Scalar v -> t square d = rect d d -- > squareEx = hcat' (with & sep .~ 0.5) [square 1, square 2, square 3] @@ -107,7 +109,7 @@ square d = rect d d -- @h@, centered at the origin. -- -- <> -rect :: (TrailLike t, Transformable t, V t ~ R2) => Double -> Double -> t +rect :: (TrailLike t, Transformable t, V t ~ v, R2Ish v) => Scalar v -> Scalar v -> t rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h -- > rectEx = rect 1 0.7 # pad 1.1 @@ -139,7 +141,7 @@ rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h -- polygons of a given /radius/). -- -- The polygon will be oriented with one edge parallel to the x-axis. -regPoly :: (TrailLike t, V t ~ R2) => Int -> Double -> t +regPoly :: (TrailLike t, V t ~ v, R2Ish v) => Int -> Scalar v -> t regPoly n l = polygon (def & polyType .~ PolySides (repeat (1/fromIntegral n @@ turn)) @@ -159,90 +161,90 @@ regPoly n l = polygon (def & polyType .~ -- > dodecagonEx = shapeEx dodecagon -- | A synonym for 'triangle', provided for backwards compatibility. -eqTriangle :: (TrailLike t, V t ~ R2) => Double -> t +eqTriangle :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t eqTriangle = triangle -- | An equilateral triangle, with sides of the given length and base -- parallel to the x-axis. -- -- <> -triangle :: (TrailLike t, V t ~ R2) => Double -> t +triangle :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t triangle = regPoly 3 -- | A regular pentagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -pentagon :: (TrailLike t, V t ~ R2) => Double -> t +pentagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t pentagon = regPoly 5 -- | A regular hexagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -hexagon :: (TrailLike t, V t ~ R2) => Double -> t +hexagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t hexagon = regPoly 6 -- | A regular heptagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -heptagon :: (TrailLike t, V t ~ R2) => Double -> t +heptagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t heptagon = regPoly 7 -- | A synonym for 'heptagon'. It is, however, completely inferior, -- being a base admixture of the Latin /septum/ (seven) and the -- Greek γωνία (angle). -septagon :: (TrailLike t, V t ~ R2) => Double -> t +septagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t septagon = heptagon -- | A regular octagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -octagon :: (TrailLike t, V t ~ R2) => Double -> t +octagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t octagon = regPoly 8 -- | A regular nonagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -nonagon :: (TrailLike t, V t ~ R2) => Double -> t +nonagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t nonagon = regPoly 9 -- | A regular decagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -decagon :: (TrailLike t, V t ~ R2) => Double -> t +decagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t decagon = regPoly 10 -- | A regular hendecagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -hendecagon :: (TrailLike t, V t ~ R2) => Double -> t +hendecagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t hendecagon = regPoly 11 -- | A regular dodecagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -dodecagon :: (TrailLike t, V t ~ R2) => Double -> t +dodecagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t dodecagon = regPoly 12 ------------------------------------------------------------ -- Other shapes ------------------------------------------ ------------------------------------------------------------ -data RoundedRectOpts = RoundedRectOpts { _radiusTL :: Double - , _radiusTR :: Double - , _radiusBL :: Double - , _radiusBR :: Double +data RoundedRectOpts d = RoundedRectOpts { _radiusTL :: d + , _radiusTR :: d + , _radiusBL :: d + , _radiusBR :: d } makeLenses ''RoundedRectOpts -instance Default RoundedRectOpts where +instance (Num d) => Default (RoundedRectOpts d) where def = RoundedRectOpts 0 0 0 0 -- | @roundedRect w h r@ generates a closed trail, or closed path @@ -266,7 +268,7 @@ instance Default RoundedRectOpts where -- > & radiusBR .~ 0.1) -- > ] -roundedRect :: (TrailLike t, V t ~ R2) => Double -> Double -> Double -> t +roundedRect :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> Scalar v -> Scalar v -> t roundedRect w h r = roundedRect' w h (def & radiusTL .~ r & radiusBR .~ r & radiusTR .~ r @@ -276,7 +278,7 @@ roundedRect w h r = roundedRect' w h (def & radiusTL .~ r -- each corner indivually, using @RoundedRectOpts@. The default corner radius is 0. -- Each radius can also be negative, which results in the curves being reversed -- to be inward instead of outward. -roundedRect' :: (TrailLike t, V t ~ R2) => Double -> Double -> RoundedRectOpts -> t +roundedRect' :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> Scalar v -> RoundedRectOpts (Scalar v) -> t roundedRect' w h opts = trailLike . (`at` (p2 (w/2, abs rBR - h/2))) diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index c71d9a1c..109e5389 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -40,44 +40,41 @@ import Data.Hashable (Hashable) import Data.VectorSpace import GHC.Generics (Generic) -type Numeric d = (Ord d, Num d, RealFloat d) -type KindaLikeR2 v = (LikeR2 v, Numeric (Scalar v)) - ------------------------------------------------------------ -- Computing diagram sizes ------------------------------------------------------------ -- | Compute the width of an enveloped object. -width :: (Enveloped a, KindaLikeR2 (V a)) => a -> Scalar (V a) +width :: (Enveloped a, R2Ish (V a)) => a -> Scalar (V a) width = maybe 0 (negate . uncurry (-)) . extentX -- | Compute the height of an enveloped object. -height :: (Enveloped a, KindaLikeR2 (V a)) => a -> Scalar (V a) +height :: (Enveloped a, R2Ish (V a)) => a -> Scalar (V a) height = maybe 0 (negate . uncurry (-)) . extentY -- | Compute the width and height of an enveloped object. -size2D :: (Enveloped a, KindaLikeR2 (V a)) => a -> (Scalar (V a), Scalar (V a)) +size2D :: (Enveloped a, R2Ish (V a)) => a -> (Scalar (V a), Scalar (V a)) size2D = width &&& height -- | Compute the size of an enveloped object as a 'SizeSpec2D' value. -sizeSpec2D :: (Enveloped a, KindaLikeR2 (V a)) => a -> SizeSpec2D (Scalar (V a)) +sizeSpec2D :: (Enveloped a, R2Ish (V a)) => a -> SizeSpec2D (Scalar (V a)) sizeSpec2D = uncurry Dims . size2D -- | Compute the absolute x-coordinate range of an enveloped object in -- R2, in the form (lo,hi). Return @Nothing@ for objects with an -- empty envelope. -extentX :: (Enveloped a, KindaLikeR2 (V a)) => a -> Maybe (Scalar (V a), Scalar (V a)) +extentX :: (Enveloped a, R2Ish (V a)) => a -> Maybe (Scalar (V a), Scalar (V a)) extentX d = (\f -> (-f unit_X, f unitX)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the absolute y-coordinate range of an enveloped object in -- R2, in the form (lo,hi). -extentY :: (Enveloped a, KindaLikeR2 (V a)) => a -> Maybe (Scalar (V a), Scalar (V a)) +extentY :: (Enveloped a, R2Ish (V a)) => a -> Maybe (Scalar (V a), Scalar (V a)) extentY d = (\f -> (-f unit_Y, f unitY)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the point at the center (in the x- and y-directions) of a -- enveloped object. Return the origin for objects with an empty -- envelope. -center2D :: (Enveloped a, KindaLikeR2 (V a)) => a -> Point (V a) +center2D :: (Enveloped a, R2Ish (V a)) => a -> Point (V a) center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) where mm = uncurry (liftA2 (,)) mid = (/2) . uncurry (+) @@ -115,7 +112,7 @@ mkSizeSpec (Just w) (Just h) = Dims w h -- | @requiredScaleT spec sz@ returns a transformation (a uniform scale) -- which can be applied to something of size @sz@ to make it fit the -- requested size @spec@, without changing the aspect ratio. -requiredScaleT :: (KindaLikeR2 v, Scalar v ~ d) => SizeSpec2D d -> (d, d) -> Transformation v +requiredScaleT :: (R2Ish v, Scalar v ~ d) => SizeSpec2D d -> (d, d) -> Transformation v requiredScaleT spec size = scaling (requiredScale spec size) -- | @requiredScale spec sz@ returns a scaling factor necessary to @@ -124,7 +121,7 @@ requiredScaleT spec size = scaling (requiredScale spec size) -- specification of both dimensions may not be honored if the aspect -- ratios do not match; in that case the scaling will be as large as -- possible so that the object still fits within the requested size. -requiredScale :: (Numeric d) => SizeSpec2D d -> (d, d) -> d +requiredScale :: (RealFloat d) => SizeSpec2D d -> (d, d) -> d requiredScale Absolute _ = 1 requiredScale (Width wSpec) (w,_) | wSpec == 0 || w == 0 = 1 @@ -141,7 +138,7 @@ requiredScale (Dims wSpec hSpec) (w,h) = s -- | Uniformly scale any enveloped object so that it fits within the -- given size. -sized :: (Transformable a, Enveloped a, KindaLikeR2 (V a)) +sized :: (Transformable a, Enveloped a, R2Ish (V a)) => SizeSpec2D (Scalar (V a)) -> a -> a sized spec a = transform (requiredScaleT spec (size2D a)) a @@ -149,7 +146,7 @@ sized spec a = transform (requiredScaleT spec (size2D a)) a -- size as\" (fits within the width and height of) some other -- object. sizedAs :: ( Transformable a, Enveloped a, Enveloped b - , KindaLikeR2 (V a), V a ~ V b + , R2Ish (V a), V a ~ V b ) => b -> a -> a sizedAs other = sized (sizeSpec2D other) diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index b8666863..6f4860e9 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -3,6 +3,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Text @@ -41,6 +43,7 @@ import Data.Colour import Data.Data import Data.Default.Class import Data.Semigroup +import Data.VectorSpace ------------------------------------------------------------ -- Text diagrams @@ -52,12 +55,12 @@ import Data.Semigroup -- text; the second accumulates normalized, "anti-scaled" versions -- of the transformations which have had their average scaling -- component removed. -data Text = Text T2 T2 TextAlignment String +data Text v = Text (Transformation v) (Transformation v) TextAlignment String deriving Typeable -type instance V Text = R2 +type instance V (Text v) = v -instance Transformable Text where +instance (R2Ish v) => Transformable (Text v) where transform t (Text tt tn a s) = Text (t <> tt) (t <> tn <> t') a s where t' = scaling (1 / avgScale t) @@ -65,16 +68,16 @@ instance Transformable Text where -- followed by the old transformation tn and then the new -- transformation t. That way translation is handled properly. -instance HasOrigin Text where +instance (R2Ish v) => HasOrigin (Text v) where moveOriginTo p = translate (origin .-. p) -instance Renderable Text NullBackend where +instance (R2Ish v) => Renderable (Text v) NullBackend where render _ _ = mempty -- | @TextAlignment@ specifies the alignment of the text's origin. data TextAlignment = BaselineText | BoxAlignedText Double Double -mkText :: Renderable Text b => TextAlignment -> String -> Diagram b R2 +mkText :: (R2Ish v, Renderable (Text v) b) => TextAlignment -> String -> Diagram b v mkText a t = recommendFillColor (black :: Colour Double) -- See Note [recommendFillColor] @@ -111,7 +114,7 @@ mkText a t = recommendFillColor (black :: Colour Double) -- -- Note that it /takes up no space/, as text size information is not -- available. -text :: Renderable Text b => String -> Diagram b R2 +text :: (R2Ish v, Renderable (Text v) b) => String -> Diagram b v text = alignedText 0.5 0.5 -- | Create a primitive text diagram from the given string, origin at @@ -119,7 +122,7 @@ text = alignedText 0.5 0.5 -- @'alignedText' 0 1@. -- -- Note that it /takes up no space/. -topLeftText :: Renderable Text b => String -> Diagram b R2 +topLeftText :: (R2Ish v, Renderable (Text v) b) => String -> Diagram b v topLeftText = alignedText 0 1 -- | Create a primitive text diagram from the given string, with the @@ -131,7 +134,7 @@ topLeftText = alignedText 0 1 -- and descent, rather than the height of the particular string. -- -- Note that it /takes up no space/. -alignedText :: Renderable Text b => Double -> Double -> String -> Diagram b R2 +alignedText :: (R2Ish v, Renderable (Text v) b) => Double -> Double -> String -> Diagram b v alignedText w h = mkText (BoxAlignedText w h) -- | Create a primitive text diagram from the given string, with the @@ -140,7 +143,7 @@ alignedText w h = mkText (BoxAlignedText w h) -- graphics library. -- -- Note that it /takes up no space/. -baselineText :: Renderable Text b => String -> Diagram b R2 +baselineText :: (R2Ish v, Renderable (Text v) b) => String -> Diagram b v baselineText = mkText BaselineText ------------------------------------------------------------ @@ -169,62 +172,63 @@ font = applyAttr . Font . Last -- | The @FontSize@ attribute specifies the size of a font's -- em-square. Inner @FontSize@ attributes override outer ones. -newtype FontSize = FontSize (Last (Measure R2, Bool)) - deriving (Typeable, Data, Semigroup) -instance AttributeClass FontSize +newtype FontSize v = FontSize (Last (Measure v, Bool)) + deriving (Typeable, Semigroup) +deriving instance (Data (Scalar v), Data v) => Data (FontSize v) +instance (Typeable v) => AttributeClass (FontSize v) -- Note, the Bool stored in the FontSize indicates whether it started -- life as Local. Typically, if the Bool is True, backends should use --- the first T2 value stored in a Text object; otherwise, the second --- (anti-scaled) T2 value should be used. +-- the first (Transformation v) value stored in a Text object; otherwise, the second +-- (anti-scaled) (Transformation v) value should be used. -type instance V FontSize = R2 +type instance V (FontSize v) = v -instance Default FontSize where +instance (R2Ish v) => Default (FontSize v) where def = FontSize (Last (Local 1, True)) -- FontSize has to be Transformable + also have an instance of Data, -- so the Measure inside it will be automatically converted to Output. -- However, we don't actually want the Transformable instance to do -- anything. All the scaling of text happens not by manipulating the --- font size but by accumulating T2 values in Text objects. -instance Transformable FontSize where +-- font size but by accumulating (Transformation v) values in Text objects. +instance (R2Ish v) => Transformable (FontSize v) where transform _ f = f -- | Extract the size from a @FontSize@ attribute. -getFontSize :: FontSize -> Measure R2 +getFontSize :: FontSize v -> Measure v getFontSize (FontSize (Last (s,_))) = s -- | Determine whether a @FontSize@ attribute began its life measured -- in 'Local' units. -getFontSizeIsLocal :: FontSize -> Bool +getFontSizeIsLocal :: FontSize v -> Bool getFontSizeIsLocal (FontSize (Last (_,b))) = b -- | Set the font size, that is, the size of the font's em-square as -- measured within the current local vector space. The default size -- is @1@. -fontSize :: (HasStyle a, V a ~ R2) => Measure R2 -> a -> a +fontSize :: (R2Ish v, HasStyle a, V a ~ v) => Measure v -> a -> a fontSize m@(Local {}) = applyGTAttr . FontSize . Last $ (m,True) fontSize m = applyGTAttr . FontSize . Last $ (m,False) -- | A convenient synonym for 'fontSize (Global w)'. -fontSizeG :: (HasStyle a, V a ~ R2) => Double -> a -> a +fontSizeG :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a fontSizeG w = fontSize (Global w) -- | A convenient synonym for 'fontSize (Normalized w)'. -fontSizeN :: (HasStyle a, V a ~ R2) => Double -> a -> a +fontSizeN :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a fontSizeN w = fontSize (Normalized w) -- | A convenient synonym for 'fontSize (Output w)'. -fontSizeO :: (HasStyle a, V a ~ R2) => Double -> a -> a +fontSizeO :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a fontSizeO w = fontSize (Output w) -- | A convenient sysnonym for 'fontSize (Local w)'. -fontSizeL :: (HasStyle a, V a ~ R2) => Double -> a -> a +fontSizeL :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a fontSizeL w = fontSize (Local w) -- | Apply a 'FontSize' attribute. -fontSizeA :: (HasStyle a, V a ~ R2) => FontSize -> a -> a +fontSizeA :: (R2Ish v, HasStyle a, V a ~ v) => FontSize v -> a -> a fontSizeA = applyGTAttr -------------------------------------------------- diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index fc02760c..3e16e57b 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -47,7 +47,6 @@ module Diagrams.TwoD.Transform -- * Utilities , onBasis - , ReallyLikeR2, ExtraLikeR2 ) where import Diagrams.Core @@ -57,7 +56,6 @@ import Diagrams.Angle import Diagrams.Transform import Diagrams.TwoD.Size (height, width) import Diagrams.TwoD.Types -import Diagrams.Coordinates import Data.AdditiveGroup import Data.AffineSpace @@ -65,9 +63,6 @@ import Data.Semigroup import Data.VectorSpace import Control.Lens (review, (^.)) -type ReallyLikeR2 v = (R2Ish v, RealFloat (Scalar v), VectorSpace (Scalar v), HasTheta v, V v ~ v, Scalar (Scalar v) ~ Scalar v, Decomposition v ~ (FinalCoord v :& FinalCoord v), PrevDim v ~ FinalCoord v, Coordinates v, FinalCoord v ~ Scalar v) -type ExtraLikeR2 v = (ReallyLikeR2 v, Transformable v, InnerSpace v) - type T = Transformation type P = Point @@ -75,7 +70,7 @@ type P = Point -- | Create a transformation which performs a rotation about the local -- origin by the given angle. See also 'rotate'. -rotation :: (ReallyLikeR2 v) => Angle (Scalar v) -> T v +rotation :: (R2Ish v) => Angle (Scalar v) -> T v rotation ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) @@ -95,170 +90,170 @@ rotation ang = fromLinear r (linv r) -- will yield an error since GHC cannot figure out which sort of -- angle you want to use. In this common situation you can use -- 'rotateBy', which interprets its argument as a number of turns. -rotate :: (ReallyLikeR2 (V t), Transformable t) => Angle (Scalar (V t)) -> t -> t +rotate :: (R2Ish (V t), Transformable t) => Angle (Scalar (V t)) -> t -> t rotate = transform . rotation -- | A synonym for 'rotate', interpreting its argument in units of -- turns; it can be more convenient to write @rotateBy (1\/4)@ than -- @'rotate' (1\/4 \@\@ 'turn')@. -rotateBy :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t +rotateBy :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t rotateBy = transform . rotation . review turn -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). -rotationAbout :: (ReallyLikeR2 v) => P v -> Angle (Scalar v) -> T v +rotationAbout :: (R2Ish v) => P v -> Angle (Scalar v) -> T v rotationAbout p angle = conjugate (translation (origin .-. p)) (rotation angle) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. -rotateAbout :: (ReallyLikeR2 (V t), Transformable t) => P (V t) -> Angle (Scalar (V t)) -> t -> t +rotateAbout :: (R2Ish (V t), Transformable t) => P (V t) -> Angle (Scalar (V t)) -> t -> t rotateAbout p angle = rotate angle `under` translation (origin .-. p) -- Scaling ------------------------------------------------- -- | Construct a transformation which scales by the given factor in -- the x (horizontal) direction. -scalingX :: (ReallyLikeR2 v) => Scalar v -> T v +scalingX :: (R2Ish v) => Scalar v -> T v scalingX c = fromLinear s s where s = (\(unr2 -> (x,y)) -> mkR2 (x*c) y) <-> (\(unr2 -> (x,y)) -> mkR2 (x/c) y) -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. -scaleX :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t +scaleX :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t scaleX = transform . scalingX -- | Construct a transformation which scales by the given factor in -- the y (vertical) direction. -scalingY :: (ReallyLikeR2 v) => Scalar v -> T v +scalingY :: (R2Ish v) => Scalar v -> T v scalingY c = fromLinear s s where s = (\(unr2 -> (x,y)) -> mkR2 x (y*c)) <-> (\(unr2 -> (x,y)) -> mkR2 x (y/c)) -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. -scaleY :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t +scaleY :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t scaleY = transform . scalingY -- | @scaleToX w@ scales a diagram in the x (horizontal) direction by -- whatever factor required to make its width @w@. @scaleToX@ -- should not be applied to diagrams with a width of 0, such as -- 'vrule'. -scaleToX :: (ReallyLikeR2 (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t +scaleToX :: (R2Ish (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t scaleToX w d = scaleX (w / width d) d -- | @scaleToY h@ scales a diagram in the y (vertical) direction by -- whatever factor required to make its height @h@. @scaleToY@ -- should not be applied to diagrams with a height of 0, such as -- 'hrule'. -scaleToY :: (ReallyLikeR2 (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t +scaleToY :: (R2Ish (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t scaleToY h d = scaleY (h / height d) d -- | @scaleUToX w@ scales a diagram /uniformly/ by whatever factor -- required to make its width @w@. @scaleUToX@ should not be -- applied to diagrams with a width of 0, such as 'vrule'. -scaleUToX :: (ReallyLikeR2 (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t +scaleUToX :: (R2Ish (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t scaleUToX w d = scale (w / width d) d -- | @scaleUToY h@ scales a diagram /uniformly/ by whatever factor -- required to make its height @h@. @scaleUToY@ should not be applied -- to diagrams with a height of 0, such as 'hrule'. -scaleUToY :: (ReallyLikeR2 (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t +scaleUToY :: (R2Ish (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t scaleUToY h d = scale (h / height d) d -- Translation --------------------------------------------- -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. -translationX :: (ReallyLikeR2 v) => Scalar v -> T v +translationX :: (R2Ish v) => Scalar v -> T v translationX x = translation (mkR2 x 0) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. -translateX :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t +translateX :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t translateX = transform . translationX -- | Construct a transformation which translates by the given distance -- in the y (vertical) direction. -translationY :: (ReallyLikeR2 v) => Scalar v -> T v +translationY :: (R2Ish v) => Scalar v -> T v translationY y = translation (mkR2 0 y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. -translateY :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t +translateY :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t translateY = transform . translationY -- Reflection ---------------------------------------------- -- | Construct a transformation which flips a diagram from left to -- right, i.e. sends the point (x,y) to (-x,y). -reflectionX :: (ReallyLikeR2 v) => T v +reflectionX :: (R2Ish v) => T v reflectionX = scalingX (-1) -- | Flip a diagram from left to right, i.e. send the point (x,y) to -- (-x,y). -reflectX :: (ReallyLikeR2 (V t), Transformable t) => t -> t +reflectX :: (R2Ish (V t), Transformable t) => t -> t reflectX = transform reflectionX -- | Construct a transformation which flips a diagram from top to -- bottom, i.e. sends the point (x,y) to (x,-y). -reflectionY :: (ReallyLikeR2 v) => T v +reflectionY :: (R2Ish v) => T v reflectionY = scalingY (-1) -- | Flip a diagram from top to bottom, i.e. send the point (x,y) to -- (x,-y). -reflectY :: (ReallyLikeR2 (V t), Transformable t) => t -> t +reflectY :: (R2Ish (V t), Transformable t) => t -> t reflectY = transform reflectionY -- | @reflectionAbout p v@ is a reflection in the line determined by -- the point @p@ and vector @v@. -reflectionAbout :: (ReallyLikeR2 v) => P v -> v -> T v +reflectionAbout :: (R2Ish v) => P v -> v -> T v reflectionAbout p v = conjugate (rotation (negateV $ v^._theta) <> translation (origin .-. p)) reflectionY -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. -reflectAbout :: (ReallyLikeR2 (V t), Transformable t) => P (V t) -> (V t) -> t -> t +reflectAbout :: (R2Ish (V t), Transformable t) => P (V t) -> (V t) -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Shears -------------------------------------------------- -- auxiliary functions for shearingX/shearingY -sh :: (ReallyLikeR2 v, s ~ Scalar v) => (s -> s -> s -> s) -> (s -> s -> s -> s) -> s -> v -> v +sh :: (R2Ish v, s ~ Scalar v) => (s -> s -> s -> s) -> (s -> s -> s -> s) -> s -> v -> v sh f g k (unr2 -> (x,y)) = mkR2 (f k x y) (g k x y) -sh' :: (ReallyLikeR2 v, s ~ Scalar v) => (s -> s -> s -> s) -> (s -> s -> s -> s) -> s -> v -> v +sh' :: (R2Ish v, s ~ Scalar v) => (s -> s -> s -> s) -> (s -> s -> s -> s) -> s -> v -> v sh' f g k = swap . sh f g k . swap -swap :: (ReallyLikeR2 v) => v -> v +swap :: (R2Ish v) => v -> v swap (unr2 -> (x,y)) = mkR2 y x -- | @shearingX d@ is the linear transformation which is the identity on -- y coordinates and sends @(0,1)@ to @(d,1)@. -shearingX :: (ReallyLikeR2 v) => Scalar v -> T v +shearingX :: (R2Ish v) => Scalar v -> T v shearingX d = fromLinear (sh f g d <-> sh f g (-d)) (sh' f g d <-> sh' f g (-d)) - where f k x y = (x+k*y); g k x y = y + where f k x y = (x+k*y); g _ _ y = y -- | @shearX d@ performs a shear in the x-direction which sends -- @(0,1)@ to @(d,1)@. -shearX :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t +shearX :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t shearX = transform . shearingX -- | @shearingY d@ is the linear transformation which is the identity on -- x coordinates and sends @(1,0)@ to @(1,d)@. -shearingY :: (ReallyLikeR2 v) => Scalar v -> T v +shearingY :: (R2Ish v) => Scalar v -> T v shearingY d = fromLinear (sh f g d <-> sh f g (-d)) (sh' f g d <-> sh' f g (-d)) - where f k x y = x; g k x y = (y+k*x) + where f _ x _ = x; g k x y = (y+k*x) -- | @shearY d@ performs a shear in the y-direction which sends -- @(1,0)@ to @(1,d)@. -shearY :: (ReallyLikeR2 (V t), Transformable t) => Scalar (V t) -> t -> t +shearY :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t shearY = transform . shearingY -- | Get the matrix equivalent of the linear transform, -- (as a pair of columns) and the translation vector. This -- is mostly useful for implementing backends. -onBasis :: (ReallyLikeR2 v) => T v -> ((v, v), v) +onBasis :: (R2Ish v) => T v -> ((v, v), v) onBasis t = ((x, y), v) where (x:y:[], v) = T.onBasis t diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index cb4932fb..2ec4493d 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -17,7 +17,7 @@ module Diagrams.TwoD.Transform.ScaleInv ( ScaleInv(..) , scaleInvObj, scaleInvDir, scaleInvLoc - , scaleInv, scaleInvPrim, ExtraLikeR2 ) + , scaleInv, scaleInvPrim) where import Control.Lens (makeLenses, view) @@ -85,7 +85,7 @@ type instance V (ScaleInv t) = V t instance (HasOrigin t) => HasOrigin (ScaleInv t) where moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) -instance (ExtraLikeR2 (V t), Transformable t) => Transformable (ScaleInv t) where +instance (R2Ish (V t), Transformable t) => Transformable (ScaleInv t) where transform :: Transformation (V (ScaleInv t)) -> ScaleInv t -> ScaleInv t transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where @@ -157,7 +157,7 @@ instance (ExtraLikeR2 (V t), Transformable t) => Transformable (ScaleInv t) wher -} -instance (ExtraLikeR2 (V t), Renderable t b) => Renderable (ScaleInv t) b where +instance (R2Ish (V t), Renderable t b) => Renderable (ScaleInv t) b where render b = render b . view scaleInvObj -- | Create a diagram from a single scale-invariant primitive. The @@ -175,6 +175,6 @@ instance (ExtraLikeR2 (V t), Renderable t b) => Renderable (ScaleInv t) b where -- scale-invariant things will be used only as \"decorations\" (/e.g./ -- arrowheads) which should not affect the envelope, trace, and -- query. -scaleInvPrim :: (Transformable t, Typeable t, ExtraLikeR2 (V t), Renderable t b, Monoid m) +scaleInvPrim :: (Transformable t, Typeable t, R2Ish (V t), Renderable t b, Monoid m) => t -> V t -> QDiagram b (V t) m scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 2ce8cdd2..539048f7 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} @@ -24,15 +24,15 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space r2, unr2, mkR2, r2Iso , p2, mkP2, unp2, p2Iso - , R2Basis + , R2Basis(..) , R2Ish + , Polar(..) ) where -import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, (^.), _1, _2) +import Control.Lens (Iso', iso) import Diagrams.Angle -import Diagrams.Direction import Diagrams.Coordinates import Diagrams.Core @@ -53,7 +53,8 @@ instance HasTrie R2Basis where untrie (R2Trie _x y) YB = y enumerate (R2Trie x y) = [(XB,x),(YB,y)] -type R2Ish v = (HasBasis v, Basis v ~ R2Basis) +type ScalarR2Ish d = (RealFloat d, VectorSpace d, HasBasis d, Basis d ~ (), Transformable d, Scalar d ~ d, V d ~ d, Data d) +type R2Ish v = (HasBasis v, Basis v ~ R2Basis, V v ~ v, Transformable v, InnerSpace v, Coordinates v, Decomposition v ~ (FinalCoord v :& FinalCoord v), PrevDim v ~ FinalCoord v, FinalCoord v ~ Scalar v, HasX v, HasY v, HasTheta v, Data v, ScalarR2Ish (Scalar v)) -- | Construct a 2D vector from a pair of components. See also '&'. r2 :: (R2Ish v) => (Scalar v, Scalar v) -> v diff --git a/src/Diagrams/TwoD/Double/Types.hs b/src/Diagrams/TwoD/Types/Double.hs similarity index 93% rename from src/Diagrams/TwoD/Double/Types.hs rename to src/Diagrams/TwoD/Types/Double.hs index 7b6f4d71..427d2724 100644 --- a/src/Diagrams/TwoD/Double/Types.hs +++ b/src/Diagrams/TwoD/Types/Double.hs @@ -11,7 +11,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | --- Module : Diagrams.TwoD.Types +-- Module : Diagrams.TwoD.Types.Double -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com @@ -21,26 +21,19 @@ ----------------------------------------------------------------------------- module Diagrams.TwoD.Types.Double - ( -- * 2D Euclidean space - R2(..), r2, unr2, mkR2, r2Iso - , P2, p2, mkP2, unp2, p2Iso - , T2 - , R2Basis - , LikeR2 + ( -- * 2D Euclidean space in Double precision + R2(..), P2, T2 ) where -import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, (^.), _1, _2) +import Control.Lens (Rewrapped, Wrapped (..), iso, (^.), _1, _2) import Diagrams.Angle -import Diagrams.Direction import Diagrams.Coordinates import Diagrams.Core import Diagrams.TwoD.Types -import Data.AffineSpace.Point import Data.Basis -import Data.MemoTrie (HasTrie (..)) import Data.VectorSpace import Data.Data diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 2327adb4..32c94764 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -22,55 +22,50 @@ module Diagrams.TwoD.Vector -- * 2D vector utilities , perp, leftTurn -- * Synonym for R2 things - , LikeR2 ) where import Control.Lens ((&), (.~)) import Data.VectorSpace -import Data.Basis import Diagrams.Core.V import Diagrams.Angle import Diagrams.Direction import Diagrams.TwoD.Types -import Diagrams.Coordinates - -type LikeR2 v = (R2Ish v, Num (Scalar v)) -- | The unit vector in the positive X direction. -unitX :: (LikeR2 v) => v +unitX :: (R2Ish v) => v unitX = mkR2 1 0 -- | The unit vector in the positive Y direction. -unitY :: (LikeR2 v) => v +unitY :: (R2Ish v) => v unitY = mkR2 0 1 -- | The unit vector in the negative X direction. -unit_X :: (LikeR2 v) => v +unit_X :: (R2Ish v) => v unit_X = mkR2 (-1) 0 -- | The unit vector in the negative Y direction. -unit_Y :: (LikeR2 v) => v +unit_Y :: (R2Ish v) => v unit_Y = mkR2 0 (-1) -- | The origin of the direction AffineSpace. For all d, @d .-. xDir -- = d^._theta@. -xDir :: (LikeR2 v) => Direction v +xDir :: (R2Ish v) => Direction v xDir = direction unitX -- | A unit vector at a specified angle counterclockwise from the -- positive X axis. -e :: (LikeR2 v, HasTheta v) => Angle (Scalar (V v)) -> v +e :: (R2Ish v) => Angle (Scalar (V v)) -> v e a = unitX & _theta .~ a -- | @perp v@ is perpendicular to and has the same magnitude as @v@. -- In particular @perp v == rotateBy (1/4) v@. -perp :: (LikeR2 v) => v -> v +perp :: (R2Ish v) => v -> v perp (unr2 -> (x,y)) = mkR2 (-y) x -- | @leftTurn v1 v2@ tests whether the direction of @v2@ is a left -- turn from @v1@ (that is, if the direction of @v2@ can be obtained -- from that of @v1@ by adding an angle 0 <= theta <= tau/2). -leftTurn :: (LikeR2 v, Ord (Scalar v), InnerSpace v) => v -> v -> Bool +leftTurn :: (R2Ish v, Ord (Scalar v), InnerSpace v) => v -> v -> Bool leftTurn v1 v2 = (v1 <.> perp v2) < 0 From f21cf4d5e50b85c23986891eaf8fe5640e35edd9 Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Thu, 19 Jun 2014 08:55:04 -0600 Subject: [PATCH 06/58] Minor tweaks --- diagrams-lib.cabal | 11 ++++++----- src/Diagrams/ThreeD.hs | 2 ++ 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 7c29bbcf..88b063d5 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -118,9 +118,10 @@ Library if impl(ghc < 7.6) Build-depends: ghc-prim Hs-source-dirs: src - ghc-options: -Wall -Werror + ghc-options: -Wall default-language: Haskell2010 - -- default-extensions: FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies - other-extensions: BangPatterns, CPP, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, ExistentialQuantification, GADTs, - GeneralizedNewtypeDeriving, NoMonomorphismRestriction, Rank2Types, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeOperators, - TypeSynonymInstances, UndecidableInstances, ViewPatterns \ No newline at end of file + other-extensions: BangPatterns, CPP, DefaultSignatures, DeriveDataTypeable, + DeriveFunctor, DeriveGeneric, EmptyDataDecls, ExistentialQuantification, + GADTs, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, Rank2Types, + RankNTypes, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, + TypeOperators, TypeSynonymInstances, UndecidableInstances, ViewPatterns \ No newline at end of file diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs index 7e338ade..60292d48 100644 --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -40,6 +40,7 @@ module Diagrams.ThreeD , module Diagrams.ThreeD.Shapes , module Diagrams.ThreeD.Transform , module Diagrams.ThreeD.Types + , module Diagrams.ThreeD.Types.Double , module Diagrams.ThreeD.Vector ) where @@ -51,4 +52,5 @@ import Diagrams.ThreeD.Light import Diagrams.ThreeD.Shapes import Diagrams.ThreeD.Transform import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Types.Double import Diagrams.ThreeD.Vector From f2573307c3c6e44c1965a74191f314fd6d1d15e2 Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Thu, 19 Jun 2014 09:38:59 -0600 Subject: [PATCH 07/58] Fix up so it compiles * revert using MeasureX * various R2 -> R2Ish changes --- src/Diagrams/ThreeD/Transform.hs | 2 +- src/Diagrams/TwoD/Arrow.hs | 8 +++++--- src/Diagrams/TwoD/Attributes.hs | 2 +- src/Diagrams/TwoD/Combinators.hs | 12 ++++++------ src/Diagrams/TwoD/Image.hs | 3 +-- src/Diagrams/TwoD/Offset.hs | 3 ++- 6 files changed, 16 insertions(+), 14 deletions(-) diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index ed44412f..547e450d 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -137,7 +137,7 @@ pointAt' :: (R3Ish v) => v -> v -> v -> Transformation v pointAt' about initial final = pointAtUnit (normalized about) (normalized initial) (normalized final) -- | pointAtUnit has the same behavior as @pointAt@, but takes unit vectors. -pointAtUnit :: R3 -> R3 -> R3 -> T3 +pointAtUnit :: (R3Ish v) => v -> v -> v -> Transformation v pointAtUnit about initial final = tilt <> pan where -- rotating u by (signedAngle rel u v) about rel gives a vector in the direction of v signedAngle rel u v = signum (cross3 u v <.> rel) *^ angleBetween u v diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 04939703..afbb620e 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -105,7 +105,6 @@ import Control.Lens (Lens', Setter', Traversal', makeLensesWith, view, (%~), (&), (.~), (^.)) import Data.AffineSpace -import Data.Data (Data) import Data.Default.Class import Data.Functor ((<$>)) import Data.Maybe (fromMaybe) @@ -251,7 +250,7 @@ headSty opts = fc black (opts^.headStyle) tailSty :: (R2Ish v) => ArrowOpts v -> Style v tailSty opts = fc black (opts^.tailStyle) -fromMeasure :: (Data d, Ord d, Fractional d) => d -> d -> MeasureX d -> d +fromMeasure :: (R2Ish v) => Scalar v -> Scalar v -> Measure v -> Scalar v fromMeasure g n m = u where Output u = toOutput g n m @@ -278,7 +277,10 @@ colorJoint sStyle = -- | Get line width from a style. widthOfJoint :: forall v. (R2Ish v) => Style v -> Scalar v -> Scalar v -> Scalar v -widthOfJoint sStyle gToO nToO = maybe (fromMeasure gToO nToO (Output 1)) (fromMeasure gToO nToO) (fmap getLineWidth . (getAttr :: Style v -> Maybe (LineWidth v)) $ sStyle) +widthOfJoint sStyle gToO nToO = + maybe (fromMeasure gToO nToO (Output 1 :: Measure v)) -- Should be same as default line width + (fromMeasure gToO nToO) + (fmap getLineWidth . getAttr $ sStyle :: Maybe (Measure v)) -- | Combine the head and its joint into a single scale invariant diagram -- and move the origin to the attachment point. Return the diagram diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 13d46185..b9858083 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -93,7 +93,7 @@ import Data.VectorSpace -- | Standard 'Measures'. none, ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, - tiny, verySmall, small, normal, large, veryLarge, huge :: (Floating d) => MeasureX d + tiny, verySmall, small, normal, large, veryLarge, huge :: (Floating (Scalar v)) => Measure v none = Output 0 ultraThin = Normalized 0.0005 `atLeast` Output 0.5 veryThin = Normalized 0.001 `atLeast` Output 0.5 diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index f5803bdf..eeaf6b8e 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -117,8 +117,8 @@ hcat' = cat' unitX -- | A convenient synonym for horizontal concatenation with -- separation: @hsep s === hcat' (with & sep .~ s)@. -hsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) - => Scalar R2 -> [a] -> a +hsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) + => Scalar v -> [a] -> a hsep s = hcat' (def & sep .~ s) -- | Lay out a list of juxtaposable objects in a column from top to @@ -146,8 +146,8 @@ vcat' = cat' (negateV unitY) -- | A convenient synonym for vertical concatenation with -- separation: @vsep s === vcat' (with & sep .~ s)@. -vsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) - => Scalar R2 -> [a] -> a +vsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) + => Scalar v -> [a] -> a vsep s = vcat' (def & sep .~ s) -- | @strutR2 v@ is a two-dimensional diagram which produces no @@ -260,6 +260,6 @@ bg c d = d <> boundingRect d # lineWidth (Output 0) # fc c -- | Similar to 'bg' but makes the colored background rectangle larger than -- the diagram. The first parameter is used to set how far the background -- extends beyond the diagram. -bgFrame :: (Renderable (Path R2) b, Backend b R2) - => Double -> Colour Double -> Diagram b R2 -> Diagram b R2 +bgFrame :: (R2Ish v, Renderable (Path v) b, Backend b v) + => Scalar v -> Colour Double -> Diagram b v -> Diagram b v bgFrame f c d = d <> boundingRect (frame f d) # lineWidth (Output 0) # fc c diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs index 01d543dc..49584aa5 100644 --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -41,10 +41,9 @@ import Data.Colour (AlphaColour) import Diagrams.Core import Diagrams.Attributes (colorToSRGBA) -import Diagrams.Path (Path) import Diagrams.TwoD.Path (isInsideEvenOdd) import Diagrams.TwoD.Shapes (rect) -import Diagrams.TwoD.Types (R2, T2) +import Diagrams.TwoD.Types (R2Ish) import Data.AffineSpace ((.-.)) import Data.Semigroup diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index b07df99f..95be95b6 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -472,7 +472,8 @@ capArc r c a b = trailLike . moveTo c $ fs -- Arc helpers -- always picks the shorter arc (< τ/2) -arcV :: (R2Ish v) => (TrailLike t, V t ~ v) => v -> v -> tarcV u v = arc (direction u) (angleBetween v u) +arcV :: (R2Ish v) => (TrailLike t, V t ~ v) => v -> v -> t +arcV u v = arc (direction u) (angleBetween v u) arcVCW :: (R2Ish v) => (TrailLike t, V t ~ v) => v -> v -> t arcVCW u v = arc (direction u) (negateV $ angleBetween v u) From 7c02053b8be1a19ad00b97a285f8befd9c9d6baf Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Sun, 22 Jun 2014 14:44:19 -0600 Subject: [PATCH 08/58] git ls-files | grep '\.hs$' | xargs -n 1 stylish-haskell -c misc/stylish-haskell.yaml -i Although I had to tweak & untweak some files so stylish-haskell / haskell-src-exts can parse them --- Setup.hs | 2 +- misc/DKSolve.hs | 6 +- misc/stylish-haskell.yaml | 29 ++++++++ src/Diagrams/Align.hs | 6 +- src/Diagrams/Angle.hs | 14 ++-- src/Diagrams/Animation.hs | 2 +- src/Diagrams/Attributes.hs | 6 +- src/Diagrams/Backend/CmdLine.hs | 4 +- src/Diagrams/BoundingBox.hs | 10 +-- src/Diagrams/Combinators.hs | 7 +- src/Diagrams/Coordinates.hs | 4 +- src/Diagrams/CubicSpline/Internal.hs | 35 +++++---- src/Diagrams/Direction.hs | 12 +-- src/Diagrams/Parametric.hs | 2 +- src/Diagrams/Parametric/Adjust.hs | 3 +- src/Diagrams/Path.hs | 4 +- src/Diagrams/Prelude.hs | 4 +- src/Diagrams/Prelude/ThreeD.hs | 4 +- src/Diagrams/Segment.hs | 11 ++- src/Diagrams/Solve.hs | 8 +- src/Diagrams/Tangent.hs | 4 +- src/Diagrams/ThreeD.hs | 20 ++--- src/Diagrams/ThreeD/Align.hs | 2 +- src/Diagrams/ThreeD/Attributes.hs | 16 ++-- src/Diagrams/ThreeD/Camera.hs | 8 +- src/Diagrams/ThreeD/Deform.hs | 12 +-- src/Diagrams/ThreeD/Light.hs | 3 +- src/Diagrams/ThreeD/Shapes.hs | 4 +- src/Diagrams/ThreeD/Transform.hs | 10 ++- src/Diagrams/ThreeD/Types.hs | 23 +++--- src/Diagrams/ThreeD/Types/Double.hs | 25 ++++--- src/Diagrams/ThreeD/Vector.hs | 11 ++- src/Diagrams/Trace.hs | 7 +- src/Diagrams/Trail.hs | 27 ++++--- src/Diagrams/TrailLike.hs | 2 +- src/Diagrams/TwoD.hs | 4 +- src/Diagrams/TwoD/Adjust.hs | 14 ++-- src/Diagrams/TwoD/Align.hs | 2 +- src/Diagrams/TwoD/Arc.hs | 10 ++- src/Diagrams/TwoD/Arrow.hs | 14 ++-- src/Diagrams/TwoD/Arrowheads.hs | 7 +- src/Diagrams/TwoD/Attributes.hs | 15 ++-- src/Diagrams/TwoD/Combinators.hs | 9 ++- src/Diagrams/TwoD/Curvature.hs | 7 +- src/Diagrams/TwoD/Deform.hs | 12 +-- src/Diagrams/TwoD/Ellipse.hs | 7 +- src/Diagrams/TwoD/Image.hs | 4 +- src/Diagrams/TwoD/Model.hs | 22 +++--- src/Diagrams/TwoD/Offset.hs | 98 +++++++++++++------------ src/Diagrams/TwoD/Path.hs | 9 ++- src/Diagrams/TwoD/Polygons.hs | 12 +-- src/Diagrams/TwoD/Segment.hs | 6 +- src/Diagrams/TwoD/Shapes.hs | 10 +-- src/Diagrams/TwoD/Size.hs | 3 +- src/Diagrams/TwoD/Text.hs | 4 +- src/Diagrams/TwoD/Transform.hs | 6 +- src/Diagrams/TwoD/Transform/ScaleInv.hs | 15 ++-- src/Diagrams/TwoD/Types.hs | 5 +- src/Diagrams/TwoD/Types/Double.hs | 4 +- src/Diagrams/TwoD/Vector.hs | 20 ++--- test/Arcs.hs | 28 +++---- test/Arrowtest.hs | 6 +- test/BBTest.hs | 6 +- test/Gradient/Ball.hs | 4 +- test/Gradient/rectGrad.hs | 4 +- test/Issue57.hs | 4 +- test/PolyTest.hs | 8 +- test/ShapeTest.hs | 6 +- test/Shapes.hs | 6 +- test/Snugtest.hs | 10 +-- test/bezbench.hs | 13 ++-- test/clipTo.hs | 6 +- test/diamBench.hs | 8 +- test/splitTests.hs | 18 +++-- 74 files changed, 431 insertions(+), 362 deletions(-) create mode 100644 misc/stylish-haskell.yaml diff --git a/Setup.hs b/Setup.hs index 9a994af6..44671092 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/misc/DKSolve.hs b/misc/DKSolve.hs index 1230f94e..3f02c4ba 100644 --- a/misc/DKSolve.hs +++ b/misc/DKSolve.hs @@ -5,8 +5,8 @@ -- See http://en.wikipedia.org/wiki/Durand–Kerner_method -import Data.Complex -import Data.List (inits, tails) +import Data.Complex +import Data.List (inits, tails) eps :: Double eps = 1e-14 @@ -48,4 +48,4 @@ type C = Complex Double fixedPt :: Double -> ([C] -> [C]) -> [C] -> [C] fixedPt eps f as | all (( a -> a snugCenter d = applyAll fs d where - fs = map snugCenterV basis \ No newline at end of file + fs = map snugCenterV basis diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 31cb0497..08145600 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Angle @@ -26,14 +26,14 @@ module Diagrams.Angle , HasPhi(..) ) where -import Control.Lens (Iso', Lens', iso, review) +import Control.Lens (Iso', Lens', iso, review) -import Data.Monoid hiding ((<>)) -import Data.Semigroup -import Data.VectorSpace +import Data.Monoid hiding ((<>)) +import Data.Semigroup +import Data.VectorSpace -import Diagrams.Core.V -import Diagrams.Points +import Diagrams.Core.V +import Diagrams.Points -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs index 647f91c5..cceb4fa6 100644 --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Animation diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index f08ae854..379e9644 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -48,8 +48,8 @@ module Diagrams.Attributes ( ) where import Data.Colour -import Data.Colour.RGBSpace (RGB (..)) -import Data.Colour.SRGB (toSRGB) +import Data.Colour.RGBSpace (RGB (..)) +import Data.Colour.SRGB (toSRGB) import Data.Default.Class import Data.Semigroup @@ -209,4 +209,4 @@ lineMiterLimit = applyAttr . LineMiterLimit . Last -- | Apply a 'LineMiterLimit' attribute. lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a -lineMiterLimitA = applyAttr \ No newline at end of file +lineMiterLimitA = applyAttr diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index 68e61ccc..72ac6aae 100644 --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -426,10 +426,10 @@ class Mainable d where -- @ -- import Diagrams.Prelude -- import Diagrams.Backend.TheBestBackend.CmdLine - -- + -- -- d :: Diagram B R2 -- d = ... - -- + -- -- main = mainWith d -- @ -- diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index f913b56f..650fe8b3 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -43,15 +43,13 @@ module Diagrams.BoundingBox import Control.Applicative ((<$>)) import qualified Data.Foldable as F -import Data.Map (Map, fromDistinctAscList, fromList, - toAscList, toList) +import Data.Map (Map, fromDistinctAscList, fromList, toAscList, toList) import Data.Maybe (fromMaybe) import Data.VectorSpace -- (VectorSpace, Scalar, AdditiveGroup, zeroV, negateV, (^+^), (^-^)) -import Data.Basis (Basis, HasBasis, basisValue, - decompose, recompose) +import Data.Basis (Basis, HasBasis, basisValue, decompose, recompose) import Data.Monoid (Monoid (..)) import Data.Semigroup (Option (..), Semigroup (..)) @@ -61,8 +59,8 @@ import Data.Typeable (Typeable) import Diagrams.Core.Envelope (Enveloped (..), appEnvelope) import Diagrams.Core.HasOrigin (HasOrigin (..)) import Diagrams.Core.Points (Point (..)) -import Diagrams.Core.Transform (HasLinearMap, Transformable (..), - Transformation (..), (<->)) +import Diagrams.Core.Transform (HasLinearMap, Transformable (..), Transformation (..), + (<->)) import Diagrams.Core.V (V) -- Unexported utility newtype diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 2b0aa4b0..e6d45ed4 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -32,7 +32,7 @@ module Diagrams.Combinators -- * n-ary operations , appends - , position, atPoints + , position, atPoints , cat, cat' , CatOpts(_catMethod, _sep), catMethod, sep , CatMethod(..) @@ -41,9 +41,8 @@ module Diagrams.Combinators import Data.Typeable -import Control.Lens (Lens', generateSignatures, lensField, - lensRules, makeLensesWith, (%~), (&), - (.~), (^.), _Wrapping) +import Control.Lens (Lens', generateSignatures, lensField, lensRules, + makeLensesWith, (%~), (&), (.~), (^.), _Wrapping) import Data.AdditiveGroup import Data.AffineSpace ((.+^)) import Data.Default.Class diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index 8d1050bb..f6a0f5b2 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -20,12 +20,12 @@ module Diagrams.Coordinates ) where -import Control.Lens (Lens') +import Control.Lens (Lens') import Data.VectorSpace -import Diagrams.Points import Data.AffineSpace.Point import Diagrams.Core.V +import Diagrams.Points -- | Types which are instances of the @Coordinates@ class can be -- constructed using '^&' (for example, a three-dimensional vector diff --git a/src/Diagrams/CubicSpline/Internal.hs b/src/Diagrams/CubicSpline/Internal.hs index 03bd10c5..3ff33196 100644 --- a/src/Diagrams/CubicSpline/Internal.hs +++ b/src/Diagrams/CubicSpline/Internal.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- | @@ -25,10 +24,10 @@ module Diagrams.CubicSpline.Internal , solveCubicSplineCoefficients ) where -import Data.List +import Data.List --- | Solves a system of the form 'A*X=D' for 'x' where 'A' is an --- 'n' by 'n' matrix with 'bs' as the main diagonal and +-- | Solves a system of the form 'A*X=D' for 'x' where 'A' is an +-- 'n' by 'n' matrix with 'bs' as the main diagonal and -- 'as' the diagonal below and 'cs' the diagonal above. -- See: solveTriDiagonal :: Fractional a => [a] -> [a] -> [a] -> [a] -> [a] @@ -39,11 +38,11 @@ solveTriDiagonal as (b0:bs) (c0:cs) (d0:ds) = h cs' ds' f (c':cs') (a:as) (b:bs) (c:cs) = c / (b - c' * a) : f cs' as bs cs f _ _ _ _ = error "solveTriDiagonal.f: impossible!" - ds' = d0 / b0 : g ds' as bs cs' ds + ds' = d0 / b0 : g ds' as bs cs' ds g _ [] _ _ _ = [] g (d':ds') (a:as) (b:bs) (c':cs') (d:ds) = (d - d' * a)/(b - c' * a) : g ds' as bs cs' ds g _ _ _ _ _ = error "solveTriDiagonal.g: impossible!" - + h _ [d] = [d] h (c:cs) (d:ds) = let xs@(x:_) = h cs ds in d - c * x : xs h _ _ = error "solveTriDiagonal.h: impossible!" @@ -58,13 +57,13 @@ modifyLast f (a:as) = a : modifyLast f as -- Helper that builds a list of length n of the form: '[s,m,m,...,m,m,e]' sparseVector :: Int -> a -> a -> a -> [a] -sparseVector n s m e +sparseVector n s m e | n < 1 = [] | otherwise = s : h (n - 1) - where + where h 1 = [e] h n = m : h (n - 1) - + -- | Solves a system similar to the tri-diagonal system using a special case -- of the Sherman-Morrison formula . -- This code is based on /Numerical Recpies in C/'s @cyclic@ function in section 2.7. @@ -74,12 +73,12 @@ solveCyclicTriDiagonal as (b0:bs) cs ds alpha beta = zipWith ((+) . (fact *)) zs l = length ds gamma = -b0 us = sparseVector l gamma 0 alpha - + bs' = (b0 - gamma) : modifyLast (subtract (alpha*beta/gamma)) bs - + xs@(x:_) = solveTriDiagonal as bs' cs ds zs@(z:_) = solveTriDiagonal as bs' cs us - + fact = -(x + beta * last xs / gamma) / (1.0 + z + beta * last zs / gamma) solveCyclicTriDiagonal _ _ _ _ _ _ = error "second argument to solveCyclicTriDiagonal must be nonempty" @@ -87,7 +86,7 @@ solveCyclicTriDiagonal _ _ _ _ _ _ = error "second argument to solveCyclicTriDia -- | Use the tri-diagonal solver with the appropriate parameters for an open cubic spline. solveCubicSplineDerivatives :: Fractional a => [a] -> [a] solveCubicSplineDerivatives (x:xs) = solveTriDiagonal as bs as ds - where + where as = replicate (l - 1) 1 bs = 2 : replicate (l - 2) 4 ++ [2] l = length ds @@ -99,7 +98,7 @@ solveCubicSplineDerivatives _ = error "argument to solveCubicSplineDerivatives m -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. solveCubicSplineDerivativesClosed :: Fractional a => [a] -> [a] solveCubicSplineDerivativesClosed xs = solveCyclicTriDiagonal as bs as ds 1 1 - where + where as = replicate (l - 1) 1 bs = replicate l 4 l = length xs @@ -109,11 +108,11 @@ solveCubicSplineDerivativesClosed xs = solveCyclicTriDiagonal as bs as ds 1 1 -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. solveCubicSplineCoefficients :: Fractional a => Bool -> [a] -> [[a]] -solveCubicSplineCoefficients closed xs = +solveCubicSplineCoefficients closed xs = [ [x,d,3*(x1-x)-2*d-d1,2*(x-x1)+d+d1] | (x,x1,d,d1) <- zip4 xs' (tail xs') ds' (tail ds') ] - where + where ds | closed = solveCubicSplineDerivativesClosed xs | otherwise = solveCubicSplineDerivatives xs close as | closed = as ++ [head as] diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index e05a7a64..87d2ee40 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Direction @@ -19,11 +19,11 @@ module Diagrams.Direction , angleBetweenDirs ) where -import Control.Lens (Iso', iso) -import Data.VectorSpace +import Control.Lens (Iso', iso) +import Data.VectorSpace -import Diagrams.Angle -import Diagrams.Core +import Diagrams.Angle +import Diagrams.Core -------------------------------------------------------------------------------- -- Direction diff --git a/src/Diagrams/Parametric.hs b/src/Diagrams/Parametric.hs index 05ae5782..bc65c980 100644 --- a/src/Diagrams/Parametric.hs +++ b/src/Diagrams/Parametric.hs @@ -25,7 +25,7 @@ module Diagrams.Parametric import Diagrams.Core import Data.VectorSpace -import qualified Numeric.Interval.Kaucher as I +import qualified Numeric.Interval.Kaucher as I -- | Codomain of parametric classes. This is usually either @(V p)@, for relative -- vector results, or @(Point (V p))@, for functions with absolute coordinates. diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs index 13b7484e..0ffe163a 100644 --- a/src/Diagrams/Parametric/Adjust.hs +++ b/src/Diagrams/Parametric/Adjust.hs @@ -20,7 +20,8 @@ module Diagrams.Parametric.Adjust ) where -import Control.Lens (makeLensesWith, lensRules, lensField, generateSignatures, (^.), (&), (.~), Lens') +import Control.Lens (Lens', generateSignatures, lensField, lensRules, + makeLensesWith, (&), (.~), (^.)) import Data.Proxy import Data.Default.Class diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index fd5a1b57..5a1278b4 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -71,8 +71,8 @@ import Diagrams.TrailLike import Diagrams.Transform import Control.Arrow ((***)) -import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, - over, view, (%~), _Unwrapped', _Wrapped) +import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, over, view, (%~), + _Unwrapped', _Wrapped) import Data.AffineSpace import qualified Data.Foldable as F import Data.List (partition) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index ca39ffb9..77ca8907 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -146,17 +146,17 @@ import Diagrams.Query import Diagrams.Segment import Diagrams.Tangent import Diagrams.Trace -import Diagrams.Trail hiding (trailPoints, loopPoints, linePoints) +import Diagrams.Trail hiding (linePoints, loopPoints, trailPoints) import Diagrams.TrailLike import Diagrams.Transform import Diagrams.TwoD import Diagrams.Util import Control.Applicative +import Control.Lens ((%~), (&), (.~)) import Data.Active import Data.AffineSpace import Data.Colour hiding (AffineSpace (..), atop, over) import Data.Colour.Names hiding (tan) import Data.Semigroup import Data.VectorSpace hiding (Sum (..)) -import Control.Lens ((&), (.~), (%~)) diff --git a/src/Diagrams/Prelude/ThreeD.hs b/src/Diagrams/Prelude/ThreeD.hs index 0f1f91d2..c1ba3fc4 100644 --- a/src/Diagrams/Prelude/ThreeD.hs +++ b/src/Diagrams/Prelude/ThreeD.hs @@ -137,18 +137,18 @@ import Diagrams.Points import Diagrams.Query import Diagrams.Segment import Diagrams.Tangent +import Diagrams.ThreeD import Diagrams.Trace import Diagrams.Trail import Diagrams.TrailLike import Diagrams.Transform -import Diagrams.ThreeD import Diagrams.Util import Control.Applicative +import Control.Lens ((%~), (&), (.~)) import Data.Active import Data.AffineSpace import Data.Colour hiding (AffineSpace (..), atop, over) import Data.Colour.Names hiding (tan) import Data.Semigroup import Data.VectorSpace hiding (Sum (..)) -import Control.Lens ((&), (.~), (%~)) diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index d9284cc8..4bcb156d 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -11,7 +11,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -64,15 +63,15 @@ module Diagrams.Segment ) where -import Control.Lens (makeLenses, Wrapped(..), Rewrapped, iso, op) -import Control.Applicative (liftA2) +import Control.Applicative (liftA2) +import Control.Lens (Rewrapped, Wrapped (..), iso, makeLenses, op) import Data.AffineSpace import Data.FingerTree import Data.Monoid.MList import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) -import Numeric.Interval.Kaucher (Interval (..)) -import qualified Numeric.Interval.Kaucher as I +import Data.VectorSpace hiding (Sum (..)) +import Numeric.Interval.Kaucher (Interval (..)) +import qualified Numeric.Interval.Kaucher as I import Diagrams.Core import Diagrams.Located diff --git a/src/Diagrams/Solve.hs b/src/Diagrams/Solve.hs index f027548d..9c18a0df 100644 --- a/src/Diagrams/Solve.hs +++ b/src/Diagrams/Solve.hs @@ -21,8 +21,8 @@ import Data.Ord (comparing) import Diagrams.Util (tau) -import Prelude hiding ((^)) -import qualified Prelude as P ((^)) +import Prelude hiding ((^)) +import qualified Prelude as P ((^)) -- | A specialization of (^) to Integer -- c.f. http://comments.gmane.org/gmane.comp.lang.haskell.libraries/21164 @@ -130,7 +130,7 @@ _cubForm_prop a b c d = all (aboutZero' 1e-5 . eval) (cubForm a b c d) -- issue in practice we could, say, use the solutions -- generated here as very good guesses to a numerical -- solver which can give us a more precise answer? - + ------------------------------------------------------------ -- Quartic formula ------------------------------------------------------------ @@ -165,7 +165,7 @@ quartForm' toler c4 c3 c2 c1 c0 -- solve the resolvent cubic - only one solution is needed z:_ = cubForm 1 (-p/2) (-r) (p*r/2 - q^2/8) - + -- solve the two quadratic equations -- y^2 ± v*y-(±u-z) u = z^2 - r diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs index 8f69ff70..697a73b3 100644 --- a/src/Diagrams/Tangent.hs +++ b/src/Diagrams/Tangent.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} ----------------------------------------------------------------------------- -- | @@ -31,8 +31,8 @@ import Diagrams.Core import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment -import Diagrams.TwoD.Vector (perp) import Diagrams.TwoD.Types (R2Ish) +import Diagrams.TwoD.Vector (perp) ------------------------------------------------------------ -- Tangent diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs index 60292d48..f536c5a2 100644 --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -44,13 +44,13 @@ module Diagrams.ThreeD , module Diagrams.ThreeD.Vector ) where -import Diagrams.ThreeD.Align -import Diagrams.ThreeD.Attributes -import Diagrams.ThreeD.Camera -import Diagrams.ThreeD.Deform -import Diagrams.ThreeD.Light -import Diagrams.ThreeD.Shapes -import Diagrams.ThreeD.Transform -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Types.Double -import Diagrams.ThreeD.Vector +import Diagrams.ThreeD.Align +import Diagrams.ThreeD.Attributes +import Diagrams.ThreeD.Camera +import Diagrams.ThreeD.Deform +import Diagrams.ThreeD.Light +import Diagrams.ThreeD.Shapes +import Diagrams.ThreeD.Transform +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Types.Double +import Diagrams.ThreeD.Vector diff --git a/src/Diagrams/ThreeD/Align.hs b/src/Diagrams/ThreeD/Align.hs index 0e9c262c..e4b3f577 100644 --- a/src/Diagrams/ThreeD/Align.hs +++ b/src/Diagrams/ThreeD/Align.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Align diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs index 469c9937..db05639f 100644 --- a/src/Diagrams/ThreeD/Attributes.hs +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Attributes @@ -26,13 +28,13 @@ module Diagrams.ThreeD.Attributes where -import Control.Lens -import Data.Semigroup -import Data.Typeable +import Control.Lens +import Data.Semigroup +import Data.Typeable -import Data.Colour +import Data.Colour -import Diagrams.Core +import Diagrams.Core -- | @SurfaceColor@ is the inherent pigment of an object, assumed to -- be opaque. @@ -88,7 +90,7 @@ ambient = applyAttr . review _Ambient -- Physically, the intensity and the value of @Diffuse@ must add up to -- less than 1; this is not enforced. data Specular = Specular { _specularIntensity :: Double - , _specularSize :: Double + , _specularSize :: Double } makeLenses ''Specular diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index 58f54176..ee4b924d 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveDataTypeable, ConstraintKinds, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -121,7 +123,7 @@ mm50 = PerspectiveLens (40.5 @@ deg) (27 @@ deg) mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) -- | mm50Narrow has the same vertical field of view as mm50, but an --- aspect ratio of 4:3, for VGA and similar computer resulotions. +-- aspect ratio of 4:3, for VGA and similar computer resolutions. mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) camForward :: (R3Ish v, v ~ V l) => Camera l -> Direction v @@ -137,5 +139,5 @@ camRight c = direction right where camLens :: (R3Ish v, v ~ V l) => Camera l -> l camLens = lens -camAspect :: (R3Ish v, v ~ V l) => CameraLens l => Camera l -> Scalar v +camAspect :: (R3Ish v, v ~ V l, CameraLens l) => Camera l -> Scalar v camAspect = aspect . camLens diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs index f684e306..c3ce4ad4 100644 --- a/src/Diagrams/ThreeD/Deform.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module Diagrams.ThreeD.Deform where -import Control.Lens +import Control.Lens -import Diagrams.Deform +import Diagrams.Deform -import Diagrams.Coordinates -import Diagrams.ThreeD.Types +import Diagrams.Coordinates +import Diagrams.ThreeD.Types -- | The parallel projection onto the plane x=0 parallelX0 :: (R3Ish v) => Deformation v diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs index 962e8492..01986ea6 100644 --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds, UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index 3479cfb5..69e272b7 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies, ConstraintKinds, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Shapes diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 547e450d..0dfc34b3 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns , ConstraintKinds, ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Transform @@ -47,12 +49,12 @@ import Diagrams.Core import qualified Diagrams.Core.Transform as T import Diagrams.Angle +import Diagrams.Coordinates import Diagrams.Direction -import Diagrams.Transform import Diagrams.ThreeD.Types -import Diagrams.Coordinates +import Diagrams.Transform -import Control.Lens (view, (*~), (//~)) +import Control.Lens (view, (*~), (//~)) import Data.Semigroup import Data.AffineSpace diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index f232819a..09dab03e 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -31,16 +32,16 @@ module Diagrams.ThreeD.Types import Control.Lens (Iso', iso) -import Diagrams.Core import Diagrams.Angle import Diagrams.Coordinates +import Diagrams.Core import Diagrams.Points import Data.AffineSpace.Point import Data.Basis import Data.Cross -import Data.VectorSpace import Data.Typeable +import Data.VectorSpace ------------------------------------------------------------ -- 3D Euclidean space diff --git a/src/Diagrams/ThreeD/Types/Double.hs b/src/Diagrams/ThreeD/Types/Double.hs index 8cf6c7b9..6880e95e 100644 --- a/src/Diagrams/ThreeD/Types/Double.hs +++ b/src/Diagrams/ThreeD/Types/Double.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -23,13 +24,13 @@ module Diagrams.ThreeD.Types.Double R3(..), P3, T3 ) where -import Control.Lens (iso, over, _1, _2, _3, (^.)) +import Control.Lens (iso, over, (^.), _1, _2, _3) -import Diagrams.Core import Diagrams.Angle -import Diagrams.TwoD.Types.Double(R2) -import Diagrams.ThreeD.Types import Diagrams.Coordinates +import Diagrams.Core +import Diagrams.ThreeD.Types +import Diagrams.TwoD.Types.Double (R2) import Data.Basis import Data.Cross diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 46b8aea3..ca325698 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE FlexibleContexts - , TypeFamilies - , ViewPatterns, ConstraintKinds - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Vector @@ -17,8 +16,8 @@ module Diagrams.ThreeD.Vector unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, ) where -import Diagrams.Coordinates -import Diagrams.ThreeD.Types +import Diagrams.Coordinates +import Diagrams.ThreeD.Types -- | The unit vector in the positive X direction. diff --git a/src/Diagrams/Trace.hs b/src/Diagrams/Trace.hs index a1a3a6dd..0f856327 100644 --- a/src/Diagrams/Trace.hs +++ b/src/Diagrams/Trace.hs @@ -27,14 +27,13 @@ module Diagrams.Trace ) where -import Diagrams.Core (HasLinearMap, Point, Subdiagram - , location, origin, setTrace, trace - , OrderedField) +import Diagrams.Core (HasLinearMap, OrderedField, Point, Subdiagram, location, + origin, setTrace, trace) import Diagrams.Core.Trace import Data.Maybe import Data.Semigroup -import Data.VectorSpace (Scalar, negateV, InnerSpace) +import Data.VectorSpace (InnerSpace, Scalar, negateV) import Diagrams.Combinators (withTrace) -- | Compute the furthest point on the boundary of a subdiagram, diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index f8490bf9..6735a7f2 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -104,20 +104,19 @@ module Diagrams.Trail ) where -import Control.Arrow ((***)) -import Control.Lens (AnIso', iso, view, op, Wrapped(..), Rewrapped - , cloneIso, (^.)) +import Control.Arrow ((***)) +import Control.Lens (AnIso', Rewrapped, Wrapped (..), cloneIso, iso, op, view, + (^.)) import Data.AffineSpace -import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), - (|>)) -import qualified Data.FingerTree as FT -import qualified Data.Foldable as F +import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), (|>)) +import qualified Data.FingerTree as FT +import qualified Data.Foldable as F import Data.Monoid.MList import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) -import qualified Numeric.Interval.Kaucher as I +import Data.VectorSpace hiding (Sum (..)) +import qualified Numeric.Interval.Kaucher as I -import Diagrams.Core hiding ((|>)) +import Diagrams.Core hiding ((|>)) import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment @@ -1057,7 +1056,7 @@ tolerance = 10e-16 -- @trailVertices . (\`at\` origin)@. trailVertices' :: (InnerSpace v, OrderedField (Scalar v)) => Scalar v -> Located (Trail v) -> [Point v] -trailVertices' toler (viewLoc -> (p,t)) +trailVertices' toler (viewLoc -> (p,t)) = withTrail (lineVertices' toler . (`at` p)) (loopVertices' toler . (`at` p)) t -- : Like trailVertices' but the tolerance is set to tolerance @@ -1069,20 +1068,20 @@ trailVertices l = trailVertices' tolerance l -- 'trailVertices' for more information. lineVertices' :: (InnerSpace v, OrderedField (Scalar v)) => Scalar v -> Located (Trail' Line v) -> [Point v] -lineVertices' toler (viewLoc -> (p,t)) +lineVertices' toler (viewLoc -> (p,t)) = segmentVertices' toler p . lineSegments $ t -- | Like lineVertices' with tolerance set to tolerance. lineVertices :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail' Line v) -> [Point v] -lineVertices l = lineVertices' tolerance l +lineVertices l = lineVertices' tolerance l -- | Extract the vertices of a concretely located loop. Note that the -- initial vertex is not repeated at the end. See 'trailVertices' for -- more information. loopVertices' :: (InnerSpace v, OrderedField (Scalar v)) => Scalar v -> Located (Trail' Loop v) -> [Point v] -loopVertices' toler (viewLoc -> (p,t)) +loopVertices' toler (viewLoc -> (p,t)) | length segs > 1 = if far > toler then init ps else init . (drop 1) $ ps | otherwise = ps where diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs index 5a6b03b1..e9fa26df 100644 --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -28,9 +28,9 @@ module Diagrams.TrailLike ) where +import Control.Lens (view, _Unwrapped') import Data.AffineSpace ((.-.)) import Data.VectorSpace -import Control.Lens (view, _Unwrapped') import Diagrams.Core import Diagrams.Located diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 5f81da7b..c4bccede 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -239,7 +239,7 @@ module Diagrams.TwoD , sized, sizedAs -- * Textures - , Texture(..), solid + , Texture(..), solid , SpreadMethod(..), GradientStop(..), mkStops, getFillTexture , fillTexture, getLineTexture, lineTexture, lineTextureA , stopFraction, stopColor @@ -293,4 +293,4 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Types.Double import Diagrams.TwoD.Vector -import Diagrams.Util (tau) +import Diagrams.Util (tau) diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs index 808e46c9..d41afaeb 100644 --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -20,12 +22,10 @@ module Diagrams.TwoD.Adjust , adjustDia2D ) where -import Diagrams.Attributes (lineCap, lineJoin, - lineMiterLimitA) +import Diagrams.Attributes (lineCap, lineJoin, lineMiterLimitA) import Diagrams.Core -import Diagrams.TwoD.Attributes (lineWidthA, lineTextureA) -import Diagrams.TwoD.Size (SizeSpec2D (..), center2D, - requiredScale, size2D) +import Diagrams.TwoD.Attributes (lineTextureA, lineWidthA) +import Diagrams.TwoD.Size (SizeSpec2D (..), center2D, requiredScale, size2D) import Diagrams.TwoD.Text (fontSizeA) import Diagrams.TwoD.Types (R2Ish, p2) import Diagrams.Util (( # )) diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs index 6f08b2b7..dbbf4d75 100644 --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index 78d92daf..b015974e 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns, ConstraintKinds, FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arc @@ -23,8 +25,8 @@ module Diagrams.TwoD.Arc ) where import Diagrams.Angle -import Diagrams.Direction import Diagrams.Core +import Diagrams.Direction import Diagrams.Located (at) import Diagrams.Segment import Diagrams.Trail @@ -34,7 +36,7 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unitY, unit_Y) import Diagrams.Util (( # )) -import Control.Lens ((^.), (&), (<>~)) +import Control.Lens ((&), (<>~), (^.)) import Data.AffineSpace import Data.Semigroup ((<>)) import Data.VectorSpace diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index afbb620e..61c5b216 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -100,10 +102,8 @@ module Diagrams.TwoD.Arrow ) where import Control.Applicative ((<*>)) -import Control.Lens (Lens', Setter', Traversal', - generateSignatures, lensRules, - makeLensesWith, view, (%~), (&), - (.~), (^.)) +import Control.Lens (Lens', Setter', Traversal', generateSignatures, + lensRules, makeLensesWith, view, (%~), (&), (.~), (^.)) import Data.AffineSpace import Data.Default.Class import Data.Functor ((<$>)) @@ -184,7 +184,7 @@ headGap :: Lens' (ArrowOpts v) (Measure v) tailGap :: Lens' (ArrowOpts v) (Measure v) -- | Set both the @headGap@ and @tailGap@ simultaneously. -gaps :: Traversal' (ArrowOpts v) (Measure v) +gaps :: Traversal' (ArrowOpts v) (Measure v) gaps f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap) @@ -208,7 +208,7 @@ shaftStyle :: Lens' (ArrowOpts v) (Style v) -- | The length from the start of the joint to the tip of the head. headLength :: Lens' (ArrowOpts v) (Measure v) --- | The length of the tail plus its joint. +-- | The length of the tail plus its joint. tailLength :: Lens' (ArrowOpts v) (Measure v) -- | Set both the @headLength@ and @tailLength@ simultaneously. diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 2dbe40f6..73eabc11 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arrowheads @@ -55,7 +56,7 @@ module Diagrams.TwoD.Arrowheads , ArrowHT ) where -import Control.Lens ((&), (.~), (^.), (<>~)) +import Control.Lens ((&), (.~), (<>~), (^.)) import Data.AffineSpace import Data.Default.Class import Data.Monoid (mempty, (<>)) @@ -204,7 +205,7 @@ spike = arrowheadSpike (3/8 @@ turn) -- > thornEx = drawHead thorn thorn :: (R2Ish v) => ArrowHT v -thorn = arrowheadThorn (3/8 @@ turn) +thorn = arrowheadThorn (3/8 @@ turn) -- | <> diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index b9858083..a0a0c067 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -68,10 +71,10 @@ module Diagrams.TwoD.Attributes ( ) where -import Diagrams.Core -import Diagrams.Core.Style (setAttr) import Diagrams.Attributes import Diagrams.Attributes.Compile +import Diagrams.Core +import Diagrams.Core.Style (setAttr) import Diagrams.TwoD.Types import Diagrams.Core.Types (RTree) @@ -79,10 +82,10 @@ import Diagrams.Located (unLoc) import Diagrams.Path (Path, pathTrails) import Diagrams.Trail (isLoop) -import Control.Lens ( makeLensesWith, generateSignatures, lensRules - , makePrisms, Lens', (&), (%~), (.~), Setter', sets) +import Control.Lens (Lens', Setter', generateSignatures, lensRules, + makeLensesWith, makePrisms, sets, (%~), (&), (.~)) -import Data.Colour hiding (AffineSpace) +import Data.Colour hiding (AffineSpace) import Data.Data import Data.Default.Class import Data.Maybe (fromMaybe) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index eeaf6b8e..4a41e220 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ConstraintKinds, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Combinators @@ -38,7 +39,7 @@ module Diagrams.TwoD.Combinators ) where -import Control.Lens ((&), (.~)) +import Control.Lens ((&), (.~)) import Data.AffineSpace import Data.Colour import Data.Default.Class @@ -54,7 +55,7 @@ import Diagrams.Path import Diagrams.Segment import Diagrams.TrailLike import Diagrams.TwoD.Align -import Diagrams.TwoD.Attributes (lineWidth, fc) +import Diagrams.TwoD.Attributes (fc, lineWidth) import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform (scaleX, scaleY) @@ -260,6 +261,6 @@ bg c d = d <> boundingRect d # lineWidth (Output 0) # fc c -- | Similar to 'bg' but makes the colored background rectangle larger than -- the diagram. The first parameter is used to set how far the background -- extends beyond the diagram. -bgFrame :: (R2Ish v, Renderable (Path v) b, Backend b v) +bgFrame :: (R2Ish v, Renderable (Path v) b, Backend b v) => Scalar v -> Colour Double -> Diagram b v -> Diagram b v bgFrame f c d = d <> boundingRect (frame f d) # lineWidth (Output 0) # fc c diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs index d1b50711..7d7e95bf 100644 --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs, ConstraintKinds #-} +{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Curvature @@ -22,8 +23,8 @@ module Diagrams.TwoD.Curvature import Data.Monoid.Inf import Data.VectorSpace -import Control.Arrow (first, second) -import Control.Monad (join) +import Control.Arrow (first, second) +import Control.Monad (join) import Diagrams.Segment import Diagrams.Tangent diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs index 5718ec6e..95a9be68 100644 --- a/src/Diagrams/TwoD/Deform.hs +++ b/src/Diagrams/TwoD/Deform.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module Diagrams.TwoD.Deform where -import Control.Lens +import Control.Lens -import Diagrams.Deform +import Diagrams.Deform -import Diagrams.Coordinates -import Diagrams.TwoD.Types +import Diagrams.Coordinates +import Diagrams.TwoD.Types -- | The parallel projection onto the line x=0 parallelX0 :: (R2Ish v) => Deformation v diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index d29ad9d2..8c3c5378 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances, ConstraintKinds #-} +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Ellipse @@ -24,16 +25,16 @@ module Diagrams.TwoD.Ellipse import Diagrams.Core +import Data.VectorSpace import Diagrams.Angle import Diagrams.Located (at) +import Diagrams.Trail (glueTrail) import Diagrams.TrailLike -import Diagrams.Trail (glueTrail) import Diagrams.TwoD.Arc import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (xDir) import Diagrams.Util -import Data.VectorSpace -- | A circle of radius 1, with center at the origin. unitCircle :: (TrailLike t, R2Ish (V t)) => t diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs index 49584aa5..1134d7da 100644 --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -1,10 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -35,8 +35,8 @@ module Diagrams.TwoD.Image import Codec.Picture import Codec.Picture.Types (dynamicMap) -import Data.Typeable (Typeable) import Data.Colour (AlphaColour) +import Data.Typeable (Typeable) import Diagrams.Core diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs index 37b23dda..5f1d8a5a 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell, ConstraintKinds, TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Model @@ -20,34 +22,34 @@ module Diagrams.TwoD.Model , showLabels ) where -import Control.Lens (makeLenses, (^.)) +import Control.Lens (makeLenses, (^.)) import Diagrams.Core -import Diagrams.TwoD.Attributes import Diagrams.Path +import Diagrams.TwoD.Attributes import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Path -import Diagrams.TwoD.Size (size2D) +import Diagrams.TwoD.Size (size2D) import Diagrams.TwoD.Text import Diagrams.TwoD.Types import Diagrams.Util -import Control.Arrow (second) -import Data.AffineSpace ((.-.)) +import Control.Arrow (second) +import Data.AffineSpace ((.-.)) import Data.Default.Class import Data.Semigroup -import Data.VectorSpace ((^*),Scalar) +import Data.VectorSpace (Scalar, (^*)) -import qualified Data.Map as M +import qualified Data.Map as M -import Data.Colour (Colour) +import Data.Colour (Colour) import Data.Colour.Names ------------------------------------------------------------ -- Marking the origin ------------------------------------------------------------ -data OriginOpts d = OriginOpts { _oColor :: Colour Double +data OriginOpts d = OriginOpts { _oColor :: Colour Double , _oScale :: d , _oMinSize :: d } diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index 95be95b6..30597a99 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -12,15 +14,15 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Compute offsets to segments in two dimensions. More details can be --- found in the manual at +-- Compute offsets to segments in two dimensions. More details can be +-- found in the manual at -- . -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Offset - ( + ( -- * Offsets - + offsetSegment , OffsetOpts(..), offsetJoin, offsetMiterLimit, offsetEpsilon @@ -39,33 +41,33 @@ module Diagrams.TwoD.Offset ) where -import Control.Applicative -import Control.Lens hiding (at) - -import Data.AffineSpace -import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Monoid.Inf -import Data.VectorSpace - -import Data.Default.Class - -import Diagrams.Core - -import Diagrams.Angle -import Diagrams.Attributes -import Diagrams.Direction (direction) -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Trail hiding (offset, isLoop) -import Diagrams.TrailLike -import Diagrams.TwoD.Arc -import Diagrams.TwoD.Curvature -import Diagrams.TwoD.Path () -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (perp) +import Control.Applicative +import Control.Lens hiding (at) + +import Data.AffineSpace +import Data.Maybe (catMaybes) +import Data.Monoid +import Data.Monoid.Inf +import Data.VectorSpace + +import Data.Default.Class + +import Diagrams.Core + +import Diagrams.Angle +import Diagrams.Attributes +import Diagrams.Direction (direction) +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail hiding (isLoop, offset) +import Diagrams.TrailLike +import Diagrams.TwoD.Arc +import Diagrams.TwoD.Curvature +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (perp) unitPerp :: (R2Ish v) => v -> v unitPerp = normalized . perp @@ -106,11 +108,11 @@ perpAtParam s@(Cubic _ _ _) t = negateV $ unitPerp a -- | Options for specifying line join and segment epsilon for an offset -- involving multiple segments. data OffsetOpts d = OffsetOpts - { _offsetJoin :: LineJoin + { _offsetJoin :: LineJoin , _offsetMiterLimit :: d - , _offsetEpsilon :: d + , _offsetEpsilon :: d } - + deriving instance Eq d => Eq (OffsetOpts d) deriving instance Show d => Show (OffsetOpts d) @@ -132,10 +134,10 @@ instance (Fractional d) => Default (OffsetOpts d) where -- | Options for specifying how a 'Trail' should be expanded. data ExpandOpts d = ExpandOpts - { _expandJoin :: LineJoin + { _expandJoin :: LineJoin , _expandMiterLimit :: d - , _expandCap :: LineCap - , _expandEpsilon :: d + , _expandCap :: LineCap + , _expandEpsilon :: d } deriving (Eq, Show) makeLensesWith (lensRules & generateSignatures .~ False) ''ExpandOpts @@ -370,7 +372,7 @@ expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) where eps = opts^.expandEpsilon offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments - f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends + f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends . offset r' $ t ends = tail . trailVertices $ t s = atStart t @@ -382,7 +384,7 @@ expandLoop opts r (mapLoc wrapLoop -> t) = (trailLike $ f r) <> (trailLike . rev where eps = opts^.expandEpsilon offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments - f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends + f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends . offset r' $ t ends = (\(a:as) -> as ++ [a]) . trailVertices $ t @@ -472,10 +474,10 @@ capArc r c a b = trailLike . moveTo c $ fs -- Arc helpers -- always picks the shorter arc (< τ/2) -arcV :: (R2Ish v) => (TrailLike t, V t ~ v) => v -> v -> t +arcV :: (R2Ish v, TrailLike t, V t ~ v) => v -> v -> t arcV u v = arc (direction u) (angleBetween v u) -arcVCW :: (R2Ish v) => (TrailLike t, V t ~ v) => v -> v -> t +arcVCW :: (R2Ish v, TrailLike t, V t ~ v) => v -> v -> t arcVCW u v = arc (direction u) (negateV $ angleBetween v u) -- | Join together a list of located trails with the given join style. The @@ -541,7 +543,7 @@ joinSegmentArc _ r e a b = capArc r e (atEnd a) (atStart b) -- If the intersection is beyond the miter limit times the radius, stop at the limit. joinSegmentIntersect :: (R2Ish v) => Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v -joinSegmentIntersect miterLimit r e a b = +joinSegmentIntersect miterLimit r e a b = if cross < 0.000001 then clip else case traceP pa va t of diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 9d1973a9..5f012920 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -1,13 +1,15 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -46,9 +48,8 @@ module Diagrams.TwoD.Path ) where import Control.Applicative (liftA2) -import Control.Lens (Lens, Lens', generateSignatures, - lensRules, makeLensesWith, makeWrapped, - op, (.~), (^.), _Wrapped') +import Control.Lens (Lens, Lens', generateSignatures, lensRules, makeLensesWith, + makeWrapped, op, (.~), (^.), _Wrapped') import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index 31b7c22d..2657ca2e 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -46,12 +49,11 @@ module Diagrams.TwoD.Polygons( ) where -import Control.Lens (Lens', generateSignatures, lensRules, - makeLensesWith, (.~), (^.), view) +import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, + view, (.~), (^.)) import Control.Monad (forM, liftM) import Control.Monad.ST (ST, runST) -import Data.Array.ST (STUArray, newArray, readArray, - writeArray) +import Data.Array.ST (STUArray, newArray, readArray, writeArray) import Data.List (maximumBy, minimumBy) import Data.Maybe (catMaybes) import Data.Monoid (mconcat, mempty) diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index 7689d18b..a510ba00 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Orphan Traced instances for Segment Closed R2 and FixedSegment R2. @@ -24,7 +24,7 @@ module Diagrams.TwoD.Segment where import Control.Applicative (liftA2) -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Data.AffineSpace import Data.VectorSpace diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index f1c1df7d..7a0dada0 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -62,7 +62,7 @@ import Diagrams.TwoD.Vector import Diagrams.Util -import Control.Lens (makeLenses, op, (&), (.~), (^.), (<>~)) +import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.)) import Data.Default.Class import Data.Semigroup import Data.VectorSpace @@ -237,9 +237,9 @@ dodecagon = regPoly 12 -- Other shapes ------------------------------------------ ------------------------------------------------------------ data RoundedRectOpts d = RoundedRectOpts { _radiusTL :: d - , _radiusTR :: d - , _radiusBL :: d - , _radiusBR :: d + , _radiusTR :: d + , _radiusBL :: d + , _radiusBR :: d } makeLenses ''RoundedRectOpts diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index 109e5389..ce5cc5c4 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies, ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -funbox-strict-fields #-} ----------------------------------------------------------------------------- diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 6f4860e9..372cfe39 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 3e16e57b..8a957429 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns, ConstraintKinds, TypeOperators #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform @@ -57,11 +59,11 @@ import Diagrams.Transform import Diagrams.TwoD.Size (height, width) import Diagrams.TwoD.Types +import Control.Lens (review, (^.)) import Data.AdditiveGroup import Data.AffineSpace import Data.Semigroup import Data.VectorSpace -import Control.Lens (review, (^.)) type T = Transformation type P = Point diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 56f5741e..cba9fcc4 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -1,8 +1,14 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies ,StandaloneDeriving , ConstraintKinds , AllowAmbiguousTypes, ScopedTypeVariables, InstanceSigs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform.ScaleInv @@ -20,12 +26,12 @@ module Diagrams.TwoD.Transform.ScaleInv , scaleInv, scaleInvPrim) where -import Control.Lens (makeLenses, view,(^.)) +import Control.Lens (makeLenses, view, (^.)) import Data.AdditiveGroup import Data.AffineSpace ((.-.)) -import Data.VectorSpace import Data.Semigroup import Data.Typeable +import Data.VectorSpace import Diagrams.Angle import Diagrams.Core @@ -86,7 +92,6 @@ instance (HasOrigin t) => HasOrigin (ScaleInv t) where moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) instance (R2Ish (V t), Transformable t) => Transformable (ScaleInv t) where - transform :: Transformation (V (ScaleInv t)) -> ScaleInv t -> ScaleInv t transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where angle :: Angle (Scalar (V (ScaleInv t))) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 539048f7..0bd8e73f 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -1,12 +1,13 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- diff --git a/src/Diagrams/TwoD/Types/Double.hs b/src/Diagrams/TwoD/Types/Double.hs index 427d2724..4a653975 100644 --- a/src/Diagrams/TwoD/Types/Double.hs +++ b/src/Diagrams/TwoD/Types/Double.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -6,7 +7,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -25,7 +25,7 @@ module Diagrams.TwoD.Types.Double R2(..), P2, T2 ) where -import Control.Lens (Rewrapped, Wrapped (..), iso, (^.), _1, _2) +import Control.Lens (Rewrapped, Wrapped (..), iso, (^.), _1, _2) import Diagrams.Angle diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 32c94764..a45330ee 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Vector @@ -24,14 +24,14 @@ module Diagrams.TwoD.Vector -- * Synonym for R2 things ) where -import Control.Lens ((&), (.~)) +import Control.Lens ((&), (.~)) -import Data.VectorSpace +import Data.VectorSpace -import Diagrams.Core.V -import Diagrams.Angle -import Diagrams.Direction -import Diagrams.TwoD.Types +import Diagrams.Angle +import Diagrams.Core.V +import Diagrams.Direction +import Diagrams.TwoD.Types -- | The unit vector in the positive X direction. unitX :: (R2Ish v) => v diff --git a/test/Arcs.hs b/test/Arcs.hs index 24c5c068..7a867585 100644 --- a/test/Arcs.hs +++ b/test/Arcs.hs @@ -1,30 +1,30 @@ -import Diagrams.Prelude -import Diagrams.Backend.Postscript -import Diagrams.Backend.Postscript.CmdLine +import Diagrams.Backend.Postscript +import Diagrams.Backend.Postscript.CmdLine +import Diagrams.Prelude -import Diagrams.TwoD.Arc +import Diagrams.TwoD.Arc -exampleArc f r = (vertLabel |||) . centerXY . (horzLabel ===) . centerXY $ hcat - [ vcat - [ phantom (circle (1.05 * abs r) :: D R2) +exampleArc f r = (vertLabel |||) . centerXY . (horzLabel ===) . centerXY $ hcat + [ vcat + [ phantom (circle (1.05 * abs r) :: D R2) <> s # lc green # lw 0.01 <> e # lc red # lw 0.01 <> (lw 0.01 . stroke $ f r (n/8) (m/8)) | n <- rs , let s = rotateBy (n/8) (origin ~~ (3 & 0)) , let e = rotateBy (m/8) (origin ~~ (3 & 0)) - ] + ] | m <- rs ] where rs = [0..7 :: CircleFrac] horzLabel = centerX $ rect 5 10 # lw 0 <> (text "start angle" # scale 0.4) vertLabel = centerY . rotateBy (1/4) $ rect 5 10 # lw 0 <> (text "end angle" # scale 0.4) - + exampleRR :: Diagram Postscript R2 -exampleRR = (vertLabel |||) . centerXY . (horzLabel ===) . centerXY $ hcat - [ vcat - [ phantom (pad 1.1 $ rect 10 15 :: D R2) +exampleRR = (vertLabel |||) . centerXY . (horzLabel ===) . centerXY $ hcat + [ vcat + [ phantom (pad 1.1 $ rect 10 15 :: D R2) <> (origin ~~ (0 & r)) # lc red # lw 0.01 <> (fc lightblue . lw 0.01 . stroke $ roundedRect' 10 15 o) | o <- [ RoundedRectOpts 0 r 0 0 @@ -32,7 +32,7 @@ exampleRR = (vertLabel |||) . centerXY . (horzLabel ===) . centerXY $ hcat , RoundedRectOpts 0 0 r 0 , RoundedRectOpts 0 0 0 r ] - ] + ] | r <- [-4..4] ] where @@ -45,4 +45,4 @@ arcs = [ ("arc' CCW", exampleArc arc' 3) , ("arcCW CCW", exampleArc (\r s e -> arcCW s e # scale (abs r)) (-3)) ] :: [(String, Diagram Postscript R2)] -main = defaultMain (vcat (map snd arcs) === exampleRR) \ No newline at end of file +main = defaultMain (vcat (map snd arcs) === exampleRR) diff --git a/test/Arrowtest.hs b/test/Arrowtest.hs index e04d00f1..f4653b92 100644 --- a/test/Arrowtest.hs +++ b/test/Arrowtest.hs @@ -1,8 +1,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -import Diagrams.Prelude -import Diagrams.Backend.SVG.CmdLine -import Data.List.Split (chunksOf) +import Data.List.Split (chunksOf) +import Diagrams.Backend.SVG.CmdLine +import Diagrams.Prelude -- Create a 3 x 3 grid of circles named "1" to "9" c = circle 1.5 # fc lightgray # lw none # showOrigin diff --git a/test/BBTest.hs b/test/BBTest.hs index 26b02807..7660affc 100644 --- a/test/BBTest.hs +++ b/test/BBTest.hs @@ -1,9 +1,9 @@ -import Test.QuickCheck +import Test.QuickCheck -import Diagrams.BoundingBox +import Diagrams.BoundingBox instance Arbitrary (NonEmptyBoundingBox Q2) where arbitrary = do p <- arbitrary PosVec v <- arbitrary - return $ NonEmptyBoundingBox p (p .+^ v) \ No newline at end of file + return $ NonEmptyBoundingBox p (p .+^ v) diff --git a/test/Gradient/Ball.hs b/test/Gradient/Ball.hs index a95ec578..d43ce901 100644 --- a/test/Gradient/Ball.hs +++ b/test/Gradient/Ball.hs @@ -2,12 +2,12 @@ module Main where -import Diagrams.Prelude import Diagrams.Backend.Rasterific.CmdLine +import Diagrams.Prelude radial = mkRadialGradient (mkStops [(white,0,1), (black,1,1)]) ((-0.1) ^& (0.1)) 0.06 (0 ^& 0) 0.35 GradPad linear = mkLinearGradient (mkStops [(black,0,1), (white,1,1)]) (0 ^& (-0.5)) (0 ^& 0.5) GradPad example = circle 0.25 # fillTexture radial # lw none <> square 1 # fillTexture linear # lw none -main = defaultMain $ example # scaleX 1 # pad 1.1 \ No newline at end of file +main = defaultMain $ example # scaleX 1 # pad 1.1 diff --git a/test/Gradient/rectGrad.hs b/test/Gradient/rectGrad.hs index decf49f1..6f038b69 100644 --- a/test/Gradient/rectGrad.hs +++ b/test/Gradient/rectGrad.hs @@ -2,8 +2,8 @@ module Main where -import Diagrams.Prelude import Diagrams.Backend.SVG.CmdLine +import Diagrams.Prelude -- Red to White to Blue linear gradient wtih direction vector (1,0). --g = LGradient [(SomeColor red, 0, 1), (SomeColor black, 0.5, 0) @@ -32,4 +32,4 @@ e2 = vcat' (with & sep .~ 35) [s # rotateBy (3/16), s' # rotateBy (1/4), s # rot e3 = vcat' (with & sep .~ 35) [s # rotateBy (3/8), s # rotateBy (7/16), s' # rotateBy (1/2)] example = hcat' (with & sep .~ 25) [e1, e2, e3] -main = defaultMain $ (example # centerXY # pad 1.1) <> (square 600 # fillTexture linear) \ No newline at end of file +main = defaultMain $ (example # centerXY # pad 1.1) <> (square 600 # fillTexture linear) diff --git a/test/Issue57.hs b/test/Issue57.hs index f16bf7f2..be7d85c3 100644 --- a/test/Issue57.hs +++ b/test/Issue57.hs @@ -19,10 +19,10 @@ Concatenating one thousand unit squares shouldn't take more than 20 seconds =). -} -- from diagrams-lib -import Diagrams.Prelude +import Diagrams.Prelude -- from diagrams-cairo -import Diagrams.Backend.Cairo.CmdLine (Cairo, multiMain) +import Diagrams.Backend.Cairo.CmdLine (Cairo, multiMain) main :: IO () main = multiMain [ ("hcat", hcat (dias n)) diff --git a/test/PolyTest.hs b/test/PolyTest.hs index fef9b57f..c3d62301 100644 --- a/test/PolyTest.hs +++ b/test/PolyTest.hs @@ -1,9 +1,9 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -import Diagrams.Prelude -import Diagrams.Backend.Cairo.CmdLine +import Diagrams.Backend.Cairo.CmdLine +import Diagrams.Prelude -import Diagrams.TwoD.Polygons +import Diagrams.TwoD.Polygons -- d = stroke . close $ fromVertices (polyPoints with { polyStar = StarFun succ }) @@ -19,7 +19,7 @@ mkR v = (mconcat . mconcat $ p) d = hcat' with {sep = 0.5} (map mkR vs) # lw 0.05 -s = stroke $ starPoly (StarSkip 5) +s = stroke $ starPoly (StarSkip 5) (polygon (with & polyType .~ PolyPolar (repeat (tau/15 :: Rad)) (take 15 (cycle [6,7,8])) diff --git a/test/ShapeTest.hs b/test/ShapeTest.hs index d342be00..a9ba02b6 100644 --- a/test/ShapeTest.hs +++ b/test/ShapeTest.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -import Diagrams.Prelude -import Diagrams.Backend.Cairo.CmdLine +import Diagrams.Backend.Cairo.CmdLine +import Diagrams.Prelude -main = defaultMain (eqTriangle 1 === square 1 === octagon 1) \ No newline at end of file +main = defaultMain (eqTriangle 1 === square 1 === octagon 1) diff --git a/test/Shapes.hs b/test/Shapes.hs index 695ca715..13ded64b 100644 --- a/test/Shapes.hs +++ b/test/Shapes.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -import Diagrams.Prelude -import Diagrams.Backend.Cairo.CmdLine +import Diagrams.Backend.Cairo.CmdLine +import Diagrams.Prelude -main = defaultMain (eqTriangle === square 1) \ No newline at end of file +main = defaultMain (eqTriangle === square 1) diff --git a/test/Snugtest.hs b/test/Snugtest.hs index abe5311a..83d7d7b0 100644 --- a/test/Snugtest.hs +++ b/test/Snugtest.hs @@ -12,12 +12,12 @@ module Main where -import Diagrams.Prelude hiding (centerXY, alignR, alignL) -import Diagrams.Backend.SVG -import Diagrams.Backend.SVG.CmdLine +import Diagrams.Backend.SVG +import Diagrams.Backend.SVG.CmdLine +import Diagrams.Prelude hiding (alignL, alignR, centerXY) -import Diagrams.Align -import Diagrams.TwoD.Align +import Diagrams.Align +import Diagrams.TwoD.Align concave :: Diagram SVG R2 concave = polygon (with & polyType .~ PolyPolar [a, b, b, b] diff --git a/test/bezbench.hs b/test/bezbench.hs index 7ab699de..71421e1e 100644 --- a/test/bezbench.hs +++ b/test/bezbench.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeFamilies, NoMonomorphismRestriction #-} -import Data.VectorSpace -import Data.NumInstances -import Criterion.Main -import Diagrams.Segment +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +import Criterion.Main +import Data.NumInstances +import Data.VectorSpace +import Diagrams.Segment type Q2 = (Rational,Rational) type R2 = (Double,Double) diff --git a/test/clipTo.hs b/test/clipTo.hs index 2dc2b38d..829ca16d 100644 --- a/test/clipTo.hs +++ b/test/clipTo.hs @@ -1,7 +1,7 @@ -import Data.Maybe +import Data.Maybe -import Diagrams.Prelude -import Diagrams.Backend.SVG.CmdLine +import Diagrams.Backend.SVG.CmdLine +import Diagrams.Prelude clipPath :: Path R2 clipPath = square 2 # alignR diff --git a/test/diamBench.hs b/test/diamBench.hs index 82e2c77a..2a668b23 100644 --- a/test/diamBench.hs +++ b/test/diamBench.hs @@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} module DiamBench where -import Criterion.Main -import Diagrams.Prelude -import Diagrams.ThreeD.Shapes -import Diagrams.ThreeD.Types +import Criterion.Main +import Diagrams.Prelude +import Diagrams.ThreeD.Shapes +import Diagrams.ThreeD.Types -- Comparing the performance of two different diameter implementations diff --git a/test/splitTests.hs b/test/splitTests.hs index 08f78850..84d14634 100644 --- a/test/splitTests.hs +++ b/test/splitTests.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} -import Test.QuickCheck -import Control.Applicative -import Data.Ratio -import Data.VectorSpace -import Data.Default +import Control.Applicative +import Data.Default +import Data.Ratio +import Data.VectorSpace +import Test.QuickCheck -import Diagrams.Prelude +import Diagrams.Prelude type Q2 = (Rational, Rational) @@ -56,4 +58,4 @@ x ==~ y = abs (x - y) < eps prop_adjustSeg_byAbs_len :: Segment R2 -> Scalar R2 -> AdjustSide -> Bool prop_adjustSeg_byAbs_len s len side = - arcLength (adjustSegment s with { adjMethod = ByAbsolute len, adjSide = side }) eps ==~ abs (arcLength s eps + len) \ No newline at end of file + arcLength (adjustSegment s with { adjMethod = ByAbsolute len, adjSide = side }) eps ==~ abs (arcLength s eps + len) From cf925809371a7f7a2ed31ca42ac3fe5d03e80879 Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Fri, 1 Aug 2014 12:38:15 -0600 Subject: [PATCH 09/58] language pragma tweaks --- src/Diagrams/Angle.hs | 1 + src/Diagrams/TwoD/Transform/ScaleInv.hs | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 08145600..b73a7ff8 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Angle diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index cba9fcc4..02a084a1 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} From 892b6ab2b9553b49cb7068bf025e94137fe71576 Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Wed, 6 Aug 2014 20:05:10 -0600 Subject: [PATCH 10/58] more language tweaks --- src/Diagrams/Coordinates.hs | 5 +++-- src/Diagrams/TwoD/Image.hs | 1 + 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index f6a0f5b2..d6d03819 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Coordinates diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs index 1134d7da..10ac7339 100644 --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -5,6 +5,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | From c49c3d0f8baf67da62e964f4114324aab75f9793 Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Fri, 8 Aug 2014 21:06:29 -0600 Subject: [PATCH 11/58] Split R2Ish into R2Sym, and remove some useless instances of Point out of Types.Double --- src/Diagrams/TwoD/Types.hs | 29 ++++++++++++++++++----------- src/Diagrams/TwoD/Types/Double.hs | 31 ++++++++----------------------- 2 files changed, 26 insertions(+), 34 deletions(-) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 0bd8e73f..6cc5dff1 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -26,7 +26,8 @@ module Diagrams.TwoD.Types r2, unr2, mkR2, r2Iso , p2, mkP2, unp2, p2Iso , R2Basis(..) - , R2Ish + , R2Sym, R2Ish + , ScalarR2Sym, ScalarR2Ish , Polar(..) ) where @@ -35,6 +36,7 @@ import Control.Lens (Iso', iso) import Diagrams.Angle import Diagrams.Coordinates +import Diagrams.Points import Diagrams.Core import Data.AffineSpace.Point @@ -54,39 +56,44 @@ instance HasTrie R2Basis where untrie (R2Trie _x y) YB = y enumerate (R2Trie x y) = [(XB,x),(YB,y)] -type ScalarR2Ish d = (RealFloat d, VectorSpace d, HasBasis d, Basis d ~ (), Transformable d, Scalar d ~ d, V d ~ d, Data d) -type R2Ish v = (HasBasis v, Basis v ~ R2Basis, V v ~ v, Transformable v, InnerSpace v, Coordinates v, Decomposition v ~ (FinalCoord v :& FinalCoord v), PrevDim v ~ FinalCoord v, FinalCoord v ~ Scalar v, HasX v, HasY v, HasTheta v, Data v, ScalarR2Ish (Scalar v)) +type ScalarR2Sym d = (VectorSpace d, HasBasis d, Basis d ~ (), Transformable d, Scalar d ~ d, V d ~ d) +type ScalarR2Ish d = (RealFloat d, ScalarR2Sym d, Data d) +type R2Sym v = (HasBasis v, Basis v ~ R2Basis, V v ~ v, Transformable v, InnerSpace v, Coordinates v, Decomposition v ~ (FinalCoord v :& FinalCoord v), PrevDim v ~ FinalCoord v, FinalCoord v ~ Scalar v, HasX v, HasY v, ScalarR2Sym (Scalar v)) +type R2Ish v = (R2Sym v, ScalarR2Ish (Scalar v), HasTheta v, Data v) -- | Construct a 2D vector from a pair of components. See also '&'. -r2 :: (R2Ish v) => (Scalar v, Scalar v) -> v +r2 :: (R2Sym v) => (Scalar v, Scalar v) -> v r2 (x,y) = recompose [(XB,x),(YB,y)] -- | Convert a 2D vector back into a pair of components. See also 'coords'. -unr2 :: (R2Ish v) => v -> (Scalar v, Scalar v) +unr2 :: (R2Sym v) => v -> (Scalar v, Scalar v) unr2 v = (decompose' v XB, decompose' v YB) -- | Curried form of `r2`. -mkR2 :: (R2Ish v) => Scalar v -> Scalar v -> v +mkR2 :: (R2Sym v) => Scalar v -> Scalar v -> v mkR2 = curry r2 -r2Iso :: (R2Ish v) => Iso' v (Scalar v, Scalar v) +r2Iso :: (R2Sym v) => Iso' v (Scalar v, Scalar v) r2Iso = iso unr2 r2 -- | Construct a 2D point from a pair of coordinates. See also '^&'. -p2 :: (R2Ish v) => (Scalar v, Scalar v) -> Point v +p2 :: (R2Sym v) => (Scalar v, Scalar v) -> Point v p2 = P . r2 -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. -unp2 :: (R2Ish v) => Point v -> (Scalar v, Scalar v) +unp2 :: (R2Sym v) => Point v -> (Scalar v, Scalar v) unp2 (P v) = unr2 v -- | Curried form of `p2`. -mkP2 :: (R2Ish v) => Scalar v -> Scalar v -> Point v +mkP2 :: (R2Sym v) => Scalar v -> Scalar v -> Point v mkP2 = curry p2 -p2Iso :: (R2Ish v) => Iso' (Point v) (Scalar v, Scalar v) +p2Iso :: (R2Sym v) => Iso' (Point v) (Scalar v, Scalar v) p2Iso = iso unp2 p2 -- | Types which can be expressed in polar 2D coordinates, as a magnitude and an angle. class Polar t where polar :: Iso' t (Scalar (V t), Angle (Scalar (V t))) + +instance (Polar v, v ~ V v) => Polar (Point v) where + polar = _pIso . polar diff --git a/src/Diagrams/TwoD/Types/Double.hs b/src/Diagrams/TwoD/Types/Double.hs index 4a653975..b0e93ac8 100644 --- a/src/Diagrams/TwoD/Types/Double.hs +++ b/src/Diagrams/TwoD/Types/Double.hs @@ -159,6 +159,14 @@ instance HasTheta R2 where instance HasR R2 where _r = polar._1 +instance Polar R2 where + polar = + iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) + (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) + +instance Transformable R2 where + transform = apply + -- | Points in R^2. This type is intentionally abstract. -- -- * To construct a point, use 'p2', or '^&' (see @@ -186,26 +194,3 @@ type P2 = Point R2 -- | Transformations in R^2. type T2 = Transformation R2 - -instance Transformable R2 where - transform = apply - -instance HasX P2 where - _x = p2Iso . _1 - -instance HasY P2 where - _y = p2Iso . _2 - -instance HasR P2 where - _r = _relative origin . _r - -instance HasTheta P2 where - _theta = _relative origin . _theta - -instance Polar R2 where - polar = - iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) - (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) - -instance Polar P2 where - polar = _relative origin . polar From dff0564cebb4d8c61f493e532423e8cb5c636e8f Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Mon, 11 Aug 2014 11:44:53 -0600 Subject: [PATCH 12/58] Remove R2Sym in favor of R2D (D for Data) - I have a (bogus) Ord instance, so I might as well have the RealFloat constraint as well. --- src/Diagrams/TwoD/Adjust.hs | 6 +++--- src/Diagrams/TwoD/Arrow.hs | 32 ++++++++++++++++---------------- src/Diagrams/TwoD/Attributes.hs | 24 ++++++++++++------------ src/Diagrams/TwoD/Combinators.hs | 4 ++-- src/Diagrams/TwoD/Model.hs | 4 ++-- src/Diagrams/TwoD/Text.hs | 12 ++++++------ src/Diagrams/TwoD/Types.hs | 28 ++++++++++++++-------------- 7 files changed, 55 insertions(+), 55 deletions(-) diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs index d41afaeb..0470484e 100644 --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -27,7 +27,7 @@ import Diagrams.Core import Diagrams.TwoD.Attributes (lineTextureA, lineWidthA) import Diagrams.TwoD.Size (SizeSpec2D (..), center2D, requiredScale, size2D) import Diagrams.TwoD.Text (fontSizeA) -import Diagrams.TwoD.Types (R2Ish, p2) +import Diagrams.TwoD.Types (R2Ish, R2D, p2) import Diagrams.Util (( # )) import Control.Lens (Lens', (&), (.~), (^.)) @@ -50,7 +50,7 @@ import Data.VectorSpace (Scalar) -- * line join miter -- -- * Miter limit 10 -setDefault2DAttributes :: (Semigroup m, R2Ish v) => QDiagram b v m -> QDiagram b v m +setDefault2DAttributes :: (Semigroup m, R2D v) => QDiagram b v m -> QDiagram b v m setDefault2DAttributes d = d # lineWidthA def # lineTextureA def # fontSizeA def # lineCap def # lineJoin def # lineMiterLimitA def @@ -99,7 +99,7 @@ adjustDiaSize2D szL _ opts d = -- to the diagram (the inverse of which can be used, say, to -- translate output/device coordinates back into local diagram -- coordinates), and the modified diagram itself. -adjustDia2D :: (Monoid' m, R2Ish v) +adjustDia2D :: (Monoid' m, R2D v) => Lens' (Options b v) (SizeSpec2D (Scalar v)) -> b -> Options b v -> QDiagram b v m -> (Options b v, Transformation v, QDiagram b v m) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 61c5b216..5f0ad5b3 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -285,7 +285,7 @@ widthOfJoint sStyle gToO nToO = -- | Combine the head and its joint into a single scale invariant diagram -- and move the origin to the attachment point. Return the diagram -- and its width. -mkHead :: (R2Ish v, Renderable (Path v) b) => +mkHead :: (R2D v, Renderable (Path v) b) => Scalar v -> ArrowOpts v -> Scalar v -> Scalar v -> (Diagram b v, Scalar v) mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 , hWidth + jWidth) @@ -298,7 +298,7 @@ mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) -- | Just like mkHead only the attachment point is on the right. -mkTail :: (R2Ish v, Renderable (Path v) b) => +mkTail :: (R2D v, Renderable (Path v) b) => Scalar v -> ArrowOpts v -> Scalar v -> Scalar v -> (Diagram b v, Scalar v) mkTail size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 , tWidth + jWidth) @@ -365,14 +365,14 @@ arrowEnv opts len = getEnvelope horizShaft -- | @arrow len@ creates an arrow of length @len@ with default -- parameters, starting at the origin and ending at the point -- @(len,0)@. -arrow :: (R2Ish v, Renderable (Path v) b) => Scalar v -> Diagram b v +arrow :: (R2D v, Renderable (Path v) b) => Scalar v -> Diagram b v arrow len = arrow' def len -- | @arrow' opts len@ creates an arrow of length @len@ using the -- given options, starting at the origin and ending at the point -- @(len,0)@. In particular, it scales the given 'arrowShaft' so -- that the entire arrow has length @len@. -arrow' :: (R2Ish v, Renderable (Path v) b) => ArrowOpts v -> Scalar v -> Diagram b v +arrow' :: (R2D v, Renderable (Path v) b) => ArrowOpts v -> Scalar v -> Diagram b v arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- Currently arrows have an empty envelope and trace. @@ -459,7 +459,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- | @arrowBetween s e@ creates an arrow pointing from @s@ to @e@ -- with default parameters. -arrowBetween :: (R2Ish v, Renderable (Path v) b) => Point v -> Point v -> Diagram b v +arrowBetween :: (R2D v, Renderable (Path v) b) => Point v -> Point v -> Diagram b v arrowBetween = arrowBetween' def -- | @arrowBetween' opts s e@ creates an arrow pointing from @s@ to @@ -467,17 +467,17 @@ arrowBetween = arrowBetween' def -- rotates @arrowShaft@ to go between @s@ and @e@, taking head, -- tail, and gaps into account. arrowBetween' - :: (R2Ish v, Renderable (Path v) b) => + :: (R2D v, Renderable (Path v) b) => ArrowOpts v -> Point v -> Point v -> Diagram b v arrowBetween' opts s e = arrowAt' opts s (e .-. s) -- | Create an arrow starting at s with length and direction determined by -- the vector v. -arrowAt :: (R2Ish v, Renderable (Path v) b) => Point v -> v -> Diagram b v +arrowAt :: (R2D v, Renderable (Path v) b) => Point v -> v -> Diagram b v arrowAt s v = arrowAt' def s v arrowAt' - :: (R2Ish v, Renderable (Path v) b) => + :: (R2D v, Renderable (Path v) b) => ArrowOpts v -> Point v -> v -> Diagram b v arrowAt' opts s v = arrow' opts len # rotate dir # moveTo s @@ -488,25 +488,25 @@ arrowAt' opts s v = arrow' opts len -- | @arrowV v@ creates an arrow with the direction and magnitude of -- the vector @v@ (with its tail at the origin), using default -- parameters. -arrowV :: (R2Ish v, Renderable (Path v) b) => v -> Diagram b v +arrowV :: (R2D v, Renderable (Path v) b) => v -> Diagram b v arrowV = arrowV' def -- | @arrowV' v@ creates an arrow with the direction and magnitude of -- the vector @v@ (with its tail at the origin). arrowV' - :: (R2Ish v, Renderable (Path v) b) + :: (R2D v, Renderable (Path v) b) => ArrowOpts v -> v -> Diagram b v arrowV' opts = arrowAt' opts origin -- | Connect two diagrams with a straight arrow. connect - :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) => n1 -> n2 -> (Diagram b v -> Diagram b v) connect = connect' def -- | Connect two diagrams with an arbitrary arrow. connect' - :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) => ArrowOpts v -> n1 -> n2 -> (Diagram b v -> Diagram b v) connect' opts n1 n2 = withName n1 $ \sub1 -> @@ -517,13 +517,13 @@ connect' opts n1 n2 = -- | Connect two diagrams at point on the perimeter of the diagrams, choosen -- by angle. connectPerim - :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) => n1 -> n2 -> Angle (Scalar v) -> Angle (Scalar v) -> (Diagram b v -> Diagram b v) connectPerim = connectPerim' def connectPerim' - :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) => ArrowOpts v -> n1 -> n2 -> Angle (Scalar v) -> Angle (Scalar v) -> (Diagram b v -> Diagram b v) connectPerim' opts n1 n2 a1 a2 = @@ -539,12 +539,12 @@ connectPerim' opts n1 n2 a1 a2 = -- drawn so that it stops at the boundaries of the diagrams, using traces -- to find the intersection points. connectOutside - :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) => n1 -> n2 -> (Diagram b v -> Diagram b v) connectOutside = connectOutside' def connectOutside' - :: (R2Ish v, Renderable (Path v) b, IsName n1, IsName n2) + :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) => ArrowOpts v -> n1 -> n2 -> (Diagram b v -> Diagram b v) connectOutside' opts n1 n2 = withName n1 $ \b1 -> diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index a0a0c067..778e450b 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -139,31 +139,31 @@ getLineWidth :: (R2Ish v) => LineWidth v -> Measure v getLineWidth (LineWidth (Last w)) = w -- | Set the line (stroke) width. -lineWidth :: (R2Ish v, HasStyle a, V a ~ v) => Measure v -> a -> a +lineWidth :: (R2D v, HasStyle a, V a ~ v) => Measure v -> a -> a lineWidth = applyGTAttr . LineWidth . Last -- | Apply a 'LineWidth' attribute. -lineWidthA :: (R2Ish v, HasStyle a, V a ~ v) => LineWidth v -> a -> a +lineWidthA :: (R2D v, HasStyle a, V a ~ v) => LineWidth v -> a -> a lineWidthA = applyGTAttr -- | Default for 'lineWidth'. -lw :: (R2Ish v, HasStyle a, V a ~ v) => Measure v -> a -> a +lw :: (R2D v, HasStyle a, V a ~ v) => Measure v -> a -> a lw = lineWidth -- | A convenient synonym for 'lineWidth (Global w)'. -lwG :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a +lwG :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a lwG w = lineWidth (Global w) -- | A convenient synonym for 'lineWidth (Normalized w)'. -lwN :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a +lwN :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a lwN w = lineWidth (Normalized w) -- | A convenient synonym for 'lineWidth (Output w)'. -lwO :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a +lwO :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a lwO w = lineWidth (Output w) -- | A convenient sysnonym for 'lineWidth (Local w)'. -lwL :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a +lwL :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a lwL w = lineWidth (Local w) ----------------------------------------------------------------- @@ -199,7 +199,7 @@ getDashing :: (R2Ish v) => DashingA v -> Dashing v getDashing (DashingA (Last d)) = d -- | Set the line dashing style. -dashing :: (R2Ish v, HasStyle a, V a ~ v) => +dashing :: (R2D v, HasStyle a, V a ~ v) => [Measure v] -- ^ A list specifying alternate lengths of on -- and off portions of the stroke. The empty -- list indicates no dashing. @@ -209,19 +209,19 @@ dashing :: (R2Ish v, HasStyle a, V a ~ v) => dashing ds offs = applyGTAttr (DashingA (Last (Dashing ds offs))) -- | A convenient synonym for 'dashing (Global w)'. -dashingG :: (R2Ish v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a +dashingG :: (R2D v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a dashingG w v = dashing (map Global w) (Global v) -- | A convenient synonym for 'dashing (Normalized w)'. -dashingN :: (R2Ish v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a +dashingN :: (R2D v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a dashingN w v = dashing (map Normalized w) (Normalized v) -- | A convenient synonym for 'dashing (Output w)'. -dashingO :: (R2Ish v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a +dashingO :: (R2D v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a dashingO w v = dashing (map Output w) (Output v) -- | A convenient sysnonym for 'dashing (Local w)'. -dashingL :: (R2Ish v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a +dashingL :: (R2D v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a dashingL w v = dashing (map Local w) (Local v) -- | A gradient stop contains a color and fraction (usually between 0 and 1) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 4a41e220..3a58e317 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -255,12 +255,12 @@ boundingRect = (`boxFit` rect 1 1) . boundingBox -- | \"Set the background color\" of a diagram. That is, place a -- diagram atop a bounding rectangle of the given color. -bg :: (R2Ish v, Renderable (Path v) b) => Colour Double -> Diagram b v -> Diagram b v +bg :: (R2D v, Renderable (Path v) b) => Colour Double -> Diagram b v -> Diagram b v bg c d = d <> boundingRect d # lineWidth (Output 0) # fc c -- | Similar to 'bg' but makes the colored background rectangle larger than -- the diagram. The first parameter is used to set how far the background -- extends beyond the diagram. -bgFrame :: (R2Ish v, Renderable (Path v) b, Backend b v) +bgFrame :: (R2D v, Renderable (Path v) b, Backend b v) => Scalar v -> Colour Double -> Diagram b v -> Diagram b v bgFrame f c d = d <> boundingRect (frame f d) # lineWidth (Output 0) # fc c diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs index 5f1d8a5a..67c6b318 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -60,13 +60,13 @@ instance (Fractional d) => Default (OriginOpts d) where def = OriginOpts red (1/50) 0.001 -- | Mark the origin of a diagram by placing a red dot 1/50th its size. -showOrigin :: (Renderable (Path v) b, R2Ish v, Backend b v, Monoid' m) +showOrigin :: (Renderable (Path v) b, R2D v, Backend b v, Monoid' m) => QDiagram b v m -> QDiagram b v m showOrigin = showOrigin' def -- | Mark the origin of a diagram, with control over colour and scale -- of marker dot. -showOrigin' :: (Renderable (Path v) b, R2Ish v, Backend b v, Monoid' m) +showOrigin' :: (Renderable (Path v) b, R2D v, Backend b v, Monoid' m) => OriginOpts (Scalar v) -> QDiagram b v m -> QDiagram b v m showOrigin' oo d = o <> d where o = stroke (circle sz) diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 372cfe39..1e548571 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -209,28 +209,28 @@ getFontSizeIsLocal (FontSize (Last (_,b))) = b -- | Set the font size, that is, the size of the font's em-square as -- measured within the current local vector space. The default size -- is @1@. -fontSize :: (R2Ish v, HasStyle a, V a ~ v) => Measure v -> a -> a +fontSize :: (R2D v, HasStyle a, V a ~ v) => Measure v -> a -> a fontSize m@(Local {}) = applyGTAttr . FontSize . Last $ (m,True) fontSize m = applyGTAttr . FontSize . Last $ (m,False) -- | A convenient synonym for 'fontSize (Global w)'. -fontSizeG :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a +fontSizeG :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a fontSizeG w = fontSize (Global w) -- | A convenient synonym for 'fontSize (Normalized w)'. -fontSizeN :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a +fontSizeN :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a fontSizeN w = fontSize (Normalized w) -- | A convenient synonym for 'fontSize (Output w)'. -fontSizeO :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a +fontSizeO :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a fontSizeO w = fontSize (Output w) -- | A convenient sysnonym for 'fontSize (Local w)'. -fontSizeL :: (R2Ish v, HasStyle a, V a ~ v) => Scalar v -> a -> a +fontSizeL :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a fontSizeL w = fontSize (Local w) -- | Apply a 'FontSize' attribute. -fontSizeA :: (R2Ish v, HasStyle a, V a ~ v) => FontSize v -> a -> a +fontSizeA :: (R2D v, HasStyle a, V a ~ v) => FontSize v -> a -> a fontSizeA = applyGTAttr -------------------------------------------------- diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 6cc5dff1..22371dd6 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -26,8 +26,8 @@ module Diagrams.TwoD.Types r2, unr2, mkR2, r2Iso , p2, mkP2, unp2, p2Iso , R2Basis(..) - , R2Sym, R2Ish - , ScalarR2Sym, ScalarR2Ish + , R2Ish, R2D + , ScalarR2Ish , Polar(..) ) where @@ -56,39 +56,39 @@ instance HasTrie R2Basis where untrie (R2Trie _x y) YB = y enumerate (R2Trie x y) = [(XB,x),(YB,y)] -type ScalarR2Sym d = (VectorSpace d, HasBasis d, Basis d ~ (), Transformable d, Scalar d ~ d, V d ~ d) -type ScalarR2Ish d = (RealFloat d, ScalarR2Sym d, Data d) -type R2Sym v = (HasBasis v, Basis v ~ R2Basis, V v ~ v, Transformable v, InnerSpace v, Coordinates v, Decomposition v ~ (FinalCoord v :& FinalCoord v), PrevDim v ~ FinalCoord v, FinalCoord v ~ Scalar v, HasX v, HasY v, ScalarR2Sym (Scalar v)) -type R2Ish v = (R2Sym v, ScalarR2Ish (Scalar v), HasTheta v, Data v) +type ScalarR2Ish d = (RealFloat d, VectorSpace d, HasBasis d, Basis d ~ (), Transformable d, Scalar d ~ d, V d ~ d, Typeable d) +type R2Ish v = (HasBasis v, Basis v ~ R2Basis, V v ~ v, Transformable v, InnerSpace v, Coordinates v, Decomposition v ~ (FinalCoord v :& FinalCoord v), PrevDim v ~ FinalCoord v, FinalCoord v ~ Scalar v, HasX v, HasY v, ScalarR2Ish (Scalar v), HasTheta v, Typeable v) + +type R2D v = (R2Ish v, Data v, Data (Scalar v)) -- | Construct a 2D vector from a pair of components. See also '&'. -r2 :: (R2Sym v) => (Scalar v, Scalar v) -> v +r2 :: (R2Ish v) => (Scalar v, Scalar v) -> v r2 (x,y) = recompose [(XB,x),(YB,y)] -- | Convert a 2D vector back into a pair of components. See also 'coords'. -unr2 :: (R2Sym v) => v -> (Scalar v, Scalar v) +unr2 :: (R2Ish v) => v -> (Scalar v, Scalar v) unr2 v = (decompose' v XB, decompose' v YB) -- | Curried form of `r2`. -mkR2 :: (R2Sym v) => Scalar v -> Scalar v -> v +mkR2 :: (R2Ish v) => Scalar v -> Scalar v -> v mkR2 = curry r2 -r2Iso :: (R2Sym v) => Iso' v (Scalar v, Scalar v) +r2Iso :: (R2Ish v) => Iso' v (Scalar v, Scalar v) r2Iso = iso unr2 r2 -- | Construct a 2D point from a pair of coordinates. See also '^&'. -p2 :: (R2Sym v) => (Scalar v, Scalar v) -> Point v +p2 :: (R2Ish v) => (Scalar v, Scalar v) -> Point v p2 = P . r2 -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. -unp2 :: (R2Sym v) => Point v -> (Scalar v, Scalar v) +unp2 :: (R2Ish v) => Point v -> (Scalar v, Scalar v) unp2 (P v) = unr2 v -- | Curried form of `p2`. -mkP2 :: (R2Sym v) => Scalar v -> Scalar v -> Point v +mkP2 :: (R2Ish v) => Scalar v -> Scalar v -> Point v mkP2 = curry p2 -p2Iso :: (R2Sym v) => Iso' (Point v) (Scalar v, Scalar v) +p2Iso :: (R2Ish v) => Iso' (Point v) (Scalar v, Scalar v) p2Iso = iso unp2 p2 -- | Types which can be expressed in polar 2D coordinates, as a magnitude and an angle. From cd66e8efb3f39e0d0ee31a50fc7683b9a1dd814d Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Tue, 12 Aug 2014 19:20:44 -0600 Subject: [PATCH 13/58] Typeable/Show instances for R2Basis --- src/Diagrams/TwoD/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 22371dd6..c7b8deda 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -47,7 +47,7 @@ import Data.VectorSpace import Data.Data -- | Basis for 2D Euclidean space -data R2Basis = XB | YB deriving (Eq, Ord, Enum) +data R2Basis = XB | YB deriving (Eq, Ord, Enum, Typeable, Show) instance HasTrie R2Basis where data R2Basis :->: x = R2Trie x x From b2fb74bc97b69814bf83ba2dc47737d455dd117e Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Thu, 14 Aug 2014 15:07:41 -0600 Subject: [PATCH 14/58] Add Float and Generic TwoD types and change exports to properly hide Types.Double --- diagrams-lib.cabal | 2 + src/Diagrams/ThreeD.hs | 2 - src/Diagrams/TwoD.hs | 6 +- src/Diagrams/TwoD/Types/Double.hs | 16 +-- src/Diagrams/TwoD/Types/Float.hs | 195 +++++++++++++++++++++++++++++ src/Diagrams/TwoD/Types/Generic.hs | 120 ++++++++++++++++++ 6 files changed, 322 insertions(+), 19 deletions(-) create mode 100644 src/Diagrams/TwoD/Types/Float.hs create mode 100644 src/Diagrams/TwoD/Types/Generic.hs diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 9d790535..b1b9b973 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -56,6 +56,8 @@ Library Diagrams.TwoD, Diagrams.TwoD.Types, Diagrams.TwoD.Types.Double, + Diagrams.TwoD.Types.Float, + Diagrams.TwoD.Types.Generic, Diagrams.TwoD.Align, Diagrams.TwoD.Arrow, Diagrams.TwoD.Arrowheads, diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs index f536c5a2..a6c87875 100644 --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -40,7 +40,6 @@ module Diagrams.ThreeD , module Diagrams.ThreeD.Shapes , module Diagrams.ThreeD.Transform , module Diagrams.ThreeD.Types - , module Diagrams.ThreeD.Types.Double , module Diagrams.ThreeD.Vector ) where @@ -52,5 +51,4 @@ import Diagrams.ThreeD.Light import Diagrams.ThreeD.Shapes import Diagrams.ThreeD.Transform import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Types.Double import Diagrams.ThreeD.Vector diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 5b456c7e..0ad12c7a 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -61,9 +61,8 @@ ----------------------------------------------------------------------------- module Diagrams.TwoD ( -- * R^2 - R2, r2, unr2, mkR2 - , P2, p2, unp2, mkP2 - , T2 + r2, unr2, mkR2 + , p2, unp2, mkP2 , unitX, unitY, unit_X, unit_Y , xDir @@ -290,7 +289,6 @@ import Diagrams.TwoD.Size import Diagrams.TwoD.Text import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Types.Double import Diagrams.TwoD.Vector import Diagrams.Util (tau) diff --git a/src/Diagrams/TwoD/Types/Double.hs b/src/Diagrams/TwoD/Types/Double.hs index b0e93ac8..245c7d58 100644 --- a/src/Diagrams/TwoD/Types/Double.hs +++ b/src/Diagrams/TwoD/Types/Double.hs @@ -1,29 +1,19 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Types.Double --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Basic types for two-dimensional Euclidean space. +-- 2D Euclidean space in Double precision -- ----------------------------------------------------------------------------- -module Diagrams.TwoD.Types.Double - ( -- * 2D Euclidean space in Double precision - R2(..), P2, T2 - ) where +module Diagrams.TwoD.Types.Double where import Control.Lens (Rewrapped, Wrapped (..), iso, (^.), _1, _2) diff --git a/src/Diagrams/TwoD/Types/Float.hs b/src/Diagrams/TwoD/Types/Float.hs new file mode 100644 index 00000000..bb2d3f69 --- /dev/null +++ b/src/Diagrams/TwoD/Types/Float.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Types.Float +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- 2D Euclidean space in Float precision +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Types.Float where + +import Control.Lens (Rewrapped, Wrapped (..), iso, (^.), _1, _2) + + +import Diagrams.Angle +import Diagrams.Coordinates +import Diagrams.Core +import Diagrams.TwoD.Types + +import Data.Basis +import Data.VectorSpace + +import Data.Data + + +-- Orphan instances that should be in diagrams-core +type instance V Float = Float + +instance Transformable Float where + transform = apply + +------------------------------------------------------------ +-- 2D Euclidean space + +-- | The two-dimensional Euclidean vector space R^2. This type is +-- intentionally abstract, but uses Floats as the scalar type. +-- +-- * To construct a vector, use 'r2', or '^&' (from "Diagrams.Coordinates"): +-- +-- @ +-- r2 (3,4) :: R2 +-- 3 ^& 4 :: R2 +-- @ +-- +-- Note that "Diagrams.Coordinates" is not re-exported by +-- "Diagrams.Prelude" and must be explicitly imported. +-- +-- * To construct the vector from the origin to a point @p@, use +-- @p 'Data.AffineSpace..-.' 'origin'@. +-- +-- * To convert a vector @v@ into the point obtained by following +-- @v@ from the origin, use @'origin' 'Data.AffineSpace..+^' v@. +-- +-- * To convert a vector back into a pair of components, use 'unv2' +-- or 'coords' (from "Diagrams.Coordinates"). These are typically +-- used in conjunction with the @ViewPatterns@ extension: +-- +-- @ +-- foo (unr2 -> (x,y)) = ... +-- foo (coords -> x :& y) = ... +-- @ +data R2 = R2 {-# UNPACK #-} !Float + {-# UNPACK #-} !Float + deriving (Eq, Ord, Typeable, Data) + +instance AdditiveGroup R2 where + zeroV = R2 0 0 + R2 x1 y1 ^+^ R2 x2 y2 = R2 (x1 + x2) (y1 + y2) + negateV (R2 x y) = R2 (-x) (-y) + +instance Num R2 where + (+) = (^+^) + R2 x1 y1 * R2 x2 y2 = R2 (x1 * x2) (y1 * y2) -- this is sort of bogus + (-) = (^-^) + negate = negateV + abs (R2 x y) = R2 (abs x) (abs y) + signum (R2 x y) = R2 (signum x) (signum y) + fromInteger i = R2 i' i' + where i' = fromInteger i + +instance Fractional R2 where + R2 x1 y1 / R2 x2 y2 = R2 (x1/x2) (y1/y2) + recip (R2 x y) = R2 (recip x) (recip y) + fromRational r = R2 r' r' + where r' = fromRational r + +instance Show R2 where + showsPrec p (R2 x y) = showParen (p >= 7) $ + showCoord x . showString " ^& " . showCoord y + where + showCoord c | c < 0 = showParen True (shows c) + | otherwise = shows c + +instance Read R2 where + readsPrec d r = readParen (d > app_prec) + (\rr -> [ (R2 x y, r''') + | (x,r') <- readsPrec (amp_prec + 1) rr + , ("^&",r'') <- lex r' + , (y,r''') <- readsPrec (amp_prec + 1) r'' + ]) + r + where + app_prec = 10 + amp_prec = 7 + +-- | Lens wrapped isomorphisms for R2. +instance Wrapped R2 where + type Unwrapped R2 = (Float, Float) + _Wrapped' = iso unr2 r2 + {-# INLINE _Wrapped' #-} + +instance Rewrapped R2 R2 + +type instance V R2 = R2 + +instance VectorSpace R2 where + type Scalar R2 = Float + s *^ R2 x y = R2 (s*x) (s*y) + +instance HasBasis R2 where + type Basis R2 = R2Basis + basisValue XB = R2 1 0 + basisValue YB = R2 0 1 + + decompose (R2 x y) = [(XB, x), (YB, y)] + + decompose' (R2 x _) (XB) = x + decompose' (R2 _ y) (YB) = y + +instance InnerSpace R2 where + (R2 x1 y1) <.> (R2 x2 y2) = x1*x2 + y1*y2 + +instance Coordinates R2 where + type FinalCoord R2 = Float + type PrevDim R2 = Float + type Decomposition R2 = Float :& Float + + x ^& y = R2 x y + coords (R2 x y) = x :& y + +instance HasX R2 where + _x = r2Iso . _1 + +instance HasY R2 where + _y = r2Iso . _2 + +instance HasTheta R2 where + _theta = polar._2 + +instance HasR R2 where + _r = polar._1 + +instance Polar R2 where + polar = + iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) + (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) + +instance Transformable R2 where + transform = apply + +-- | Points in R^2. This type is intentionally abstract. +-- +-- * To construct a point, use 'p2', or '^&' (see +-- "Diagrams.Coordinates"): +-- +-- @ +-- p2 (3,4) :: P2 +-- 3 ^& 4 :: P2 +-- @ +-- +-- * To construct a point from a vector @v@, use @'origin' 'Data.AffineSpace..+^' v@. +-- +-- * To convert a point @p@ into the vector from the origin to @p@, +-- use @p 'Data.AffineSpace..-.' 'origin'@. +-- +-- * To convert a point back into a pair of coordinates, use 'unp2', +-- or 'coords' (from "Diagrams.Coordinates"). It's common to use +-- these in conjunction with the @ViewPatterns@ extension: +-- +-- @ +-- foo (unp2 -> (x,y)) = ... +-- foo (coords -> x :& y) = ... +-- @ +type P2 = Point R2 + +-- | Transformations in R^2. +type T2 = Transformation R2 diff --git a/src/Diagrams/TwoD/Types/Generic.hs b/src/Diagrams/TwoD/Types/Generic.hs new file mode 100644 index 00000000..2a8bccf8 --- /dev/null +++ b/src/Diagrams/TwoD/Types/Generic.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Types.Generic +-- Copyright : (c) 2014 diagrams team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Generic type for two-dimensional Euclidean space. +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Types.Generic where + +import Control.Lens (Rewrapped, Wrapped (..), iso, (^.), _1, _2) + + +import Diagrams.Angle +import Diagrams.Coordinates +import Diagrams.Core +import Diagrams.TwoD.Types + +import Data.Basis +import Data.VectorSpace + +import Data.Data +import Data.Foldable +import Data.Traversable + +data V2 a = V2 a a + deriving (Eq, Typeable, Functor, Foldable, Traversable, Data) + +instance (ScalarR2Ish a) => AdditiveGroup (V2 a) where + zeroV = V2 0 0 + V2 x1 y1 ^+^ V2 x2 y2 = V2 (x1 + x2) (y1 + y2) + negateV (V2 x y) = V2 (-x) (-y) + +instance (ScalarR2Ish a) => Num (V2 a) where + (+) = (^+^) + V2 x1 y1 * V2 x2 y2 = V2 (x1 * x2) (y1 * y2) -- this is sort of bogus + (-) = (^-^) + negate = negateV + abs (V2 x y) = V2 (abs x) (abs y) + signum (V2 x y) = V2 (signum x) (signum y) + fromInteger i = V2 i' i' + where i' = fromInteger i + +instance (ScalarR2Ish a) => Fractional (V2 a) where + V2 x1 y1 / V2 x2 y2 = V2 (x1/x2) (y1/y2) + recip (V2 x y) = V2 (recip x) (recip y) + fromRational r = V2 r' r' + where r' = fromRational r + +instance (ScalarR2Ish a, Show a) => Show (V2 a) where + showsPrec p (V2 x y) = showParen (p >= 7) $ + showCoord x . showString " ^& " . showCoord y + where + showCoord = showParen True . shows + +-- | Lens wrapped isomorphisms for V2. +instance (ScalarR2Ish a) => Wrapped (V2 a) where + type Unwrapped (V2 a) = (a, a) + _Wrapped' = iso unr2 r2 + {-# INLINE _Wrapped' #-} + +instance (ScalarR2Ish a) => Rewrapped (V2 a) (V2 a) + +type instance V (V2 a) = V2 a + +instance (ScalarR2Ish a) => VectorSpace (V2 a) where + type Scalar (V2 a) = a + s *^ V2 x y = V2 (s*x) (s*y) + +instance (ScalarR2Ish a) => HasBasis (V2 a) where + type Basis (V2 a) = R2Basis + basisValue XB = V2 1 0 + basisValue YB = V2 0 1 + + decompose (V2 x y) = [(XB, x), (YB, y)] + + decompose' (V2 x _) (XB) = x + decompose' (V2 _ y) (YB) = y + +instance (ScalarR2Ish a) => InnerSpace (V2 a) where + (V2 x1 y1) <.> (V2 x2 y2) = x1*x2 + y1*y2 + +instance (ScalarR2Ish a) => Coordinates (V2 a) where + type FinalCoord (V2 a) = a + type PrevDim (V2 a) = a + type Decomposition (V2 a) = a :& a + + x ^& y = V2 x y + coords (V2 x y) = x :& y + +instance (ScalarR2Ish a) => HasX (V2 a) where + _x = r2Iso . _1 + +instance (ScalarR2Ish a) => HasY (V2 a) where + _y = r2Iso . _2 + +instance (ScalarR2Ish a) => HasTheta (V2 a) where + _theta = polar._2 + +instance (ScalarR2Ish a) => HasR (V2 a) where + _r = polar._1 + +instance (ScalarR2Ish a) => Polar (V2 a) where + polar = + iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) + (\(r,θ) -> V2 (r * cosA θ) (r * sinA θ)) + +instance (ScalarR2Ish a) => Transformable (V2 a) where + transform = apply + From e1a681d3c39f1a0d7b6efa5d7b2cf46b5bc20be8 Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Thu, 14 Aug 2014 17:50:42 -0600 Subject: [PATCH 15/58] Fix errors on GHC 7.6 --- src/Diagrams/TwoD/Types.hs | 2 +- src/Diagrams/TwoD/Types/Generic.hs | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index c7b8deda..aa7ee304 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} - +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Diagrams/TwoD/Types/Generic.hs b/src/Diagrams/TwoD/Types/Generic.hs index 2a8bccf8..250613d2 100644 --- a/src/Diagrams/TwoD/Types/Generic.hs +++ b/src/Diagrams/TwoD/Types/Generic.hs @@ -6,6 +6,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Types.Generic From c84ccedcfe79e91aa03f3280b00a9499b9b93416 Mon Sep 17 00:00:00 2001 From: Mathnerd314 Date: Sat, 16 Aug 2014 16:19:00 -0600 Subject: [PATCH 16/58] Add parameters to GradientStop and TextAlignment, which I missed on my initial pass. --- src/Diagrams/TwoD/Attributes.hs | 22 +++++++++++----------- src/Diagrams/TwoD/Text.hs | 8 ++++---- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 778e450b..9ec99698 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -225,17 +225,17 @@ dashingL :: (R2D v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a dashingL w v = dashing (map Local w) (Local v) -- | A gradient stop contains a color and fraction (usually between 0 and 1) -data GradientStop = GradientStop +data GradientStop d = GradientStop { _stopColor :: SomeColor - , _stopFraction :: Double} + , _stopFraction :: d} makeLensesWith (lensRules & generateSignatures .~ False) ''GradientStop -- | A color for the stop. -stopColor :: Lens' GradientStop SomeColor +stopColor :: Lens' (GradientStop d) SomeColor -- | The fraction for stop. -stopFraction :: Lens' GradientStop Double +stopFraction :: Lens' (GradientStop d) d -- | The 'SpreadMethod' determines what happens before 'lGradStart' and after -- 'lGradEnd'. 'GradPad' fills the space before the start of the gradient @@ -246,7 +246,7 @@ data SpreadMethod = GradPad | GradReflect | GradRepeat -- | Linear Gradient data LGradient v = LGradient - { _lGradStops :: [GradientStop] + { _lGradStops :: [GradientStop (Scalar v)] , _lGradStart :: Point v , _lGradEnd :: Point v , _lGradTrans :: Transformation v @@ -255,7 +255,7 @@ data LGradient v = LGradient makeLensesWith (lensRules & generateSignatures .~ False) ''LGradient -- | A list of stops (colors and fractions). -lGradStops :: (R2Ish v) => Lens' (LGradient v) [GradientStop] +lGradStops :: (R2Ish v) => Lens' (LGradient v) [GradientStop (Scalar v)] -- | A transformation to be applied to the gradient. Usually this field will -- start as the identity transform and capture the transforms that are applied @@ -275,7 +275,7 @@ lGradSpreadMethod :: (R2Ish v) => Lens' (LGradient v) SpreadMethod -- | Radial Gradient data RGradient v = RGradient - { _rGradStops :: [GradientStop] + { _rGradStops :: [GradientStop (Scalar v)] , _rGradCenter0 :: Point v , _rGradRadius0 :: Scalar v , _rGradCenter1 :: Point v @@ -286,7 +286,7 @@ data RGradient v = RGradient makeLensesWith (lensRules & generateSignatures .~ False) ''RGradient -- | A list of stops (colors and fractions). -rGradStops :: (R2Ish v) => Lens' (RGradient v) [GradientStop] +rGradStops :: (R2Ish v) => Lens' (RGradient v) [GradientStop (Scalar v)] -- | The center point of the inner circle. rGradCenter0 :: (R2Ish v) => Lens' (RGradient v) (Point v) @@ -350,20 +350,20 @@ defaultRG = RG (RGradient -- | A convenient function for making gradient stops from a list of triples. -- (An opaque color, a stop fraction, an opacity). -mkStops :: [(Colour Double, Double, Double)] -> [GradientStop] +mkStops :: [(Colour Double, d, Double)] -> [GradientStop d] mkStops = map (\(x, y, z) -> GradientStop (SomeColor (withOpacity x z)) y) -- | Make a linear gradient texture from a stop list, start point, end point, -- and 'SpreadMethod'. The 'lGradTrans' field is set to the identity -- transfrom, to change it use the 'lGradTrans' lens. -mkLinearGradient :: (R2Ish v) => [GradientStop] -> Point v -> Point v -> SpreadMethod -> Texture v +mkLinearGradient :: (R2Ish v) => [GradientStop (Scalar v)] -> Point v -> Point v -> SpreadMethod -> Texture v mkLinearGradient stops start end spreadMethod = LG (LGradient stops start end mempty spreadMethod) -- | Make a radial gradient texture from a stop list, radius, start point, -- end point, and 'SpreadMethod'. The 'rGradTrans' field is set to the identity -- transfrom, to change it use the 'rGradTrans' lens. -mkRadialGradient :: (R2Ish v) => [GradientStop] -> Point v -> Scalar v +mkRadialGradient :: (R2Ish v) => [GradientStop (Scalar v)] -> Point v -> Scalar v -> Point v -> Scalar v -> SpreadMethod -> Texture v mkRadialGradient stops c0 r0 c1 r1 spreadMethod = RG (RGradient stops c0 r0 c1 r1 mempty spreadMethod) diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 1e548571..d882ef17 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -57,7 +57,7 @@ import Data.VectorSpace -- text; the second accumulates normalized, "anti-scaled" versions -- of the transformations which have had their average scaling -- component removed. -data Text v = Text (Transformation v) (Transformation v) TextAlignment String +data Text v = Text (Transformation v) (Transformation v) (TextAlignment (Scalar v)) String deriving Typeable type instance V (Text v) = v @@ -77,9 +77,9 @@ instance (R2Ish v) => Renderable (Text v) NullBackend where render _ _ = mempty -- | @TextAlignment@ specifies the alignment of the text's origin. -data TextAlignment = BaselineText | BoxAlignedText Double Double +data TextAlignment d = BaselineText | BoxAlignedText d d -mkText :: (R2Ish v, Renderable (Text v) b) => TextAlignment -> String -> Diagram b v +mkText :: (R2Ish v, Renderable (Text v) b) => TextAlignment (Scalar v) -> String -> Diagram b v mkText a t = recommendFillColor (black :: Colour Double) -- See Note [recommendFillColor] @@ -136,7 +136,7 @@ topLeftText = alignedText 0 1 -- and descent, rather than the height of the particular string. -- -- Note that it /takes up no space/. -alignedText :: (R2Ish v, Renderable (Text v) b) => Double -> Double -> String -> Diagram b v +alignedText :: (R2Ish v, Renderable (Text v) b) => Scalar v -> Scalar v -> String -> Diagram b v alignedText w h = mkText (BoxAlignedText w h) -- | Create a primitive text diagram from the given string, with the From 2a407135c2978d0d459001ae5143188499998140 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 18 Aug 2014 16:30:49 +0100 Subject: [PATCH 17/58] Some progress. --- diagrams-lib.cabal | 9 +- src/Diagrams/Angle.hs | 92 +++++---- src/Diagrams/Located.hs | 63 +++--- src/Diagrams/Parametric.hs | 58 +++--- src/Diagrams/Points.hs | 21 +- src/Diagrams/Prelude.hs | 162 --------------- src/Diagrams/Segment.hs | 252 ++++++++++++----------- src/Diagrams/Tangent.hs | 70 ++++--- src/Diagrams/Trail.hs | 406 +++++++++++++++++++------------------ 9 files changed, 501 insertions(+), 632 deletions(-) delete mode 100644 src/Diagrams/Prelude.hs diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index b1b9b973..42e98165 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -25,8 +25,7 @@ Source-repository head location: http://github.com/diagrams/diagrams-lib.git Library - Exposed-modules: Diagrams.Prelude, - Diagrams.Prelude.ThreeD, + Exposed-modules: Diagrams.Prelude.ThreeD, Diagrams.Align, Diagrams.Angle, Diagrams.Combinators, @@ -116,7 +115,11 @@ Library filepath, safe >= 0.2 && < 0.4, JuicyPixels >= 3.1.5 && < 3.2, - hashable >= 1.1 && < 1.3 + hashable >= 1.1 && < 1.3, + linear, + adjunctions, + distributive + if impl(ghc < 7.6) Build-depends: ghc-prim Hs-source-dirs: src diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index b73a7ff8..0c108ee2 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -1,9 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} +-- {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Angle @@ -31,84 +32,85 @@ import Control.Lens (Iso', Lens', iso, review) import Data.Monoid hiding ((<>)) import Data.Semigroup -import Data.VectorSpace +-- import Data.VectorSpace +import Linear.Affine +import Linear.Metric +import Linear.Vector +import Linear.Epsilon +import Linear.V1 import Diagrams.Core.V import Diagrams.Points -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. -newtype Angle v = Radians v - deriving (Read, Show, Eq, Ord, AdditiveGroup) +newtype Angle n = Radians (V1 n) + deriving (Read, Show, Eq, Ord, Functor, Additive, Metric) -instance AdditiveGroup v => Semigroup (Angle v) where - (<>) = (^+^) +instance Num n => Semigroup (Angle n) where + (<>) = (^+^) -instance AdditiveGroup v => Monoid (Angle v) where - mappend = (<>) - mempty = Radians zeroV +instance Num n => Monoid (Angle n) where + mappend = (<>) + mempty = Radians zero -instance VectorSpace v => VectorSpace (Angle v) where - type Scalar (Angle v) = Scalar v - s *^ Radians t = Radians (s *^ t) +-- deriving instance InnerSpace v => InnerSpace (Angle v) -deriving instance InnerSpace v => InnerSpace (Angle v) - -type instance V (Angle v) = V v +type instance N (Angle n) = n -- | The radian measure of an @Angle@ @a@ can be accessed as @a -- ^. rad@. A new @Angle@ can be defined in radians as @pi \@\@ rad@. -rad :: Iso' (Angle v) v -rad = iso (\(Radians r) -> r) Radians +rad :: Iso' (Angle n) n +rad = iso (\(Radians (V1 r)) -> r) (Radians . V1) -- | The measure of an @Angle@ @a@ in full circles can be accessed as -- @a ^. turn@. A new @Angle@ of one-half circle can be defined in as -- @1/2 \@\@ turn@. -turn :: (VectorSpace v, Floating (Scalar v)) => Iso' (Angle v) v -turn = iso (\(Radians r) -> r ^/ (2*pi)) (Radians . (^*(2*pi))) +turn :: Floating n => Iso' (Angle n) n +turn = iso (\(Radians (V1 r)) -> r / (2*pi)) (Radians . V1 . (*(2*pi))) -- | The degree measure of an @Angle@ @a@ can be accessed as @a -- ^. deg@. A new @Angle@ can be defined in degrees as @180 \@\@ -- deg@. -deg :: (VectorSpace v, Floating (Scalar v)) => Iso' (Angle v) v -deg = iso (\(Radians r) -> r ^/ (2*pi/360)) (Radians . (^*(2*pi/360))) +deg :: Floating n => Iso' (Angle n) n +deg = iso (\(Radians (V1 r)) -> r / (2*pi/360)) (Radians . V1 . ( * (2*pi/360))) -- | An angle representing one full turn. -fullTurn :: (VectorSpace v, Floating (Scalar v), Num v) => Angle v +fullTurn :: Floating v => Angle v fullTurn = 1 @@ turn -- | Calculate ratio between two angles. -angleRatio :: (InnerSpace v, Floating (Scalar v)) => Angle v -> Angle v -> Scalar v -angleRatio a b = (magnitude a) / (magnitude b) +angleRatio :: Floating n => Angle n -> Angle n -> n +angleRatio a b = norm a / norm b -- | The sine of the given @Angle@. -sinA :: (Floating v) => Angle v -> v -sinA (Radians r) = sin r +sinA :: Floating n => Angle n -> n +sinA (Radians (V1 r)) = sin r -- | The cosine of the given @Angle@. -cosA :: (Floating v) => Angle v -> v -cosA (Radians r) = cos r +cosA :: Floating n => Angle n -> n +cosA (Radians (V1 r)) = cos r -- | The tangent function of the given @Angle@. -tanA :: (Floating v) => Angle v -> v -tanA (Radians r) = tan r +tanA :: Floating n => Angle n -> n +tanA (Radians (V1 r)) = tan r -- | The @Angle@ with the given sine. -asinA :: (Floating v) => v -> Angle v -asinA = Radians . asin +asinA :: Floating n => n -> Angle n +asinA = Radians . V1 . asin -- | The @Angle@ with the given cosine. -acosA :: (Floating v) => v -> Angle v -acosA = Radians . acos +acosA :: Floating n => n -> Angle n +acosA = Radians . V1 . acos -- | The @Angle@ with the given tangent. -atanA :: (Floating v) => v -> Angle v -atanA = Radians . atan +atanA :: Floating n => n -> Angle n +atanA = Radians . V1 . atan -- | @atan2A n d@ is the @Angle with tangent @n/d@, unless d is 0, in -- which case it is ±π/2. -atan2A :: (RealFloat v) => v -> v -> Angle v -atan2A n d = Radians $ atan2 n d +atan2A :: RealFloat n => n -> n -> Angle n +atan2A n d = Radians . V1 $ atan2 n d -- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. -- @@ -123,25 +125,25 @@ infixl 5 @@ -- | compute the positive angle between the two vectors in their common plane -- | N.B.: currently discards the common plane information -angleBetween :: (InnerSpace v, Floating (Scalar v)) => v -> v -> Angle (Scalar v) -angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad +angleBetween :: (Metric v, Floating n, Epsilon n) => v n -> v n -> Angle n +angleBetween v1 v2 = acos (normalize v1 `dot` normalize v2) @@ rad ------------------------------------------------------------ -- Polar Coordinates -- | The class of types with at least one angle coordinate, called _theta. class HasTheta t where - _theta :: Lens' t (Angle (Scalar (V t))) + _theta :: Floating n => Lens' (t n) (Angle n) -- | The class of types with at least two angle coordinates, the -- second called _phi. -class HasPhi t where - _phi :: Lens' t (Angle (Scalar (V t))) +class HasTheta t => HasPhi t where + _phi :: Floating n => Lens' (t n) (Angle n) -- Point instances -instance (HasTheta v, v ~ V v) => HasTheta (Point v) where +instance HasTheta v => HasTheta (Point v) where _theta = _pIso . _theta -instance (HasPhi v, v ~ V v) => HasPhi (Point v) where +instance HasPhi v => HasPhi (Point v) where _phi = _pIso . _phi diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs index 6410c0e1..15be79a0 100644 --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -24,11 +24,14 @@ module Diagrams.Located where import Control.Lens (Lens) -import Data.AffineSpace +-- import Data.AffineSpace import Data.Functor ((<$>)) -import Data.VectorSpace + +import Linear.Vector +import Linear.Affine import Diagrams.Core +import Diagrams.Core.V import Diagrams.Core.Points () import Diagrams.Core.Transform import Diagrams.Parametric @@ -49,27 +52,28 @@ import Diagrams.Parametric -- 'HasOrigin', 'Transformable', 'Enveloped', 'Traced', and -- 'TrailLike' instances are particularly useful; see the documented -- instances below for more information. -data Located a = Loc { loc :: Point (V a) -- ^ Project out the - -- location of a @Located@ - -- value. - , unLoc :: a -- ^ Project the value - -- of type @a@ out of - -- a @Located a@, - -- discarding the - -- location. - } +data Located a = + Loc { loc :: Point (V a) (N a) -- ^ Project out the + -- location of a @Located@ + -- value. + , unLoc :: a -- ^ Project the value + -- of type @a@ out of + -- a @Located a@, + -- discarding the + -- location. + } infix 5 `at` -- | Construct a @Located a@ from a value of type @a@ and a location. -- @at@ is intended to be used infix, like @x \`at\` origin@. -at :: a -> Point (V a) -> Located a +at :: a -> Point (V a) (N a) -> Located a at a p = Loc p a -- | Deconstruct a @Located a@ into a location and a value of type -- @a@. @viewLoc@ can be especially useful in conjunction with the -- @ViewPatterns@ extension. -viewLoc :: Located a -> (Point (V a), a) +viewLoc :: Located a -> (Point (V a) (N a), a) viewLoc (Loc p a) = (p,a) -- | 'Located' is not a @Functor@, since changing the type could @@ -82,32 +86,33 @@ viewLoc (Loc p a) = (p,a) -- @Located@ is a little-f (endo)functor on the category of types -- with associated vector space @v@; but that is not covered by the -- standard @Functor@ class.) -mapLoc :: (V a ~ V b) => (a -> b) -> Located a -> Located b +mapLoc :: (V a ~ V b, N a ~ N b) => (a -> b) -> Located a -> Located b mapLoc f (Loc p a) = Loc p (f a) -- | A lens giving access to the object within a 'Located' wrapper. -located :: (V a ~ V a') => Lens (Located a) (Located a') a a' +located :: (V a ~ V a', N a ~ N a') => Lens (Located a) (Located a') a a' located f (Loc p a) = Loc p <$> f a -deriving instance (Eq (V a), Eq a ) => Eq (Located a) -deriving instance (Ord (V a), Ord a ) => Ord (Located a) -deriving instance (Show (V a), Show a) => Show (Located a) +deriving instance (Eq (V a (N a)), Eq a ) => Eq (Located a) +deriving instance (Ord (V a (N a)), Ord a ) => Ord (Located a) +deriving instance (Show (V a (N a)), Show a) => Show (Located a) type instance V (Located a) = V a +type instance N (Located a) = N a -- | @Located a@ is an instance of @HasOrigin@ whether @a@ is or not. -- In particular, translating a @Located a@ simply translates the -- associated point (and does /not/ affect the value of type @a@). -instance VectorSpace (V a) => HasOrigin (Located a) where +instance (Num (N a), Additive (V a)) => HasOrigin (Located a) where moveOriginTo o (Loc p a) = Loc (moveOriginTo o p) a -- | Applying a transformation @t@ to a @Located a@ results in the -- transformation being applied to the location, and the /linear/ -- /portion/ of @t@ being applied to the value of type @a@ (/i.e./ -- it is not translated). -instance Transformable a => Transformable (Located a) where +instance (Additive (V a), Num (N a), Transformable a) => Transformable (Located a) where transform t@(Transformation t1 t2 _) (Loc p a) - = Loc (transform t p) (transform (Transformation t1 t2 zeroV) a) + = Loc (transform t p) (transform (Transformation t1 t2 zero) a) -- | The envelope of a @Located a@ is the envelope of the @a@, -- translated to the location. @@ -119,7 +124,7 @@ instance Enveloped a => Juxtaposable (Located a) where -- | The trace of a @Located a@ is the trace of the @a@, -- translated to the location. -instance Traced a => Traced (Located a) where +instance (Traced a, Num (N a)) => Traced (Located a) where getTrace (Loc p a) = moveTo p (getTrace a) instance Qualifiable a => Qualifiable (Located a) where @@ -127,7 +132,7 @@ instance Qualifiable a => Qualifiable (Located a) where type instance Codomain (Located a) = Point (Codomain a) -instance (Codomain a ~ V a, AdditiveGroup (V a), Parametric a) +instance (Codomain a ~ V a, Additive (V a), Num (N a), Parametric a) -- , Diff (Point (V a) (N a)) ~ V a (N a)) => Parametric (Located a) where (Loc x a) `atParam` p = x .+^ (a `atParam` p) @@ -135,10 +140,10 @@ instance DomainBounds a => DomainBounds (Located a) where domainLower (Loc _ a) = domainLower a domainUpper (Loc _ a) = domainUpper a -instance (Codomain a ~ V a, AdditiveGroup (V a), EndValues a) +instance (Codomain a ~ V a, Additive (V a), Num (N a), EndValues a) => EndValues (Located a) -instance ( Codomain a ~ V a, Fractional (Scalar (V a)), AdditiveGroup (V a) +instance ( Codomain a ~ V a, Fractional (N a), Additive (V a) , Sectionable a, Parametric a ) => Sectionable (Located a) where @@ -146,11 +151,11 @@ instance ( Codomain a ~ V a, Fractional (Scalar (V a)), AdditiveGroup (V a) where (a1,a2) = splitAtParam a p reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a) - where y = a `atParam` (domainUpper a) + where y = a `atParam` domainUpper a -instance ( Codomain a ~ V a, AdditiveGroup (V a), Fractional (Scalar (V a)) +instance ( Codomain a ~ V a, Additive (V a), Fractional (N a) , HasArcLength a ) => HasArcLength (Located a) where - arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a - arcLengthToParam eps (Loc _ a) l = arcLengthToParam eps a l + arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a + arcLengthToParam eps (Loc _ a) = arcLengthToParam eps a diff --git a/src/Diagrams/Parametric.hs b/src/Diagrams/Parametric.hs index bc65c980..70fd1b3a 100644 --- a/src/Diagrams/Parametric.hs +++ b/src/Diagrams/Parametric.hs @@ -22,14 +22,12 @@ module Diagrams.Parametric ) where -import Diagrams.Core - -import Data.VectorSpace +import Diagrams.Core.V import qualified Numeric.Interval.Kaucher as I -- | Codomain of parametric classes. This is usually either @(V p)@, for relative -- vector results, or @(Point (V p))@, for functions with absolute coordinates. -type family Codomain p :: * +type family Codomain p :: * -> * -- | Type class for parametric functions. class Parametric p where @@ -37,7 +35,7 @@ class Parametric p where -- | 'atParam' yields a parameterized view of an object as a -- continuous function. It is designed to be used infix, like @path -- ``atParam`` 0.5@. - atParam :: p -> Scalar (V p) -> Codomain p + atParam :: p -> N p -> Codomain p (N p) -- | Type class for parametric functions with a bounded domain. The -- default bounds are @[0,1]@. @@ -48,17 +46,17 @@ class Parametric p where class DomainBounds p where -- | 'domainLower' defaults to being constantly 0 (for vector spaces with -- numeric scalars). - domainLower :: p -> Scalar (V p) + domainLower :: p -> N p - default domainLower :: Num (Scalar (V p)) => p -> Scalar (V p) - domainLower = const 0 + -- default domainLower :: Num n => p n -> n + -- domainLower = const 0 -- | 'domainUpper' defaults to being constantly 1 (for vector spaces -- with numeric scalars). - domainUpper :: p -> Scalar (V p) + domainUpper :: p -> N p - default domainUpper :: Num (Scalar (V p)) => p -> Scalar (V p) - domainUpper = const 1 + -- default domainUpper :: Num n => p n -> n + -- domainUpper = const 1 -- | Type class for querying the values of a parametric object at the -- ends of its domain. @@ -69,7 +67,7 @@ class (Parametric p, DomainBounds p) => EndValues p where -- -- This is the default implementation, but some representations will -- have a more efficient and/or precise implementation. - atStart :: p -> Codomain p + atStart :: p -> Codomain p (N p) atStart x = x `atParam` domainLower x -- | 'atEnd' is the value at the end of the domain. That is, @@ -78,12 +76,12 @@ class (Parametric p, DomainBounds p) => EndValues p where -- -- This is the default implementation, but some representations will -- have a more efficient and/or precise implementation. - atEnd :: p -> Codomain p + atEnd :: p -> Codomain p (N p) atEnd x = x `atParam` domainUpper x -- | Return the lower and upper bounds of a parametric domain together -- as a pair. -domainBounds :: DomainBounds p => p -> (Scalar (V p), Scalar (V p)) +domainBounds :: DomainBounds p => p -> (N p, N p) domainBounds x = (domainLower x, domainUpper x) -- | Type class for parametric objects which can be split into @@ -113,7 +111,7 @@ class DomainBounds p => Sectionable p where -- result paths where the first is the original path extended to -- the parameter 2, and the second result path travels /backwards/ -- from the end of the first to the end of the original path. - splitAtParam :: p -> Scalar (V p) -> (p, p) + splitAtParam :: p -> N p -> (p, p) splitAtParam x t = ( section x (domainLower x) t , section x t (domainUpper x)) @@ -129,9 +127,9 @@ class DomainBounds p => Sectionable p where -- -- That is, the section should have the same domain as the -- original, and the reparameterization should be linear. - section :: p -> Scalar (V p) -> Scalar (V p) -> p - default section :: Fractional (Scalar (V p)) => p -> Scalar (V p) -> Scalar (V p) -> p - section x t1 t2 = snd (splitAtParam (fst (splitAtParam x t2)) (t1/t2)) + section :: p -> n -> n -> p + -- default section :: Fractional n => p n -> n -> n -> p n + -- section x t1 t2 = snd (splitAtParam (fst (splitAtParam x t2)) (t1/t2)) -- | Flip the parameterization on the domain. reverseDomain :: p -> p @@ -148,19 +146,19 @@ class Parametric p => HasArcLength p where -- | @arcLengthBounded eps x@ approximates the arc length of @x@. -- The true arc length is guaranteed to lie within the interval -- returned, which will have a size of at most @eps@. - arcLengthBounded :: Scalar (V p) -> p -> I.Interval (Scalar (V p)) + arcLengthBounded :: N p -> p -> I.Interval (N p) -- | @arcLength eps s@ approximates the arc length of @x@ up to the -- accuracy @eps@ (plus or minus). - arcLength :: Scalar (V p) -> p -> Scalar (V p) - default arcLength :: Fractional (Scalar (V p)) => Scalar (V p ) -> p -> Scalar (V p) - arcLength eps = I.midpoint . arcLengthBounded eps + arcLength :: N p -> p -> N p + -- default arcLength :: Fractional n => n -> p n -> n + -- arcLength eps = I.midpoint . arcLengthBounded eps -- | Approximate the arc length up to a standard accuracy of -- 'stdTolerance' (@1e-6@). - stdArcLength :: p -> Scalar (V p) - default stdArcLength :: Fractional (Scalar (V p)) => p -> Scalar (V p) - stdArcLength = arcLength stdTolerance + stdArcLength :: p -> N p + -- default stdArcLength :: Fractional n => p n -> n + -- stdArcLength = arcLength stdTolerance -- | @'arcLengthToParam' eps s l@ converts the absolute arc length -- @l@, measured from the start of the domain, to a parameter on @@ -169,11 +167,11 @@ class Parametric p => HasArcLength p where -- -- This should work for /any/ arc length, and may return any -- parameter value (not just parameters in the domain). - arcLengthToParam :: Scalar (V p) -> p -> Scalar (V p) -> Scalar (V p) + arcLengthToParam :: N p -> p -> N p -> N p -- | A simple interface to convert arc length to a parameter, -- guaranteed to be accurate within 'stdTolerance', or @1e-6@. - stdArcLengthToParam :: p -> Scalar (V p) -> Scalar (V p) - default stdArcLengthToParam :: Fractional (Scalar (V p)) - => p -> Scalar (V p) -> Scalar (V p) - stdArcLengthToParam = arcLengthToParam stdTolerance + stdArcLengthToParam :: p -> N p -> N p + -- default stdArcLengthToParam :: Fractional n + -- => p n -> n -> n + -- stdArcLengthToParam = arcLengthToParam stdTolerance diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs index 5efcbafa..d99934fd 100644 --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -20,22 +20,27 @@ module Diagrams.Points -- * Point-related utilities , centroid , pointDiagram - , _pIso + , _pIso, lensP ) where import Diagrams.Core (pointDiagram) import Diagrams.Core.Points -import Control.Arrow ((&&&)) import Control.Lens (Iso', iso) -import Data.AffineSpace.Point -import Data.VectorSpace +import Linear.Affine +import Linear.Vector +import Data.Foldable as F -- Point v <-> v -_pIso :: Iso' (Point v) v -_pIso = iso unPoint P +_pIso :: Iso' (Point v n) (v n) +_pIso = iso (\(P a) -> a) P -- | The centroid of a set of /n/ points is their sum divided by /n/. -centroid :: (VectorSpace v, Fractional (Scalar v)) => [Point v] -> Point v -centroid = P . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unPoint +centroid :: (Additive v, Fractional n) => [Point v n] -> Point v n +centroid = meanV + +meanV :: (Foldable f, Additive v, Fractional a) => f (v a) -> v a +meanV = uncurry (^/) . F.foldl' (\(s,c) e -> (e ^+^ s,c+1)) (zero,0) +{-# INLINE meanV #-} + diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs deleted file mode 100644 index 77ca8907..00000000 --- a/src/Diagrams/Prelude.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} ------------------------------------------------------------------------------ --- | --- Module : Diagrams.Prelude --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- A module to re-export most of the functionality of the diagrams --- core and standard library. --- ------------------------------------------------------------------------------ - -module Diagrams.Prelude - ( - -- * Core library - -- | The core definitions of transformations, diagrams, - -- backends, and so on. - module Diagrams.Core - - -- * Standard library - - -- | Attributes (color, line style, etc.) and styles. - , module Diagrams.Attributes - - -- | Alignment of diagrams relative to their envelopes. - , module Diagrams.Align - - -- | Combining multiple diagrams into one. - , module Diagrams.Combinators - - -- | Giving concrete locations to translation-invariant things. - , module Diagrams.Located - - -- | Linear and cubic bezier segments. - , module Diagrams.Segment - - -- | Trails. - , module Diagrams.Trail - - -- | Parametrization of segments and trails. - , module Diagrams.Parametric - - -- | Adjusting the length of parameterized objects. - , module Diagrams.Parametric.Adjust - - -- | Computing tangent and normal vectors of segments and - -- trails. - , module Diagrams.Tangent - - -- | Trail-like things. - , module Diagrams.TrailLike - - -- | Paths. - , module Diagrams.Path - - -- | Cubic splines. - , module Diagrams.CubicSpline - - -- | Some additional transformation-related functions, like - -- conjugation of transformations. - , module Diagrams.Transform - - -- | Projective transformations and other deformations - -- lacking an inverse. - , module Diagrams.Deform - - -- | Giving names to subdiagrams and later retrieving - -- subdiagrams by name. - , module Diagrams.Names - - -- | Envelopes, aka functional bounding regions. - , module Diagrams.Envelope - - -- | Traces, aka embedded raytracers, for finding points on - -- the boundary of a diagram. - , module Diagrams.Trace - - -- | A query is a function that maps points in a vector space - -- to values in some monoid; they can be used to annotate - -- the points of a diagram with some values. - , module Diagrams.Query - - -- | Utilities for working with points. - , module Diagrams.Points - - -- | Angles - , module Diagrams.Angle - -- | Convenience infix operators for working with coordinates. - , module Diagrams.Coordinates - -- | Directions, distinguished from angles or vectors - , module Diagrams.Direction - - -- | A wide range of things (shapes, transformations, - -- combinators) specific to creating two-dimensional - -- diagrams. - , module Diagrams.TwoD - - -- | Tools for making animations. - , module Diagrams.Animation - - -- | Various utility definitions. - , module Diagrams.Util - - -- * Convenience re-exports - -- | For representing and operating on colors. - , module Data.Colour - -- | A large list of color names. - , module Data.Colour.Names - -- | Semigroups and monoids show up all over the place, so things from - -- Data.Semigroup and Data.Monoid often come in handy. - , module Data.Semigroup - -- | For computing with vectors. - , module Data.VectorSpace - -- | For computing with points and vectors. - , module Data.AffineSpace - - -- | For working with 'Active' (i.e. animated) things. - , module Data.Active - - -- | Essential Lens Combinators - , (&), (.~), (%~) - - , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 - ) where - -import Diagrams.Core - -import Diagrams.Align -import Diagrams.Angle -import Diagrams.Animation -import Diagrams.Attributes -import Diagrams.Combinators -import Diagrams.Coordinates -import Diagrams.CubicSpline -import Diagrams.Deform -import Diagrams.Direction -import Diagrams.Envelope -import Diagrams.Located -import Diagrams.Names -import Diagrams.Parametric -import Diagrams.Parametric.Adjust -import Diagrams.Path -import Diagrams.Points -import Diagrams.Query -import Diagrams.Segment -import Diagrams.Tangent -import Diagrams.Trace -import Diagrams.Trail hiding (linePoints, loopPoints, trailPoints) -import Diagrams.TrailLike -import Diagrams.Transform -import Diagrams.TwoD -import Diagrams.Util - -import Control.Applicative -import Control.Lens ((%~), (&), (.~)) -import Data.Active -import Data.AffineSpace -import Data.Colour hiding (AffineSpace (..), atop, over) -import Data.Colour.Names hiding (tan) -import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index 4bcb156d..3a5bd97e 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -41,7 +41,7 @@ module Diagrams.Segment -- * Segment offsets - , Offset(..), segOffset + , Offset(..) , segOffset -- * Constructing and modifying segments @@ -65,15 +65,18 @@ module Diagrams.Segment import Control.Applicative (liftA2) import Control.Lens (Rewrapped, Wrapped (..), iso, makeLenses, op) -import Data.AffineSpace import Data.FingerTree import Data.Monoid.MList import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) import Numeric.Interval.Kaucher (Interval (..)) import qualified Numeric.Interval.Kaucher as I +import Linear.Affine +import Linear.Vector +import Linear.Metric + import Diagrams.Core +import Diagrams.Core.V import Diagrams.Located import Diagrams.Parametric import Diagrams.Solve @@ -101,22 +104,25 @@ data Closed -- the context, /i.e./ its endpoint is not fixed. The offset for a -- /closed/ segment is stored explicitly, /i.e./ its endpoint is at -- a fixed offset from its start. -data Offset c v where - OffsetOpen :: Offset Open v - OffsetClosed :: !v -> Offset Closed v +data Offset c v n where + OffsetOpen :: Offset Open v n + OffsetClosed :: v n -> Offset Closed v n + -- OffsetClosed :: !v -> Offset Closed v n -deriving instance Show v => Show (Offset c v) -deriving instance Eq v => Eq (Offset c v) -deriving instance Ord v => Ord (Offset c v) +deriving instance Show (v n) => Show (Offset c v n) +deriving instance Eq (v n) => Eq (Offset c v n) +deriving instance Ord (v n) => Ord (Offset c v n) -instance Functor (Offset c) where +instance Functor v => Functor (Offset c v) where fmap _ OffsetOpen = OffsetOpen - fmap f (OffsetClosed v) = OffsetClosed (f v) + fmap f (OffsetClosed v) = OffsetClosed (fmap f v) -type instance V (Offset c v) = v +type instance V (Offset c v n) = v +type instance N (Offset c v n) = n -instance HasLinearMap v => Transformable (Offset c v) where - transform = fmap . apply +instance Transformable (Offset c v n) where + transform _ OffsetOpen = OffsetOpen + transform t (OffsetClosed v) = OffsetClosed (apply t v) ------------------------------------------------------------ -- Constructing segments --------------------------------- @@ -129,11 +135,11 @@ instance HasLinearMap v => Transformable (Offset c v) where -- \"location\" and are unaffected by translations. They are, -- however, affected by other transformations such as rotations and -- scales. -data Segment c v - = Linear !(Offset c v) +data Segment c v n + = Linear !(Offset c v n) -- ^ A linear segment with given offset. - | Cubic !v !v !(Offset c v) + | Cubic !(v n) !(v n) !(Offset c v n) -- ^ A cubic Bézier segment specified by -- three offsets from the starting -- point to the first control point, @@ -146,17 +152,19 @@ data Segment c v -- http://trac.haskell.org/haddock/ticket/43. For now we don't need -- Segment to be a GADT but we might in the future. (?) -type instance V (Segment c v) = v +type instance V (Segment c v n) = v +type instance N (Segment c v n) = n -instance HasLinearMap v => Transformable (Segment c v) where - transform = fmap . apply +instance Transformable (Segment c v n) where + transform t (Linear v) = Linear (transform t v) + transform t (Cubic v1 v2 v3) = Cubic (apply t v1) (apply t v2) (transform t v3) -instance HasLinearMap v => Renderable (Segment c v) NullBackend where +instance Renderable (Segment c v n) NullBackend where render _ _ = mempty -- | @'straight' v@ constructs a translationally invariant linear -- segment with direction and length given by the vector @v@. -straight :: v -> Segment Closed v +straight :: v n -> Segment Closed v n straight = Linear . OffsetClosed -- Note, if we didn't have a Linear constructor we could also create @@ -168,37 +176,37 @@ straight = Linear . OffsetClosed -- Bézier curve where the offsets from the first endpoint to the -- first and second control point and endpoint are respectively -- given by @c1@, @c2@, and @x@. -bezier3 :: v -> v -> v -> Segment Closed v +bezier3 :: v n -> v n -> v n -> Segment Closed v n bezier3 c1 c2 x = Cubic c1 c2 (OffsetClosed x) -- | @bézier3@ is the same as @bezier3@, but with more snobbery. -bézier3 :: v -> v -> v -> Segment Closed v +bézier3 :: v n -> v n -> v n -> Segment Closed v n bézier3 = bezier3 -type instance Codomain (Segment Closed v) = v +type instance Codomain (Segment Closed v n) = v -- | 'atParam' yields a parametrized view of segments as continuous -- functions @[0,1] -> v@, which give the offset from the start of -- the segment for each value of the parameter between @0@ and @1@. -- It is designed to be used infix, like @seg ``atParam`` 0.5@. -instance (VectorSpace v, Num (Scalar v)) => Parametric (Segment Closed v) where +instance (Additive v, Num n) => Parametric (Segment Closed v n) where atParam (Linear (OffsetClosed x)) t = t *^ x atParam (Cubic c1 c2 (OffsetClosed x2)) t = (3 * t'*t'*t ) *^ c1 ^+^ (3 * t'*t *t ) *^ c2 ^+^ ( t *t *t ) *^ x2 where t' = 1-t -instance Num (Scalar v) => DomainBounds (Segment Closed v) +instance Num n => DomainBounds (Segment Closed v n) -instance (VectorSpace v, Num (Scalar v)) => EndValues (Segment Closed v) where - atStart = const zeroV +instance (Additive v, Num n) => EndValues (Segment Closed v n) where + atStart = const zero atEnd (Linear (OffsetClosed v)) = v atEnd (Cubic _ _ (OffsetClosed v)) = v -- | Compute the offset from the start of a segment to the -- end. Note that in the case of a Bézier segment this is /not/ the -- same as the length of the curve itself; for that, see 'arcLength'. -segOffset :: Segment Closed v -> v +segOffset :: Segment Closed v n -> v n segOffset (Linear (OffsetClosed v)) = v segOffset (Cubic _ _ (OffsetClosed v)) = v @@ -229,61 +237,61 @@ segOffset (Cubic _ _ (OffsetClosed v)) = v -} -- | The envelope for a segment is based at the segment's start. -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Segment Closed v) where +instance (Metric v, OrderedField n) => Enveloped (Segment Closed v n) where getEnvelope (s@(Linear {})) = mkEnvelope $ \v -> - maximum (map (\t -> ((s `atParam` t) <.> v)) [0,1]) / magnitudeSq v + maximum (map (\t -> (s `atParam` t) `dot` v) [0,1]) / quadrance v getEnvelope (s@(Cubic c1 c2 (OffsetClosed x2))) = mkEnvelope $ \v -> maximum . - map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ + map (\t -> ((s `atParam` t) `dot` v) / quadrance v) $ [0,1] ++ filter (liftA2 (&&) (>0) (<1)) - (quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) <.> v)) - (6 * (((-2) *^ c1 ^+^ c2) <.> v)) - ((3 *^ c1) <.> v)) + (quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) `dot` v)) + (6 * (((-2) *^ c1 ^+^ c2) `dot` v)) + ((3 *^ c1) `dot` v)) ------------------------------------------------------------ -- Manipulating segments ------------------------------------------------------------ -instance (VectorSpace v, Fractional (Scalar v)) => Sectionable (Segment Closed v) where +instance (Additive v, Fractional n) => Sectionable (Segment Closed v n) where splitAtParam (Linear (OffsetClosed x1)) t = (left, right) where left = straight p right = straight (x1 ^-^ p) - p = lerp zeroV x1 t + p = lerp t zero x1 splitAtParam (Cubic c1 c2 (OffsetClosed x2)) t = (left, right) where left = bezier3 a b e right = bezier3 (c ^-^ e) (d ^-^ e) (x2 ^-^ e) - p = lerp c1 c2 t - a = lerp zeroV c1 t - b = lerp a p t - d = lerp c2 x2 t - c = lerp p d t - e = lerp b c t + p = lerp t c1 c2 + a = lerp t zero c1 + b = lerp t a p + d = lerp t c2 x2 + c = lerp t p d + e = lerp t b c reverseDomain = reverseSegment -- | Reverse the direction of a segment. -reverseSegment :: AdditiveGroup v => Segment Closed v -> Segment Closed v -reverseSegment (Linear (OffsetClosed v)) = straight (negateV v) -reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negateV x2) +reverseSegment :: (Num n, Additive v) => Segment Closed v n -> Segment Closed v n +reverseSegment (Linear (OffsetClosed v)) = straight (negated v) +reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negated x2) -instance (InnerSpace v, Floating (Scalar v), Ord (Scalar v), AdditiveGroup v) - => HasArcLength (Segment Closed v) where +instance (Metric v, Floating n, Ord n, Additive v) + => HasArcLength (Segment Closed v n) where - arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ magnitude x1 + arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ norm x1 arcLengthBounded m s@(Cubic c1 c2 (OffsetClosed x2)) | ub - lb < m = I lb ub | otherwise = arcLengthBounded (m/2) l + arcLengthBounded (m/2) r where (l,r) = s `splitAtParam` 0.5 - ub = sum (map magnitude [c1, c2 ^-^ c1, x2 ^-^ c2]) - lb = magnitude x2 + ub = sum (map norm [c1, c2 ^-^ c1, x2 ^-^ c2]) + lb = norm x2 arcLengthToParam m s _ | arcLength m s == 0 = 0.5 arcLengthToParam m s@(Linear {}) len = len / arcLength m s arcLengthToParam m s@(Cubic {}) len - | len `I.elem` (I (-m/2) (m/2)) = 0 + | len `I.elem` I (-m/2) (m/2) = 0 | len < 0 = - arcLengthToParam m (fst (splitAtParam s (-1))) (-len) | len `I.elem` slen = 1 | len > I.sup slen = 2 * arcLengthToParam m (fst (splitAtParam s 2)) len @@ -307,13 +315,14 @@ instance (InnerSpace v, Floating (Scalar v), Ord (Scalar v), AdditiveGroup v) -- (Segment Closed v)@, as witnessed by 'mkFixedSeg' and -- 'fromFixedSeg', but @FixedSegment@ is convenient when one needs -- the absolute locations of the vertices and control points. -data FixedSegment v = FLinear (Point v) (Point v) - | FCubic (Point v) (Point v) (Point v) (Point v) +data FixedSegment v n = FLinear (Point v n) (Point v n) + | FCubic (Point v n) (Point v n) (Point v n) (Point v n) deriving Show -type instance V (FixedSegment v) = v +type instance V (FixedSegment v n) = v +type instance N (FixedSegment v n) = n -instance HasLinearMap v => Transformable (FixedSegment v) where +instance (Additive v, Num n) => Transformable (FixedSegment v n) where transform t (FLinear p1 p2) = FLinear (transform t p1) @@ -326,7 +335,7 @@ instance HasLinearMap v => Transformable (FixedSegment v) where (transform t c2) (transform t p2) -instance VectorSpace v => HasOrigin (FixedSegment v) where +instance (Additive v, Num n) => HasOrigin (FixedSegment v n) where moveOriginTo o (FLinear p1 p2) = FLinear (moveOriginTo o p1) @@ -339,7 +348,7 @@ instance VectorSpace v => HasOrigin (FixedSegment v) where (moveOriginTo o c2) (moveOriginTo o p2) -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (FixedSegment v) where +instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where getEnvelope f = moveTo p (getEnvelope s) where (p, s) = viewLoc $ fromFixedSeg f @@ -349,56 +358,56 @@ instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (FixedSegment v) w -- instead of the other way around -- | Create a 'FixedSegment' from a located 'Segment'. -mkFixedSeg :: AdditiveGroup v => Located (Segment Closed v) -> FixedSegment v +mkFixedSeg :: (Num n, Additive v) => Located (Segment Closed v n) -> FixedSegment v n mkFixedSeg ls = case viewLoc ls of (p, Linear (OffsetClosed v)) -> FLinear p (p .+^ v) (p, Cubic c1 c2 (OffsetClosed x2)) -> FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) -- | Convert a 'FixedSegment' back into a located 'Segment'. -fromFixedSeg :: AdditiveGroup v => FixedSegment v -> Located (Segment Closed v) +fromFixedSeg :: (Num n, Additive v) => FixedSegment v n -> Located (Segment Closed v n) fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 -type instance Codomain (FixedSegment v) = Point v +type instance Codomain (FixedSegment v n) = Point v -instance VectorSpace v => Parametric (FixedSegment v) where - atParam (FLinear p1 p2) t = alerp p1 p2 t +instance (Additive v, Num n) => Parametric (FixedSegment v n) where + atParam (FLinear p1 p2) t = lerp t p1 p2 atParam (FCubic x1 c1 c2 x2) t = p3 - where p11 = alerp x1 c1 t - p12 = alerp c1 c2 t - p13 = alerp c2 x2 t + where p11 = lerp t x1 c1 + p12 = lerp t c1 c2 + p13 = lerp t c2 x2 - p21 = alerp p11 p12 t - p22 = alerp p12 p13 t + p21 = lerp t p11 p12 + p22 = lerp t p12 p13 - p3 = alerp p21 p22 t + p3 = lerp t p21 p22 -instance Num (Scalar v) => DomainBounds (FixedSegment v) +instance Num n => DomainBounds (FixedSegment v n) -instance (VectorSpace v, Num (Scalar v)) => EndValues (FixedSegment v) where +instance (Additive v, Num n) => EndValues (FixedSegment v n) where atStart (FLinear p0 _) = p0 atStart (FCubic p0 _ _ _) = p0 atEnd (FLinear _ p1) = p1 atEnd (FCubic _ _ _ p1 ) = p1 -instance (VectorSpace v, Fractional (Scalar v)) => Sectionable (FixedSegment v) where +instance (Additive v, Fractional n) => Sectionable (FixedSegment v n) where splitAtParam (FLinear p0 p1) t = (left, right) where left = FLinear p0 p right = FLinear p p1 - p = alerp p0 p1 t + p = lerp t p0 p1 splitAtParam (FCubic p0 c1 c2 p1) t = (left, right) where left = FCubic p0 a b cut right = FCubic cut c d p1 -- first round - a = alerp p0 c1 t - p = alerp c1 c2 t - d = alerp c2 p1 t + a = lerp t p0 c1 + p = lerp t c1 c2 + d = lerp t c2 p1 -- second round - b = alerp a p t - c = alerp p d t + b = lerp t a p + c = lerp t p d -- final round - cut = alerp b c t + cut = lerp t b c reverseDomain (FLinear p0 p1) = FLinear p1 p0 reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0 @@ -427,70 +436,69 @@ instance Rewrapped SegCount SegCount -- a generic arc length function taking the tolerance as an -- argument. -newtype ArcLength v - = ArcLength (Sum (Interval (Scalar v)), Scalar v -> Sum (Interval (Scalar v))) +newtype ArcLength n + = ArcLength (Sum (Interval n), n -> Sum (Interval n)) -instance Wrapped (ArcLength v) where - type Unwrapped (ArcLength v) = - (Sum (Interval (Scalar v)), Scalar v -> Sum (Interval (Scalar v))) - _Wrapped' = iso (\(ArcLength x) -> x) ArcLength +instance Wrapped (ArcLength n) where + type Unwrapped (ArcLength n) = (Sum (Interval n), n -> Sum (Interval n)) + _Wrapped' = iso (\(ArcLength x) -> x) ArcLength -instance Rewrapped (ArcLength v) (ArcLength v') +instance Rewrapped (ArcLength n) (ArcLength n') -- | Project out the cached arc length, stored together with error -- bounds. -getArcLengthCached :: ArcLength v -> Interval (Scalar v) +getArcLengthCached :: ArcLength n -> Interval n getArcLengthCached = getSum . fst . op ArcLength -- | Project out the generic arc length function taking the tolerance as -- an argument. -getArcLengthFun :: ArcLength v -> Scalar v -> Interval (Scalar v) +getArcLengthFun :: ArcLength n -> n -> Interval n getArcLengthFun = fmap getSum . snd . op ArcLength -- | Given a specified tolerance, project out the cached arc length if -- it is accurate enough; otherwise call the generic arc length -- function with the given tolerance. -getArcLengthBounded :: (Num (Scalar v), Ord (Scalar v)) - => Scalar v -> ArcLength v -> Interval (Scalar v) +getArcLengthBounded :: (Num n, Ord n) + => n -> ArcLength n -> Interval n getArcLengthBounded eps al | I.width cached <= eps = cached | otherwise = getArcLengthFun al eps where cached = getArcLengthCached al -deriving instance (Num (Scalar v), Ord (Scalar v)) => Semigroup (ArcLength v) -deriving instance (Num (Scalar v), Ord (Scalar v)) => Monoid (ArcLength v) +deriving instance (Num n, Ord n) => Semigroup (ArcLength n) +deriving instance (Num n, Ord n) => Monoid (ArcLength n) -- | A type to represent the total cumulative offset of a chain of -- segments. -newtype TotalOffset v = TotalOffset v +newtype TotalOffset v n = TotalOffset (v n) -instance Wrapped (TotalOffset v) where - type Unwrapped (TotalOffset v) = v +instance Wrapped (TotalOffset v n) where + type Unwrapped (TotalOffset v n) = v n _Wrapped' = iso (\(TotalOffset x) -> x) TotalOffset -instance Rewrapped (TotalOffset v) (TotalOffset v') +instance Rewrapped (TotalOffset v n) (TotalOffset v' n') -instance AdditiveGroup v => Semigroup (TotalOffset v) where +instance (Num n, Additive v) => Semigroup (TotalOffset v n) where TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2) -instance AdditiveGroup v => Monoid (TotalOffset v) where - mempty = TotalOffset zeroV +instance (Num n, Additive v) => Monoid (TotalOffset v n) where + mempty = TotalOffset zero mappend = (<>) -- | A type to represent the offset and envelope of a chain of -- segments. They have to be paired into one data structure, since -- combining the envelopes of two consecutive chains needs to take -- the offset of the the offset of the first into account. -data OffsetEnvelope v = OffsetEnvelope - { _oeOffset :: !(TotalOffset v) - , _oeEnvelope :: Envelope v +data OffsetEnvelope v n = OffsetEnvelope + { _oeOffset :: !(TotalOffset v n) + , _oeEnvelope :: Envelope v n } makeLenses ''OffsetEnvelope -instance (InnerSpace v, OrderedField (Scalar v)) => Semigroup (OffsetEnvelope v) where +instance (Metric v, OrderedField n) => Semigroup (OffsetEnvelope v n) where (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) - = let !negOff = negateV . op TotalOffset $ o1 + = let !negOff = negated . op TotalOffset $ o1 e2Off = moveOriginBy negOff e2 !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off in OffsetEnvelope @@ -499,32 +507,30 @@ instance (InnerSpace v, OrderedField (Scalar v)) => Semigroup (OffsetEnvelope v) -- | @SegMeasure@ collects up all the measurements over a chain of -- segments. -type SegMeasure v = SegCount - ::: ArcLength v - ::: OffsetEnvelope v - ::: () +type SegMeasure v n = SegCount + ::: ArcLength n + ::: OffsetEnvelope v n + ::: () -- unfortunately we can't cache Trace, since there is not a generic -- instance Traced (Segment Closed v), only Traced (Segment Closed R2). -instance (InnerSpace v, OrderedField (Scalar v)) - => Measured (SegMeasure v) (SegMeasure v) where +instance (Metric v, OrderedField n) + => Measured (SegMeasure v n) (SegMeasure v n) where measure = id -instance (OrderedField (Scalar v), InnerSpace v) - => Measured (SegMeasure v) (Segment Closed v) where - measure s = (SegCount . Sum $ 1) +instance (OrderedField n, Metric v) + => Measured (SegMeasure v n) (Segment Closed v n) where + measure s = (SegCount . Sum) 1 -- cache arc length with two orders of magnitude more -- accuracy than standard, so we have a hope of coming out -- with an accurate enough total arc length for -- reasonable-length trails - *: (ArcLength $ ( Sum $ arcLengthBounded (stdTolerance/100) s - , Sum . flip arcLengthBounded s - ) - ) - - *: (OffsetEnvelope - (TotalOffset . segOffset $ s) - (getEnvelope s) - ) + *: ArcLength ( Sum $ arcLengthBounded (stdTolerance/100) s + , Sum . flip arcLengthBounded s ) + + *: OffsetEnvelope (TotalOffset . segOffset $ s) + (getEnvelope s) + *: () + diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs index 697a73b3..a8ef12e6 100644 --- a/src/Diagrams/Tangent.hs +++ b/src/Diagrams/Tangent.hs @@ -19,20 +19,23 @@ module Diagrams.Tangent ( tangentAtParam , tangentAtStart , tangentAtEnd - , normalAtParam - , normalAtStart - , normalAtEnd + -- , normalAtParam + -- , normalAtStart + -- , normalAtEnd , Tangent(..) ) where -import Data.VectorSpace + +import Linear.Vector +-- import Linear.Metric import Diagrams.Core +import Diagrams.Core.V import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment -import Diagrams.TwoD.Types (R2Ish) -import Diagrams.TwoD.Vector (perp) +-- import Diagrams.TwoD.Types (R2Ish) +-- import Diagrams.TwoD.Vector (perp) ------------------------------------------------------------ -- Tangent @@ -43,6 +46,7 @@ import Diagrams.TwoD.Vector (perp) newtype Tangent t = Tangent t type instance V (Tangent t) = V t +type instance N (Tangent t) = N t instance DomainBounds t => DomainBounds (Tangent t) where domainLower (Tangent t) = domainLower t @@ -70,30 +74,30 @@ instance (DomainBounds t, EndValues (Tangent t)) -- * @Located (Trail R2) -> Double -> R2@ -- -- See the instances listed for the 'Tangent' newtype for more. -tangentAtParam :: Parametric (Tangent t) => t -> Scalar (V t) -> Codomain (Tangent t) +tangentAtParam :: Parametric (Tangent t) => t -> N t -> Codomain (Tangent t) (N t) tangentAtParam t p = Tangent t `atParam` p -- | Compute the tangent vector at the start of a segment or trail. -tangentAtStart :: EndValues (Tangent t) => t -> Codomain (Tangent t) +tangentAtStart :: EndValues (Tangent t) => t -> Codomain (Tangent t) (N t) tangentAtStart = atStart . Tangent -- | Compute the tangent vector at the end of a segment or trail. -tangentAtEnd :: EndValues (Tangent t) => t -> Codomain (Tangent t) +tangentAtEnd :: EndValues (Tangent t) => t -> Codomain (Tangent t) (N t) tangentAtEnd = atEnd . Tangent -------------------------------------------------- -- Segment -type instance Codomain (Tangent (Segment Closed v)) = Codomain (Segment Closed v) +type instance Codomain (Tangent (Segment Closed v n)) = Codomain (Segment Closed v n) -instance (VectorSpace v, Num (Scalar v)) - => Parametric (Tangent (Segment Closed v)) where +instance (Additive v, Num n) + => Parametric (Tangent (Segment Closed v n)) where Tangent (Linear (OffsetClosed v)) `atParam` _ = v Tangent (Cubic c1 c2 (OffsetClosed x2)) `atParam` p = (3*(3*p*p-4*p+1))*^c1 ^+^ (3*(2-3*p)*p)*^c2 ^+^ (3*p*p)*^x2 -instance (VectorSpace v, Num (Scalar v)) - => EndValues (Tangent (Segment Closed v)) where +instance (Additive v, Num n) + => EndValues (Tangent (Segment Closed v n)) where atStart (Tangent (Linear (OffsetClosed v))) = v atStart (Tangent (Cubic c1 _ _)) = c1 atEnd (Tangent (Linear (OffsetClosed v))) = v @@ -115,23 +119,23 @@ instance (VectorSpace v, Num (Scalar v)) -- * @Located (Trail R2) -> Double -> P2@ -- -- See the instances listed for the 'Tangent' newtype for more. -normalAtParam - :: (R2Ish (Codomain (Tangent t)), Parametric (Tangent t)) - => t -> Scalar (V t) -> Codomain (Tangent t) -normalAtParam t p = normize (t `tangentAtParam` p) - --- | Compute the normal vector at the start of a segment or trail. -normalAtStart - :: (R2Ish (Codomain (Tangent t)), EndValues (Tangent t)) - => t -> Codomain (Tangent t) -normalAtStart = normize . tangentAtStart - --- | Compute the normal vector at the end of a segment or trail. -normalAtEnd - :: (R2Ish (Codomain (Tangent t)), EndValues (Tangent t)) - => t -> Codomain (Tangent t) -normalAtEnd = normize . tangentAtEnd - +-- normalAtParam +-- :: (R2Ish (Codomain (Tangent t)), Parametric (Tangent t)) +-- => t -> Scalar (V t) -> Codomain (Tangent t) +-- normalAtParam t p = normize (t `tangentAtParam` p) +-- +-- -- | Compute the normal vector at the start of a segment or trail. +-- normalAtStart +-- :: (R2Ish (Codomain (Tangent t)), EndValues (Tangent t)) +-- => t -> Codomain (Tangent t) +-- normalAtStart = normize . tangentAtStart +-- +-- -- | Compute the normal vector at the end of a segment or trail. +-- normalAtEnd +-- :: (R2Ish (Codomain (Tangent t)), EndValues (Tangent t)) +-- => t -> Codomain (Tangent t) +-- normalAtEnd = normize . tangentAtEnd +-- -- | Construct a normal vector from a tangent. -normize :: (R2Ish v) => v -> v -normize = negateV . perp . normalized +-- normize :: (Additive v, Num n) => v n -> v n +-- normize = negated . perp . normalize diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 83580c73..fc37cedf 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -113,15 +113,19 @@ import qualified Data.FingerTree as FT import qualified Data.Foldable as F import Data.Monoid.MList import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) +-- import Data.VectorSpace hiding (Sum (..)) import qualified Numeric.Interval.Kaucher as I import Diagrams.Core hiding ((|>)) +import Diagrams.Core.V import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment import Diagrams.Tangent +import Linear.Vector +import Linear.Metric + -- $internals -- -- Most users of diagrams should not need to use anything in this @@ -133,8 +137,9 @@ import Diagrams.Tangent ------------------------------------------------------------ type instance V (FingerTree m a) = V a +type instance N (FingerTree m a) = N a -instance ( HasLinearMap (V a), InnerSpace (V a), OrderedField (Scalar (V a)) +instance ( Metric (V a), OrderedField (Scalar (V a)) , FT.Measured m a, Transformable a ) => Transformable (FingerTree m a) where @@ -151,37 +156,38 @@ instance ( HasLinearMap (V a), InnerSpace (V a), OrderedField (Scalar (V a)) -- (/e.g./, split off the smallest number of segments from the -- beginning which have a combined arc length of at least 5). -newtype SegTree v = SegTree (FingerTree (SegMeasure v) (Segment Closed v)) +newtype SegTree v n = SegTree (FingerTree (SegMeasure v n) (Segment Closed v n)) deriving (Eq, Ord, Show) -instance Wrapped (SegTree v) where - type Unwrapped (SegTree v) = FingerTree (SegMeasure v) (Segment Closed v) +instance Wrapped (SegTree v n) where + type Unwrapped (SegTree v n) = FingerTree (SegMeasure v n) (Segment Closed v n) _Wrapped' = iso (\(SegTree x) -> x) SegTree -instance Rewrapped (SegTree v) (SegTree v') +instance Rewrapped (SegTree v n) (SegTree v' n') -type instance V (SegTree v) = v +type instance V (SegTree v n) = v +type instance N (SegTree v n) = n -deriving instance (OrderedField (Scalar v), InnerSpace v) - => Monoid (SegTree v) -deriving instance (OrderedField (Scalar v), InnerSpace v) - => FT.Measured (SegMeasure v) (SegTree v) -deriving instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (SegTree v) +deriving instance (OrderedField n, Metric v) + => Monoid (SegTree v n) +deriving instance (OrderedField n, Metric v) + => FT.Measured (SegMeasure v n) (SegTree v n) +deriving instance (Metric v, OrderedField n) + => Transformable (SegTree v n) -type instance Codomain (SegTree v) = v +type instance Codomain (SegTree v n) = v -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => Parametric (SegTree v) where +instance (Metric v, OrderedField n, RealFrac n) + => Parametric (SegTree v n) where atParam t p = offset . fst $ splitAtParam t p -instance Num (Scalar v) => DomainBounds (SegTree v) +instance Num n => DomainBounds (SegTree v n) -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v), Num (Scalar v)) - => EndValues (SegTree v) +instance (Metric v, OrderedField n, RealFrac n, Num n) + => EndValues (SegTree v n) -instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) - => Sectionable (SegTree v) where +instance (Metric v, RealFrac n, Floating n) + => Sectionable (SegTree v n) where splitAtParam (SegTree t) p | p < 0 = case FT.viewl t of EmptyL -> emptySplit @@ -215,8 +221,8 @@ instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) -- XXX seems like it should be possible to collapse some of the -- above cases into one? -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => HasArcLength (SegTree v) where +instance (Metric v, OrderedField n, RealFrac n) + => HasArcLength (SegTree v n) where arcLengthBounded eps t -- Use the cached value if it is accurate enough; otherwise fall -- back to recomputing a more accurate value @@ -224,10 +230,10 @@ instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) | otherwise = fun (eps / numSegs t) where i = trailMeasure (I.singleton 0) - (getArcLengthCached :: ArcLength v -> I.Interval (Scalar v)) + (getArcLengthCached :: ArcLength v -> I.Interval n) t fun = trailMeasure (const 0) - (getArcLengthFun :: ArcLength v -> Scalar v -> I.Interval (Scalar v)) + (getArcLengthFun :: ArcLength v -> n -> I.Interval n) t arcLengthToParam eps st@(SegTree t) l @@ -250,15 +256,15 @@ instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) totalAL = arcLength eps st tSegs = numSegs t before, after :: FingerTree (SegMeasure v) (Segment Closed v) - (before, after) = FT.split ((>= l) . trailMeasure 0 (I.midpoint . (getArcLengthBounded eps :: ArcLength v -> I.Interval (Scalar v)))) t + (before, after) = FT.split ((>= l) . trailMeasure 0 (I.midpoint . (getArcLengthBounded eps :: ArcLength v -> I.Interval n))) t -- | Given a default result (to be used in the case of an empty -- trail), and a function to map a single measure to a result, -- extract the given measure for a trail and use it to compute a -- result. Put another way, lift a function on a single measure -- (along with a default value) to a function on an entire trail. -trailMeasure :: ( InnerSpace v, OrderedField (Scalar v) - , SegMeasure v :>: m, FT.Measured (SegMeasure v) t +trailMeasure :: ( Metric v, OrderedField n + , SegMeasure v :>: m, FT.Measured (SegMeasure v n) t ) => a -> (m -> a) -> t -> a trailMeasure d f = option d f . get . FT.measure @@ -266,18 +272,18 @@ trailMeasure d f = option d f . get . FT.measure -- | Compute the number of segments of anything measured by -- 'SegMeasure' (/e.g./ @SegMeasure@ itself, @Segment@, @SegTree@, -- @Trail@s...) -numSegs :: ( Floating (Scalar v), Num c, Ord (Scalar v), InnerSpace v, - FT.Measured (SegMeasure v) a +numSegs :: ( Floating n, Num c, Ord n, Metric v, + FT.Measured (SegMeasure v n) a ) => a -> c numSegs = fromIntegral . trailMeasure 0 (getSum . op SegCount) -- | Compute the total offset of anything measured by 'SegMeasure'. -offset :: ( Floating (Scalar v), Ord (Scalar v), InnerSpace v, - FT.Measured (SegMeasure v) t +offset :: ( Floating n, Ord n, Metric v, + FT.Measured (SegMeasure v n) t ) => t -> v -offset = trailMeasure zeroV (op TotalOffset . view oeOffset) +offset = trailMeasure zero (op TotalOffset . view oeOffset) ------------------------------------------------------------ -- Trails ------------------------------------------------ @@ -351,96 +357,96 @@ data Trail' l v where -- | A generic eliminator for 'Trail'', taking functions specifying -- what to do in the case of a line or a loop. -withTrail' :: (Trail' Line v -> r) -> (Trail' Loop v -> r) -> Trail' l v -> r +withTrail' :: (Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail' l v n -> r withTrail' line _ t@(Line{}) = line t withTrail' _ loop t@(Loop{}) = loop t -deriving instance Show v => Show (Trail' l v) -deriving instance Eq v => Eq (Trail' l v) -deriving instance Ord v => Ord (Trail' l v) +deriving instance Show (v n) => Show (Trail' l v) +deriving instance Eq (v n) => Eq (Trail' l v) +deriving instance Ord (v n) => Ord (Trail' l v) type instance V (Trail' l v) = v type instance Codomain (Trail' l v) = v -instance (OrderedField (Scalar v), InnerSpace v) => Semigroup (Trail' Line v) where +instance (OrderedField n, Metric v) => Semigroup (Trail' Line v n) where (Line t1) <> (Line t2) = Line (t1 `mappend` t2) -- | The empty trail is constantly the zero vector. Trails are -- composed via concatenation. Note that only lines have a monoid -- instance (and not loops). -instance (OrderedField (Scalar v), InnerSpace v) => Monoid (Trail' Line v) where +instance (OrderedField n, Metric v) => Monoid (Trail' Line v) where mempty = emptyLine mappend = (<>) -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (Trail' l v) where +instance (HasLinearMap v, Metric v, OrderedField n) + => Transformable (Trail' l v n) where transform tr (Line t ) = Line (transform tr t) transform tr (Loop t s) = Loop (transform tr t) (transform tr s) -- | The envelope for a trail is based at the trail's start. -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail' l v) where +instance (Metric v, OrderedField n) => Enveloped (Trail' l v n) where getEnvelope = withTrail' ftEnv (ftEnv . cutLoop) where ftEnv :: Trail' Line v -> Envelope v ftEnv (Line t) = trailMeasure mempty (view oeEnvelope) $ t -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Renderable (Trail' o v) NullBackend where +instance (HasLinearMap v, Metric v, OrderedField n) + => Renderable (Trail' o v n) NullBackend where render _ _ = mempty -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => Parametric (Trail' l v) where +instance (Metric v, OrderedField n, RealFrac n) + => Parametric (Trail' l v n) where atParam t p = withTrail' (\(Line segT) -> segT `atParam` p) (\l -> cutLoop l `atParam` mod1 p) t -type instance Codomain (Tangent (Trail' c v)) = Codomain (Trail' c v) +type instance Codomain (Tangent (Trail' c v n)) = Codomain (Trail' c v n) -instance ( Parametric (GetSegment (Trail' c v)) +instance ( Parametric (GetSegment (Trail' c v n)) , VectorSpace v - , Num (Scalar v) + , Num n ) - => Parametric (Tangent (Trail' c v)) where + => Parametric (Tangent (Trail' c v n)) where Tangent tr `atParam` p = case GetSegment tr `atParam` p of - Nothing -> zeroV + Nothing -> zero Just (_, seg, reparam) -> Tangent seg `atParam` (p ^. cloneIso reparam) -instance ( Parametric (GetSegment (Trail' c v)) - , EndValues (GetSegment (Trail' c v)) +instance ( Parametric (GetSegment (Trail' c v n)) + , EndValues (GetSegment (Trail' c v n)) , VectorSpace v - , Num (Scalar v) + , Num n ) - => EndValues (Tangent (Trail' c v)) where + => EndValues (Tangent (Trail' c v n)) where atStart (Tangent tr) = case atStart (GetSegment tr) of - Nothing -> zeroV + Nothing -> zero Just (_, seg, _) -> atStart (Tangent seg) atEnd (Tangent tr) = case atEnd (GetSegment tr) of - Nothing -> zeroV + Nothing -> zero Just (_, seg, _) -> atEnd (Tangent seg) -type instance Codomain (Tangent (Trail v)) = Codomain (Trail v) +type instance Codomain (Tangent (Trail v n)) = Codomain (Trail v n) -instance ( InnerSpace v - , OrderedField (Scalar v) - , RealFrac (Scalar v) +instance ( Metric v + , OrderedField n + , RealFrac n ) - => Parametric (Tangent (Trail v)) where + => Parametric (Tangent (Trail v n)) where Tangent tr `atParam` p = withTrail ((`atParam` p) . Tangent) ((`atParam` p) . Tangent) tr -instance ( InnerSpace v - , OrderedField (Scalar v) - , RealFrac (Scalar v) +instance ( Metric v + , OrderedField n + , RealFrac n ) - => EndValues (Tangent (Trail v)) where + => EndValues (Tangent (Trail v n)) where atStart (Tangent tr) = withTrail (atStart . Tangent) (atStart . Tangent) tr atEnd (Tangent tr) = withTrail (atEnd . Tangent) (atEnd . Tangent) tr @@ -457,21 +463,21 @@ mod1 p = p' propFrac :: RealFrac a => a -> (Int, a) propFrac = properFraction -instance Num (Scalar v) => DomainBounds (Trail' l v) +instance Num n => DomainBounds (Trail' l v n) -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) +instance (Metric v, OrderedField n, RealFrac n) => EndValues (Trail' l v) -instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) - => Sectionable (Trail' Line v) where +instance (Metric v, RealFrac n, Floating n) + => Sectionable (Trail' Line v n) where splitAtParam (Line t) p = (Line t1, Line t2) where (t1, t2) = splitAtParam t p reverseDomain = reverseLine -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => HasArcLength (Trail' l v) where +instance (Metric v, OrderedField n, RealFrac n) + => HasArcLength (Trail' l v n) where arcLengthBounded eps = withTrail' (\(Line t) -> arcLengthBounded eps t) @@ -505,7 +511,7 @@ instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) -- -- The codomain for 'GetSegment', /i.e./ the result you get from -- calling 'atParam', 'atStart', or 'atEnd', is @Maybe (v, Segment --- Closed v, AnIso' (Scalar v) (Scalar v))@. @Nothing@ results if +-- Closed v, AnIso' n n)@. @Nothing@ results if -- the trail is empty; otherwise, you get: -- -- * the offset from the start of the trail to the beginning of the @@ -526,24 +532,25 @@ getSegment :: t -> GetSegment t getSegment = GetSegment type instance V (GetSegment t) = V t +type instance N (GetSegment t) = N t type instance Codomain (GetSegment t) = Maybe ( V t -- offset from trail start to segment start , Segment Closed (V t) -- the segment - , AnIso' (Scalar (V t)) (Scalar (V t)) -- reparameterization, trail <-> segment + , AnIso' (N t) (N t) -- reparameterization, trail <-> segment ) -- | Parameters less than 0 yield the first segment; parameters -- greater than 1 yield the last. A parameter exactly at the -- junction of two segments yields the second segment (/i.e./ the -- one with higher parameter values). -instance (InnerSpace v, OrderedField (Scalar v)) +instance (Metric v, OrderedField n) => Parametric (GetSegment (Trail' Line v)) where atParam (GetSegment (Line (SegTree ft))) p | p <= 0 = case FT.viewl ft of EmptyL -> Nothing - seg :< _ -> Just (zeroV, seg, reparam 0) + seg :< _ -> Just (zero, seg, reparam 0) | p >= 1 = case FT.viewr ft of @@ -551,7 +558,7 @@ instance (InnerSpace v, OrderedField (Scalar v)) ft' :> seg -> Just (offset ft', seg, reparam (n-1)) | otherwise - = let (before, after) = FT.split ((p*n <) . numSegs) $ ft + = let (before, after) = FT.split ((p*n <) . numSegs) ft in case FT.viewl after of EmptyL -> Nothing seg :< _ -> Just (offset before, seg, reparam (numSegs before)) @@ -562,12 +569,12 @@ instance (InnerSpace v, OrderedField (Scalar v)) -- | The parameterization for loops wraps around, /i.e./ parameters -- are first reduced \"mod 1\". -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => Parametric (GetSegment (Trail' Loop v)) where +instance (Metric v, OrderedField n, RealFrac n) + => Parametric (GetSegment (Trail' Loop v n)) where atParam (GetSegment l) p = atParam (GetSegment (cutLoop l)) (mod1 p) -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => Parametric (GetSegment (Trail v)) where +instance (Metric v, OrderedField n, RealFrac n) + => Parametric (GetSegment (Trail v n)) where atParam (GetSegment t) p = withTrail ((`atParam` p) . GetSegment) @@ -578,14 +585,14 @@ instance DomainBounds t => DomainBounds (GetSegment t) where domainLower (GetSegment t) = domainLower t domainUpper (GetSegment t) = domainUpper t -instance (InnerSpace v, OrderedField (Scalar v)) +instance (Metric v, OrderedField n) => EndValues (GetSegment (Trail' Line v)) where atStart (GetSegment (Line (SegTree ft))) = case FT.viewl ft of EmptyL -> Nothing seg :< _ -> let n = numSegs ft - in Just (zeroV, seg, iso (*n) (/n)) + in Just (zero, seg, iso (*n) (/n)) atEnd (GetSegment (Line (SegTree ft))) = case FT.viewr ft of @@ -596,13 +603,13 @@ instance (InnerSpace v, OrderedField (Scalar v)) ((/n) . (+ (n-1))) ) -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => EndValues (GetSegment (Trail' Loop v)) where +instance (Metric v, OrderedField n, RealFrac n) + => EndValues (GetSegment (Trail' Loop v n)) where atStart (GetSegment l) = atStart (GetSegment (cutLoop l)) atEnd (GetSegment l) = atEnd (GetSegment (cutLoop l)) -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => EndValues (GetSegment (Trail v)) where +instance (Metric v, OrderedField n, RealFrac n) + => EndValues (GetSegment (Trail v n)) where atStart (GetSegment t) = withTrail (\l -> atStart (GetSegment l)) @@ -620,19 +627,19 @@ instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) -- | @Trail@ is a wrapper around @Trail'@, hiding whether the -- underlying @Trail'@ is a line or loop (though which it is can be -- recovered; see /e.g./ 'withTrail'). -data Trail v where - Trail :: Trail' l v -> Trail v +data Trail v n where + Trail :: Trail' l v n -> Trail v n -deriving instance Show v => Show (Trail v) +deriving instance Show (v n) => Show (Trail v n) -instance Eq v => Eq (Trail v) where +instance Eq (v n) => Eq (Trail v n) where t1 == t2 = withTrail (\ln1 -> withTrail (\ln2 -> ln1 == ln2) (const False) t2) (\lp1 -> withTrail (const False) (\lp2 -> lp1 == lp2) t2) t1 -instance Ord v => Ord (Trail v) where +instance Ord v => Ord (Trail v n) where compare t1 t2 = withTrail (\ln1 -> withTrail (\ln2 -> compare ln1 ln2) (const LT) t2) @@ -644,7 +651,7 @@ instance Ord v => Ord (Trail v) where -- result, in general, is a line. However, there is a special case -- for the empty line, which acts as the identity (so combining the -- empty line with a loop results in a loop). -instance (OrderedField (Scalar v), InnerSpace v) => Semigroup (Trail v) where +instance (OrderedField n, Metric v) => Semigroup (Trail v n) where (Trail (Line (SegTree ft))) <> t2 | FT.null ft = t2 t1 <> (Trail (Line (SegTree ft))) | FT.null ft = t1 t1 <> t2 = flip withLine t1 $ \l1 -> @@ -659,29 +666,30 @@ instance (OrderedField (Scalar v), InnerSpace v) => Semigroup (Trail v) where -- strange. Mostly it is provided for convenience, so one can work -- directly with @Trail@s instead of working with @Trail' Line@s and -- then wrapping. -instance (OrderedField (Scalar v), InnerSpace v) => Monoid (Trail v) where +instance (OrderedField n, Metric v) => Monoid (Trail v n) where mempty = wrapLine emptyLine mappend = (<>) -type instance V (Trail v) = v +type instance V (Trail v n) = v +type instance N (Trail v n) = n -type instance Codomain (Trail v) = v +type instance Codomain (Trail v n) = v -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (Trail v) where +instance (HasLinearMap v, Metric v, OrderedField n) + => Transformable (Trail v n) where transform t = onTrail (transform t) (transform t) -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail v) where +instance (Metric v, OrderedField n) => Enveloped (Trail v n) where getEnvelope = withTrail getEnvelope getEnvelope -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => Parametric (Trail v) where +instance (Metric v, OrderedField n, RealFrac n) + => Parametric (Trail v n) where atParam t p = withTrail (`atParam` p) (`atParam` p) t -instance Num (Scalar v) => DomainBounds (Trail v) +instance Num n => DomainBounds (Trail v n) -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => EndValues (Trail v) +instance (Metric v, OrderedField n, RealFrac n) + => EndValues (Trail v n) -- | Note that there is no @Sectionable@ instance for @Trail' Loop@, -- because it does not make sense (splitting a loop at a parameter @@ -692,14 +700,14 @@ instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) -- semantically a bit silly, so please don't rely on it. (*E.g.* if -- this is really the behavior you want, consider first calling -- 'cutLoop' yourself.) -instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) - => Sectionable (Trail v) where +instance (Metric v, RealFrac n, Floating n) + => Sectionable (Trail v n) where splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t reverseDomain = reverseTrail -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => HasArcLength (Trail v) where +instance (Metric v, OrderedField n, RealFrac n) + => HasArcLength (Trail v n) where arcLengthBounded = withLine . arcLengthBounded arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr @@ -708,12 +716,12 @@ instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) -- | A generic eliminator for 'Trail', taking functions specifying -- what to do in the case of a line or a loop. -withTrail :: (Trail' Line v -> r) -> (Trail' Loop v -> r) -> Trail v -> r +withTrail :: (Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r withTrail line loop (Trail t) = withTrail' line loop t -- | Modify a @Trail@, specifying two separate transformations for the -- cases of a line or a loop. -onTrail :: (Trail' Line v -> Trail' l1 v) -> (Trail' Loop v -> Trail' l2 v) +onTrail :: (Trail' Line v n -> Trail' l1 v) -> (Trail' Loop v n -> Trail' l2 v n) -> (Trail v -> Trail v) onTrail o c = withTrail (wrapTrail . o) (wrapTrail . c) @@ -724,8 +732,8 @@ onTrail o c = withTrail (wrapTrail . o) (wrapTrail . c) -- @ -- withLine f === 'withTrail' f (f . 'cutLoop') -- @ -withLine :: (InnerSpace v, OrderedField (Scalar v)) - => (Trail' Line v -> r) -> Trail v -> r +withLine :: (Metric v, OrderedField n) + => (Trail' Line v n -> r) -> Trail v n -> r withLine f = withTrail f (f . cutLoop) -- | Modify a @Trail@ by specifying a transformation on lines. If the @@ -741,25 +749,25 @@ withLine f = withTrail f (f . cutLoop) -- Note that there is no corresponding @onLoop@ function, because -- there is no nice way in general to convert a line into a loop, -- operate on it, and then convert back. -onLine :: (InnerSpace v, OrderedField (Scalar v)) - => (Trail' Line v -> Trail' Line v) -> Trail v -> Trail v +onLine :: (Metric v, OrderedField n) + => (Trail' Line v n -> Trail' Line v n) -> Trail v n -> Trail v n onLine f = onTrail f (glueLine . f . cutLoop) -- | Convert a 'Trail'' into a 'Trail', hiding the type-level -- distinction between lines and loops. -wrapTrail :: Trail' l v -> Trail v +wrapTrail :: Trail' l v n -> Trail v n wrapTrail = Trail -- | Convert a line into a 'Trail'. This is the same as 'wrapTrail', -- but with a more specific type, which can occasionally be -- convenient for fixing the type of a polymorphic expression. -wrapLine :: Trail' Line v -> Trail v +wrapLine :: Trail' Line v n -> Trail v n wrapLine = wrapTrail -- | Convert a loop into a 'Trail'. This is the same as 'wrapTrail', -- but with a more specific type, which can occasionally be -- convenient for fixing the type of a polymorphic expression. -wrapLoop :: Trail' Loop v -> Trail v +wrapLoop :: Trail' Loop v n -> Trail v n wrapLoop = wrapTrail ------------------------------------------------------------ @@ -767,22 +775,22 @@ wrapLoop = wrapTrail ------------------------------------------------------------ -- | The empty line, which is the identity for concatenation of lines. -emptyLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v +emptyLine :: (Metric v, OrderedField n) => Trail' Line v n emptyLine = Line mempty -- | A wrapped variant of 'emptyLine'. -emptyTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v +emptyTrail :: (Metric v, OrderedField n) => Trail v n emptyTrail = wrapLine emptyLine -- | Construct a line from a list of closed segments. -lineFromSegments :: (InnerSpace v, OrderedField (Scalar v)) - => [Segment Closed v] -> Trail' Line v +lineFromSegments :: (Metric v, OrderedField n) + => [Segment Closed v n] -> Trail' Line v n lineFromSegments = Line . SegTree . FT.fromList -- | @trailFromSegments === 'wrapTrail' . 'lineFromSegments'@, for -- conveniently constructing a @Trail@ instead of a @Trail'@. -trailFromSegments :: (InnerSpace v, OrderedField (Scalar v)) - => [Segment Closed v] -> Trail v +trailFromSegments :: (Metric v, OrderedField n) + => [Segment Closed v n] -> Trail v n trailFromSegments = wrapTrail . lineFromSegments -- | Construct a line containing only linear segments from a list of @@ -793,14 +801,14 @@ trailFromSegments = wrapTrail . lineFromSegments -- -- > import Diagrams.Coordinates -- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 ^& 1, 2 ^& (-1), 2 ^& 0.5 ] -lineFromOffsets :: (InnerSpace v, OrderedField (Scalar v)) - => [v] -> Trail' Line v +lineFromOffsets :: (Metric v, OrderedField n) + => [v n] -> Trail' Line v n lineFromOffsets = lineFromSegments . map straight -- | @trailFromOffsets === 'wrapTrail' . 'lineFromOffsets'@, for -- conveniently constructing a @Trail@ instead of a @Trail' Line@. -trailFromOffsets :: (InnerSpace v, OrderedField (Scalar v)) - => [v] -> Trail v +trailFromOffsets :: (Metric v, OrderedField n) + => [v n] -> Trail v n trailFromOffsets = wrapTrail . lineFromOffsets -- | Construct a line containing only linear segments from a list of @@ -822,8 +830,8 @@ trailFromOffsets = wrapTrail . lineFromOffsets -- > import Diagrams.Coordinates -- > lineFromVerticesEx = pad 1.1 . centerXY . strokeLine -- > $ lineFromVertices [origin, 0 ^& 1, 1 ^& 2, 5 ^& 1] -lineFromVertices :: (InnerSpace v, OrderedField (Scalar v)) - => [Point v] -> Trail' Line v +lineFromVertices :: (Metric v, OrderedField n) + => [Point v n] -> Trail' Line v n lineFromVertices [] = emptyLine lineFromVertices [_] = emptyLine lineFromVertices ps = lineFromSegments . map straight $ zipWith (.-.) (tail ps) ps @@ -831,8 +839,8 @@ lineFromVertices ps = lineFromSegments . map straight $ zipWith (.-.) (tail ps) -- | @trailFromVertices === 'wrapTrail' . 'lineFromVertices'@, for -- conveniently constructing a @Trail@ instead of a @Trail' Line@. -trailFromVertices :: (InnerSpace v, OrderedField (Scalar v)) - => [Point v] -> Trail v +trailFromVertices :: (Metric v, OrderedField n) + => [Point v n] -> Trail v n trailFromVertices = wrapTrail . lineFromVertices ------------------------------------------------------------ @@ -859,7 +867,7 @@ trailFromVertices = wrapTrail . lineFromVertices -- @ -- glueLine . cutLoop === id -- @ -glueLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Trail' Loop v +glueLine :: (Metric v, OrderedField n) => Trail' Line v n -> Trail' Loop v n glueLine (Line (SegTree t)) = case FT.viewr t of FT.EmptyR -> Loop mempty (Linear OffsetOpen) @@ -868,7 +876,7 @@ glueLine (Line (SegTree t)) = -- | @glueTrail@ is a variant of 'glueLine' which works on 'Trail's. -- It performs 'glueLine' on lines and is the identity on loops. -glueTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v +glueTrail :: (Metric v, OrderedField n) => Trail v n -> Trail v n glueTrail = onTrail glueLine id -- | Make a line into a loop by adding a new linear segment from the @@ -894,12 +902,12 @@ glueTrail = onTrail glueLine id -- -- > closeLineEx = pad 1.1 . centerXY . hcat' (with & sep .~ 1) -- > $ [almostClosed # strokeLine, almostClosed # closeLine # strokeLoop] -closeLine :: Trail' Line v -> Trail' Loop v +closeLine :: Trail' Line v n -> Trail' Loop v n closeLine (Line t) = Loop t (Linear OffsetOpen) -- | @closeTrail@ is a variant of 'closeLine' for 'Trail', which -- performs 'closeLine' on lines and is the identity on loops. -closeTrail :: Trail v -> Trail v +closeTrail :: Trail v n -> Trail v n closeTrail = onTrail closeLine id -- | Turn a loop into a line by \"cutting\" it at the common start/end @@ -911,8 +919,8 @@ closeTrail = onTrail closeLine id -- @ -- glueLine . cutLoop === id -- @ -cutLoop :: forall v. (InnerSpace v, OrderedField (Scalar v)) - => Trail' Loop v -> Trail' Line v +cutLoop :: forall v n. (Metric v, OrderedField n) + => Trail' Loop v n -> Trail' Line v n cutLoop (Loop (SegTree t) c) = case (FT.null t, c) of (True, Linear OffsetOpen) -> emptyLine @@ -920,13 +928,13 @@ cutLoop (Loop (SegTree t) c) = (_ , Cubic c1 c2 OffsetOpen) -> Line (SegTree (t |> Cubic c1 c2 off)) where offV :: v - offV = negateV . trailMeasure zeroV (op TotalOffset .view oeOffset) $ t + offV = negated . trailMeasure zero (op TotalOffset .view oeOffset) $ t off = OffsetClosed offV -- | @cutTrail@ is a variant of 'cutLoop' for 'Trail'; it is the is -- the identity on lines and performs 'cutLoop' on loops. -cutTrail :: (InnerSpace v, OrderedField (Scalar v)) - => Trail v -> Trail v +cutTrail :: (Metric v, OrderedField n) + => Trail v n -> Trail v n cutTrail = onTrail id cutLoop ------------------------------------------------------------ @@ -934,45 +942,45 @@ cutTrail = onTrail id cutLoop ------------------------------------------------------------ -- | Test whether a line is empty. -isLineEmpty :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Bool +isLineEmpty :: (Metric v, OrderedField n) => Trail' Line v n -> Bool isLineEmpty (Line (SegTree t)) = FT.null t -- | Test whether a trail is empty. Note that loops are never empty. -isTrailEmpty :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Bool +isTrailEmpty :: (Metric v, OrderedField n) => Trail v n -> Bool isTrailEmpty = withTrail isLineEmpty (const False) -- | Determine whether a trail is a line. -isLine :: Trail v -> Bool +isLine :: Trail v n -> Bool isLine = not . isLoop -- | Determine whether a trail is a loop. -isLoop :: Trail v -> Bool +isLoop :: Trail v n -> Bool isLoop = withTrail (const False) (const True) -- | Extract the segments comprising a line. -lineSegments :: Trail' Line v -> [Segment Closed v] +lineSegments :: Trail' Line v n -> [Segment Closed v n] lineSegments (Line (SegTree t)) = F.toList t -- | Modify a line by applying a function to its list of segments. onLineSegments - :: (InnerSpace v, OrderedField (Scalar v)) - => ([Segment Closed v] -> [Segment Closed v]) - -> Trail' Line v -> Trail' Line v + :: (Metric v, OrderedField n) + => ([Segment Closed v n] -> [Segment Closed v n]) + -> Trail' Line v n -> Trail' Line v n onLineSegments f = lineFromSegments . f . lineSegments -- | Extract the segments comprising a loop: a list of closed -- segments, and one final open segment. -loopSegments :: Trail' Loop v -> ([Segment Closed v], Segment Open v) +loopSegments :: Trail' Loop v n -> ([Segment Closed v n], Segment Open v n) loopSegments (Loop (SegTree t) c) = (F.toList t, c) -- | Extract the segments of a trail. If the trail is a loop it will -- first have 'cutLoop' applied. -trailSegments :: (InnerSpace v, OrderedField (Scalar v)) - => Trail v -> [Segment Closed v] +trailSegments :: (Metric v, OrderedField n) + => Trail v n -> [Segment Closed v n] trailSegments = withLine lineSegments -- | Extract the offsets of the segments of a trail. -trailOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> [v] +trailOffsets :: (Metric v, OrderedField n) => Trail v n -> [v n] trailOffsets = withLine lineOffsets -- | Compute the offset from the start of a trail to the end. Satisfies @@ -988,22 +996,22 @@ trailOffsets = withLine lineOffsets -- > trailOffsetEx = (strokeLine almostClosed <> showOffset) # centerXY # pad 1.1 -- > where showOffset = fromOffsets [trailOffset (wrapLine almostClosed)] -- > # stroke # lc red -trailOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> v +trailOffset :: (Metric v, OrderedField n) => Trail v n -> v n trailOffset = withLine lineOffset -- | Extract the offsets of the segments of a line. -lineOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> [v] +lineOffsets :: (Metric v, OrderedField n) => Trail' Line v n -> [v n] lineOffsets = map segOffset . lineSegments -- | Extract the offsets of the segments of a loop. -loopOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Loop v -> [v] +loopOffsets :: (Metric v, OrderedField n) => Trail' Loop v n -> [v n] loopOffsets = lineOffsets . cutLoop -- | Compute the offset from the start of a line to the end. (Note, -- there is no corresponding @loopOffset@ function because by -- definition it would be constantly zero.) -lineOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> v -lineOffset (Line t) = trailMeasure zeroV (op TotalOffset . view oeOffset) t +lineOffset :: (Metric v, OrderedField n) => Trail' Line v n -> v n +lineOffset (Line t) = trailMeasure zero (op TotalOffset . view oeOffset) t -- | Extract the points of a concretely located trail. That is the points -- where one segment ends and the next begings. Note that @@ -1017,27 +1025,27 @@ lineOffset (Line t) = trailMeasure zeroV (op TotalOffset . view oeOffset) t -- 'Trail' by itself; if you want the points of a trail -- with the first point at, say, the origin, you can use -- @trailPoints . (\`at\` origin)@. -trailPoints :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail v) -> [Point v] +trailPoints :: (Metric v, OrderedField n) + => Located (Trail v n) -> [Point v n] trailPoints (viewLoc -> (p,t)) = withTrail (linePoints . (`at` p)) (loopPoints . (`at` p)) t -- | Extract the vertices of a concretely located line. See -- 'trailPoints' for more information. -linePoints :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail' Line v) -> [Point v] +linePoints :: (Metric v, OrderedField n) + => Located (Trail' Line v n) -> [Point v n] linePoints (viewLoc -> (p,t)) = segmentPoints p . lineSegments $ t -- | Extract the vertices of a concretely located loop. Note that the -- initial vertex is not repeated at the end. See 'trailPoints' for -- more information. -loopPoints :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail' Loop v) -> [Point v] +loopPoints :: (Metric v, OrderedField n) + => Located (Trail' Loop v n) -> [Point v n] loopPoints (viewLoc -> (p,t)) = segmentPoints p . fst . loopSegments $ t -segmentPoints :: AdditiveGroup v => Point v -> [Segment Closed v] -> [Point v] +segmentPoints :: Additive v => Point v n -> [Segment Closed v n] -> [Point v n] segmentPoints p = scanl (.+^) p . map segOffset tolerance :: OrderedField a => a @@ -1054,45 +1062,45 @@ tolerance = 10e-16 -- 'Trail' by itself; if you want the vertices of a trail -- with the first vertex at, say, the origin, you can use -- @trailVertices . (\`at\` origin)@. -trailVertices' :: (InnerSpace v, OrderedField (Scalar v)) - => Scalar v -> Located (Trail v) -> [Point v] +trailVertices' :: (Metric v, OrderedField n) + => n -> Located (Trail v n) -> [Point v n] trailVertices' toler (viewLoc -> (p,t)) = withTrail (lineVertices' toler . (`at` p)) (loopVertices' toler . (`at` p)) t -- : Like trailVertices' but the tolerance is set to tolerance -trailVertices :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail v) -> [Point v] +trailVertices :: (Metric v, OrderedField n) + => Located (Trail v n) -> [Point v n] trailVertices l = trailVertices' tolerance l -- | Extract the vertices of a concretely located line. See -- 'trailVertices' for more information. -lineVertices' :: (InnerSpace v, OrderedField (Scalar v)) - => Scalar v -> Located (Trail' Line v) -> [Point v] +lineVertices' :: (Metric v, OrderedField n) + => n -> Located (Trail' Line v n) -> [Point v n] lineVertices' toler (viewLoc -> (p,t)) = segmentVertices' toler p . lineSegments $ t -- | Like lineVertices' with tolerance set to tolerance. -lineVertices :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail' Line v) -> [Point v] +lineVertices :: (Metric v, OrderedField n) + => Located (Trail' Line v n) -> [Point v n] lineVertices l = lineVertices' tolerance l -- | Extract the vertices of a concretely located loop. Note that the -- initial vertex is not repeated at the end. See 'trailVertices' for -- more information. -loopVertices' :: (InnerSpace v, OrderedField (Scalar v)) - => Scalar v -> Located (Trail' Loop v) -> [Point v] +loopVertices' :: (Metric v, OrderedField n) + => n -> Located (Trail' Loop v n) -> [Point v n] loopVertices' toler (viewLoc -> (p,t)) - | length segs > 1 = if far > toler then init ps else init . (drop 1) $ ps + | length segs > 1 = if far > toler then init ps else init . drop 1 $ ps | otherwise = ps where - far = magnitudeSq ((normalized . tangentAtStart . head $ segs) ^-^ - (normalized . tangentAtEnd . last $ segs)) + far = quadrance ((normalize . tangentAtStart . head $ segs) ^-^ + (normalize . tangentAtEnd . last $ segs)) segs = lineSegments . cutLoop $ t ps = segmentVertices' toler p segs -- | Same as loopVertices' with tolerance set to tolerance. -loopVertices :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail' Loop v) -> [Point v] +loopVertices :: (Metric v, OrderedField n) + => Located (Trail' Loop v n) -> [Point v n] loopVertices l = loopVertices' tolerance l -- The vertices of a list of segments laid end to end. @@ -1101,30 +1109,30 @@ loopVertices l = loopVertices' tolerance l -- end of a segment is not equal to the slope at the beginning of the next. -- The 'toler' parameter is used to control how close the slopes need to -- be in order to declatre them equal. -segmentVertices' :: (InnerSpace v, OrderedField (Scalar v)) - => Scalar v -> Point v -> [Segment Closed v] -> [Point v] +segmentVertices' :: (Metric v, OrderedField n) + => n -> Point v -> [Segment Closed v n] -> [Point v n] segmentVertices' toler p ts = case ps of (x:_:_) -> x : select (drop 1 ps) ds ++ [last ps] _ -> ps where ds = zipWith far tans (drop 1 tans) - tans = [(normalized . tangentAtStart $ s - ,normalized . tangentAtEnd $ s) | s <- ts] + tans = [(normalize . tangentAtStart $ s + ,normalize . tangentAtEnd $ s) | s <- ts] ps = scanl (.+^) p . map segOffset $ ts - far p2 q2 = magnitudeSq ((snd p2) ^-^ (fst q2)) > toler + far p2 q2 = quadrance ((snd p2) ^-^ (fst q2)) > toler select :: [a] -> [Bool] -> [a] select xs bs = map fst $ filter snd (zip xs bs) -- | Convert a concretely located trail into a list of fixed segments. -fixTrail :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail v) -> [FixedSegment v] +fixTrail :: (Metric v, OrderedField n) + => Located (Trail v n) -> [FixedSegment v n] fixTrail t = map mkFixedSeg (trailLocSegments t) -- | Convert a concretely located trail into a list of located segments. -trailLocSegments :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail v) -> [Located (Segment Closed v)] +trailLocSegments :: (Metric v, OrderedField n) + => Located (Trail v n) -> [Located (Segment Closed v n)] trailLocSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints t) ------------------------------------------------------------ @@ -1138,7 +1146,7 @@ trailLocSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints t) -- @ -- reverseTrail . reverseTrail === id -- @ -reverseTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v +reverseTrail :: (Metric v, OrderedField n) => Trail v n -> Trail v n reverseTrail = onTrail reverseLine reverseLoop -- | Reverse a concretely located trail. The endpoint of the original @@ -1149,27 +1157,27 @@ reverseTrail = onTrail reverseLine reverseLoop -- @ -- reverseLocTrail . reverseLocTrail === id -- @ -reverseLocTrail :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail v) -> Located (Trail v) +reverseLocTrail :: (Metric v, OrderedField n) + => Located (Trail v n) -> Located (Trail v n) reverseLocTrail (viewLoc -> (p, t)) = reverseTrail t `at` (p .+^ trailOffset t) -- | Reverse a line. See 'reverseTrail'. -reverseLine :: (InnerSpace v, OrderedField (Scalar v)) - => Trail' Line v -> Trail' Line v +reverseLine :: (Metric v, OrderedField n) + => Trail' Line v n -> Trail' Line v n reverseLine = onLineSegments (reverse . map reverseSegment) -- | Reverse a concretely located line. See 'reverseLocTrail'. -reverseLocLine :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail' Line v) -> Located (Trail' Line v) +reverseLocLine :: (Metric v, OrderedField n) + => Located (Trail' Line v n) -> Located (Trail' Line v n) reverseLocLine (viewLoc -> (p,l)) = reverseLine l `at` (p .+^ lineOffset l) -- | Reverse a loop. See 'reverseTrail'. -reverseLoop :: (InnerSpace v, OrderedField (Scalar v)) - => Trail' Loop v -> Trail' Loop v +reverseLoop :: (Metric v, OrderedField n) + => Trail' Loop v n -> Trail' Loop v n reverseLoop = glueLine . reverseLine . cutLoop -- | Reverse a concretely located loop. See 'reverseLocTrail'. Note -- that this is guaranteed to preserve the location. -reverseLocLoop :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail' Loop v) -> Located (Trail' Loop v) +reverseLocLoop :: (Metric v, OrderedField n) + => Located (Trail' Loop v n) -> Located (Trail' Loop v n) reverseLocLoop = mapLoc reverseLoop From 4b8469ab9b1de7a1c35ad2d80e8ae20509ea9766 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 18 Aug 2014 23:17:35 +0100 Subject: [PATCH 18/58] More progress. --- src/Diagrams/Parametric.hs | 2 +- src/Diagrams/Trail.hs | 120 +++++++++++++++++++------------------ src/Diagrams/TrailLike.hs | 4 +- 3 files changed, 65 insertions(+), 61 deletions(-) diff --git a/src/Diagrams/Parametric.hs b/src/Diagrams/Parametric.hs index 70fd1b3a..f2d26f7a 100644 --- a/src/Diagrams/Parametric.hs +++ b/src/Diagrams/Parametric.hs @@ -27,7 +27,7 @@ import qualified Numeric.Interval.Kaucher as I -- | Codomain of parametric classes. This is usually either @(V p)@, for relative -- vector results, or @(Point (V p))@, for functions with absolute coordinates. -type family Codomain p :: * -> * +type family Codomain p n :: * -- | Type class for parametric functions. class Parametric p where diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index fc37cedf..42665fc2 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -107,13 +105,13 @@ module Diagrams.Trail import Control.Arrow ((***)) import Control.Lens (AnIso', Rewrapped, Wrapped (..), cloneIso, iso, op, view, (^.)) -import Data.AffineSpace +-- import Data.AffineSpace import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), (|>)) import qualified Data.FingerTree as FT import qualified Data.Foldable as F import Data.Monoid.MList import Data.Semigroup --- import Data.VectorSpace hiding (Sum (..)) +-- import Data.Additive hiding (Sum (..)) import qualified Numeric.Interval.Kaucher as I import Diagrams.Core hiding ((|>)) @@ -123,8 +121,10 @@ import Diagrams.Parametric import Diagrams.Segment import Diagrams.Tangent +import Linear.Affine import Linear.Vector import Linear.Metric +import Linear.Epsilon -- $internals -- @@ -139,7 +139,7 @@ import Linear.Metric type instance V (FingerTree m a) = V a type instance N (FingerTree m a) = N a -instance ( Metric (V a), OrderedField (Scalar (V a)) +instance ( Metric (V a), OrderedField (N a) , FT.Measured m a, Transformable a ) => Transformable (FingerTree m a) where @@ -186,7 +186,7 @@ instance Num n => DomainBounds (SegTree v n) instance (Metric v, OrderedField n, RealFrac n, Num n) => EndValues (SegTree v n) -instance (Metric v, RealFrac n, Floating n) +instance (Metric v, RealFrac n, Floating n, Epsilon n) => Sectionable (SegTree v n) where splitAtParam (SegTree t) p | p < 0 = case FT.viewl t of @@ -230,7 +230,7 @@ instance (Metric v, OrderedField n, RealFrac n) | otherwise = fun (eps / numSegs t) where i = trailMeasure (I.singleton 0) - (getArcLengthCached :: ArcLength v -> I.Interval n) + (getArcLengthCached :: ArcLength (v n) -> I.Interval n) t fun = trailMeasure (const 0) (getArcLengthFun :: ArcLength v -> n -> I.Interval n) @@ -255,8 +255,13 @@ instance (Metric v, OrderedField n, RealFrac n) where totalAL = arcLength eps st tSegs = numSegs t - before, after :: FingerTree (SegMeasure v) (Segment Closed v) - (before, after) = FT.split ((>= l) . trailMeasure 0 (I.midpoint . (getArcLengthBounded eps :: ArcLength v -> I.Interval n))) t + before, after :: FingerTree (SegMeasure v n) (Segment Closed v n) + (before, after) = + FT.split ((>= l) + . trailMeasure + 0 + (I.midpoint . (getArcLengthBounded eps :: ArcLength (v n) -> I.Interval n))) + t -- | Given a default result (to be used in the case of an empty -- trail), and a function to map a single measure to a result, @@ -264,7 +269,7 @@ instance (Metric v, OrderedField n, RealFrac n) -- result. Put another way, lift a function on a single measure -- (along with a default value) to a function on an entire trail. trailMeasure :: ( Metric v, OrderedField n - , SegMeasure v :>: m, FT.Measured (SegMeasure v n) t + , SegMeasure v n :>: m, FT.Measured (SegMeasure v n) t ) => a -> (m -> a) -> t -> a trailMeasure d f = option d f . get . FT.measure @@ -272,17 +277,17 @@ trailMeasure d f = option d f . get . FT.measure -- | Compute the number of segments of anything measured by -- 'SegMeasure' (/e.g./ @SegMeasure@ itself, @Segment@, @SegTree@, -- @Trail@s...) -numSegs :: ( Floating n, Num c, Ord n, Metric v, +numSegs :: ( OrderedField n, Num c, Metric v, FT.Measured (SegMeasure v n) a ) => a -> c numSegs = fromIntegral . trailMeasure 0 (getSum . op SegCount) -- | Compute the total offset of anything measured by 'SegMeasure'. -offset :: ( Floating n, Ord n, Metric v, +offset :: ( OrderedField n, Metric v, FT.Measured (SegMeasure v n) t ) - => t -> v + => t -> v n offset = trailMeasure zero (op TotalOffset . view oeOffset) ------------------------------------------------------------ @@ -351,9 +356,9 @@ data Loop -- To extract information from trails, see 'withLine', 'isLoop', -- 'trailSegments', 'trailOffsets', 'trailVertices', and friends. -data Trail' l v where - Line :: SegTree v -> Trail' Line v - Loop :: SegTree v -> Segment Open v -> Trail' Loop v +data Trail' l v n where + Line :: SegTree v n -> Trail' Line v n + Loop :: SegTree v n -> Segment Open v n -> Trail' Loop v n -- | A generic eliminator for 'Trail'', taking functions specifying -- what to do in the case of a line or a loop. @@ -361,13 +366,14 @@ withTrail' :: (Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail' l v n - withTrail' line _ t@(Line{}) = line t withTrail' _ loop t@(Loop{}) = loop t -deriving instance Show (v n) => Show (Trail' l v) -deriving instance Eq (v n) => Eq (Trail' l v) -deriving instance Ord (v n) => Ord (Trail' l v) +deriving instance Show (v n) => Show (Trail' l v n) +deriving instance Eq (v n) => Eq (Trail' l v n) +deriving instance Ord (v n) => Ord (Trail' l v n) -type instance V (Trail' l v) = v +type instance V (Trail' l v n) = v +type instance N (Trail' l v n) = n -type instance Codomain (Trail' l v) = v +type instance Codomain (Trail' l v n) = v instance (OrderedField n, Metric v) => Semigroup (Trail' Line v n) where (Line t1) <> (Line t2) = Line (t1 `mappend` t2) @@ -375,7 +381,7 @@ instance (OrderedField n, Metric v) => Semigroup (Trail' Line v n) where -- | The empty trail is constantly the zero vector. Trails are -- composed via concatenation. Note that only lines have a monoid -- instance (and not loops). -instance (OrderedField n, Metric v) => Monoid (Trail' Line v) where +instance (OrderedField n, Metric v) => Monoid (Trail' Line v n) where mempty = emptyLine mappend = (<>) @@ -388,8 +394,8 @@ instance (HasLinearMap v, Metric v, OrderedField n) instance (Metric v, OrderedField n) => Enveloped (Trail' l v n) where getEnvelope = withTrail' ftEnv (ftEnv . cutLoop) where - ftEnv :: Trail' Line v -> Envelope v - ftEnv (Line t) = trailMeasure mempty (view oeEnvelope) $ t + ftEnv :: Trail' Line v n -> Envelope v n + ftEnv (Line t) = trailMeasure mempty (view oeEnvelope) t instance (HasLinearMap v, Metric v, OrderedField n) => Renderable (Trail' o v n) NullBackend where @@ -405,7 +411,7 @@ instance (Metric v, OrderedField n, RealFrac n) type instance Codomain (Tangent (Trail' c v n)) = Codomain (Trail' c v n) instance ( Parametric (GetSegment (Trail' c v n)) - , VectorSpace v + , Additive v , Num n ) => Parametric (Tangent (Trail' c v n)) where @@ -416,7 +422,7 @@ instance ( Parametric (GetSegment (Trail' c v n)) instance ( Parametric (GetSegment (Trail' c v n)) , EndValues (GetSegment (Trail' c v n)) - , VectorSpace v + , Additive v , Num n ) => EndValues (Tangent (Trail' c v n)) where @@ -442,10 +448,7 @@ instance ( Metric v ((`atParam` p) . Tangent) tr -instance ( Metric v - , OrderedField n - , RealFrac n - ) +instance (Metric v, OrderedField n, RealFrac n) => EndValues (Tangent (Trail v n)) where atStart (Tangent tr) = withTrail (atStart . Tangent) (atStart . Tangent) tr atEnd (Tangent tr) = withTrail (atEnd . Tangent) (atEnd . Tangent) tr @@ -466,9 +469,9 @@ propFrac = properFraction instance Num n => DomainBounds (Trail' l v n) instance (Metric v, OrderedField n, RealFrac n) - => EndValues (Trail' l v) + => EndValues (Trail' l v n) -instance (Metric v, RealFrac n, Floating n) +instance (Metric v, RealFrac n, Floating n, Epsilon n) => Sectionable (Trail' Line v n) where splitAtParam (Line t) p = (Line t1, Line t2) where @@ -533,11 +536,12 @@ getSegment = GetSegment type instance V (GetSegment t) = V t type instance N (GetSegment t) = N t -type instance Codomain (GetSegment t) +type instance Codomain (GetSegment t) (N t) + -- = V t = Maybe - ( V t -- offset from trail start to segment start - , Segment Closed (V t) -- the segment - , AnIso' (N t) (N t) -- reparameterization, trail <-> segment + ( V t (N t) -- offset from trail start to segment start + , Segment Closed (V t) (N t) -- the segment + , AnIso' (N t) (N t) -- reparameterization, trail <-> segment ) -- | Parameters less than 0 yield the first segment; parameters @@ -545,7 +549,7 @@ type instance Codomain (GetSegment t) -- junction of two segments yields the second segment (/i.e./ the -- one with higher parameter values). instance (Metric v, OrderedField n) - => Parametric (GetSegment (Trail' Line v)) where + => Parametric (GetSegment (Trail' Line v n)) where atParam (GetSegment (Line (SegTree ft))) p | p <= 0 = case FT.viewl ft of @@ -586,7 +590,7 @@ instance DomainBounds t => DomainBounds (GetSegment t) where domainUpper (GetSegment t) = domainUpper t instance (Metric v, OrderedField n) - => EndValues (GetSegment (Trail' Line v)) where + => EndValues (GetSegment (Trail' Line v n)) where atStart (GetSegment (Line (SegTree ft))) = case FT.viewl ft of EmptyL -> Nothing @@ -612,13 +616,13 @@ instance (Metric v, OrderedField n, RealFrac n) => EndValues (GetSegment (Trail v n)) where atStart (GetSegment t) = withTrail - (\l -> atStart (GetSegment l)) - (\l -> atStart (GetSegment l)) + (atStart . GetSegment) + (atStart . GetSegment) t atEnd (GetSegment t) = withTrail - (\l -> atEnd (GetSegment l)) - (\l -> atEnd (GetSegment l)) + (atEnd . GetSegment) + (atEnd . GetSegment) t -------------------------------------------------- @@ -639,11 +643,11 @@ instance Eq (v n) => Eq (Trail v n) where (\lp1 -> withTrail (const False) (\lp2 -> lp1 == lp2) t2) t1 -instance Ord v => Ord (Trail v n) where +instance Ord (v n) => Ord (Trail v n) where compare t1 t2 = withTrail - (\ln1 -> withTrail (\ln2 -> compare ln1 ln2) (const LT) t2) - (\lp1 -> withTrail (const GT) (\lp2 -> compare lp1 lp2) t2) + (\ln1 -> withTrail (compare ln1) (const LT) t2) + (\lp1 -> withTrail (const GT) (compare lp1) t2) t1 -- | Two @Trail@s are combined by first ensuring they are both lines @@ -700,7 +704,7 @@ instance (Metric v, OrderedField n, RealFrac n) -- semantically a bit silly, so please don't rely on it. (*E.g.* if -- this is really the behavior you want, consider first calling -- 'cutLoop' yourself.) -instance (Metric v, RealFrac n, Floating n) +instance (Metric v, RealFrac n, Floating n, Epsilon n) => Sectionable (Trail v n) where splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t @@ -721,8 +725,8 @@ withTrail line loop (Trail t) = withTrail' line loop t -- | Modify a @Trail@, specifying two separate transformations for the -- cases of a line or a loop. -onTrail :: (Trail' Line v n -> Trail' l1 v) -> (Trail' Loop v n -> Trail' l2 v n) - -> (Trail v -> Trail v) +onTrail :: (Trail' Line v n -> Trail' l1 v n) -> (Trail' Loop v n -> Trail' l2 v n) + -> Trail v n -> Trail v n onTrail o c = withTrail (wrapTrail . o) (wrapTrail . c) -- | An eliminator for @Trail@ based on eliminating lines: if the @@ -870,9 +874,9 @@ trailFromVertices = wrapTrail . lineFromVertices glueLine :: (Metric v, OrderedField n) => Trail' Line v n -> Trail' Loop v n glueLine (Line (SegTree t)) = case FT.viewr t of - FT.EmptyR -> Loop mempty (Linear OffsetOpen) - t' :> (Linear _) -> Loop (SegTree t') (Linear OffsetOpen) - t' :> (Cubic c1 c2 _) -> Loop (SegTree t') (Cubic c1 c2 OffsetOpen) + FT.EmptyR -> Loop mempty (Linear OffsetOpen) + t' :> Linear _ -> Loop (SegTree t') (Linear OffsetOpen) + t' :> Cubic c1 c2 _ -> Loop (SegTree t') (Cubic c1 c2 OffsetOpen) -- | @glueTrail@ is a variant of 'glueLine' which works on 'Trail's. -- It performs 'glueLine' on lines and is the identity on loops. @@ -927,7 +931,7 @@ cutLoop (Loop (SegTree t) c) = (_ , Linear OffsetOpen) -> Line (SegTree (t |> Linear off)) (_ , Cubic c1 c2 OffsetOpen) -> Line (SegTree (t |> Cubic c1 c2 off)) where - offV :: v + offV :: v n offV = negated . trailMeasure zero (op TotalOffset .view oeOffset) $ t off = OffsetClosed offV @@ -1045,7 +1049,7 @@ loopPoints :: (Metric v, OrderedField n) loopPoints (viewLoc -> (p,t)) = segmentPoints p . fst . loopSegments $ t -segmentPoints :: Additive v => Point v n -> [Segment Closed v n] -> [Point v n] +segmentPoints :: (Additive v, Num n) => Point v n -> [Segment Closed v n] -> [Point v n] segmentPoints p = scanl (.+^) p . map segOffset tolerance :: OrderedField a => a @@ -1070,7 +1074,7 @@ trailVertices' toler (viewLoc -> (p,t)) -- : Like trailVertices' but the tolerance is set to tolerance trailVertices :: (Metric v, OrderedField n) => Located (Trail v n) -> [Point v n] -trailVertices l = trailVertices' tolerance l +trailVertices = trailVertices' tolerance -- | Extract the vertices of a concretely located line. See -- 'trailVertices' for more information. @@ -1082,7 +1086,7 @@ lineVertices' toler (viewLoc -> (p,t)) -- | Like lineVertices' with tolerance set to tolerance. lineVertices :: (Metric v, OrderedField n) => Located (Trail' Line v n) -> [Point v n] -lineVertices l = lineVertices' tolerance l +lineVertices = lineVertices' tolerance -- | Extract the vertices of a concretely located loop. Note that the -- initial vertex is not repeated at the end. See 'trailVertices' for @@ -1101,7 +1105,7 @@ loopVertices' toler (viewLoc -> (p,t)) -- | Same as loopVertices' with tolerance set to tolerance. loopVertices :: (Metric v, OrderedField n) => Located (Trail' Loop v n) -> [Point v n] -loopVertices l = loopVertices' tolerance l +loopVertices = loopVertices' tolerance -- The vertices of a list of segments laid end to end. -- The start and end points are always included in the list of vertices. @@ -1110,7 +1114,7 @@ loopVertices l = loopVertices' tolerance l -- The 'toler' parameter is used to control how close the slopes need to -- be in order to declatre them equal. segmentVertices' :: (Metric v, OrderedField n) - => n -> Point v -> [Segment Closed v n] -> [Point v n] + => n -> Point v n -> [Segment Closed v n] -> [Point v n] segmentVertices' toler p ts = case ps of (x:_:_) -> x : select (drop 1 ps) ds ++ [last ps] @@ -1120,7 +1124,7 @@ segmentVertices' toler p ts = tans = [(normalize . tangentAtStart $ s ,normalize . tangentAtEnd $ s) | s <- ts] ps = scanl (.+^) p . map segOffset $ ts - far p2 q2 = quadrance ((snd p2) ^-^ (fst q2)) > toler + far p2 q2 = quadrance (snd p2 ^-^ fst q2) > toler select :: [a] -> [Bool] -> [a] select xs bs = map fst $ filter snd (zip xs bs) diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs index e9fa26df..21610041 100644 --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -29,8 +29,8 @@ module Diagrams.TrailLike ) where import Control.Lens (view, _Unwrapped') -import Data.AffineSpace ((.-.)) -import Data.VectorSpace +-- import Data.AffineSpace ((.-.)) +-- import Data.VectorSpace import Diagrams.Core import Diagrams.Located From 48cbd1d57b8a3ae100a9ad50b5a75bfb457c6c97 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 18 Aug 2014 23:40:44 +0100 Subject: [PATCH 19/58] Bounding box. --- src/Diagrams/BoundingBox.hs | 272 +++++++++++++----------------------- 1 file changed, 95 insertions(+), 177 deletions(-) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index 9247a285..f83c876e 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.BoundingBox @@ -24,7 +24,7 @@ module Diagrams.BoundingBox ( -- * Bounding boxes - BoundingBox() + BoundingBox -- * Constructing bounding boxes , emptyBox, fromCorners, fromPoint, fromPoints @@ -33,7 +33,7 @@ module Diagrams.BoundingBox -- * Queries on bounding boxes , isEmptyBox , getCorners, getAllCorners - , boxExtents, boxTransform, boxFit + , boxExtents , boxTransform, boxFit , contains, contains' , inside, inside', outside, outside' @@ -41,290 +41,208 @@ module Diagrams.BoundingBox , union, intersection ) where -import Control.Applicative ((<$>)) -import qualified Data.Foldable as F -import Data.Map (Map, fromDistinctAscList, fromList, toAscList, toList) - -import Data.Maybe (fromMaybe) - -import Data.VectorSpace --- (VectorSpace, Scalar, AdditiveGroup, zeroV, negateV, (^+^), (^-^)) -import Data.Basis (Basis, HasBasis, basisValue, decompose, recompose) -import Data.Monoid (Monoid (..)) -import Data.Semigroup (Option (..), Semigroup (..)) +import Data.Data (Data, Typeable) +import Data.Foldable as F +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Option (..), Semigroup (..)) -import Data.Data (Data) -import Data.Typeable (Typeable) +import Diagrams.Core.Envelope +import Diagrams.Core.HasOrigin (HasOrigin (..)) +import Diagrams.Core.Transform +import Diagrams.Core.V -import Diagrams.Core.Envelope (Enveloped (..), appEnvelope) -import Diagrams.Core.HasOrigin (HasOrigin (..)) -import Diagrams.Core.Points (Point (..)) -import Diagrams.Core.Transform (HasLinearMap, Transformable (..), Transformation (..), - (<->)) -import Diagrams.Core.V (V) +import Control.Applicative +import Data.Traversable as T +import Linear.Affine +import Linear.Metric +import Linear.Vector -- Unexported utility newtype -newtype NonEmptyBoundingBox v = NonEmptyBoundingBox (Point v, Point v) - deriving (Eq, Data, Typeable) +newtype NonEmptyBoundingBox v n = NonEmptyBoundingBox (Point v n, Point v n) + deriving (Eq, Data, Typeable, Functor) -fromNonEmpty :: NonEmptyBoundingBox v -> BoundingBox v +type instance V (NonEmptyBoundingBox v n) = v +type instance N (NonEmptyBoundingBox v n) = n + +fromNonEmpty :: NonEmptyBoundingBox v n -> BoundingBox v n fromNonEmpty = BoundingBox . Option . Just -fromMaybeEmpty :: Maybe (NonEmptyBoundingBox v) -> BoundingBox v +fromMaybeEmpty :: Maybe (NonEmptyBoundingBox v n) -> BoundingBox v n fromMaybeEmpty = maybe emptyBox fromNonEmpty -nonEmptyCorners :: NonEmptyBoundingBox v -> (Point v, Point v) +nonEmptyCorners :: NonEmptyBoundingBox v n -> (Point v n, Point v n) nonEmptyCorners (NonEmptyBoundingBox x) = x -instance (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => Semigroup (NonEmptyBoundingBox v) where +instance (Additive v, Ord n) => Semigroup (NonEmptyBoundingBox v n) where (NonEmptyBoundingBox (ul, uh)) <> (NonEmptyBoundingBox (vl, vh)) - = NonEmptyBoundingBox - $ mapT toPoint (combineP min ul vl, combineP max uh vh) - + = NonEmptyBoundingBox (liftU2 min ul vl, liftU2 max uh vh) -- | A bounding box is an axis-aligned region determined by two points -- indicating its \"lower\" and \"upper\" corners. It can also represent -- an empty bounding box - the points are wrapped in @Maybe@. -newtype BoundingBox v = BoundingBox (Option (NonEmptyBoundingBox v)) - deriving (Eq, Data, Typeable) +newtype BoundingBox v n = BoundingBox (Option (NonEmptyBoundingBox v n)) + deriving (Eq, Data, Typeable, Functor) -deriving instance - ( HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v) - ) => Semigroup (BoundingBox v) -deriving instance - ( HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v) - ) => Monoid (BoundingBox v) +deriving instance (Additive v, Ord n) => Semigroup (BoundingBox v n) +deriving instance (Additive v, Ord n) => Monoid (BoundingBox v n) -type instance V (BoundingBox v) = v +type instance V (BoundingBox v n) = v +type instance N (BoundingBox v n) = n -- Map a function on a homogenous 2-tuple. (unexported utility) mapT :: (a -> b) -> (a, a) -> (b, b) mapT f (x, y) = (f x, f y) +{-# NOINLINE mapT #-} -instance ( VectorSpace v, HasBasis v, Ord (Basis v) - , AdditiveGroup (Scalar v), Ord (Scalar v) - ) => HasOrigin (BoundingBox v) where +instance (Additive v, Num n, Ord n) => HasOrigin (BoundingBox v n) where moveOriginTo p b = fromMaybeEmpty - ( NonEmptyBoundingBox . mapT (moveOriginTo p) <$> getCorners b ) + (NonEmptyBoundingBox . mapT (moveOriginTo p) <$> getCorners b) -instance ( InnerSpace v, HasBasis v, Ord (Basis v) - , AdditiveGroup (Scalar v), Ord (Scalar v), Floating (Scalar v) - ) => Enveloped (BoundingBox v) where +instance (Metric v, Traversable v, OrderedField n) + => Enveloped (BoundingBox v n) where getEnvelope = getEnvelope . getAllCorners -instance Show v => Show (BoundingBox v) where +instance Show (v n) => Show (BoundingBox v n) where show = maybe "emptyBox" (\(l, u) -> "fromCorners " ++ show l ++ " " ++ show u) . getCorners -{- TODO -instance Read v => Read (BoundingBox v) where - read "emptyBox" = emptyBox --} - -- | An empty bounding box. This is the same thing as @mempty@, but it doesn't -- require the same type constraints that the @Monoid@ instance does. -emptyBox :: BoundingBox v +emptyBox :: BoundingBox v n emptyBox = BoundingBox $ Option Nothing -- | Create a bounding box from a point that is component-wise @(<=)@ than the -- other. If this is not the case, then @mempty@ is returned. fromCorners - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => Point v -> Point v -> BoundingBox v + :: (Additive v, Foldable v, Ord n) + => Point v n -> Point v n -> BoundingBox v n fromCorners l h - | F.and (combineP (<=) l h) = fromNonEmpty $ NonEmptyBoundingBox (l, h) - | otherwise = mempty + | F.and (liftI2 (<=) l h) = fromNonEmpty $ NonEmptyBoundingBox (l, h) + | otherwise = mempty -- | Create a degenerate bounding \"box\" containing only a single point. -fromPoint - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => Point v -> BoundingBox v +fromPoint :: Point v n -> BoundingBox v n fromPoint p = fromNonEmpty $ NonEmptyBoundingBox (p, p) -- | Create the smallest bounding box containing all the given points. -fromPoints - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => [Point v] -> BoundingBox v +fromPoints :: (Additive v, Ord n) => [Point v n] -> BoundingBox v n fromPoints = mconcat . map fromPoint -- | Create a bounding box for any enveloped object (such as a diagram or path). -boundingBox :: forall a. ( Enveloped a, HasBasis (V a), AdditiveGroup (V a) - , Ord (Basis (V a)) - ) => a -> BoundingBox (V a) +boundingBox :: (VN a ~ v n, Enveloped a, HasLinearMap v, Num n) + => a -> BoundingBox v n boundingBox a = fromMaybeEmpty $ do - env <- appEnvelope $ getEnvelope a - let h = recompose $ map (\v -> (v, env $ basisValue v)) us - l = recompose $ map (\v -> (v, negate . env . negateV $ basisValue v)) us - return $ NonEmptyBoundingBox (P l, P h) - where - -- The units. Might not work if 0-components aren't reported. - --TODO: Depend on Enum Basis? - us = map fst $ decompose (zeroV :: V a) + env <- (appEnvelope . getEnvelope) a + let h = fmap env eye + l = negated $ fmap (env . negated) eye + return $ NonEmptyBoundingBox (P l, P h) -- | Queries whether the BoundingBox is empty. -isEmptyBox :: BoundingBox v -> Bool +isEmptyBox :: BoundingBox v n -> Bool isEmptyBox (BoundingBox (Option Nothing)) = True -isEmptyBox _ = False +isEmptyBox _ = False -- | Gets the lower and upper corners that define the bounding box. -getCorners :: BoundingBox v -> Maybe (Point v, Point v) +getCorners :: BoundingBox v n -> Maybe (Point v n, Point v n) getCorners (BoundingBox p) = nonEmptyCorners <$> getOption p - --- | Computes all of the corners of the bounding box. -getAllCorners :: (HasBasis v, AdditiveGroup (Scalar v), Ord (Basis v)) - => BoundingBox v -> [Point v] +-- +-- -- | Computes all of the corners of the bounding box. +getAllCorners :: (Additive v, Traversable v, Num n) => BoundingBox v n -> [Point v n] getAllCorners (BoundingBox (Option Nothing)) = [] getAllCorners (BoundingBox (Option (Just (NonEmptyBoundingBox (l, u))))) - = map (P . recompose) - -- Enumerate all combinations of selections of lower / higher values. - . mapM (\(b, (l', u')) -> [(b, l'), (b, u')]) - -- List of [(basis, (lower, upper))] - . toList - $ combineP (,) l u + = T.sequence (liftI2 (\a b -> [a,b]) l u) -- | Get the size of the bounding box - the vector from the (component-wise) -- lesser point to the greater point. -boxExtents :: (AdditiveGroup v) => BoundingBox v -> v -boxExtents = maybe zeroV (\(P l, P h) -> h ^-^ l) . getCorners +boxExtents :: (Additive v, Num n) => BoundingBox v n -> v n +boxExtents = maybe zero (uncurry (.-.)) . getCorners -- | Create a transformation mapping points from one bounding box to the other. -boxTransform :: (AdditiveGroup v, HasLinearMap v, - Fractional (Scalar v), AdditiveGroup (Scalar v), Ord (Basis v)) - => BoundingBox v -> BoundingBox v -> Maybe (Transformation v) +boxTransform + :: (Additive v, Fractional n) + => BoundingBox v n -> BoundingBox v n -> Maybe (Transformation v n) boxTransform u v = do - ((P ul), _) <- getCorners u - ((P vl), _) <- getCorners v - let lin_map = box_scale (v, u) <-> box_scale (u, v) - box_scale = combineV' (*) . uncurry (combineV' (/)) . mapT boxExtents - combineV' f x = toVector . combineV f x - return $ Transformation lin_map lin_map (vl ^-^ box_scale (v, u) ul) + (P ul, _) <- getCorners u + (P vl, _) <- getCorners v + let i = s (v, u) <-> s (u, v) + s = liftU2 (*) . uncurry (liftU2 (/)) . mapT boxExtents + return $ Transformation i i (vl ^-^ s (v, u) ul) + -- NOTE: Need to check this one -- | Transforms an enveloped thing to fit within a @BoundingBox@. If it's -- empty, then the result is also @mempty@. -boxFit :: (Enveloped a, Transformable a, Monoid a, Ord (Basis (V a))) - => BoundingBox (V a) -> a -> a +boxFit + :: (VN a ~ v n, Enveloped a, Transformable a, Monoid a, HasLinearMap v, Num n) + => BoundingBox (V a) (N a) -> a -> a boxFit b x = maybe mempty (`transform` x) $ boxTransform (boundingBox x) b -- | Check whether a point is contained in a bounding box (including its edges). -contains - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> Point v -> Bool +contains :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> Point v n -> Bool contains b p = maybe False check $ getCorners b where - check (l, h) = F.and (combineP (<=) l p) - && F.and (combineP (<=) p h) + check (l, h) = F.and (liftI2 (<=) l p) + && F.and (liftI2 (<=) p h) -- | Check whether a point is /strictly/ contained in a bounding box. -contains' - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> Point v -> Bool +contains' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> Point v n -> Bool contains' b p = maybe False check $ getCorners b where - check (l, h) = F.and (combineP (<) l p) - && F.and (combineP (<) p h) + check (l, h) = F.and (liftI2 (<) l p) + && F.and (liftI2 (<) p h) -- | Test whether the first bounding box is contained inside -- the second. -inside - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +inside :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool inside u v = fromMaybe False $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.and (combineP (>=) ul vl) - && F.and (combineP (<=) uh vh) + return $ F.and (liftI2 (>=) ul vl) + && F.and (liftI2 (<=) uh vh) -- | Test whether the first bounding box is /strictly/ contained -- inside the second. -inside' - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +inside' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool inside' u v = fromMaybe False $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.and (combineP (>) ul vl) - && F.and (combineP (<) uh vh) + return $ F.and (liftI2 (>) ul vl) + && F.and (liftI2 (<) uh vh) -- | Test whether the first bounding box lies outside the second -- (although they may intersect in their boundaries). -outside - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +outside :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool outside u v = fromMaybe True $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.or (combineP (<=) uh vl) - || F.or (combineP (>=) ul vh) + return $ F.or (liftI2 (<=) uh vl) + || F.or (liftI2 (>=) ul vh) -- | Test whether the first bounding box lies /strictly/ outside the second -- (they do not intersect at all). -outside' - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +outside' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool outside' u v = fromMaybe True $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.or (combineP (<) uh vl) - || F.or (combineP (>) ul vh) + return $ F.or (liftI2 (<) uh vl) + || F.or (liftI2 (>) ul vh) -- | Form the largest bounding box contained within this given two -- bounding boxes, or @Nothing@ if the two bounding boxes do not -- overlap at all. intersection - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> BoundingBox v + :: (Additive v, Foldable v, Ord n) + => BoundingBox v n -> BoundingBox v n -> BoundingBox v n intersection u v = maybe mempty (uncurry fromCorners) $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ mapT toPoint (combineP max ul vl, combineP min uh vh) + return (liftI2 max ul vl, liftI2 min uh vh) -- | Form the smallest bounding box containing the given two bound union. This -- function is just an alias for @mappend@. -union :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> BoundingBox v +union :: (Additive v, Ord n) => BoundingBox v n -> BoundingBox v n -> BoundingBox v n union = mappend --- internals using Map (Basis v) (Scalar v) --- probably paranoia, but decompose might not always --- 1. contain basis elements whose component is zero --- 2. have basis elements in the same order - -fromVector :: (HasBasis v, Ord (Basis v)) => v -> Map (Basis v) (Scalar v) -fromVector = fromList . decompose - -toVector :: HasBasis v => Map (Basis v) (Scalar v) -> v -toVector = recompose . toList - -toPoint :: HasBasis v => Map (Basis v) (Scalar v) -> Point v -toPoint = P . toVector - -combineV :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) - => (Scalar v -> Scalar v -> a) -> v -> v -> Map (Basis v) a -combineV f u v = combineDefault zeroV zeroV f (fromVector u) (fromVector v) - -combineP :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) - => (Scalar v -> Scalar v -> a) -> Point v -> Point v -> Map (Basis v) a -combineP f (P u) (P v) = combineV f u v - -combineDefault :: Ord k => a -> b -> (a -> b -> c) -> Map k a -> Map k b -> Map k c -combineDefault a b f = combine g - where - g Nothing Nothing = f a b - g Nothing (Just y) = f a y - g (Just x) Nothing = f x b - g (Just x) (Just y) = f x y - -combine :: Ord k => (Maybe a -> Maybe b -> c) -> Map k a -> Map k b -> Map k c -combine f am bm = fromDistinctAscList $ merge (toAscList am) (toAscList bm) - where - merge [] [] = [] - merge ((x,a):xs) [] = (x, f (Just a) Nothing) : merge xs [] - merge [] ((y,b):ys) = (y, f Nothing (Just b)) : merge [] ys - merge xs0@((x,a):xs) ys0@((y,b):ys) = case compare x y of - LT -> (x, f (Just a) Nothing ) : merge xs ys0 - EQ -> (x, f (Just a) (Just b)) : merge xs ys - GT -> (y, f Nothing (Just b)) : merge xs0 ys From fe4892acc894c208394ffb9366e8255a79f314ae Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 18 Aug 2014 23:40:44 +0100 Subject: [PATCH 20/58] Bounding box. --- src/Diagrams/BoundingBox.hs | 272 +++++++++++++----------------------- 1 file changed, 95 insertions(+), 177 deletions(-) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index 9247a285..f83c876e 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.BoundingBox @@ -24,7 +24,7 @@ module Diagrams.BoundingBox ( -- * Bounding boxes - BoundingBox() + BoundingBox -- * Constructing bounding boxes , emptyBox, fromCorners, fromPoint, fromPoints @@ -33,7 +33,7 @@ module Diagrams.BoundingBox -- * Queries on bounding boxes , isEmptyBox , getCorners, getAllCorners - , boxExtents, boxTransform, boxFit + , boxExtents , boxTransform, boxFit , contains, contains' , inside, inside', outside, outside' @@ -41,290 +41,208 @@ module Diagrams.BoundingBox , union, intersection ) where -import Control.Applicative ((<$>)) -import qualified Data.Foldable as F -import Data.Map (Map, fromDistinctAscList, fromList, toAscList, toList) - -import Data.Maybe (fromMaybe) - -import Data.VectorSpace --- (VectorSpace, Scalar, AdditiveGroup, zeroV, negateV, (^+^), (^-^)) -import Data.Basis (Basis, HasBasis, basisValue, decompose, recompose) -import Data.Monoid (Monoid (..)) -import Data.Semigroup (Option (..), Semigroup (..)) +import Data.Data (Data, Typeable) +import Data.Foldable as F +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Option (..), Semigroup (..)) -import Data.Data (Data) -import Data.Typeable (Typeable) +import Diagrams.Core.Envelope +import Diagrams.Core.HasOrigin (HasOrigin (..)) +import Diagrams.Core.Transform +import Diagrams.Core.V -import Diagrams.Core.Envelope (Enveloped (..), appEnvelope) -import Diagrams.Core.HasOrigin (HasOrigin (..)) -import Diagrams.Core.Points (Point (..)) -import Diagrams.Core.Transform (HasLinearMap, Transformable (..), Transformation (..), - (<->)) -import Diagrams.Core.V (V) +import Control.Applicative +import Data.Traversable as T +import Linear.Affine +import Linear.Metric +import Linear.Vector -- Unexported utility newtype -newtype NonEmptyBoundingBox v = NonEmptyBoundingBox (Point v, Point v) - deriving (Eq, Data, Typeable) +newtype NonEmptyBoundingBox v n = NonEmptyBoundingBox (Point v n, Point v n) + deriving (Eq, Data, Typeable, Functor) -fromNonEmpty :: NonEmptyBoundingBox v -> BoundingBox v +type instance V (NonEmptyBoundingBox v n) = v +type instance N (NonEmptyBoundingBox v n) = n + +fromNonEmpty :: NonEmptyBoundingBox v n -> BoundingBox v n fromNonEmpty = BoundingBox . Option . Just -fromMaybeEmpty :: Maybe (NonEmptyBoundingBox v) -> BoundingBox v +fromMaybeEmpty :: Maybe (NonEmptyBoundingBox v n) -> BoundingBox v n fromMaybeEmpty = maybe emptyBox fromNonEmpty -nonEmptyCorners :: NonEmptyBoundingBox v -> (Point v, Point v) +nonEmptyCorners :: NonEmptyBoundingBox v n -> (Point v n, Point v n) nonEmptyCorners (NonEmptyBoundingBox x) = x -instance (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => Semigroup (NonEmptyBoundingBox v) where +instance (Additive v, Ord n) => Semigroup (NonEmptyBoundingBox v n) where (NonEmptyBoundingBox (ul, uh)) <> (NonEmptyBoundingBox (vl, vh)) - = NonEmptyBoundingBox - $ mapT toPoint (combineP min ul vl, combineP max uh vh) - + = NonEmptyBoundingBox (liftU2 min ul vl, liftU2 max uh vh) -- | A bounding box is an axis-aligned region determined by two points -- indicating its \"lower\" and \"upper\" corners. It can also represent -- an empty bounding box - the points are wrapped in @Maybe@. -newtype BoundingBox v = BoundingBox (Option (NonEmptyBoundingBox v)) - deriving (Eq, Data, Typeable) +newtype BoundingBox v n = BoundingBox (Option (NonEmptyBoundingBox v n)) + deriving (Eq, Data, Typeable, Functor) -deriving instance - ( HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v) - ) => Semigroup (BoundingBox v) -deriving instance - ( HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v) - ) => Monoid (BoundingBox v) +deriving instance (Additive v, Ord n) => Semigroup (BoundingBox v n) +deriving instance (Additive v, Ord n) => Monoid (BoundingBox v n) -type instance V (BoundingBox v) = v +type instance V (BoundingBox v n) = v +type instance N (BoundingBox v n) = n -- Map a function on a homogenous 2-tuple. (unexported utility) mapT :: (a -> b) -> (a, a) -> (b, b) mapT f (x, y) = (f x, f y) +{-# NOINLINE mapT #-} -instance ( VectorSpace v, HasBasis v, Ord (Basis v) - , AdditiveGroup (Scalar v), Ord (Scalar v) - ) => HasOrigin (BoundingBox v) where +instance (Additive v, Num n, Ord n) => HasOrigin (BoundingBox v n) where moveOriginTo p b = fromMaybeEmpty - ( NonEmptyBoundingBox . mapT (moveOriginTo p) <$> getCorners b ) + (NonEmptyBoundingBox . mapT (moveOriginTo p) <$> getCorners b) -instance ( InnerSpace v, HasBasis v, Ord (Basis v) - , AdditiveGroup (Scalar v), Ord (Scalar v), Floating (Scalar v) - ) => Enveloped (BoundingBox v) where +instance (Metric v, Traversable v, OrderedField n) + => Enveloped (BoundingBox v n) where getEnvelope = getEnvelope . getAllCorners -instance Show v => Show (BoundingBox v) where +instance Show (v n) => Show (BoundingBox v n) where show = maybe "emptyBox" (\(l, u) -> "fromCorners " ++ show l ++ " " ++ show u) . getCorners -{- TODO -instance Read v => Read (BoundingBox v) where - read "emptyBox" = emptyBox --} - -- | An empty bounding box. This is the same thing as @mempty@, but it doesn't -- require the same type constraints that the @Monoid@ instance does. -emptyBox :: BoundingBox v +emptyBox :: BoundingBox v n emptyBox = BoundingBox $ Option Nothing -- | Create a bounding box from a point that is component-wise @(<=)@ than the -- other. If this is not the case, then @mempty@ is returned. fromCorners - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => Point v -> Point v -> BoundingBox v + :: (Additive v, Foldable v, Ord n) + => Point v n -> Point v n -> BoundingBox v n fromCorners l h - | F.and (combineP (<=) l h) = fromNonEmpty $ NonEmptyBoundingBox (l, h) - | otherwise = mempty + | F.and (liftI2 (<=) l h) = fromNonEmpty $ NonEmptyBoundingBox (l, h) + | otherwise = mempty -- | Create a degenerate bounding \"box\" containing only a single point. -fromPoint - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => Point v -> BoundingBox v +fromPoint :: Point v n -> BoundingBox v n fromPoint p = fromNonEmpty $ NonEmptyBoundingBox (p, p) -- | Create the smallest bounding box containing all the given points. -fromPoints - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => [Point v] -> BoundingBox v +fromPoints :: (Additive v, Ord n) => [Point v n] -> BoundingBox v n fromPoints = mconcat . map fromPoint -- | Create a bounding box for any enveloped object (such as a diagram or path). -boundingBox :: forall a. ( Enveloped a, HasBasis (V a), AdditiveGroup (V a) - , Ord (Basis (V a)) - ) => a -> BoundingBox (V a) +boundingBox :: (VN a ~ v n, Enveloped a, HasLinearMap v, Num n) + => a -> BoundingBox v n boundingBox a = fromMaybeEmpty $ do - env <- appEnvelope $ getEnvelope a - let h = recompose $ map (\v -> (v, env $ basisValue v)) us - l = recompose $ map (\v -> (v, negate . env . negateV $ basisValue v)) us - return $ NonEmptyBoundingBox (P l, P h) - where - -- The units. Might not work if 0-components aren't reported. - --TODO: Depend on Enum Basis? - us = map fst $ decompose (zeroV :: V a) + env <- (appEnvelope . getEnvelope) a + let h = fmap env eye + l = negated $ fmap (env . negated) eye + return $ NonEmptyBoundingBox (P l, P h) -- | Queries whether the BoundingBox is empty. -isEmptyBox :: BoundingBox v -> Bool +isEmptyBox :: BoundingBox v n -> Bool isEmptyBox (BoundingBox (Option Nothing)) = True -isEmptyBox _ = False +isEmptyBox _ = False -- | Gets the lower and upper corners that define the bounding box. -getCorners :: BoundingBox v -> Maybe (Point v, Point v) +getCorners :: BoundingBox v n -> Maybe (Point v n, Point v n) getCorners (BoundingBox p) = nonEmptyCorners <$> getOption p - --- | Computes all of the corners of the bounding box. -getAllCorners :: (HasBasis v, AdditiveGroup (Scalar v), Ord (Basis v)) - => BoundingBox v -> [Point v] +-- +-- -- | Computes all of the corners of the bounding box. +getAllCorners :: (Additive v, Traversable v, Num n) => BoundingBox v n -> [Point v n] getAllCorners (BoundingBox (Option Nothing)) = [] getAllCorners (BoundingBox (Option (Just (NonEmptyBoundingBox (l, u))))) - = map (P . recompose) - -- Enumerate all combinations of selections of lower / higher values. - . mapM (\(b, (l', u')) -> [(b, l'), (b, u')]) - -- List of [(basis, (lower, upper))] - . toList - $ combineP (,) l u + = T.sequence (liftI2 (\a b -> [a,b]) l u) -- | Get the size of the bounding box - the vector from the (component-wise) -- lesser point to the greater point. -boxExtents :: (AdditiveGroup v) => BoundingBox v -> v -boxExtents = maybe zeroV (\(P l, P h) -> h ^-^ l) . getCorners +boxExtents :: (Additive v, Num n) => BoundingBox v n -> v n +boxExtents = maybe zero (uncurry (.-.)) . getCorners -- | Create a transformation mapping points from one bounding box to the other. -boxTransform :: (AdditiveGroup v, HasLinearMap v, - Fractional (Scalar v), AdditiveGroup (Scalar v), Ord (Basis v)) - => BoundingBox v -> BoundingBox v -> Maybe (Transformation v) +boxTransform + :: (Additive v, Fractional n) + => BoundingBox v n -> BoundingBox v n -> Maybe (Transformation v n) boxTransform u v = do - ((P ul), _) <- getCorners u - ((P vl), _) <- getCorners v - let lin_map = box_scale (v, u) <-> box_scale (u, v) - box_scale = combineV' (*) . uncurry (combineV' (/)) . mapT boxExtents - combineV' f x = toVector . combineV f x - return $ Transformation lin_map lin_map (vl ^-^ box_scale (v, u) ul) + (P ul, _) <- getCorners u + (P vl, _) <- getCorners v + let i = s (v, u) <-> s (u, v) + s = liftU2 (*) . uncurry (liftU2 (/)) . mapT boxExtents + return $ Transformation i i (vl ^-^ s (v, u) ul) + -- NOTE: Need to check this one -- | Transforms an enveloped thing to fit within a @BoundingBox@. If it's -- empty, then the result is also @mempty@. -boxFit :: (Enveloped a, Transformable a, Monoid a, Ord (Basis (V a))) - => BoundingBox (V a) -> a -> a +boxFit + :: (VN a ~ v n, Enveloped a, Transformable a, Monoid a, HasLinearMap v, Num n) + => BoundingBox (V a) (N a) -> a -> a boxFit b x = maybe mempty (`transform` x) $ boxTransform (boundingBox x) b -- | Check whether a point is contained in a bounding box (including its edges). -contains - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> Point v -> Bool +contains :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> Point v n -> Bool contains b p = maybe False check $ getCorners b where - check (l, h) = F.and (combineP (<=) l p) - && F.and (combineP (<=) p h) + check (l, h) = F.and (liftI2 (<=) l p) + && F.and (liftI2 (<=) p h) -- | Check whether a point is /strictly/ contained in a bounding box. -contains' - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> Point v -> Bool +contains' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> Point v n -> Bool contains' b p = maybe False check $ getCorners b where - check (l, h) = F.and (combineP (<) l p) - && F.and (combineP (<) p h) + check (l, h) = F.and (liftI2 (<) l p) + && F.and (liftI2 (<) p h) -- | Test whether the first bounding box is contained inside -- the second. -inside - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +inside :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool inside u v = fromMaybe False $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.and (combineP (>=) ul vl) - && F.and (combineP (<=) uh vh) + return $ F.and (liftI2 (>=) ul vl) + && F.and (liftI2 (<=) uh vh) -- | Test whether the first bounding box is /strictly/ contained -- inside the second. -inside' - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +inside' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool inside' u v = fromMaybe False $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.and (combineP (>) ul vl) - && F.and (combineP (<) uh vh) + return $ F.and (liftI2 (>) ul vl) + && F.and (liftI2 (<) uh vh) -- | Test whether the first bounding box lies outside the second -- (although they may intersect in their boundaries). -outside - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +outside :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool outside u v = fromMaybe True $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.or (combineP (<=) uh vl) - || F.or (combineP (>=) ul vh) + return $ F.or (liftI2 (<=) uh vl) + || F.or (liftI2 (>=) ul vh) -- | Test whether the first bounding box lies /strictly/ outside the second -- (they do not intersect at all). -outside' - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +outside' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool outside' u v = fromMaybe True $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.or (combineP (<) uh vl) - || F.or (combineP (>) ul vh) + return $ F.or (liftI2 (<) uh vl) + || F.or (liftI2 (>) ul vh) -- | Form the largest bounding box contained within this given two -- bounding boxes, or @Nothing@ if the two bounding boxes do not -- overlap at all. intersection - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> BoundingBox v + :: (Additive v, Foldable v, Ord n) + => BoundingBox v n -> BoundingBox v n -> BoundingBox v n intersection u v = maybe mempty (uncurry fromCorners) $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ mapT toPoint (combineP max ul vl, combineP min uh vh) + return (liftI2 max ul vl, liftI2 min uh vh) -- | Form the smallest bounding box containing the given two bound union. This -- function is just an alias for @mappend@. -union :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> BoundingBox v +union :: (Additive v, Ord n) => BoundingBox v n -> BoundingBox v n -> BoundingBox v n union = mappend --- internals using Map (Basis v) (Scalar v) --- probably paranoia, but decompose might not always --- 1. contain basis elements whose component is zero --- 2. have basis elements in the same order - -fromVector :: (HasBasis v, Ord (Basis v)) => v -> Map (Basis v) (Scalar v) -fromVector = fromList . decompose - -toVector :: HasBasis v => Map (Basis v) (Scalar v) -> v -toVector = recompose . toList - -toPoint :: HasBasis v => Map (Basis v) (Scalar v) -> Point v -toPoint = P . toVector - -combineV :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) - => (Scalar v -> Scalar v -> a) -> v -> v -> Map (Basis v) a -combineV f u v = combineDefault zeroV zeroV f (fromVector u) (fromVector v) - -combineP :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) - => (Scalar v -> Scalar v -> a) -> Point v -> Point v -> Map (Basis v) a -combineP f (P u) (P v) = combineV f u v - -combineDefault :: Ord k => a -> b -> (a -> b -> c) -> Map k a -> Map k b -> Map k c -combineDefault a b f = combine g - where - g Nothing Nothing = f a b - g Nothing (Just y) = f a y - g (Just x) Nothing = f x b - g (Just x) (Just y) = f x y - -combine :: Ord k => (Maybe a -> Maybe b -> c) -> Map k a -> Map k b -> Map k c -combine f am bm = fromDistinctAscList $ merge (toAscList am) (toAscList bm) - where - merge [] [] = [] - merge ((x,a):xs) [] = (x, f (Just a) Nothing) : merge xs [] - merge [] ((y,b):ys) = (y, f Nothing (Just b)) : merge [] ys - merge xs0@((x,a):xs) ys0@((y,b):ys) = case compare x y of - LT -> (x, f (Just a) Nothing ) : merge xs ys0 - EQ -> (x, f (Just a) (Just b)) : merge xs ys - GT -> (y, f Nothing (Just b)) : merge xs0 ys From 552c822fb679beb3d7770098d3384376066b4e39 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Thu, 21 Aug 2014 15:18:54 +0100 Subject: [PATCH 21/58] Starting on 2D and 3D modules. --- diagrams-lib.cabal | 4 - src/Diagrams/Angle.hs | 78 ++++++++++++---- src/Diagrams/Attributes/Compile.hs | 16 ++-- src/Diagrams/BoundingBox.hs | 3 +- src/Diagrams/Coordinates.hs | 37 ++++---- src/Diagrams/Direction.hs | 30 ++++--- src/Diagrams/Located.hs | 2 +- src/Diagrams/Names.hs | 13 ++- src/Diagrams/Parametric/Adjust.hs | 33 +++---- src/Diagrams/ThreeD/Camera.hs | 70 ++++++++------- src/Diagrams/ThreeD/Light.hs | 35 ++++---- src/Diagrams/ThreeD/Shapes.hs | 92 ++++++++++--------- src/Diagrams/ThreeD/Types.hs | 109 ++++++++++++++-------- src/Diagrams/ThreeD/Vector.hs | 29 ++---- src/Diagrams/Trail.hs | 3 +- src/Diagrams/TrailLike.hs | 32 +++---- src/Diagrams/Transform.hs | 10 ++- src/Diagrams/TwoD/Size.hs | 70 +++++++++------ src/Diagrams/TwoD/Transform.hs | 115 +++++++++++++----------- src/Diagrams/TwoD/Transform/ScaleInv.hs | 38 ++++---- src/Diagrams/TwoD/Types.hs | 109 +++++++++++----------- src/Diagrams/TwoD/Vector.hs | 57 ++++++------ 22 files changed, 551 insertions(+), 434 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 42e98165..205c632f 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -54,9 +54,6 @@ Library Diagrams.Query, Diagrams.TwoD, Diagrams.TwoD.Types, - Diagrams.TwoD.Types.Double, - Diagrams.TwoD.Types.Float, - Diagrams.TwoD.Types.Generic, Diagrams.TwoD.Align, Diagrams.TwoD.Arrow, Diagrams.TwoD.Arrowheads, @@ -87,7 +84,6 @@ Library Diagrams.ThreeD.Shapes, Diagrams.ThreeD.Transform, Diagrams.ThreeD.Types, - Diagrams.ThreeD.Types.Double, Diagrams.ThreeD.Vector, Diagrams.ThreeD, Diagrams.Animation, diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 0c108ee2..7c4dcdfe 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -20,7 +20,7 @@ module Diagrams.Angle ( Angle , rad, turn, deg - , fullTurn, angleRatio + , fullTurn, halfTurn, quarterTurn, angleRatio , sinA, cosA, tanA, asinA, acosA, atanA, atan2A , (@@) , angleBetween @@ -28,7 +28,7 @@ module Diagrams.Angle , HasPhi(..) ) where -import Control.Lens (Iso', Lens', iso, review) +import Control.Lens (Iso', Lens', iso, review, (^.)) import Data.Monoid hiding ((<>)) import Data.Semigroup @@ -37,22 +37,34 @@ import Linear.Affine import Linear.Metric import Linear.Vector import Linear.Epsilon -import Linear.V1 + +import Control.Applicative import Diagrams.Core.V import Diagrams.Points +-- import Data.Fixed -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. -newtype Angle n = Radians (V1 n) - deriving (Read, Show, Eq, Ord, Functor, Additive, Metric) +newtype Angle n = Radians n + deriving (Read, Show, Eq, Ord, Functor) + +instance Applicative Angle where + pure = Radians + {-# INLINE pure #-} + Radians f <*> Radians x = Radians (f x) + {-# INLINE (<*>) #-} + +instance Additive Angle where + zero = pure 0 + {-# INLINE zero #-} instance Num n => Semigroup (Angle n) where (<>) = (^+^) instance Num n => Monoid (Angle n) where mappend = (<>) - mempty = Radians zero + mempty = Radians 0 -- deriving instance InnerSpace v => InnerSpace (Angle v) @@ -61,56 +73,80 @@ type instance N (Angle n) = n -- | The radian measure of an @Angle@ @a@ can be accessed as @a -- ^. rad@. A new @Angle@ can be defined in radians as @pi \@\@ rad@. rad :: Iso' (Angle n) n -rad = iso (\(Radians (V1 r)) -> r) (Radians . V1) +rad = iso (\(Radians r) -> r) Radians -- | The measure of an @Angle@ @a@ in full circles can be accessed as -- @a ^. turn@. A new @Angle@ of one-half circle can be defined in as -- @1/2 \@\@ turn@. turn :: Floating n => Iso' (Angle n) n -turn = iso (\(Radians (V1 r)) -> r / (2*pi)) (Radians . V1 . (*(2*pi))) +turn = iso (\(Radians r) -> r / (2*pi)) (Radians . (*(2*pi))) -- | The degree measure of an @Angle@ @a@ can be accessed as @a -- ^. deg@. A new @Angle@ can be defined in degrees as @180 \@\@ -- deg@. deg :: Floating n => Iso' (Angle n) n -deg = iso (\(Radians (V1 r)) -> r / (2*pi/360)) (Radians . V1 . ( * (2*pi/360))) +deg = iso (\(Radians r) -> r / (2*pi/360)) (Radians . ( * (2*pi/360))) -- | An angle representing one full turn. fullTurn :: Floating v => Angle v fullTurn = 1 @@ turn +-- | An angle representing a half. +halfTurn :: Floating v => Angle v +halfTurn = 0.5 @@ turn + +-- | An angle representing a quarter turn. +quarterTurn :: Floating v => Angle v +quarterTurn = 0.25 @@ turn + -- | Calculate ratio between two angles. angleRatio :: Floating n => Angle n -> Angle n -> n -angleRatio a b = norm a / norm b +angleRatio a b = abs (a ^. rad) / abs (b ^. rad) -- | The sine of the given @Angle@. sinA :: Floating n => Angle n -> n -sinA (Radians (V1 r)) = sin r +sinA (Radians r) = sin r -- | The cosine of the given @Angle@. cosA :: Floating n => Angle n -> n -cosA (Radians (V1 r)) = cos r +cosA (Radians r) = cos r -- | The tangent function of the given @Angle@. tanA :: Floating n => Angle n -> n -tanA (Radians (V1 r)) = tan r +tanA (Radians r) = tan r -- | The @Angle@ with the given sine. asinA :: Floating n => n -> Angle n -asinA = Radians . V1 . asin +asinA = Radians . asin -- | The @Angle@ with the given cosine. acosA :: Floating n => n -> Angle n -acosA = Radians . V1 . acos +acosA = Radians . acos -- | The @Angle@ with the given tangent. atanA :: Floating n => n -> Angle n -atanA = Radians . V1 . atan +atanA = Radians . atan -- | @atan2A n d@ is the @Angle with tangent @n/d@, unless d is 0, in -- which case it is ±π/2. atan2A :: RealFloat n => n -> n -> Angle n -atan2A n d = Radians . V1 $ atan2 n d +atan2A y x = Radians $ atan2 y x + +-- Like atan2 but unable to differentiate between 0 and -0: +-- atan2 0 (-0) = pi +-- atan2' 0 (-0) = 0 +-- +-- have to decide if this technicality is worth a RealFloat instance. + +-- atan2' :: (Floating n, Ord n) => n -> n -> n +-- atan2' y x +-- | x > 0 = atan (y/x) +-- | x == 0 && y > 0 = pi/2 +-- | x < 0 && y > 0 = pi + atan (y/x) +-- | x <= 0 && y < 0 = -atan2' (-y) x +-- | y == 0 && x < 0 = pi -- must be after the previous test on zero y +-- | x == 0 && y == 0 = y -- must be after the other double zero tests +-- | otherwise = x + y -- x or y is a NaN, return a NaN (via +) -- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. -- @@ -128,17 +164,21 @@ infixl 5 @@ angleBetween :: (Metric v, Floating n, Epsilon n) => v n -> v n -> Angle n angleBetween v1 v2 = acos (normalize v1 `dot` normalize v2) @@ rad +-- | Normalize an angle so that is lies in the [0,tau) range. +-- normalizeAngle :: (Floating n, Real n) => Angle n -> Angle n +-- normalizeAngle = over rad (`mod'` (2 * pi)) + ------------------------------------------------------------ -- Polar Coordinates -- | The class of types with at least one angle coordinate, called _theta. class HasTheta t where - _theta :: Floating n => Lens' (t n) (Angle n) + _theta :: RealFloat n => Lens' (t n) (Angle n) -- | The class of types with at least two angle coordinates, the -- second called _phi. class HasTheta t => HasPhi t where - _phi :: Floating n => Lens' (t n) (Angle n) + _phi :: RealFloat n => Lens' (t n) (Angle n) -- Point instances instance HasTheta v => HasTheta (Point v) where diff --git a/src/Diagrams/Attributes/Compile.hs b/src/Diagrams/Attributes/Compile.hs index 8daa8028..54b2cbee 100644 --- a/src/Diagrams/Attributes/Compile.hs +++ b/src/Diagrams/Attributes/Compile.hs @@ -44,7 +44,7 @@ class (AttributeClass (AttrType code), Typeable (PrimType code)) => SplitAttribu -- containing only "safe" nodes. In particular this is used to push -- fill attributes down until they are over only loops; see -- 'splitFills'. -splitAttr :: forall code b v a. SplitAttribute code => code -> RTree b v a -> RTree b v a +splitAttr :: forall code b v n a. SplitAttribute code => code -> RTree b v n a -> RTree b v n a splitAttr code = fst . splitAttr' Nothing where @@ -57,7 +57,7 @@ splitAttr code = fst . splitAttr' Nothing -- Output: tree with attributes pushed down appropriately, and -- a Bool indicating whether the tree contains only "safe" prims (True) or -- contains some unsafe ones (False). - splitAttr' :: Maybe (AttrType code) -> RTree b v a -> (RTree b v a, Bool) + splitAttr' :: Maybe (AttrType code) -> RTree b v n a -> (RTree b v n a, Bool) -- RStyle node: Check for the special attribute, and split it out of -- the style, combining it with the incoming attribute. Recurse and @@ -87,9 +87,9 @@ splitAttr code = fst . splitAttr' Nothing case cast prm :: Maybe (PrimType code) of Nothing -> (Node rp [], True) Just p -> - case primOK code p of - True -> (rebuildNode mattr True rp [], True) - False -> (Node rp [], False) + if primOK code p + then (rebuildNode mattr True rp [], True) + else (Node rp [], False) -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild. Note -- we assume that transformations do not affect the attributes. @@ -101,7 +101,7 @@ splitAttr code = fst . splitAttr' Nothing -- Recursively call splitAttr' on all subtrees, returning the -- logical AND of the Bool results returned (the whole forest is -- safe iff all subtrees are). - splitAttr'Forest :: Maybe (AttrType code) -> [RTree b v a] -> ([RTree b v a], Bool) + splitAttr'Forest :: Maybe (AttrType code) -> [RTree b v n a] -> ([RTree b v n a], Bool) splitAttr'Forest mattr cs = (cs', ok) where (cs', ok) = second and . unzip . map (splitAttr' mattr) $ cs @@ -110,13 +110,13 @@ splitAttr code = fst . splitAttr' Nothing -- subforest contains only loops, a node, and a subforest, rebuild a -- tree, applying the fill attribute as appropriate (only if the -- Bool is true and the attribute is not Nothing). - rebuildNode :: Maybe (AttrType code) -> Bool -> RNode b v a -> [RTree b v a] -> RTree b v a + rebuildNode :: Maybe (AttrType code) -> Bool -> RNode b v n a -> [RTree b v n a] -> RTree b v n a rebuildNode mattr ok nd cs | ok = applyMattr mattr (Node nd cs) | otherwise = Node nd cs -- Prepend a new fill color node if Just; the identity function if -- Nothing. - applyMattr :: Maybe (AttrType code) -> RTree b v a -> RTree b v a + applyMattr :: Maybe (AttrType code) -> RTree b v n a -> RTree b v n a applyMattr Nothing t = t applyMattr (Just a) t = Node (RStyle $ attrToStyle a) [t] diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index f83c876e..8b5ba59d 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -33,7 +33,7 @@ module Diagrams.BoundingBox -- * Queries on bounding boxes , isEmptyBox , getCorners, getAllCorners - , boxExtents , boxTransform, boxFit + , boxExtents, boxTransform, boxFit , contains, contains' , inside, inside', outside, outside' @@ -94,7 +94,6 @@ type instance N (BoundingBox v n) = n -- Map a function on a homogenous 2-tuple. (unexported utility) mapT :: (a -> b) -> (a, a) -> (b, b) mapT f (x, y) = (f x, f y) -{-# NOINLINE mapT #-} instance (Additive v, Num n, Ord n) => HasOrigin (BoundingBox v n) where moveOriginTo p b diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index d6d03819..56ef6308 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -21,12 +21,9 @@ module Diagrams.Coordinates ) where -import Control.Lens (Lens') -import Data.VectorSpace - -import Data.AffineSpace.Point -import Diagrams.Core.V -import Diagrams.Points +import Control.Lens (Lens') +import Diagrams.Points +import Linear.Affine -- | Types which are instances of the @Coordinates@ class can be -- constructed using '^&' (for example, a three-dimensional vector @@ -114,40 +111,40 @@ instance Coordinates (a,b,c,d) where (w,x,y) ^& z = (w,x,y,z) coords (w,x,y,z) = coords (w,x,y) :& z -instance Coordinates v => Coordinates (Point v) where - type FinalCoord (Point v) = FinalCoord v - type PrevDim (Point v) = PrevDim v - type Decomposition (Point v) = Decomposition v +instance Coordinates (v n) => Coordinates (Point v n) where + type FinalCoord (Point v n) = FinalCoord (v n) + type PrevDim (Point v n) = PrevDim (v n) + type Decomposition (Point v n) = Decomposition (v n) x ^& y = P (x ^& y) coords (P v) = coords v -- | The class of types with at least one coordinate, called _x. class HasX t where - _x :: Lens' t (Scalar (V t)) + _x :: Floating n => Lens' (t n) n -- | The class of types with at least two coordinates, the second called _y. -class HasY t where - _y :: Lens' t (Scalar (V t)) +class HasX t => HasY t where + _y :: Floating n => Lens' (t n) n -- | The class of types with at least three coordinates, the third called _z. -class HasZ t where - _z :: Lens' t (Scalar (V t)) +class HasY t => HasZ t where + _z :: Floating n => Lens' (t n) n -- | The class of types with a single length coordinate _r. _r is -- magnitude of a vector, or the distance from the origin of a point. class HasR t where - _r :: Lens' t (Scalar (V t)) + _r :: Lens' (t n) n -instance (HasX v, v ~ V v) => HasX (Point v) where +instance HasX v => HasX (Point v) where _x = _pIso . _x -instance (HasY v, v ~ V v) => HasY (Point v) where +instance HasY v => HasY (Point v) where _y = _pIso . _y -instance (HasZ v, v ~ V v) => HasZ (Point v) where +instance HasZ v => HasZ (Point v) where _z = _pIso . _z -instance (HasR v, v ~ V v) => HasR (Point v) where +instance HasR v => HasR (Point v) where _r = _pIso . _r diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index 87d2ee40..72272c52 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -20,10 +20,11 @@ module Diagrams.Direction ) where import Control.Lens (Iso', iso) -import Data.VectorSpace import Diagrams.Angle import Diagrams.Core +import Linear.Metric +import Linear.Epsilon -------------------------------------------------------------------------------- -- Direction @@ -32,36 +33,39 @@ import Diagrams.Core -- can think of a @Direction@ as a vector that has forgotten its -- magnitude. @Direction@s can be used with 'fromDirection' and the -- lenses provided by its instances. -newtype Direction v = Direction v - deriving (Read, Show, Eq, Ord) -- todo: special instances +newtype Direction v n = Direction (v n) + deriving (Read, Show, Eq, Ord) -- todo: special instances -type instance V (Direction v) = v +type instance V (Direction v n) = v +type instance N (Direction v n) = n -instance (Transformable v, V (Direction v) ~ V v) => Transformable (Direction v) where +-- instance (Transformable v, VN (Direction v n) ~ v n) => Transformable (Direction v) where +instance (VN (v n) ~ v n, Transformable (v n)) => Transformable (Direction v n) where transform t (Direction v) = Direction (transform t v) -instance (HasTheta v, V (Direction v) ~ V v) => HasTheta (Direction v) where +instance HasTheta v => HasTheta (Direction v) where _theta = _Dir . _theta -instance (HasPhi v, V (Direction v) ~ V v) => HasPhi (Direction v) where +instance HasPhi v => HasPhi (Direction v) where _phi = _Dir . _phi -- | _Dir is provided to allow efficient implementations of functions -- in particular vector-spaces, but should be used with care as it -- exposes too much information. -_Dir :: Iso' (Direction v) v +_Dir :: Iso' (Direction v n) (v n) _Dir = iso (\(Direction v) -> v) Direction -- | @direction v@ is the direction in which @v@ points. Returns an -- unspecified value when given the zero vector as input. -direction :: v -> Direction v +direction :: v n -> Direction v n direction = Direction -- | @fromDirection d@ is the unit vector in the direction @d@. -fromDirection :: (InnerSpace v, Floating (Scalar v)) => Direction v -> v -fromDirection (Direction v) = normalized v +fromDirection :: (Metric v, Floating n, Epsilon n) => Direction v n -> v n +fromDirection (Direction v) = normalize v -- | compute the positive angle between the two directions in their common plane -angleBetweenDirs :: (InnerSpace v, Floating (Scalar v)) => - Direction v -> Direction v -> Angle (Scalar v) +angleBetweenDirs :: (Metric v, Floating n, Epsilon n) => + Direction v n -> Direction v n -> Angle n angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) + diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs index 15be79a0..88555582 100644 --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -130,7 +130,7 @@ instance (Traced a, Num (N a)) => Traced (Located a) where instance Qualifiable a => Qualifiable (Located a) where n |> (Loc p a) = Loc p (n |> a) -type instance Codomain (Located a) = Point (Codomain a) +type instance Codomain (Located a) (N a) = Point (Codomain a) (N a) instance (Codomain a ~ V a, Additive (V a), Num (N a), Parametric a) -- , Diff (Point (V a) (N a)) ~ V a (N a)) => Parametric (Located a) where diff --git a/src/Diagrams/Names.hs b/src/Diagrams/Names.hs index 9e617645..98181a84 100644 --- a/src/Diagrams/Names.hs +++ b/src/Diagrams/Names.hs @@ -39,23 +39,22 @@ module Diagrams.Names ) where import Data.Semigroup -import Data.VectorSpace import Diagrams.Core (HasLinearMap, OrderedField, Point) import Diagrams.Core.Names import Diagrams.Core.Types +import Linear.Metric + -- | Attach an atomic name to a diagram. -named :: ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) - => n -> QDiagram b v m -> QDiagram b v m +named :: (IsName nm, HasLinearMap v, Metric v, OrderedField n, Semigroup m) + => nm -> QDiagram b v n m -> QDiagram b v n m named = nameSub mkSubdiagram -- | Attach an atomic name to a certain point (which may be computed -- from the given diagram), treated as a subdiagram with no content -- and a point envelope. -namePoint :: ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) - => (QDiagram b v m -> Point v) -> n -> QDiagram b v m -> QDiagram b v m +namePoint :: (IsName nm , HasLinearMap v, Metric v, OrderedField n, Semigroup m) + => (QDiagram b v n m -> Point v n) -> nm -> QDiagram b v n m -> QDiagram b v n m namePoint p = nameSub (subPoint . p) diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs index 0ffe163a..50d77a51 100644 --- a/src/Diagrams/Parametric/Adjust.hs +++ b/src/Diagrams/Parametric/Adjust.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Parametric.Adjust @@ -25,18 +26,17 @@ import Control.Lens (Lens', generateSignatures, lensField, lens import Data.Proxy import Data.Default.Class -import Data.VectorSpace import Diagrams.Core.V import Diagrams.Parametric -- | What method should be used for adjusting a segment, trail, or -- path? -data AdjustMethod v = ByParam (Scalar v) -- ^ Extend by the given parameter value +data AdjustMethod n = ByParam n -- ^ Extend by the given parameter value -- (use a negative parameter to shrink) - | ByAbsolute (Scalar v) -- ^ Extend by the given arc length + | ByAbsolute n -- ^ Extend by the given arc length -- (use a negative length to shrink) - | ToAbsolute (Scalar v) -- ^ Extend or shrink to the given + | ToAbsolute n -- ^ Extend or shrink to the given -- arc length -- | Which side of a segment, trail, or path should be adjusted? @@ -46,11 +46,11 @@ data AdjustSide = Start -- ^ Adjust only the beginning deriving (Show, Read, Eq, Ord, Bounded, Enum) -- | How should a segment, trail, or path be adjusted? -data AdjustOpts v = AO { _adjMethod :: AdjustMethod v - , _adjSide :: AdjustSide - , _adjEps :: Scalar v - , _adjOptsvProxy__ :: Proxy v - } +data AdjustOpts v n = AO { _adjMethod :: AdjustMethod n + , _adjSide :: AdjustSide + , _adjEps :: n + , _adjOptsvProxy__ :: Proxy (v n) + } makeLensesWith ( lensRules @@ -65,28 +65,28 @@ makeLensesWith ''AdjustOpts -- | Which method should be used for adjusting? -adjMethod :: Lens' (AdjustOpts v) (AdjustMethod v) +adjMethod :: Lens' (AdjustOpts v n) (AdjustMethod n) -- | Which end(s) of the object should be adjusted? -adjSide :: Lens' (AdjustOpts v) AdjustSide +adjSide :: Lens' (AdjustOpts v n) AdjustSide -- | Tolerance to use when doing adjustment. -adjEps :: Lens' (AdjustOpts v) (Scalar v) +adjEps :: Lens' (AdjustOpts v n) n -instance Fractional (Scalar v) => Default (AdjustMethod v) where +instance Fractional n => Default (AdjustMethod n) where def = ByParam 0.2 instance Default AdjustSide where def = Both -instance Fractional (Scalar v) => Default (AdjustOpts v) where +instance Fractional n => Default (AdjustOpts v n) where def = AO def def stdTolerance Proxy -- | Adjust the length of a parametric object such as a segment or -- trail. The second parameter is an option record which controls how -- the adjustment should be performed; see 'AdjustOpts'. -adjust :: (DomainBounds a, Sectionable a, HasArcLength a, Fractional (Scalar (V a))) - => a -> AdjustOpts (V a) -> a +adjust :: (VN a ~ v n, DomainBounds a, Sectionable a, HasArcLength a, Fractional n) + => a -> AdjustOpts v n -> a adjust s opts = section s (if opts^.adjSide == End then domainLower s else getParam s) (if opts^.adjSide == Start then domainUpper s else domainUpper s - getParam (reverseDomain s)) @@ -100,3 +100,4 @@ adjust s opts = section s absDelta len = arcLength eps s - len bothCoef = if opts^.adjSide == Both then 0.5 else 1 eps = opts^.adjEps + diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index ee4b924d..6468fea6 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -32,87 +32,91 @@ module Diagrams.ThreeD.Camera where import Control.Lens (makeLenses) -import Data.Cross import Data.Monoid import Data.Typeable -import Data.VectorSpace import Diagrams.Angle import Diagrams.Core import Diagrams.Direction -import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Types () import Diagrams.ThreeD.Vector +import Linear.V3 + -- Parameterize Camera on the lens type, so that Backends can express which -- lenses they handle. data Camera l = Camera - { camLoc :: Point (V l) - , forward :: V l - , up :: V l + { camLoc :: Point (V l) (N l) + , forward :: VN l + , up :: VN l , lens :: l } deriving Typeable -class (Typeable l, Typeable (V l)) => CameraLens l where +class (Typeable l, Typeable (VN l)) => CameraLens l where -- | The natural aspect ratio of the projection. - aspect :: l -> Scalar (V l) + aspect :: l -> N l -- | A perspective projection -data PerspectiveLens v = PerspectiveLens - { _horizontalFieldOfView :: Angle (Scalar v) -- ^ Horizontal field of view. - , _verticalFieldOfView :: Angle (Scalar v) -- ^ Vertical field of view. - } +data PerspectiveLens n = PerspectiveLens + { _horizontalFieldOfView :: Angle n -- ^ Horizontal field of view. + , _verticalFieldOfView :: Angle n -- ^ Vertical field of view. + } deriving Typeable makeLenses ''PerspectiveLens -type instance V (PerspectiveLens v) = v +type instance V (PerspectiveLens n) = V3 +type instance N (PerspectiveLens n) = n -instance (R3Ish v) => CameraLens (PerspectiveLens v) where - aspect (PerspectiveLens h v) = angleRatio h v +instance (Floating n, Typeable n) => CameraLens (PerspectiveLens n) where + aspect (PerspectiveLens h v) = angleRatio h v -- | An orthographic projection -data OrthoLens v = OrthoLens - { _orthoWidth :: Scalar v -- ^ Width - , _orthoHeight :: Scalar v -- ^ Height +data OrthoLens n = OrthoLens + { _orthoWidth :: n -- ^ Width + , _orthoHeight :: n -- ^ Height } deriving Typeable makeLenses ''OrthoLens -type instance V (OrthoLens v) = v +type instance V (OrthoLens n) = V3 +type instance N (OrthoLens n) = n -instance (R3Ish v) => CameraLens (OrthoLens v) where +instance (Typeable n, Fractional n) => CameraLens (OrthoLens n) where aspect (OrthoLens h v) = h / v type instance V (Camera l) = V l +type instance N (Camera l) = N l -instance (R3Ish (V l)) => Transformable (Camera l) where +instance (VN l ~ V3 n, Num n) => Transformable (Camera l) where transform t (Camera p f u l) = Camera (transform t p) (transform t f) (transform t u) l -instance (R3Ish (V l)) => Renderable (Camera l) NullBackend where +instance (VN l ~ V3 n, Num n) => Renderable (Camera l) NullBackend where render _ _ = mempty -- | A camera at the origin facing along the negative Z axis, with its -- up-axis coincident with the positive Y axis. The field of view is -- chosen to match a 50mm camera on 35mm film. Note that Cameras take -- up no space in the Diagram. -mm50Camera :: (R3Ish v, Backend b v, Renderable (Camera (PerspectiveLens v)) b) => Diagram b v +mm50Camera :: (Typeable n, Floating n, Ord n, Backend b V3 n, Renderable (Camera (PerspectiveLens n)) b) + => Diagram b V3 n mm50Camera = facing_ZCamera mm50 -- | 'facing_ZCamera l' is a camera at the origin facing along the -- negative Z axis, with its up-axis coincident with the positive Y -- axis, with the projection defined by l. -facing_ZCamera :: (R3Ish v, V l ~ v, CameraLens l, Backend b v, Renderable (Camera l) b) => - l -> Diagram b v +facing_ZCamera :: (VN l ~ V3 n, Floating n, Ord n, CameraLens l, Backend b V3 n, Renderable (Camera l) b) => + l -> Diagram b V3 n facing_ZCamera l = mkQD (Prim $ Camera origin unit_Z unitY l) mempty mempty mempty (Query . const . Any $ False) -mm50, mm50Wide, mm50Narrow :: (R3Ish v) => PerspectiveLens v +mm50, mm50Wide, mm50Narrow :: Floating n => PerspectiveLens n -- | mm50 has the field of view of a 50mm lens on standard 35mm film, -- hence an aspect ratio of 3:2. @@ -126,18 +130,20 @@ mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) -- aspect ratio of 4:3, for VGA and similar computer resolutions. mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) -camForward :: (R3Ish v, v ~ V l) => Camera l -> Direction v +camForward :: (VN l ~ V3 n, Fractional n) => Camera l -> Direction V3 n camForward = direction . forward -camUp :: (R3Ish v, v ~ V l) => Camera l -> Direction v +camUp :: (VN l ~ V3 n, Fractional n) => Camera l -> Direction V3 n camUp = direction . up -camRight :: (R3Ish v, v ~ V l) => Camera l -> Direction v +camRight :: (VN l ~ V3 n, Fractional n) => Camera l -> Direction V3 n camRight c = direction right where - right = cross3 (forward c) (up c) + right = cross (forward c) (up c) -camLens :: (R3Ish v, v ~ V l) => Camera l -> l +camLens :: (V3 ~ V l) => Camera l -> l camLens = lens -camAspect :: (R3Ish v, v ~ V l, CameraLens l) => Camera l -> Scalar v +camAspect :: (VN l ~ V3 n, CameraLens l) => Camera l -> n camAspect = aspect . camLens + +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs index 01986ea6..5acbaab9 100644 --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -26,33 +26,38 @@ import Diagrams.Core import Diagrams.Direction import Diagrams.ThreeD.Types -data PointLight v = PointLight (Point v) (Colour Double) +import Linear.Affine + +data PointLight n = PointLight (Point V3 n) (Colour Double) deriving Typeable -data ParallelLight v = ParallelLight v (Colour Double) +type instance V (PointLight n) = V3 +type instance N (PointLight n) = n + +data ParallelLight n = ParallelLight (Point V3 n) (Colour Double) deriving Typeable -type instance V (PointLight v) = v -type instance V (ParallelLight v) = v +type instance V (ParallelLight n) = V3 +type instance N (ParallelLight n) = n -instance (R3Ish v) => Transformable (PointLight v) where - transform t (PointLight p c) = PointLight (transform t p) c +instance Fractional n => Transformable (PointLight n) where + transform t (PointLight p c) = PointLight (transform t p) c -instance (R3Ish v) => Transformable (ParallelLight v) where - transform t (ParallelLight v c) = ParallelLight (transform t v) c +instance Fractional n => Transformable (ParallelLight n) where + transform t (ParallelLight v c) = ParallelLight (transform t v) c -- | Construct a Diagram with a single PointLight at the origin, which -- takes up no space. -pointLight :: (Backend b v, Renderable (PointLight v) b, R3Ish v) +pointLight :: (Typeable n, Num n, Ord n, Backend b V3 n, Renderable (PointLight n) b) => Colour Double -- ^ The color of the light - -> Diagram b v + -> Diagram b V3 n pointLight c = mkQD (Prim $ PointLight origin c) mempty mempty mempty (Query . const . Any $ False) -- | Construct a Diagram with a single ParallelLight, which takes up no space. -parallelLight :: (Backend b v, Renderable (ParallelLight v) b, R3Ish v) - => Direction v -- ^ The direction in which the light travels. - -> Colour Double -- ^ The color of the light. - -> Diagram b v -parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c) +parallelLight :: (Typeable n, OrderedField n, Backend b V3 n, Renderable (ParallelLight n) b) + => Direction V3 n -- ^ The direction in which the light travels. + -> Colour Double -- ^ The color of the light. + -> Diagram b V3 n +parallelLight d c = mkQD (Prim $ ParallelLight (P $ fromDirection d) c) mempty mempty mempty (Query . const . Any $ False) diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index 69e272b7..2c6a51eb 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Shapes @@ -26,9 +27,7 @@ import Control.Applicative import Control.Lens (review, (^.), _1) import Data.Typeable -import Data.AffineSpace import Data.Semigroup -import Data.VectorSpace import Diagrams.Angle import Diagrams.Coordinates import Diagrams.Core @@ -36,46 +35,53 @@ import Diagrams.Solve import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector -data Ellipsoid v = Ellipsoid (Transformation v) +import Linear.Affine +import Linear.Vector +import Linear.Metric + +data Ellipsoid n = Ellipsoid (Transformation V3 n) deriving Typeable -type instance V (Ellipsoid v) = v +type instance V (Ellipsoid n) = V3 +type instance N (Ellipsoid n) = n -instance (R3Ish v) => Transformable (Ellipsoid v) where +instance Fractional n => Transformable (Ellipsoid n) where transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) -instance (R3Ish v) => Renderable (Ellipsoid v) NullBackend where +instance Fractional n => Renderable (Ellipsoid n) NullBackend where render _ _ = mempty -- | A sphere of radius 1 with its center at the origin. -sphere :: (R3Ish v, Backend b v, Renderable (Ellipsoid v) b) => Diagram b v +sphere :: (Typeable n, OrderedField n, Backend b V3 n, Renderable (Ellipsoid n) b) => Diagram b V3 n sphere = mkQD (Prim $ Ellipsoid mempty) (mkEnvelope sphereEnv) (mkTrace sphereTrace) mempty (Query sphereQuery) - where sphereEnv v = 1 / magnitude v - sphereTrace p v = mkSortedList $ quadForm a b c - where a = v <.> v - b = 2 *^ p' <.> v - c = p' <.> p' - 1 - p' = p .-. origin - sphereQuery v = Any $ magnitudeSq (v .-. origin) <= 1 - -data Box v = Box (Transformation v) + where + sphereEnv v = 1 / norm v + sphereTrace (P p) v = mkSortedList $ quadForm a b c + where + a = v `dot` v + b = 2 * (p `dot` v) + c = p `dot` (p - 1) + sphereQuery v = Any $ quadrance (v .-. origin) <= 1 + +data Box n = Box (Transformation V3 n) deriving (Typeable) -type instance V (Box v) = v +type instance V (Box n) = V3 +type instance N (Box n) = n -instance (R3Ish v) => Transformable (Box v) where +instance Fractional n => Transformable (Box n) where transform t1 (Box t2) = Box (t1 <> t2) -instance (R3Ish v) => Renderable (Box v) NullBackend where - render _ _ = mempty +instance Fractional n => Renderable (Box n) NullBackend where + render _ _ = mempty -- | A cube with side length 1, in the positive octant, with one -- vertex at the origin. -cube :: (R3Ish v, Backend b v, Renderable (Box v) b) => Diagram b v +cube :: (Typeable n, OrderedField n, Backend b V3 n, Renderable (Box n) b) => Diagram b V3 n cube = mkQD (Prim $ Box mempty) (mkEnvelope boxEnv) (mkTrace boxTrace) @@ -83,7 +89,7 @@ cube = mkQD (Prim $ Box mempty) (Query boxQuery) where corners = mkR3 <$> [0,1] <*> [0,1] <*> [0,1] - boxEnv v = maximum (map (v <.>) corners) / magnitudeSq v + boxEnv v = maximum (map (v `dot`) corners) / quadrance v -- ts gives all intersections with the planes forming the box -- filter keeps only those actually on the box surface boxTrace p v = mkSortedList . filter (range . atT) $ ts where @@ -98,21 +104,27 @@ cube = mkQD (Prim $ Box mempty) (x, y, z) = unp3 u boxQuery = Any . range -data Frustum v = Frustum (Scalar v) (Scalar v) (Transformation v) - deriving (Typeable) +data Frustum n = Frustum n n (Transformation V3 n) + deriving Typeable -type instance V (Frustum v) = v +type instance V (Frustum n) = V3 +type instance N (Frustum n) = n -instance (R3Ish v) => Transformable (Frustum v) where +instance Fractional n => Transformable (Frustum n) where transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) -instance (R3Ish v) => Renderable (Frustum v) NullBackend where +instance Fractional n => Renderable (Frustum n) NullBackend where render _ _ = mempty +-- | @project u v@ computes the projection of @v@ onto @u@. +project :: (Metric v, Fractional n) => v n -> v n -> v n +project u v = ((v `dot` u) / quadrance u) *^ u + + -- | A frustum of a right circular cone. It has height 1 oriented -- along the positive z axis, and radii r0 and r1 at Z=0 and Z=1. -- 'cone' and 'cylinder' are special cases. -frustum :: (R3Ish v, Backend b v, Renderable (Frustum v) b) => (Scalar v) -> (Scalar v) -> Diagram b v +frustum :: (Typeable n, OrderedField n, RealFloat n, Backend b V3 n, Renderable (Frustum n) b) => n -> n -> Diagram b V3 n frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) (mkEnvelope frEnv) (mkTrace frTrace) @@ -122,14 +134,14 @@ frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) projectXY u = u ^-^ project unitZ u frQuery p = Any $ x >= 0 && x <= 1 && a <= r where (x, _, z) = unp3 p - r = r0 + (r1-r0)*z + r = r0 + (r1 - r0)*z v = p .-. origin - a = magnitude $ projectXY v + a = norm $ projectXY v -- The plane containing v and the z axis intersects the frustum in a trapezoid -- Test the four corners of this trapezoid; one must determine the Envelope - frEnv v = maximum . map (magnitude . project v . review cylindrical) $ corners + frEnv v = maximum . map (norm . project v . review cylindrical) $ corners where - θ = v^._theta + θ = v ^. _theta corners = [(r1,θ,1), (-r1,θ,1), (r0,θ,0), (-r0,θ,0)] -- The trace can intersect the sides of the cone or one of the end -- caps The sides are described by a quadric equation; substitute @@ -140,25 +152,25 @@ frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) where (px, py, pz) = unp3 p (vx, vy, vz) = unr3 v - ray t = p .+^ t*^v - dr = r1-r0 + ray t = p .+^ t *^ v + dr = r1 - r0 a = vx**2 + vy**2 - vz**2 * dr**2 b = 2 * (px * vx + py * vy - (r0+pz*dr) * dr * vz) c = px**2 + py**2 - (r0 + dr*pz)**2 - zbounds t = (ray t)^._z >= 0 && (ray t)^._z <= 1 + zbounds t = ray t ^. _z >= 0 + && ray t ^. _z <= 1 ends = concatMap cap [0,1] - cap z = if (ray t)^.cylindrical._1 < r0 + z*dr - then [t] - else [] + cap z = [ t | ray t ^. cylindrical . _1 < r0 + z * dr ] where t = (z - pz) / vz -- | A cone with its base centered on the origin, with radius 1 at the -- base, height 1, and it's apex on the positive Z axis. -cone :: (R3Ish v, Backend b v, Renderable (Frustum v) b) => Diagram b v +cone :: (Typeable n, OrderedField n, RealFloat n, Backend b V3 n, Renderable (Frustum n) b) => Diagram b V3 n cone = frustum 1 0 -- | A circular cylinder of radius 1 with one end cap centered on the -- origin, and extending to Z=1. -cylinder :: (R3Ish v, Backend b v, Renderable (Frustum v) b) => Diagram b v +cylinder :: (Typeable n, OrderedField n, RealFloat n, Backend b V3 n, Renderable (Frustum n) b) => Diagram b V3 n cylinder = frustum 1 1 + diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 09dab03e..27619521 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,13 +1,5 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -25,7 +17,8 @@ module Diagrams.ThreeD.Types r3, unr3, mkR3 , p3, unp3, mkP3 , r3Iso, p3Iso - , R3Ish + , V3 (..) + -- * other coördinate systems , Spherical(..), Cylindrical(..), HasPhi(..) ) where @@ -33,69 +26,107 @@ module Diagrams.ThreeD.Types import Control.Lens (Iso', iso) import Diagrams.Angle -import Diagrams.Coordinates import Diagrams.Core import Diagrams.Points -import Data.AffineSpace.Point -import Data.Basis -import Data.Cross -import Data.Typeable -import Data.VectorSpace +import Linear.V3 as V +import Linear.Affine +import Linear.Metric +import Diagrams.Coordinates +import Control.Lens (_1, _2) ------------------------------------------------------------ -- 3D Euclidean space -type R3Basis = Either () (Either () ()) - -- Basic R3 types -type ScalarR3Ish d = (Ord d, Scalar d ~ d, InnerSpace d, RealFloat d) -type R3Ish v = (HasBasis v, Basis v ~ R3Basis, Coordinates v, Coordinates (PrevDim v), PrevDim (PrevDim v) ~ Scalar v, FinalCoord (PrevDim v) ~ Scalar v, FinalCoord v ~ Scalar v, Decomposition v ~ (Scalar v :& Scalar v :& Scalar v), v ~ V v, Typeable v, ScalarR3Ish (Scalar v), Transformable v, InnerSpace v, HasCross3 v, HasX v, HasY v, HasZ v, HasTheta v, Cylindrical v) +-- type R3 = V3 +type P3 = Point V3 -r3Iso :: (R3Ish v) => Iso' v (Scalar v, Scalar v, Scalar v) +r3Iso :: Iso' (V3 n) (n, n, n) r3Iso = iso unr3 r3 -- | Construct a 3D vector from a triple of components. -r3 :: (R3Ish v) => (Scalar v, Scalar v, Scalar v) -> v -r3 (x,y,z) = x ^& y ^& z +r3 :: (n, n, n) -> V3 n +r3 (x,y,z) = V3 x y z -- | Curried version of `r3`. -mkR3 :: (R3Ish v) => Scalar v -> Scalar v -> Scalar v -> v -mkR3 x y z = x ^& y ^& z +mkR3 :: n -> n -> n -> V3 n +mkR3 = V3 -- | Convert a 3D vector back into a triple of components. -unr3 :: (R3Ish v) => v -> (Scalar v, Scalar v, Scalar v) -unr3 (coords -> (coords -> x :& y) :& z) = (x,y,z) +unr3 :: V3 n -> (n, n, n) +unr3 (V3 x y z) = (x,y,z) -- | Construct a 3D point from a triple of coordinates. -p3 :: (R3Ish v) => (Scalar v, Scalar v, Scalar v) -> Point v +p3 :: (n, n, n) -> P3 n p3 = P . r3 -- | Convert a 3D point back into a triple of coordinates. -unp3 :: (R3Ish v) => Point v -> (Scalar v, Scalar v, Scalar v) -unp3 = unr3 . unPoint +unp3 :: P3 n -> (n, n, n) +unp3 (P (V3 x y z)) = (x,y,z) -p3Iso :: (R3Ish v) => Iso' (Point v) (Scalar v, Scalar v, Scalar v) +p3Iso :: Iso' (P3 n) (n, n, n) p3Iso = iso unp3 p3 -- | Curried version of `r3`. -mkP3 :: (R3Ish v) => Scalar v -> Scalar v -> Scalar v -> Point v +mkP3 :: n -> n -> n -> P3 n mkP3 x y z = p3 (x, y, z) -- | Types which can be expressed in spherical 3D coordinates, as a -- triple (r,θ,φ), where θ is rotation about the Z axis, and φ is the -- angle from the Z axis. -class Spherical t where - spherical :: Iso' t (Scalar (V t), Angle (Scalar (V t)), Angle (Scalar (V t))) +class Spherical v where + spherical :: RealFloat n => Iso' (v n) (n, Angle n, Angle n) -- | Types which can be expressed in cylindrical 3D coordinates. -class Cylindrical t where - cylindrical :: Iso' t (Scalar (V t), Angle (Scalar (V t)), Scalar (V t)) -- r, θ, z +class Cylindrical v where + cylindrical :: Floating n => Iso' (v n) (n, Angle n, n) -- r, θ, z -instance (Cylindrical v, v ~ V v) => Cylindrical (Point v) where +instance Cylindrical v => Cylindrical (Point v) where cylindrical = _pIso . cylindrical -instance (Spherical v, v ~ V v) => Spherical (Point v) where +instance Spherical v => Spherical (Point v) where spherical = _pIso . spherical +instance HasX V3 where + _x = V._x + +instance HasY V3 where + _y = V._y + +instance HasZ V3 where + _z = V._z + +type instance V (V3 n) = V3 +type instance N (V3 n) = n + +instance Transformable (V3 n) where + transform = apply + +instance Cylindrical V3 where + cylindrical = iso + (\(V3 x y z) -> (sqrt (sq x + sq y), atanA (y/x), z)) + (\(r,θ,z) -> V3 (r*cosA θ) (r*sinA θ) z) + where sq x = x * x + +instance Spherical V3 where + spherical = iso + (\v@(V3 x y z) -> (norm v, atan2A y x, acosA (z / norm v))) + (\(r,θ,φ) -> V3 (r * cosA θ * sinA φ) (r * sinA θ * sinA φ) (r * cosA φ)) + + -- spherical = iso + -- (\v@(R3 x y z) -> (magnitude v, atanA (y/x), atanA (v^._r/z))) + -- (\(r,θ,φ) -> R3 (r*cosA θ*sinA φ) (r*sinA θ*sinA φ) (r*cosA φ)) + +-- We'd like to write: instance Spherical t => HasR t +-- But GHC can't work out that the instance won't overlap. Just write them explicitly: + +-- instance HasR V3 where +-- _r = spherical . _1 + +instance HasTheta V3 where + _theta = cylindrical . _2 + +-- instance HasPhi V3 where +-- _phi = spherical . _3 diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index ca325698..309f3770 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -13,33 +13,18 @@ ----------------------------------------------------------------------------- module Diagrams.ThreeD.Vector ( -- * Special 2D vectors - unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, + unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, unit, unit_ ) where import Diagrams.Coordinates -import Diagrams.ThreeD.Types +import Diagrams.TwoD.Vector - --- | The unit vector in the positive X direction. -unitX :: (R3Ish v) => v -unitX = 1 ^& 0 ^& 0 +import Linear.Vector hiding (unit) -- | The unit vector in the positive Y direction. -unitY :: (R3Ish v) => v -unitY = 0 ^& 1 ^& 0 - --- | The unit vector in the positive Z direction. -unitZ :: (R3Ish v) => v -unitZ = 0 ^& 0 ^& 1 +unitZ :: (HasZ v, Additive v, Floating n) => v n +unitZ = unit _y -- | The unit vector in the negative X direction. -unit_X :: (R3Ish v) => v -unit_X = (-1) ^& 0 ^& 0 - --- | The unit vector in the negative Y direction. -unit_Y :: (R3Ish v) => v -unit_Y = 0 ^& (-1) ^& 0 - --- | The unit vector in the negative Z direction. -unit_Z :: (R3Ish v) => v -unit_Z = 0 ^& 0 ^& (-1) +unit_Z :: (HasZ v, Additive v, Floating n) => v n +unit_Z = unit_ _z diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 42665fc2..465a0dcb 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -381,7 +381,7 @@ instance (OrderedField n, Metric v) => Semigroup (Trail' Line v n) where -- | The empty trail is constantly the zero vector. Trails are -- composed via concatenation. Note that only lines have a monoid -- instance (and not loops). -instance (OrderedField n, Metric v) => Monoid (Trail' Line v n) where +instance (Metric v, OrderedField n) => Monoid (Trail' Line v n) where mempty = emptyLine mappend = (<>) @@ -1185,3 +1185,4 @@ reverseLoop = glueLine . reverseLine . cutLoop reverseLocLoop :: (Metric v, OrderedField n) => Located (Trail' Loop v n) -> Located (Trail' Loop v n) reverseLocLoop = mapLoc reverseLoop + diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs index 21610041..a1a7c1fb 100644 --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -61,13 +61,13 @@ import Diagrams.Trail -- course call 'trailLike' directly; more typically, one would use -- one of the provided functions like 'fromOffsets', 'fromVertices', -- 'fromSegments', or '~~'. -class (InnerSpace (V t), OrderedField (Scalar (V t))) => TrailLike t where +class (Metric (V t), OrderedField (N t)) => TrailLike t where trailLike - :: Located (Trail (V t)) -- ^ The concretely located trail. Note - -- that some trail-like things - -- (e.g. 'Trail's) may ignore the - -- location. + :: Located (Trail (V t) (N t)) -- ^ The concretely located trail. Note + -- that some trail-like things + -- (e.g. 'Trail's) may ignore the + -- location. -> t ------------------------------------------------------------ @@ -75,22 +75,22 @@ class (InnerSpace (V t), OrderedField (Scalar (V t))) => TrailLike t where -- | A list of points is trail-like; this instance simply -- computes the vertices of the trail, using 'trailPoints'. -instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike [Point v] where +instance (Metric v, OrderedField n) => TrailLike [Point v n] where trailLike = trailPoints -- | Lines are trail-like. If given a 'Trail' which contains a loop, -- the loop will be cut with 'cutLoop'. The location is ignored. -instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail' Line v) where +instance (Metric v, OrderedField n) => TrailLike (Trail' Line v n) where trailLike = withTrail id cutLoop . unLoc -- | Loops are trail-like. If given a 'Trail' containing a line, the -- line will be turned into a loop using 'glueLine'. The location -- is ignored. -instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail' Loop v) where +instance (Metric v, OrderedField n) => TrailLike (Trail' Loop v n) where trailLike = withTrail glueLine id . unLoc -- | 'Trail's are trail-like; the location is simply ignored. -instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail v) where +instance (Metric v, OrderedField n) => TrailLike (Trail v n) where trailLike = unLoc -- | Translationally invariant things are trail-like as long as the @@ -119,11 +119,11 @@ instance TrailLike t => TrailLike (Located t) where -- > , straight unit_X -- > ] -- > # centerXY # pad 1.1 -fromSegments :: TrailLike t => [Segment Closed (V t)] -> t +fromSegments :: TrailLike t => [Segment Closed (V t) (N t)] -> t fromSegments = fromLocSegments . (`at` origin) -- | Construct a trail-like thing from a located list of segments. -fromLocSegments :: TrailLike t => Located [Segment Closed (V t)] -> t +fromLocSegments :: TrailLike t => Located [Segment Closed (V t) (N t)] -> t fromLocSegments = trailLike . mapLoc trailFromSegments -- | Construct a trail-like thing of linear segments from a list @@ -138,12 +138,12 @@ fromLocSegments = trailLike . mapLoc trailFromSegments -- > , unitX -- > ] -- > # centerXY # pad 1.1 -fromOffsets :: TrailLike t => [V t] -> t +fromOffsets :: TrailLike t => [VN t] -> t fromOffsets = trailLike . (`at` origin) . trailFromOffsets -- | Construct a trail-like thing of linear segments from a located -- list of offsets. -fromLocOffsets :: (V (V t) ~ V t, TrailLike t) => Located [V t] -> t +fromLocOffsets :: (V (V t) ~ V t, TrailLike t) => Located [VN t] -> t fromLocOffsets = trailLike . mapLoc trailFromOffsets -- | Construct a trail-like thing connecting the given vertices with @@ -166,7 +166,7 @@ fromLocOffsets = trailLike . mapLoc trailFromOffsets -- > # fromVertices -- > # closeTrail # strokeTrail -- > # centerXY # pad 1.1 -fromVertices :: TrailLike t => [Point (V t)] -> t +fromVertices :: TrailLike t => [Point (V t) (N t)] -> t fromVertices [] = trailLike (emptyTrail `at` origin) fromVertices ps@(p:_) = trailLike (trailFromSegments (segmentsFromVertices ps) `at` p) @@ -181,7 +181,7 @@ segmentsFromVertices vvs@(_:vs) = map straight (zipWith (flip (.-.)) vvs vs) -- > twiddleEx -- > = mconcat ((~~) <$> hexagon 1 <*> hexagon 1) -- > # centerXY # pad 1.1 -(~~) :: TrailLike t => Point (V t) -> Point (V t) -> t +(~~) :: TrailLike t => Point (V t) (N t) -> Point (V t) (N t) -> t p1 ~~ p2 = fromVertices [p1, p2] -- | Given a concretely located trail, \"explode\" it by turning each @@ -195,7 +195,7 @@ p1 ~~ p2 = fromVertices [p1, p2] -- > # explodeTrail -- generate a list of diagrams -- > # zipWith lc [orange, green, yellow, red, blue] -- > # mconcat # centerXY # pad 1.1 -explodeTrail :: (VectorSpace (V t), TrailLike t) => Located (Trail (V t)) -> [t] +explodeTrail :: (VN ~ v n, Additive v, TrailLike t) => Located (Trail v n) -> [t] explodeTrail = map (mkTrail . fromFixedSeg) . fixTrail where mkTrail = trailLike . mapLoc (trailFromSegments . (:[])) diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs index b3c379d9..f9c89812 100644 --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -32,13 +32,14 @@ module Diagrams.Transform ) where -import Data.Semigroup -import Diagrams.Core +import Data.Semigroup +import Diagrams.Core -- | Conjugate one transformation by another. @conjugate t1 t2@ is the -- transformation which performs first @t1@, then @t2@, then the -- inverse of @t1@. -conjugate :: HasLinearMap v => Transformation v -> Transformation v -> Transformation v +conjugate :: (HasLinearMap v, Num n, Functor v) + => Transformation v n -> Transformation v n -> Transformation v n conjugate t1 t2 = inv t1 <> t2 <> t1 -- | Carry out some transformation \"under\" another one: @f ``under`` @@ -54,5 +55,6 @@ conjugate t1 t2 = inv t1 <> t2 <> t1 -- @ -- -- for all transformations @t1@ and @t2@. -under :: (Transformable a, Transformable b, V a ~ V b) => (a -> b) -> Transformation (V a) -> a -> b +under :: (Transformable a, Transformable b, VN a ~ VN b, VN a ~ v n, Num n, Functor v) + => (a -> b) -> Transformation v n -> a -> b f `under` t = transform (inv t) . f . transform t diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index ce5cc5c4..e7435643 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -24,6 +24,7 @@ module Diagrams.TwoD.Size -- ** Specifying sizes , SizeSpec2D(..) , mkSizeSpec + , spec2D , requiredScaleT, requiredScale @@ -38,44 +39,46 @@ import Diagrams.TwoD.Vector import Control.Applicative (liftA2, (<$>)) import Control.Arrow ((&&&), (***)) import Data.Hashable (Hashable) -import Data.VectorSpace import GHC.Generics (Generic) +import Linear.Vector +import Control.Lens (Iso', iso) + ------------------------------------------------------------ -- Computing diagram sizes ------------------------------------------------------------ -- | Compute the width of an enveloped object. -width :: (Enveloped a, R2Ish (V a)) => a -> Scalar (V a) +width :: (VN a ~ V2 n, Enveloped a) => a -> n width = maybe 0 (negate . uncurry (-)) . extentX -- | Compute the height of an enveloped object. -height :: (Enveloped a, R2Ish (V a)) => a -> Scalar (V a) +height :: (VN a ~ V2 n, Enveloped a) => a -> n height = maybe 0 (negate . uncurry (-)) . extentY -- | Compute the width and height of an enveloped object. -size2D :: (Enveloped a, R2Ish (V a)) => a -> (Scalar (V a), Scalar (V a)) +size2D :: (VN a ~ V2 n, Enveloped a) => a -> (n, n) size2D = width &&& height -- | Compute the size of an enveloped object as a 'SizeSpec2D' value. -sizeSpec2D :: (Enveloped a, R2Ish (V a)) => a -> SizeSpec2D (Scalar (V a)) +sizeSpec2D :: (VN a ~ V2 n, Enveloped a) => a -> SizeSpec2D n sizeSpec2D = uncurry Dims . size2D -- | Compute the absolute x-coordinate range of an enveloped object in -- R2, in the form (lo,hi). Return @Nothing@ for objects with an -- empty envelope. -extentX :: (Enveloped a, R2Ish (V a)) => a -> Maybe (Scalar (V a), Scalar (V a)) +extentX :: (VN a ~ V2 n, Enveloped a) => a -> Maybe (n, n) extentX d = (\f -> (-f unit_X, f unitX)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the absolute y-coordinate range of an enveloped object in -- R2, in the form (lo,hi). -extentY :: (Enveloped a, R2Ish (V a)) => a -> Maybe (Scalar (V a), Scalar (V a)) +extentY :: (VN a ~ V2 n, Enveloped a) => a -> Maybe (n, n) extentY d = (\f -> (-f unit_Y, f unitY)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the point at the center (in the x- and y-directions) of a -- enveloped object. Return the origin for objects with an empty -- envelope. -center2D :: (Enveloped a, R2Ish (V a)) => a -> Point (V a) +center2D :: (VN a ~ V2 n, Enveloped a) => a -> Point V2 n center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) where mm = uncurry (liftA2 (,)) mid = (/2) . uncurry (+) @@ -85,22 +88,22 @@ center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) ------------------------------------------------------------ -- | A specification of a (requested) rectangular size. -data SizeSpec2D d = Width !d -- ^ Specify an explicit - -- width. The height should be - -- determined automatically (so - -- as to preserve aspect ratio). - | Height !d -- ^ Specify an explicit - -- height. The width should be - -- determined automatically (so - -- as to preserve aspect ratio). - | Dims !d !d -- ^ An explicit specification - -- of a width and height. - | Absolute -- ^ Absolute size: use whatever - -- size an object already has; - -- do not rescale. +data SizeSpec2D n = Width !n -- ^ Specify an explicit + -- width. The height should be + -- determined automatically (so + -- as to preserve aspect ratio). + | Height !n -- ^ Specify an explicit + -- height. The width should be + -- determined automatically (so + -- as to preserve aspect ratio). + | Dims !n !n -- ^ An explicit specification + -- of a width and height. + | Absolute -- ^ Absolute size: use whatever + -- size an object already has; + -- do not rescale. deriving (Eq, Ord, Show, Generic) -instance Hashable d => Hashable (SizeSpec2D d) +instance Hashable n => Hashable (SizeSpec2D n) -- | Create a size specification from a possibly-specified width and -- height. @@ -110,11 +113,22 @@ mkSizeSpec (Just w) Nothing = Width w mkSizeSpec Nothing (Just h) = Height h mkSizeSpec (Just w) (Just h) = Dims w h +-- | Isomorphism from 'SizeSpec2D' to @(Maybe width, Maybe height)@. +spec2D :: Iso' (SizeSpec2D n) (Maybe n, Maybe n) +spec2D = iso getter (uncurry mkSizeSpec) + where getter (Width w) = (Just w, Nothing) + getter (Height h) = (Nothing, Just h) + getter (Dims w h) = (Just w, Just h) + getter Absolute = (Nothing, Nothing) + -- | @requiredScaleT spec sz@ returns a transformation (a uniform scale) -- which can be applied to something of size @sz@ to make it fit the -- requested size @spec@, without changing the aspect ratio. -requiredScaleT :: (R2Ish v, Scalar v ~ d) => SizeSpec2D d -> (d, d) -> Transformation v +requiredScaleT + :: (Additive v, RealFloat n) + => SizeSpec2D n -> (n, n) -> Transformation v n requiredScaleT spec size = scaling (requiredScale spec size) +-- is requiredScaling a more consistent name? -- | @requiredScale spec sz@ returns a scaling factor necessary to -- make something of size @sz@ fit the requested size @spec@, @@ -139,16 +153,15 @@ requiredScale (Dims wSpec hSpec) (w,h) = s -- | Uniformly scale any enveloped object so that it fits within the -- given size. -sized :: (Transformable a, Enveloped a, R2Ish (V a)) - => SizeSpec2D (Scalar (V a)) -> a -> a +sized :: (VN a ~ V2 n, Transformable a, Enveloped a, RealFloat n) + => SizeSpec2D n -> a -> a sized spec a = transform (requiredScaleT spec (size2D a)) a -- | Uniformly scale an enveloped object so that it \"has the same -- size as\" (fits within the width and height of) some other -- object. -sizedAs :: ( Transformable a, Enveloped a, Enveloped b - , R2Ish (V a), V a ~ V b - ) +sizedAs :: (VN a ~ V2 n, VN a ~ VN b, Transformable a, + Enveloped a, Enveloped b, RealFloat n) => b -> a -> a sizedAs other = sized (sizeSpec2D other) @@ -158,3 +171,4 @@ sizePair (Width w') = (w',w') sizePair (Height h') = (h',h') sizePair (Dims w' h') = (w',h') sizePair Absolute = (100,100) + diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 8a957429..99b9da10 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -48,35 +48,37 @@ module Diagrams.TwoD.Transform , shearingY, shearY -- * Utilities - , onBasis + -- , onBasis ) where import Diagrams.Core -import qualified Diagrams.Core.Transform as T import Diagrams.Angle import Diagrams.Transform import Diagrams.TwoD.Size (height, width) import Diagrams.TwoD.Types -import Control.Lens (review, (^.)) -import Data.AdditiveGroup -import Data.AffineSpace +import Control.Lens (review, (^.), (*~), (//~), (&), (.~)) import Data.Semigroup -import Data.VectorSpace -type T = Transformation -type P = Point +import Diagrams.Coordinates +import Linear.V2 hiding (_x, _y, angle) +import Linear.Vector +import Linear.Affine + + + +type T2 = Transformation V2 -- Rotation ------------------------------------------------ -- | Create a transformation which performs a rotation about the local -- origin by the given angle. See also 'rotate'. -rotation :: (R2Ish v) => Angle (Scalar v) -> T v +rotation :: Floating n => Angle n -> T2 n rotation ang = fromLinear r (linv r) where - r = rot theta <-> rot (-theta) - theta = ang^.rad + r = rot theta <-> rot (-theta) + theta = ang^.rad rot th (unr2 -> (x,y)) = mkR2 (cos th * x - sin th * y) (sin th * x + cos th * y) -- | Rotate about the local origin by the given angle. Positive angles @@ -92,170 +94,179 @@ rotation ang = fromLinear r (linv r) -- will yield an error since GHC cannot figure out which sort of -- angle you want to use. In this common situation you can use -- 'rotateBy', which interprets its argument as a number of turns. -rotate :: (R2Ish (V t), Transformable t) => Angle (Scalar (V t)) -> t -> t +rotate :: (VN t ~ V2 n, Transformable t, Floating n) => Angle n -> t -> t rotate = transform . rotation -- | A synonym for 'rotate', interpreting its argument in units of -- turns; it can be more convenient to write @rotateBy (1\/4)@ than -- @'rotate' (1\/4 \@\@ 'turn')@. -rotateBy :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t +rotateBy :: (VN t ~ V2 n, Transformable t, Floating n) => n -> t -> t rotateBy = transform . rotation . review turn -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). -rotationAbout :: (R2Ish v) => P v -> Angle (Scalar v) -> T v +rotationAbout :: Floating n => P2 n -> Angle n -> T2 n rotationAbout p angle = conjugate (translation (origin .-. p)) (rotation angle) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. -rotateAbout :: (R2Ish (V t), Transformable t) => P (V t) -> Angle (Scalar (V t)) -> t -> t +rotateAbout :: (VN t ~ V2 n, Transformable t, Floating n) => P2 n -> Angle n -> t -> t rotateAbout p angle = rotate angle `under` translation (origin .-. p) -- Scaling ------------------------------------------------- -- | Construct a transformation which scales by the given factor in -- the x (horizontal) direction. -scalingX :: (R2Ish v) => Scalar v -> T v +scalingX :: (HasX v, Additive v, Floating n) => n -> Transformation v n scalingX c = fromLinear s s - where s = (\(unr2 -> (x,y)) -> mkR2 (x*c) y) <-> (\(unr2 -> (x,y)) -> mkR2 (x/c) y) + where s = (_x *~ c) <-> (_x //~ c) -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. -scaleX :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t +scaleX :: (VN t ~ v n, Transformable t, HasX v, Additive v, Floating n) + => n -> t -> t scaleX = transform . scalingX -- | Construct a transformation which scales by the given factor in -- the y (vertical) direction. -scalingY :: (R2Ish v) => Scalar v -> T v +scalingY :: (HasY v, Additive v, Floating n) => n -> Transformation v n scalingY c = fromLinear s s - where s = (\(unr2 -> (x,y)) -> mkR2 x (y*c)) <-> (\(unr2 -> (x,y)) -> mkR2 x (y/c)) + where s = (_y *~ c) <-> (_y //~ c) -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. -scaleY :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t +scaleY :: (VN t ~ v n, Transformable t, HasY v, Additive v, Floating n) + => n -> t -> t scaleY = transform . scalingY -- | @scaleToX w@ scales a diagram in the x (horizontal) direction by -- whatever factor required to make its width @w@. @scaleToX@ -- should not be applied to diagrams with a width of 0, such as -- 'vrule'. -scaleToX :: (R2Ish (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t +scaleToX :: (VN t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t scaleToX w d = scaleX (w / width d) d -- | @scaleToY h@ scales a diagram in the y (vertical) direction by -- whatever factor required to make its height @h@. @scaleToY@ -- should not be applied to diagrams with a height of 0, such as -- 'hrule'. -scaleToY :: (R2Ish (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t +scaleToY :: (VN t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t scaleToY h d = scaleY (h / height d) d -- | @scaleUToX w@ scales a diagram /uniformly/ by whatever factor -- required to make its width @w@. @scaleUToX@ should not be -- applied to diagrams with a width of 0, such as 'vrule'. -scaleUToX :: (R2Ish (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t +scaleUToX :: (VN t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t scaleUToX w d = scale (w / width d) d -- | @scaleUToY h@ scales a diagram /uniformly/ by whatever factor -- required to make its height @h@. @scaleUToY@ should not be applied -- to diagrams with a height of 0, such as 'hrule'. -scaleUToY :: (R2Ish (V t), Enveloped t, Transformable t) => Scalar (V t) -> t -> t +scaleUToY :: (VN t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t scaleUToY h d = scale (h / height d) d -- Translation --------------------------------------------- -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. -translationX :: (R2Ish v) => Scalar v -> T v -translationX x = translation (mkR2 x 0) +translationX :: (HasX v, Additive v, Floating n) => n -> Transformation v n +translationX x = translation (zero & _x .~ x) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. -translateX :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t +translateX :: (VN t ~ v n, Transformable t, HasX v, Additive v, Floating n) + => n -> t -> t translateX = transform . translationX -- | Construct a transformation which translates by the given distance -- in the y (vertical) direction. -translationY :: (R2Ish v) => Scalar v -> T v -translationY y = translation (mkR2 0 y) +translationY :: (HasY v, Additive v, Floating n) => n -> Transformation v n +translationY y = translation (zero & _y .~ y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. -translateY :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t +translateY :: (VN t ~ v n, Transformable t, HasY v, Additive v, Floating n) + => n -> t -> t translateY = transform . translationY -- Reflection ---------------------------------------------- -- | Construct a transformation which flips a diagram from left to -- right, i.e. sends the point (x,y) to (-x,y). -reflectionX :: (R2Ish v) => T v +reflectionX :: (HasX v, Additive v, Floating n) => Transformation v n reflectionX = scalingX (-1) -- | Flip a diagram from left to right, i.e. send the point (x,y) to -- (-x,y). -reflectX :: (R2Ish (V t), Transformable t) => t -> t +reflectX :: (VN t ~ v n, Transformable t, HasX v, Additive v, Floating n) => t -> t reflectX = transform reflectionX -- | Construct a transformation which flips a diagram from top to -- bottom, i.e. sends the point (x,y) to (x,-y). -reflectionY :: (R2Ish v) => T v +reflectionY :: (HasY v, Additive v, Floating n) => Transformation v n reflectionY = scalingY (-1) -- | Flip a diagram from top to bottom, i.e. send the point (x,y) to -- (x,-y). -reflectY :: (R2Ish (V t), Transformable t) => t -> t +reflectY :: (VN t ~ v n, Transformable t, HasY v, Additive v, Floating n) + => t -> t reflectY = transform reflectionY -- | @reflectionAbout p v@ is a reflection in the line determined by -- the point @p@ and vector @v@. -reflectionAbout :: (R2Ish v) => P v -> v -> T v +reflectionAbout :: RealFloat n => P2 n -> V2 n -> T2 n reflectionAbout p v = - conjugate (rotation (negateV $ v^._theta) <> translation (origin .-. p)) + conjugate (rotation (negated $ v ^. _theta) <> translation (origin .-. p)) reflectionY -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. -reflectAbout :: (R2Ish (V t), Transformable t) => P (V t) -> (V t) -> t -> t +reflectAbout :: (VN t ~ V2 n, Transformable t, RealFloat n) => P2 n -> V2 n -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Shears -------------------------------------------------- -- auxiliary functions for shearingX/shearingY -sh :: (R2Ish v, s ~ Scalar v) => (s -> s -> s -> s) -> (s -> s -> s -> s) -> s -> v -> v -sh f g k (unr2 -> (x,y)) = mkR2 (f k x y) (g k x y) +sh :: (n -> n -> n -> n) -> (n -> n -> n -> n) -> n -> V2 n -> V2 n +sh f g k (V2 x y) = V2 (f k x y) (g k x y) -sh' :: (R2Ish v, s ~ Scalar v) => (s -> s -> s -> s) -> (s -> s -> s -> s) -> s -> v -> v +sh' :: (n -> n -> n -> n) -> (n -> n -> n -> n) -> n -> V2 n -> V2 n sh' f g k = swap . sh f g k . swap -swap :: (R2Ish v) => v -> v -swap (unr2 -> (x,y)) = mkR2 y x +swap :: V2 n -> V2 n +swap (V2 x y) = V2 y x -- | @shearingX d@ is the linear transformation which is the identity on -- y coordinates and sends @(0,1)@ to @(d,1)@. -shearingX :: (R2Ish v) => Scalar v -> T v +shearingX :: Num n => n -> T2 n shearingX d = fromLinear (sh f g d <-> sh f g (-d)) (sh' f g d <-> sh' f g (-d)) - where f k x y = (x+k*y); g _ _ y = y + where + f k x y = x + k*y + g _ _ y = y -- | @shearX d@ performs a shear in the x-direction which sends -- @(0,1)@ to @(d,1)@. -shearX :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t +shearX :: (VN t ~ V2 n, Transformable t, Num n) => n -> t -> t shearX = transform . shearingX -- | @shearingY d@ is the linear transformation which is the identity on -- x coordinates and sends @(1,0)@ to @(1,d)@. -shearingY :: (R2Ish v) => Scalar v -> T v +shearingY :: Num n => n -> T2 n shearingY d = fromLinear (sh f g d <-> sh f g (-d)) (sh' f g d <-> sh' f g (-d)) - where f _ x _ = x; g k x y = (y+k*x) + where + f _ x _ = x + g k x y = y + k*x -- | @shearY d@ performs a shear in the y-direction which sends -- @(1,0)@ to @(1,d)@. -shearY :: (R2Ish (V t), Transformable t) => Scalar (V t) -> t -> t +shearY :: (VN t ~ V2 n, Transformable t, Num n) => n -> t -> t shearY = transform . shearingY -- | Get the matrix equivalent of the linear transform, -- (as a pair of columns) and the translation vector. This -- is mostly useful for implementing backends. -onBasis :: (R2Ish v) => T v -> ((v, v), v) -onBasis t = ((x, y), v) - where (x:y:[], v) = T.onBasis t +-- onBasis :: T v -> ((v, v), v) +-- onBasis t = ((x, y), v) +-- where (x:y:[], v) = T.onBasis t diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 02a084a1..3675c37b 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -26,17 +26,17 @@ module Diagrams.TwoD.Transform.ScaleInv where import Control.Lens (makeLenses, view, (^.)) -import Data.AdditiveGroup -import Data.AffineSpace ((.-.)) import Data.Semigroup import Data.Typeable -import Data.VectorSpace import Diagrams.Angle import Diagrams.Core import Diagrams.TwoD.Transform import Diagrams.TwoD.Types +import Linear.Vector +import Linear.Affine + -- | The @ScaleInv@ wrapper creates two-dimensional /scale-invariant/ -- objects. Intuitively, a scale-invariant object is affected by -- transformations like translations and rotations, but not by scales. @@ -71,35 +71,39 @@ import Diagrams.TwoD.Types data ScaleInv t = ScaleInv { _scaleInvObj :: t - , _scaleInvDir :: V t - , _scaleInvLoc :: Point (V t) + , _scaleInvDir :: VN t + , _scaleInvLoc :: Point (V t) (N t) } - deriving (Typeable) + deriving Typeable -deriving instance (Show t, Show (V t)) => Show (ScaleInv t) +deriving instance (Show t, Show (VN t)) => Show (ScaleInv t) makeLenses ''ScaleInv -- | Create a scale-invariant object pointing in the given direction, -- located at the origin. -scaleInv :: (AdditiveGroup (V t)) => t -> V t -> ScaleInv t +scaleInv :: (VN t ~ v n, Additive v, Num n) => t -> v n -> ScaleInv t scaleInv t d = ScaleInv t d origin type instance V (ScaleInv t) = V t +type instance N (ScaleInv t) = N t -instance (HasOrigin t) => HasOrigin (ScaleInv t) where +instance (VN t ~ v n, Additive v, Num n, HasOrigin t) => HasOrigin (ScaleInv t) where moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) -instance (R2Ish (V t), Transformable t) => Transformable (ScaleInv t) where +instance (VN t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv t) where transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where - angle :: Angle (Scalar (V (ScaleInv t))) + -- angle :: Angle n angle = transform tr v ^. _theta - rot :: (V k ~ V t, Transformable k) => k -> k + + rot :: (VN k ~ VN t, Transformable k) => k -> k rot = rotateAbout l angle - l' :: Point (V (ScaleInv t)) + + -- l' :: Point V2 n l' = transform tr l - trans :: (V k ~ V t, Transformable k) => k -> k + + -- trans :: (VN k ~ VN t, Transformable k) => k -> k trans = translate (l' .-. l) {- Proof that the above satisfies the monoid action laws. @@ -161,7 +165,7 @@ instance (R2Ish (V t), Transformable t) => Transformable (ScaleInv t) where -} -instance (R2Ish (V t), Renderable t b) => Renderable (ScaleInv t) b where +instance (VN t ~ V2 n, RealFloat n, Renderable t b) => Renderable (ScaleInv t) b where render b = render b . view scaleInvObj -- | Create a diagram from a single scale-invariant primitive. The @@ -179,6 +183,6 @@ instance (R2Ish (V t), Renderable t b) => Renderable (ScaleInv t) b where -- scale-invariant things will be used only as \"decorations\" (/e.g./ -- arrowheads) which should not affect the envelope, trace, and -- query. -scaleInvPrim :: (Transformable t, Typeable t, R2Ish (V t), Renderable t b, Monoid m) - => t -> V t -> QDiagram b (V t) m +scaleInvPrim :: (VN t ~ V2 n, RealFloat n, Transformable t, Typeable t, Renderable t b, Monoid m) + => t -> V2 n -> QDiagram b (V t) (N t) m scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index aa7ee304..67a4186d 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -1,15 +1,7 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Types @@ -23,77 +15,88 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space - r2, unr2, mkR2, r2Iso + V2 (..), R2, P2, r2, unr2, mkR2, r2Iso , p2, mkP2, unp2, p2Iso - , R2Basis(..) - , R2Ish, R2D - , ScalarR2Ish , Polar(..) ) where -import Control.Lens (Iso', iso) - +import Control.Lens (Iso', iso, _2) import Diagrams.Angle -import Diagrams.Coordinates +-- import Diagrams.Coordinates import Diagrams.Points -import Diagrams.Core -import Data.AffineSpace.Point -import Data.Basis -import Data.MemoTrie (HasTrie (..)) -import Data.VectorSpace +import Linear.Affine +import Linear.Metric +import Linear.V2 hiding (R2) +import qualified Linear.V2 as V +import Diagrams.Coordinates +import Diagrams.Core.V +import Diagrams.Core.Transform -import Data.Data +type R2 = V2 +type P2 = Point V2 --- | Basis for 2D Euclidean space -data R2Basis = XB | YB deriving (Eq, Ord, Enum, Typeable, Show) +type instance V (V2 n) = V2 +type instance N (V2 n) = n -instance HasTrie R2Basis where - data R2Basis :->: x = R2Trie x x - trie f = R2Trie (f XB) (f YB) - untrie (R2Trie x _y) XB = x - untrie (R2Trie _x y) YB = y - enumerate (R2Trie x y) = [(XB,x),(YB,y)] +-- type ScalarR2Ish d = (RealFloat d, VectorSpace d, HasBasis d, Basis d ~ (), Transformable d, Scalar d ~ d, V d ~ d, Typeable d) +-- type R2Ish v = (HasBasis v, Basis v ~ R2Basis, V v ~ v, Transformable v, InnerSpace v, Coordinates v, Decomposition v ~ (FinalCoord v :& FinalCoord v), PrevDim v ~ FinalCoord v, FinalCoord v ~ Scalar v, HasX v, HasY v, ScalarR2Ish (Scalar v), HasTheta v, Typeable v) -type ScalarR2Ish d = (RealFloat d, VectorSpace d, HasBasis d, Basis d ~ (), Transformable d, Scalar d ~ d, V d ~ d, Typeable d) -type R2Ish v = (HasBasis v, Basis v ~ R2Basis, V v ~ v, Transformable v, InnerSpace v, Coordinates v, Decomposition v ~ (FinalCoord v :& FinalCoord v), PrevDim v ~ FinalCoord v, FinalCoord v ~ Scalar v, HasX v, HasY v, ScalarR2Ish (Scalar v), HasTheta v, Typeable v) - -type R2D v = (R2Ish v, Data v, Data (Scalar v)) +-- type R2D v = (R2Ish v, Data v, Data (Scalar v)) -- | Construct a 2D vector from a pair of components. See also '&'. -r2 :: (R2Ish v) => (Scalar v, Scalar v) -> v -r2 (x,y) = recompose [(XB,x),(YB,y)] +r2 :: (n, n) -> V2 n +r2 = uncurry V2 -- | Convert a 2D vector back into a pair of components. See also 'coords'. -unr2 :: (R2Ish v) => v -> (Scalar v, Scalar v) -unr2 v = (decompose' v XB, decompose' v YB) +unr2 :: V2 n -> (n, n) +unr2 (V2 x y) = (x, y) -- | Curried form of `r2`. -mkR2 :: (R2Ish v) => Scalar v -> Scalar v -> v -mkR2 = curry r2 +mkR2 :: n -> n -> V2 n +mkR2 = V2 -r2Iso :: (R2Ish v) => Iso' v (Scalar v, Scalar v) +r2Iso :: Iso' (V2 n) (n, n) r2Iso = iso unr2 r2 -- | Construct a 2D point from a pair of coordinates. See also '^&'. -p2 :: (R2Ish v) => (Scalar v, Scalar v) -> Point v -p2 = P . r2 +p2 :: (n, n) -> P2 n +p2 = P . uncurry V2 -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. -unp2 :: (R2Ish v) => Point v -> (Scalar v, Scalar v) -unp2 (P v) = unr2 v +unp2 :: P2 n -> (n,n) +unp2 (P (V2 x y)) = (x,y) -- | Curried form of `p2`. -mkP2 :: (R2Ish v) => Scalar v -> Scalar v -> Point v -mkP2 = curry p2 +mkP2 :: n -> n -> P2 n +mkP2 x = P . V2 x -p2Iso :: (R2Ish v) => Iso' (Point v) (Scalar v, Scalar v) +p2Iso :: Iso' (Point V2 n) (n, n) p2Iso = iso unp2 p2 -- | Types which can be expressed in polar 2D coordinates, as a magnitude and an angle. class Polar t where - polar :: Iso' t (Scalar (V t), Angle (Scalar (V t))) + polar :: RealFloat n => Iso' (t n) (n, Angle n) + +instance Polar v => Polar (Point v) where + polar = _pIso . polar + +-- TODO: coordinate instance for V2 + +instance Transformable (V2 n) where + transform = apply + +instance HasX V2 where + _x = V._x + +instance HasY V2 where + _y = V._y + +instance Polar V2 where + polar = iso (\v@(V2 x y) -> (norm v, atan2A y x)) + (\(r,θ) -> V2 (r * cosA θ) (r * sinA θ)) + +instance HasTheta V2 where + _theta = polar . _2 -instance (Polar v, v ~ V v) => Polar (Point v) where - polar = _pIso . polar diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index a45330ee..11e8dca2 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Vector @@ -15,6 +12,7 @@ module Diagrams.TwoD.Vector ( -- * Special 2D vectors unitX, unitY, unit_X, unit_Y + , unit, unit_ -- * Converting between vectors and angles , e, xDir @@ -24,48 +22,57 @@ module Diagrams.TwoD.Vector -- * Synonym for R2 things ) where -import Control.Lens ((&), (.~)) - -import Data.VectorSpace +import Control.Lens ((&), (.~), set', ASetter') import Diagrams.Angle -import Diagrams.Core.V import Diagrams.Direction -import Diagrams.TwoD.Types + +import Linear.Vector hiding (unit) +import Linear.V2 hiding (_x,_y) +import Linear.Metric +import Diagrams.Coordinates + +unit :: (Additive v, Num n) => ASetter' (v n) n -> v n +unit l = set' l 1 zero + +unit_ :: (Additive v, Num n) => ASetter' (v n) n -> v n +unit_ l = set' l (-1) zero + -- | The unit vector in the positive X direction. -unitX :: (R2Ish v) => v -unitX = mkR2 1 0 +unitX :: (HasX v, Additive v, Floating n) => v n +unitX = unit _x -- | The unit vector in the positive Y direction. -unitY :: (R2Ish v) => v -unitY = mkR2 0 1 +unitY :: (HasY v, Additive v, Floating n) => v n +unitY = unit _y -- | The unit vector in the negative X direction. -unit_X :: (R2Ish v) => v -unit_X = mkR2 (-1) 0 +unit_X :: (HasX v, Additive v, Floating n) => v n +unit_X = unit_ _x -- | The unit vector in the negative Y direction. -unit_Y :: (R2Ish v) => v -unit_Y = mkR2 0 (-1) +unit_Y :: (HasY v, Additive v, Floating n) => v n +unit_Y = unit_ _y -- | The origin of the direction AffineSpace. For all d, @d .-. xDir -- = d^._theta@. -xDir :: (R2Ish v) => Direction v +xDir :: (HasX v, Additive v, Floating n) => Direction v n xDir = direction unitX -- | A unit vector at a specified angle counterclockwise from the -- positive X axis. -e :: (R2Ish v) => Angle (Scalar (V v)) -> v +e :: (HasTheta v, HasX v, Additive v, RealFloat n) => Angle n -> v n e a = unitX & _theta .~ a --- | @perp v@ is perpendicular to and has the same magnitude as @v@. --- In particular @perp v == rotateBy (1/4) v@. -perp :: (R2Ish v) => v -> v -perp (unr2 -> (x,y)) = mkR2 (-y) x +-- -- | @perp v@ is perpendicular to and has the same magnitude as @v@. +-- -- In particular @perp v == rotateBy (1/4) v@. +-- perp :: Num n => V2 n -> V2 n +-- perp (V2 x y) = V2 (-y) x -- | @leftTurn v1 v2@ tests whether the direction of @v2@ is a left -- turn from @v1@ (that is, if the direction of @v2@ can be obtained -- from that of @v1@ by adding an angle 0 <= theta <= tau/2). -leftTurn :: (R2Ish v, Ord (Scalar v), InnerSpace v) => v -> v -> Bool -leftTurn v1 v2 = (v1 <.> perp v2) < 0 +leftTurn :: (Num n, Ord n) => V2 n -> V2 n -> Bool +leftTurn v1 v2 = (v1 `dot` perp v2) < 0 + From a267069a5f9d40454b0d4053433e85df7d0e7623 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Thu, 21 Aug 2014 15:33:31 +0100 Subject: [PATCH 22/58] Change VN to Vn. --- src/Diagrams/Angle.hs | 2 -- src/Diagrams/BoundingBox.hs | 4 +-- src/Diagrams/Direction.hs | 4 +-- src/Diagrams/Parametric/Adjust.hs | 2 +- src/Diagrams/Path.hs | 1 + src/Diagrams/ThreeD/Camera.hs | 20 +++++++-------- src/Diagrams/ThreeD/Types.hs | 7 +++--- src/Diagrams/TrailLike.hs | 6 ++--- src/Diagrams/Transform.hs | 2 +- src/Diagrams/TwoD/Path.hs | 1 + src/Diagrams/TwoD/Size.hs | 18 +++++++------- src/Diagrams/TwoD/Transform.hs | 33 ++++++++++++------------- src/Diagrams/TwoD/Transform/ScaleInv.hs | 18 +++++++------- 13 files changed, 58 insertions(+), 60 deletions(-) diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 7c4dcdfe..9a7a2966 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -66,8 +66,6 @@ instance Num n => Monoid (Angle n) where mappend = (<>) mempty = Radians 0 --- deriving instance InnerSpace v => InnerSpace (Angle v) - type instance N (Angle n) = n -- | The radian measure of an @Angle@ @a@ can be accessed as @a diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index 8b5ba59d..d7a320e6 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -132,7 +132,7 @@ fromPoints :: (Additive v, Ord n) => [Point v n] -> BoundingBox v n fromPoints = mconcat . map fromPoint -- | Create a bounding box for any enveloped object (such as a diagram or path). -boundingBox :: (VN a ~ v n, Enveloped a, HasLinearMap v, Num n) +boundingBox :: (Vn a ~ v n, Enveloped a, HasLinearMap v, Num n) => a -> BoundingBox v n boundingBox a = fromMaybeEmpty $ do env <- (appEnvelope . getEnvelope) a @@ -175,7 +175,7 @@ boxTransform u v = do -- | Transforms an enveloped thing to fit within a @BoundingBox@. If it's -- empty, then the result is also @mempty@. boxFit - :: (VN a ~ v n, Enveloped a, Transformable a, Monoid a, HasLinearMap v, Num n) + :: (Vn a ~ v n, Enveloped a, Transformable a, Monoid a, HasLinearMap v, Num n) => BoundingBox (V a) (N a) -> a -> a boxFit b x = maybe mempty (`transform` x) $ boxTransform (boundingBox x) b diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index 72272c52..9c8696d1 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -39,8 +39,8 @@ newtype Direction v n = Direction (v n) type instance V (Direction v n) = v type instance N (Direction v n) = n --- instance (Transformable v, VN (Direction v n) ~ v n) => Transformable (Direction v) where -instance (VN (v n) ~ v n, Transformable (v n)) => Transformable (Direction v n) where +-- instance (Transformable v, Vn (Direction v n) ~ v n) => Transformable (Direction v) where +instance (Vn (v n) ~ v n, Transformable (v n)) => Transformable (Direction v n) where transform t (Direction v) = Direction (transform t v) instance HasTheta v => HasTheta (Direction v) where diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs index 50d77a51..599c6526 100644 --- a/src/Diagrams/Parametric/Adjust.hs +++ b/src/Diagrams/Parametric/Adjust.hs @@ -85,7 +85,7 @@ instance Fractional n => Default (AdjustOpts v n) where -- | Adjust the length of a parametric object such as a segment or -- trail. The second parameter is an option record which controls how -- the adjustment should be performed; see 'AdjustOpts'. -adjust :: (VN a ~ v n, DomainBounds a, Sectionable a, HasArcLength a, Fractional n) +adjust :: (Vn a ~ v n, DomainBounds a, Sectionable a, HasArcLength a, Fractional n) => a -> AdjustOpts v n -> a adjust s opts = section s (if opts^.adjSide == End then domainLower s else getParam s) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 5a1278b4..e0e66e4c 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -220,3 +220,4 @@ scalePath d p = (scale d `under` translation (origin .-. pathCentroid p)) p -- | Reverse all the component trails of a path. reversePath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Path v reversePath = _Wrapped . mapped %~ reverseLocTrail + diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index 6468fea6..3c1895ca 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -47,13 +47,13 @@ import Linear.V3 -- lenses they handle. data Camera l = Camera { camLoc :: Point (V l) (N l) - , forward :: VN l - , up :: VN l + , forward :: Vn l + , up :: Vn l , lens :: l } deriving Typeable -class (Typeable l, Typeable (VN l)) => CameraLens l where +class (Typeable l, Typeable (Vn l)) => CameraLens l where -- | The natural aspect ratio of the projection. aspect :: l -> N l @@ -90,14 +90,14 @@ instance (Typeable n, Fractional n) => CameraLens (OrthoLens n) where type instance V (Camera l) = V l type instance N (Camera l) = N l -instance (VN l ~ V3 n, Num n) => Transformable (Camera l) where +instance (Vn l ~ V3 n, Num n) => Transformable (Camera l) where transform t (Camera p f u l) = Camera (transform t p) (transform t f) (transform t u) l -instance (VN l ~ V3 n, Num n) => Renderable (Camera l) NullBackend where +instance (Vn l ~ V3 n, Num n) => Renderable (Camera l) NullBackend where render _ _ = mempty -- | A camera at the origin facing along the negative Z axis, with its @@ -111,7 +111,7 @@ mm50Camera = facing_ZCamera mm50 -- | 'facing_ZCamera l' is a camera at the origin facing along the -- negative Z axis, with its up-axis coincident with the positive Y -- axis, with the projection defined by l. -facing_ZCamera :: (VN l ~ V3 n, Floating n, Ord n, CameraLens l, Backend b V3 n, Renderable (Camera l) b) => +facing_ZCamera :: (Vn l ~ V3 n, Floating n, Ord n, CameraLens l, Backend b V3 n, Renderable (Camera l) b) => l -> Diagram b V3 n facing_ZCamera l = mkQD (Prim $ Camera origin unit_Z unitY l) mempty mempty mempty (Query . const . Any $ False) @@ -130,20 +130,20 @@ mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) -- aspect ratio of 4:3, for VGA and similar computer resolutions. mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) -camForward :: (VN l ~ V3 n, Fractional n) => Camera l -> Direction V3 n +camForward :: (Vn l ~ V3 n, Fractional n) => Camera l -> Direction V3 n camForward = direction . forward -camUp :: (VN l ~ V3 n, Fractional n) => Camera l -> Direction V3 n +camUp :: (Vn l ~ V3 n, Fractional n) => Camera l -> Direction V3 n camUp = direction . up -camRight :: (VN l ~ V3 n, Fractional n) => Camera l -> Direction V3 n +camRight :: (Vn l ~ V3 n, Fractional n) => Camera l -> Direction V3 n camRight c = direction right where right = cross (forward c) (up c) camLens :: (V3 ~ V l) => Camera l -> l camLens = lens -camAspect :: (VN l ~ V3 n, CameraLens l) => Camera l -> n +camAspect :: (Vn l ~ V3 n, CameraLens l) => Camera l -> n camAspect = aspect . camLens {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 27619521..a3f36d8a 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -23,7 +23,7 @@ module Diagrams.ThreeD.Types , Spherical(..), Cylindrical(..), HasPhi(..) ) where -import Control.Lens (Iso', iso) +import Control.Lens (Iso', iso, _2) import Diagrams.Angle import Diagrams.Core @@ -33,7 +33,6 @@ import Linear.V3 as V import Linear.Affine import Linear.Metric import Diagrams.Coordinates -import Control.Lens (_1, _2) ------------------------------------------------------------ -- 3D Euclidean space @@ -84,10 +83,10 @@ class Cylindrical v where cylindrical :: Floating n => Iso' (v n) (n, Angle n, n) -- r, θ, z instance Cylindrical v => Cylindrical (Point v) where - cylindrical = _pIso . cylindrical + cylindrical = _pIso . cylindrical instance Spherical v => Spherical (Point v) where - spherical = _pIso . spherical + spherical = _pIso . spherical instance HasX V3 where _x = V._x diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs index a1a7c1fb..af3e56b6 100644 --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -138,12 +138,12 @@ fromLocSegments = trailLike . mapLoc trailFromSegments -- > , unitX -- > ] -- > # centerXY # pad 1.1 -fromOffsets :: TrailLike t => [VN t] -> t +fromOffsets :: TrailLike t => [Vn t] -> t fromOffsets = trailLike . (`at` origin) . trailFromOffsets -- | Construct a trail-like thing of linear segments from a located -- list of offsets. -fromLocOffsets :: (V (V t) ~ V t, TrailLike t) => Located [VN t] -> t +fromLocOffsets :: (V (V t) ~ V t, TrailLike t) => Located [Vn t] -> t fromLocOffsets = trailLike . mapLoc trailFromOffsets -- | Construct a trail-like thing connecting the given vertices with @@ -195,7 +195,7 @@ p1 ~~ p2 = fromVertices [p1, p2] -- > # explodeTrail -- generate a list of diagrams -- > # zipWith lc [orange, green, yellow, red, blue] -- > # mconcat # centerXY # pad 1.1 -explodeTrail :: (VN ~ v n, Additive v, TrailLike t) => Located (Trail v n) -> [t] +explodeTrail :: (Vn ~ v n, Additive v, TrailLike t) => Located (Trail v n) -> [t] explodeTrail = map (mkTrail . fromFixedSeg) . fixTrail where mkTrail = trailLike . mapLoc (trailFromSegments . (:[])) diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs index f9c89812..206e477c 100644 --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -55,6 +55,6 @@ conjugate t1 t2 = inv t1 <> t2 <> t1 -- @ -- -- for all transformations @t1@ and @t2@. -under :: (Transformable a, Transformable b, VN a ~ VN b, VN a ~ v n, Num n, Functor v) +under :: (Transformable a, Transformable b, Vn a ~ Vn b, Vn a ~ v n, Num n, Functor v) => (a -> b) -> Transformation v n -> a -> b f `under` t = transform (inv t) . f . transform t diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 5f012920..38cfbbf7 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -392,3 +392,4 @@ clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d -- path. clipped :: (R2Ish v, Renderable (Path v) b) => Path v -> Diagram b v -> Diagram b v clipped p = (withTrace p) . (withEnvelope p) . (clipBy p) + diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index e7435643..9f4f4885 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -49,36 +49,36 @@ import Control.Lens (Iso', iso) ------------------------------------------------------------ -- | Compute the width of an enveloped object. -width :: (VN a ~ V2 n, Enveloped a) => a -> n +width :: (Vn a ~ V2 n, Enveloped a) => a -> n width = maybe 0 (negate . uncurry (-)) . extentX -- | Compute the height of an enveloped object. -height :: (VN a ~ V2 n, Enveloped a) => a -> n +height :: (Vn a ~ V2 n, Enveloped a) => a -> n height = maybe 0 (negate . uncurry (-)) . extentY -- | Compute the width and height of an enveloped object. -size2D :: (VN a ~ V2 n, Enveloped a) => a -> (n, n) +size2D :: (Vn a ~ V2 n, Enveloped a) => a -> (n, n) size2D = width &&& height -- | Compute the size of an enveloped object as a 'SizeSpec2D' value. -sizeSpec2D :: (VN a ~ V2 n, Enveloped a) => a -> SizeSpec2D n +sizeSpec2D :: (Vn a ~ V2 n, Enveloped a) => a -> SizeSpec2D n sizeSpec2D = uncurry Dims . size2D -- | Compute the absolute x-coordinate range of an enveloped object in -- R2, in the form (lo,hi). Return @Nothing@ for objects with an -- empty envelope. -extentX :: (VN a ~ V2 n, Enveloped a) => a -> Maybe (n, n) +extentX :: (Vn a ~ V2 n, Enveloped a) => a -> Maybe (n, n) extentX d = (\f -> (-f unit_X, f unitX)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the absolute y-coordinate range of an enveloped object in -- R2, in the form (lo,hi). -extentY :: (VN a ~ V2 n, Enveloped a) => a -> Maybe (n, n) +extentY :: (Vn a ~ V2 n, Enveloped a) => a -> Maybe (n, n) extentY d = (\f -> (-f unit_Y, f unitY)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the point at the center (in the x- and y-directions) of a -- enveloped object. Return the origin for objects with an empty -- envelope. -center2D :: (VN a ~ V2 n, Enveloped a) => a -> Point V2 n +center2D :: (Vn a ~ V2 n, Enveloped a) => a -> Point V2 n center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) where mm = uncurry (liftA2 (,)) mid = (/2) . uncurry (+) @@ -153,14 +153,14 @@ requiredScale (Dims wSpec hSpec) (w,h) = s -- | Uniformly scale any enveloped object so that it fits within the -- given size. -sized :: (VN a ~ V2 n, Transformable a, Enveloped a, RealFloat n) +sized :: (Vn a ~ V2 n, Transformable a, Enveloped a, RealFloat n) => SizeSpec2D n -> a -> a sized spec a = transform (requiredScaleT spec (size2D a)) a -- | Uniformly scale an enveloped object so that it \"has the same -- size as\" (fits within the width and height of) some other -- object. -sizedAs :: (VN a ~ V2 n, VN a ~ VN b, Transformable a, +sizedAs :: (Vn a ~ V2 n, Vn a ~ Vn b, Transformable a, Enveloped a, Enveloped b, RealFloat n) => b -> a -> a sizedAs other = sized (sizeSpec2D other) diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 99b9da10..f6fa268a 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -62,7 +62,6 @@ import Control.Lens (review, (^.), (*~), (//~), (&), (.~)) import Data.Semigroup import Diagrams.Coordinates -import Linear.V2 hiding (_x, _y, angle) import Linear.Vector import Linear.Affine @@ -94,13 +93,13 @@ rotation ang = fromLinear r (linv r) -- will yield an error since GHC cannot figure out which sort of -- angle you want to use. In this common situation you can use -- 'rotateBy', which interprets its argument as a number of turns. -rotate :: (VN t ~ V2 n, Transformable t, Floating n) => Angle n -> t -> t +rotate :: (Vn t ~ V2 n, Transformable t, Floating n) => Angle n -> t -> t rotate = transform . rotation -- | A synonym for 'rotate', interpreting its argument in units of -- turns; it can be more convenient to write @rotateBy (1\/4)@ than -- @'rotate' (1\/4 \@\@ 'turn')@. -rotateBy :: (VN t ~ V2 n, Transformable t, Floating n) => n -> t -> t +rotateBy :: (Vn t ~ V2 n, Transformable t, Floating n) => n -> t -> t rotateBy = transform . rotation . review turn -- | @rotationAbout p@ is a rotation about the point @p@ (instead of @@ -110,7 +109,7 @@ rotationAbout p angle = conjugate (translation (origin .-. p)) (rotation angle) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. -rotateAbout :: (VN t ~ V2 n, Transformable t, Floating n) => P2 n -> Angle n -> t -> t +rotateAbout :: (Vn t ~ V2 n, Transformable t, Floating n) => P2 n -> Angle n -> t -> t rotateAbout p angle = rotate angle `under` translation (origin .-. p) -- Scaling ------------------------------------------------- @@ -123,7 +122,7 @@ scalingX c = fromLinear s s -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. -scaleX :: (VN t ~ v n, Transformable t, HasX v, Additive v, Floating n) +scaleX :: (Vn t ~ v n, Transformable t, HasX v, Additive v, Floating n) => n -> t -> t scaleX = transform . scalingX @@ -135,7 +134,7 @@ scalingY c = fromLinear s s -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. -scaleY :: (VN t ~ v n, Transformable t, HasY v, Additive v, Floating n) +scaleY :: (Vn t ~ v n, Transformable t, HasY v, Additive v, Floating n) => n -> t -> t scaleY = transform . scalingY @@ -143,26 +142,26 @@ scaleY = transform . scalingY -- whatever factor required to make its width @w@. @scaleToX@ -- should not be applied to diagrams with a width of 0, such as -- 'vrule'. -scaleToX :: (VN t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t +scaleToX :: (Vn t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t scaleToX w d = scaleX (w / width d) d -- | @scaleToY h@ scales a diagram in the y (vertical) direction by -- whatever factor required to make its height @h@. @scaleToY@ -- should not be applied to diagrams with a height of 0, such as -- 'hrule'. -scaleToY :: (VN t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t +scaleToY :: (Vn t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t scaleToY h d = scaleY (h / height d) d -- | @scaleUToX w@ scales a diagram /uniformly/ by whatever factor -- required to make its width @w@. @scaleUToX@ should not be -- applied to diagrams with a width of 0, such as 'vrule'. -scaleUToX :: (VN t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t +scaleUToX :: (Vn t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t scaleUToX w d = scale (w / width d) d -- | @scaleUToY h@ scales a diagram /uniformly/ by whatever factor -- required to make its height @h@. @scaleUToY@ should not be applied -- to diagrams with a height of 0, such as 'hrule'. -scaleUToY :: (VN t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t +scaleUToY :: (Vn t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t scaleUToY h d = scale (h / height d) d -- Translation --------------------------------------------- @@ -174,7 +173,7 @@ translationX x = translation (zero & _x .~ x) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. -translateX :: (VN t ~ v n, Transformable t, HasX v, Additive v, Floating n) +translateX :: (Vn t ~ v n, Transformable t, HasX v, Additive v, Floating n) => n -> t -> t translateX = transform . translationX @@ -185,7 +184,7 @@ translationY y = translation (zero & _y .~ y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. -translateY :: (VN t ~ v n, Transformable t, HasY v, Additive v, Floating n) +translateY :: (Vn t ~ v n, Transformable t, HasY v, Additive v, Floating n) => n -> t -> t translateY = transform . translationY @@ -198,7 +197,7 @@ reflectionX = scalingX (-1) -- | Flip a diagram from left to right, i.e. send the point (x,y) to -- (-x,y). -reflectX :: (VN t ~ v n, Transformable t, HasX v, Additive v, Floating n) => t -> t +reflectX :: (Vn t ~ v n, Transformable t, HasX v, Additive v, Floating n) => t -> t reflectX = transform reflectionX -- | Construct a transformation which flips a diagram from top to @@ -208,7 +207,7 @@ reflectionY = scalingY (-1) -- | Flip a diagram from top to bottom, i.e. send the point (x,y) to -- (x,-y). -reflectY :: (VN t ~ v n, Transformable t, HasY v, Additive v, Floating n) +reflectY :: (Vn t ~ v n, Transformable t, HasY v, Additive v, Floating n) => t -> t reflectY = transform reflectionY @@ -221,7 +220,7 @@ reflectionAbout p v = -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. -reflectAbout :: (VN t ~ V2 n, Transformable t, RealFloat n) => P2 n -> V2 n -> t -> t +reflectAbout :: (Vn t ~ V2 n, Transformable t, RealFloat n) => P2 n -> V2 n -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Shears -------------------------------------------------- @@ -247,7 +246,7 @@ shearingX d = fromLinear (sh f g d <-> sh f g (-d)) -- | @shearX d@ performs a shear in the x-direction which sends -- @(0,1)@ to @(d,1)@. -shearX :: (VN t ~ V2 n, Transformable t, Num n) => n -> t -> t +shearX :: (Vn t ~ V2 n, Transformable t, Num n) => n -> t -> t shearX = transform . shearingX -- | @shearingY d@ is the linear transformation which is the identity on @@ -261,7 +260,7 @@ shearingY d = fromLinear (sh f g d <-> sh f g (-d)) -- | @shearY d@ performs a shear in the y-direction which sends -- @(1,0)@ to @(1,d)@. -shearY :: (VN t ~ V2 n, Transformable t, Num n) => n -> t -> t +shearY :: (Vn t ~ V2 n, Transformable t, Num n) => n -> t -> t shearY = transform . shearingY -- | Get the matrix equivalent of the linear transform, diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 3675c37b..cd459453 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -71,39 +71,39 @@ import Linear.Affine data ScaleInv t = ScaleInv { _scaleInvObj :: t - , _scaleInvDir :: VN t + , _scaleInvDir :: Vn t , _scaleInvLoc :: Point (V t) (N t) } deriving Typeable -deriving instance (Show t, Show (VN t)) => Show (ScaleInv t) +deriving instance (Show t, Show (Vn t)) => Show (ScaleInv t) makeLenses ''ScaleInv -- | Create a scale-invariant object pointing in the given direction, -- located at the origin. -scaleInv :: (VN t ~ v n, Additive v, Num n) => t -> v n -> ScaleInv t +scaleInv :: (Vn t ~ v n, Additive v, Num n) => t -> v n -> ScaleInv t scaleInv t d = ScaleInv t d origin type instance V (ScaleInv t) = V t type instance N (ScaleInv t) = N t -instance (VN t ~ v n, Additive v, Num n, HasOrigin t) => HasOrigin (ScaleInv t) where +instance (Vn t ~ v n, Additive v, Num n, HasOrigin t) => HasOrigin (ScaleInv t) where moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) -instance (VN t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv t) where +instance (Vn t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv t) where transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where -- angle :: Angle n angle = transform tr v ^. _theta - rot :: (VN k ~ VN t, Transformable k) => k -> k + rot :: (Vn k ~ Vn t, Transformable k) => k -> k rot = rotateAbout l angle -- l' :: Point V2 n l' = transform tr l - -- trans :: (VN k ~ VN t, Transformable k) => k -> k + -- trans :: (Vn k ~ Vn t, Transformable k) => k -> k trans = translate (l' .-. l) {- Proof that the above satisfies the monoid action laws. @@ -165,7 +165,7 @@ instance (VN t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv -} -instance (VN t ~ V2 n, RealFloat n, Renderable t b) => Renderable (ScaleInv t) b where +instance (Vn t ~ V2 n, RealFloat n, Renderable t b) => Renderable (ScaleInv t) b where render b = render b . view scaleInvObj -- | Create a diagram from a single scale-invariant primitive. The @@ -183,6 +183,6 @@ instance (VN t ~ V2 n, RealFloat n, Renderable t b) => Renderable (ScaleInv t) b -- scale-invariant things will be used only as \"decorations\" (/e.g./ -- arrowheads) which should not affect the envelope, trace, and -- query. -scaleInvPrim :: (VN t ~ V2 n, RealFloat n, Transformable t, Typeable t, Renderable t b, Monoid m) +scaleInvPrim :: (Vn t ~ V2 n, RealFloat n, Transformable t, Typeable t, Renderable t b, Monoid m) => t -> V2 n -> QDiagram b (V t) (N t) m scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty From 71d5ada844ce5d451fb887c837202785615b74fd Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Fri, 22 Aug 2014 14:53:03 +0100 Subject: [PATCH 23/58] Almost done. --- src/Diagrams/Align.hs | 95 +++++----- src/Diagrams/Animation.hs | 25 ++- src/Diagrams/Animation/Active.hs | 1 + src/Diagrams/Combinators.hs | 102 +++++------ src/Diagrams/CubicSpline.hs | 14 +- src/Diagrams/Deform.hs | 114 ++++++------ src/Diagrams/Located.hs | 18 +- src/Diagrams/Path.hs | 73 ++++---- src/Diagrams/Segment.hs | 34 +++- src/Diagrams/Tangent.hs | 12 +- src/Diagrams/ThreeD/Align.hs | 113 ++++++------ src/Diagrams/ThreeD/Deform.hs | 19 +- src/Diagrams/ThreeD/Shapes.hs | 5 - src/Diagrams/ThreeD/Transform.hs | 209 ++++++++------------- src/Diagrams/ThreeD/Types.hs | 8 +- src/Diagrams/Trace.hs | 15 +- src/Diagrams/Trail.hs | 25 ++- src/Diagrams/TrailLike.hs | 13 +- src/Diagrams/TwoD/Align.hs | 69 ++++--- src/Diagrams/TwoD/Arc.hs | 65 +++---- src/Diagrams/TwoD/Arrow.hs | 214 +++++++++++----------- src/Diagrams/TwoD/Arrowheads.hs | 100 +++++----- src/Diagrams/TwoD/Attributes.hs | 301 ++++++++++++++++--------------- src/Diagrams/TwoD/Curvature.hs | 75 +++++--- src/Diagrams/TwoD/Deform.hs | 13 +- src/Diagrams/TwoD/Ellipse.hs | 11 +- src/Diagrams/TwoD/Path.hs | 104 ++++++----- src/Diagrams/TwoD/Polygons.hs | 96 +++++----- src/Diagrams/TwoD/Segment.hs | 28 +-- src/Diagrams/TwoD/Shapes.hs | 45 +++-- src/Diagrams/TwoD/Types.hs | 9 +- 31 files changed, 1020 insertions(+), 1005 deletions(-) diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs index 747ffe3e..e56071ac 100644 --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -38,15 +38,17 @@ module Diagrams.Align import Diagrams.Core import Diagrams.Util (applyAll) -import Data.AffineSpace (alerp, (.-.)) import Data.Maybe (fromMaybe) import Data.Ord (comparing) -import Data.VectorSpace import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S +import Linear.Affine +import Linear.Vector +import Linear.Metric + -- | Class of things which can be aligned. class Alignable a where @@ -56,61 +58,58 @@ class Alignable a where -- edge of the boundary in the direction of the negation of @v@. -- Other values of @d@ interpolate linearly (so for example, @d = -- 0@ centers the origin along the direction of @v@). - alignBy' :: ( HasOrigin a, AdditiveGroup (V a), Num (Scalar (V a)) - , Fractional (Scalar (V a))) - => (V a -> a -> Point (V a)) -> V a -> Scalar (V a) -> a -> a + alignBy' :: (Vn a ~ v n, HasOrigin a, Additive v, Fractional n) + => (v n -> a -> Point v n) -> v n -> n -> a -> a alignBy' = alignBy'Default - defaultBoundary :: V a -> a -> Point (V a) + defaultBoundary :: Vn a ~ v n => v n -> a -> Point v n - alignBy :: (HasOrigin a, Num (Scalar (V a)), Fractional (Scalar (V a))) - => V a -> Scalar (V a) -> a -> a + alignBy :: (Vn a ~ v n, Additive v, HasOrigin a, Fractional n) + => v n -> n -> a -> a alignBy = alignBy' defaultBoundary -- | Default implementation of 'alignBy' for types with 'HasOrigin' -- and 'AdditiveGroup' instances. -alignBy'Default :: ( HasOrigin a, AdditiveGroup (V a), Num (Scalar (V a)) - , Fractional (Scalar (V a))) - => (V a -> a -> Point (V a)) -> V a -> Scalar (V a) -> a -> a -alignBy'Default boundary v d a = moveOriginTo (alerp (boundary (negateV v) a) - (boundary v a) - ((d + 1) / 2)) a +alignBy'Default :: (Vn a ~ v n, HasOrigin a, Additive v, Fractional n) + => (v n -> a -> Point v n) -> v n -> n -> a -> a +alignBy'Default boundary v d a = moveOriginTo (lerp ((d + 1) / 2) + (boundary v a) + (boundary (negated v) a) + ) a -- | Some standard functions which can be used as the `boundary` argument to -- `alignBy'`. -envelopeBoundary :: Enveloped a => V a -> a -> Point (V a) +envelopeBoundary :: (Vn a ~ v n, Enveloped a) => v n -> a -> Point v n envelopeBoundary = envelopeP -traceBoundary :: Traced a => V a -> a -> Point (V a) +traceBoundary :: (Vn a ~ v n, Num n, Traced a) => v n -> a -> Point v n traceBoundary v a = fromMaybe origin (maxTraceP origin v a) combineBoundaries - :: (F.Foldable f, InnerSpace (V a), Ord (Scalar (V a))) - => (V a -> a -> Point (V a)) -> (V a -> f a -> Point (V a)) + :: (Vn a ~ v n, F.Foldable f, Metric v, Ord n, Num n) + => (v n -> a -> Point v n) -> v n -> f a -> Point v n combineBoundaries b v fa - = b v $ F.maximumBy (comparing (magnitudeSq . (.-. origin) . b v)) fa + = b v $ F.maximumBy (comparing (quadrance . (.-. origin) . b v)) fa -instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Envelope v) where +instance (Metric v, OrderedField n) => Alignable (Envelope v n) where defaultBoundary = envelopeBoundary -instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Trace v) where +instance (Metric v, OrderedField n) => Alignable (Trace v n) where defaultBoundary = traceBoundary -instance (InnerSpace (V b), Ord (Scalar (V b)), Alignable b) - => Alignable [b] where +instance (Vn b ~ v n, Metric v, OrderedField n, Alignable b) => Alignable [b] where defaultBoundary = combineBoundaries defaultBoundary -instance (InnerSpace (V b), Ord (Scalar (V b)), Alignable b) - => Alignable (S.Set b) where +instance (Vn b ~ v n, Metric v, OrderedField n, Alignable b) + => Alignable (S.Set b) where defaultBoundary = combineBoundaries defaultBoundary -instance (InnerSpace (V b), Ord (Scalar (V b)), Alignable b) - => Alignable (M.Map k b) where +instance (Vn b ~ v n, Metric v, OrderedField n, Alignable b) + => Alignable (M.Map k b) where defaultBoundary = combineBoundaries defaultBoundary -instance ( HasLinearMap v, InnerSpace v, OrderedField (Scalar v) - , Monoid' m - ) => Alignable (QDiagram b v m) where +instance (HasLinearMap v, Metric v, OrderedField n, Monoid' m) + => Alignable (QDiagram b v n m) where defaultBoundary = envelopeBoundary -- | Although the 'alignBy' method for the @(b -> a)@ instance is @@ -118,8 +117,8 @@ instance ( HasLinearMap v, InnerSpace v, OrderedField (Scalar v) -- 'defaultBoundary'. Instead, we provide a total method, but one that -- is not sensible. This should not present a serious problem as long -- as your use of 'Alignable' happens through 'alignBy'. -instance (HasOrigin a, Alignable a) => Alignable (b -> a) where - alignBy v d f b = alignBy v d (f b) +instance (Vn a ~ v n, Additive v, Num n, HasOrigin a, Alignable a) => Alignable (b -> a) where + alignBy v d f b = alignBy v d (f b) defaultBoundary _ _ = origin -- | @align v@ aligns an enveloped object along the edge in the @@ -127,42 +126,40 @@ instance (HasOrigin a, Alignable a) => Alignable (b -> a) where -- direction of @v@ until it is on the edge of the envelope. (Note -- that if the local origin is outside the envelope to begin with, -- it may have to move \"backwards\".) -align :: ( Alignable a, HasOrigin a, Num (Scalar (V a)) - , Fractional (Scalar (V a))) => V a -> a -> a +align :: (Vn a ~ v n, Additive v, Alignable a, HasOrigin a, Fractional n) => v n -> a -> a align v = alignBy v 1 -- | Version of @alignBy@ specialized to use @traceBoundary@ -snugBy :: (Alignable a, Traced a, HasOrigin a, Num (Scalar (V a)), Fractional (Scalar (V a))) - => V a -> Scalar (V a) -> a -> a +snugBy :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, Fractional n) + => v n -> n -> a -> a snugBy = alignBy' traceBoundary -- | Like align but uses trace. -snug :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a) - => V a -> a -> a +snug :: (Vn a ~ v n, Fractional n, Alignable a, Traced a, HasOrigin a) + => v n -> a -> a snug v = snugBy v 1 -- | @centerV v@ centers an enveloped object along the direction of -- @v@. -centerV :: ( Alignable a, HasOrigin a, Num (Scalar (V a)) - , Fractional (Scalar (V a))) => V a -> a -> a +centerV :: (Vn a ~ v n, Additive v, Alignable a, HasOrigin a, Fractional n) => v n -> a -> a centerV v = alignBy v 0 -- | @center@ centers an enveloped object along all of its basis vectors. -center :: ( HasLinearMap (V a), Alignable a, HasOrigin a, Num (Scalar (V a)), - Fractional (Scalar (V a))) => a -> a -center d = applyAll fs d +center :: (Vn a ~ v n, HasLinearMap v, Alignable a, HasOrigin a, Fractional n) => a -> a +center = applyAll fs where fs = map centerV basis -- | Like @centerV@ using trace. snugCenterV - :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a) - => V a -> a -> a -snugCenterV v = (alignBy' traceBoundary) v 0 + :: (Vn a ~ v n, Fractional n, Alignable a, Traced a, HasOrigin a) + => v n -> a -> a +snugCenterV v = alignBy' traceBoundary v 0 -- | Like @center@ using trace. -snugCenter :: ( HasLinearMap (V a), Alignable a, HasOrigin a, Num (Scalar (V a)), - Fractional (Scalar (V a)), Traced a) => a -> a -snugCenter d = applyAll fs d +snugCenter :: (Vn a ~ v n, HasLinearMap v, Alignable a, HasOrigin a, Fractional n, Traced a) + => a -> a +snugCenter = applyAll fs where fs = map snugCenterV basis + diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs index cceb4fa6..bd2eca1c 100644 --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -44,13 +44,14 @@ import Data.Semigroup import Control.Applicative ((<$>)) import Data.Foldable (foldMap) -import Data.VectorSpace + +import Linear.Metric -- | A value of type @QAnimation b v m@ is an animation (a -- time-varying diagram with start and end times) that can be -- rendered by backspace @b@, with vector space @v@ and monoidal -- annotations of type @m@. -type QAnimation b v m = Active (QDiagram b v m) +type QAnimation b v n m = Active (QDiagram b v n m) -- | A value of type @Animation b v@ is an animation (a time-varying -- diagram with start and end times) in vector space @v@ that can be @@ -59,7 +60,7 @@ type QAnimation b v m = Active (QDiagram b v m) -- Note that @Animation@ is actually a synonym for @QAnimation@ -- where the type of the monoidal annotations has been fixed to -- 'Any' (the default). -type Animation b v = QAnimation b v Any +type Animation b v n = QAnimation b v n Any -- $animComb -- Most combinators for working with animations are to be found in the @@ -91,16 +92,16 @@ type Animation b v = QAnimation b v Any -- -- See also 'animRect' for help constructing a background to go -- behind an animation. -animEnvelope :: (Backend b v, OrderedField (Scalar v), InnerSpace v, Monoid' m) - => QAnimation b v m -> QAnimation b v m +animEnvelope :: (Backend b v n, OrderedField n, Metric v, Monoid' m) + => QAnimation b v n m -> QAnimation b v n m animEnvelope = animEnvelope' 30 -- | Like 'animEnvelope', but with an adjustible sample rate. The first -- parameter is the number of samples per time unit to use. Lower -- rates will be faster but less accurate; higher rates are more -- accurate but slower. -animEnvelope' :: (Backend b v, OrderedField (Scalar v), InnerSpace v, Monoid' m) - => Rational -> QAnimation b v m -> QAnimation b v m +animEnvelope' :: (Backend b v n, OrderedField n, Metric v, Monoid' m) + => Rational -> QAnimation b v n m -> QAnimation b v n m animEnvelope' r a = withEnvelope (simulate r a) <$> a -- | @animRect@ works similarly to 'animEnvelope' for 2D diagrams, but @@ -110,18 +111,16 @@ animEnvelope' r a = withEnvelope (simulate r a) <$> a -- -- Uses 30 samples per time unit by default; to adjust this number -- see 'animRect''. -animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ v, R2Ish v - , Monoid' m) - => QAnimation b v m -> t +animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, Vn t ~ V2 n, RealFloat n, Monoid' m) + => QAnimation b V2 n m -> t animRect = animRect' 30 -- | Like 'animRect', but with an adjustible sample rate. The first -- parameter is the number of samples per time unit to use. Lower -- rates will be faster but less accurate; higher rates are more -- accurate but slower. -animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ v, R2Ish v - , Monoid' m) - => Rational -> QAnimation b v m -> t +animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, Vn t ~ V2 n, RealFloat n, Monoid' m) + => Rational -> QAnimation b V2 n m -> t animRect' r anim | null results = rect 1 1 | otherwise = boxFit (foldMap boundingBox results) (rect 1 1) diff --git a/src/Diagrams/Animation/Active.hs b/src/Diagrams/Animation/Active.hs index 16017150..bef589e3 100644 --- a/src/Diagrams/Animation/Active.hs +++ b/src/Diagrams/Animation/Active.hs @@ -45,6 +45,7 @@ import Diagrams.TrailLike import Data.Active type instance V (Active a) = V a +type instance N (Active a) = N a -- Yes, these are all orphan instances. Get over it. We don't want to -- put them in the 'active' package because 'active' is supposed to be diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index e6d45ed4..490d9eb7 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -43,8 +43,6 @@ import Data.Typeable import Control.Lens (Lens', generateSignatures, lensField, lensRules, makeLensesWith, (%~), (&), (.~), (^.), _Wrapping) -import Data.AdditiveGroup -import Data.AffineSpace ((.+^)) import Data.Default.Class import Data.Monoid.Deletable (toDeletable) import Data.Monoid.MList (inj) @@ -53,7 +51,6 @@ import Data.Proxy #endif import Data.Semigroup import qualified Data.Tree.DUAL as D -import Data.VectorSpace import Diagrams.Core import Diagrams.Core.Types (QDiagram (QD)) @@ -61,6 +58,11 @@ import Diagrams.Direction import Diagrams.Segment (straight) import Diagrams.Util +import Linear.Affine +import Linear.Epsilon +import Linear.Metric +import Linear.Vector + ------------------------------------------------------------ -- Working with envelopes ------------------------------------------------------------ @@ -78,19 +80,19 @@ import Diagrams.Util -- > ) -- > c = circle 0.8 -- > withEnvelopeEx = sqNewEnv # centerXY # pad 1.5 -withEnvelope :: (HasLinearMap (V a), Enveloped a, Monoid' m) - => a -> QDiagram b (V a) m -> QDiagram b (V a) m +withEnvelope :: (Vn a ~ v n, HasLinearMap v, Enveloped a, Monoid' m) + => a -> QDiagram b v n m -> QDiagram b v n m withEnvelope = setEnvelope . getEnvelope -- | Use the trace from some object as the trace for a diagram, in -- place of the diagram's default trace. -withTrace :: (HasLinearMap (V a), Traced a, OrderedField (Scalar (V a)), InnerSpace (V a), Monoid' m) - => a -> QDiagram b (V a) m -> QDiagram b (V a) m +withTrace :: (Vn a ~ v n, HasLinearMap v, Traced a, OrderedField n, Metric v, Monoid' m) + => a -> QDiagram b v n m -> QDiagram b v n m withTrace = setTrace . getTrace -- | @phantom x@ produces a \"phantom\" diagram, which has the same -- envelope and trace as @x@ but produces no output. -phantom :: (Backend b (V a), Typeable (V a), Enveloped a, Traced a, Monoid' m) => a -> QDiagram b (V a) m +phantom :: (Enveloped a, Traced a, Vn a ~ v n, Monoid' m) => a -> QDiagram b v n m phantom a = QD $ D.leafU ((inj . toDeletable . getEnvelope $ a) <> (inj . toDeletable . getTrace $ a)) -- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of @@ -99,21 +101,19 @@ phantom a = QD $ D.leafU ((inj . toDeletable . getEnvelope $ a) <> (inj . toDele -- origin, so if the origin is not centered the padding may appear -- \"uneven\". If this is not desired, the origin can be centered -- (using, e.g., 'centerXY' for 2D diagrams) before applying @pad@. -pad :: ( Backend b v - , InnerSpace v, OrderedField (Scalar v) - , Monoid' m ) - => Scalar v -> QDiagram b v m -> QDiagram b v m +pad :: (HasLinearMap v, Metric v, OrderedField n, Monoid' m) + => n -> QDiagram b v n m -> QDiagram b v n m pad s d = withEnvelope (d # scale s) d -- | @frame s@ increases the envelope of a diagram by and absolute amount @s@, -- s is in the local units of the diagram. This function is similar to @pad@, -- only it takes an absolute quantity and pre-centering should not be -- necessary. -frame :: ( Backend b v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => Scalar v -> QDiagram b v m -> QDiagram b v m +frame :: (HasLinearMap v, Metric v, OrderedField n, Monoid' m) + => n -> QDiagram b v n m -> QDiagram b v n m frame s d = setEnvelope (onEnvelope t (d^.envelope)) d where - t f = \x -> f x + s + t f x = f x + s -- | @strut v@ is a diagram which produces no output, but with respect -- to alignment and envelope acts like a 1-dimensional segment @@ -126,12 +126,8 @@ frame s d = setEnvelope (onEnvelope t (d^.envelope)) d -- <> -- -- > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1 -strut :: ( Backend b v, Typeable v - , InnerSpace v - , OrderedField (Scalar v) - , Monoid' m - ) - => v -> QDiagram b v m +strut :: (Metric v, OrderedField n, Monoid' m) + => v n -> QDiagram b v n m strut v = QD $ D.leafU (inj . toDeletable $ env) where env = translate ((-0.5) *^ v) . getEnvelope $ straight v -- note we can't use 'phantom' here because it tries to construct a @@ -152,9 +148,8 @@ strut v = QD $ D.leafU (inj . toDeletable $ env) -- the cosine of the difference in angle, and leaving it unchanged -- when this factor is negative. extrudeEnvelope - :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) - , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) - => v -> QDiagram b v m -> QDiagram b v m + :: (HasLinearMap v, Ord n, Floating n, Epsilon n, Metric v, Monoid' m) + => v n -> QDiagram b v n m -> QDiagram b v n m extrudeEnvelope = deformEnvelope 0.5 -- | @intrudeEnvelope v d@ asymmetrically \"intrudes\" the envelope of @@ -165,24 +160,22 @@ extrudeEnvelope = deformEnvelope 0.5 -- Note that this could create strange inverted envelopes, where -- @ diameter v d < 0 @. intrudeEnvelope - :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) - , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) - => v -> QDiagram b v m -> QDiagram b v m + :: (HasLinearMap v, Ord n, Floating n, Epsilon n, Metric v, Monoid' m) + => v n -> QDiagram b v n m -> QDiagram b v n m intrudeEnvelope = deformEnvelope (-0.5) -- Utility for extrudeEnvelope / intrudeEnvelope deformEnvelope - :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) - , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) - => (Scalar v) -> v -> QDiagram b v m -> QDiagram b v m + :: (HasLinearMap v, Ord n, Epsilon n, Floating n, Metric v, Monoid' m) + => n -> v n -> QDiagram b v n m -> QDiagram b v n m deformEnvelope s v d = setEnvelope (getEnvelope d & _Wrapping Envelope %~ deformE) d where deformE = Option . fmap deformE' . getOption deformE' env v' - | dot > 0 = Max $ getMax (env v') + (dot * s) / magnitude v' + | dp > 0 = Max $ getMax (env v') + (dp * s) / norm v' | otherwise = env v' where - dot = v' <.> v + dp = v' `dot` v ------------------------------------------------------------ -- Combining two objects @@ -191,8 +184,8 @@ deformEnvelope s v d = setEnvelope (getEnvelope d & _Wrapping Envelope %~ deform -- | @beneath@ is just a convenient synonym for @'flip' 'atop'@; that is, -- @d1 \`beneath\` d2@ is the diagram with @d2@ superimposed on top of -- @d1@. -beneath :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid' m) - => QDiagram b v m -> QDiagram b v m -> QDiagram b v m +beneath :: (HasLinearMap v, OrderedField n, Metric v, Monoid' m) + => QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m beneath = flip atop infixl 6 `beneath` @@ -232,7 +225,7 @@ infixl 6 `beneath` -- To get something like @beside v x1 x2@ whose local origin is -- identified with that of @x2@ instead of @x1@, use @beside -- (negateV v) x2 x1@. -beside :: (Juxtaposable a, Semigroup a) => V a -> a -> a -> a +beside :: (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a beside v d1 d2 = d1 <> juxtapose v d1 d2 -- | Place two diagrams (or other juxtaposable objects) adjacent to @@ -240,8 +233,8 @@ beside v d1 d2 = d1 <> juxtapose v d1 d2 -- from the first. The local origin of the resulting combined -- diagram is the same as the local origin of the first. See the -- documentation of 'beside' for more information. -atDirection :: (Juxtaposable a, Semigroup a, InnerSpace (V a), Floating (Scalar (V a))) => - Direction (V a) -> a -> a -> a +atDirection :: (Juxtaposable a, Semigroup a, Vn a ~ v n, Metric v, Floating n, Epsilon n) + => Direction v n -> a -> a -> a atDirection = beside . fromDirection ------------------------------------------------------------ @@ -258,7 +251,7 @@ atDirection = beside . fromDirection -- > appendsEx = appends c (zip (iterateN 6 (rotateBy (1/6)) unitX) (repeat c)) -- > # centerXY # pad 1.1 -- > where c = circle 1 -appends :: (Juxtaposable a, Monoid' a) => a -> [(V a,a)] -> a +appends :: (Juxtaposable a, Monoid' a) => a -> [(Vn a,a)] -> a appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps) -- | Position things absolutely: combine a list of objects @@ -270,12 +263,12 @@ appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps) -- > positionEx = position (zip (map mkPoint [-3, -2.8 .. 3]) (repeat dot)) -- > where dot = circle 0.2 # fc black -- > mkPoint x = p2 (x,x^2) -position :: (HasOrigin a, Monoid' a) => [(Point (V a), a)] -> a +position :: (Vn a ~ v n, Additive v, Num n, HasOrigin a, Monoid' a) => [(Point v n, a)] -> a position = mconcat . map (uncurry moveTo) -- | Curried version of @position@, takes a list of points and a list of -- objects. -atPoints :: (HasOrigin a, Monoid' a) => [Point (V a)] -> [a] -> a +atPoints :: (Vn a ~ v n, Additive v, Num n, HasOrigin a, Monoid' a) => [Point v n] -> [a] -> a atPoints ps as = position $ zip ps as -- | Methods for concatenating diagrams. @@ -295,9 +288,9 @@ data CatMethod = Cat -- ^ Normal catenation: simply put diagrams -- of separation, diagrams may overlap. -- | Options for 'cat''. -data CatOpts v = CatOpts { _catMethod :: CatMethod - , _sep :: Scalar v - , _catOptsvProxy__ :: Proxy v +data CatOpts n = CatOpts { _catMethod :: CatMethod + , _sep :: n + , _catOptsvProxy__ :: Proxy n } -- The reason the proxy field is necessary is that without it, @@ -325,15 +318,15 @@ makeLensesWith -- | Which 'CatMethod' should be used: -- normal catenation (default), or distribution? -catMethod :: forall v. Lens' (CatOpts v) CatMethod +catMethod :: forall n. Lens' (CatOpts n) CatMethod -- | How much separation should be used between successive diagrams -- (default: 0)? When @catMethod = Cat@, this is the distance between -- /envelopes/; when @catMethod = Distrib@, this is the distance -- between /origins/. -sep :: forall v. Lens' (CatOpts v) (Scalar v) +sep :: forall n. Lens' (CatOpts n) n -instance Num (Scalar v) => Default (CatOpts v) where +instance Num n => Default (CatOpts n) where def = CatOpts { _catMethod = Cat , _sep = 0 , _catOptsvProxy__ = Proxy @@ -347,10 +340,8 @@ instance Num (Scalar v) => Default (CatOpts v) where -- -- See also 'cat'', which takes an extra options record allowing -- certain aspects of the operation to be tweaked. -cat :: ( Juxtaposable a, Monoid' a, HasOrigin a - , InnerSpace (V a), OrderedField (Scalar (V a)) - ) - => V a -> [a] -> a +cat :: (Juxtaposable a, Monoid' a, HasOrigin a , Vn a ~ v n, Metric v, OrderedField n) + => v n -> [a] -> a cat v = cat' v def -- | Like 'cat', but taking an extra 'CatOpts' arguments allowing the @@ -370,13 +361,12 @@ cat v = cat' v def -- Note that @cat' v (with & catMethod .~ Distrib) === mconcat@ -- (distributing with a separation of 0 is the same as -- superimposing). -cat' :: ( Juxtaposable a, Monoid' a, HasOrigin a - , InnerSpace (V a), OrderedField (Scalar (V a)) - ) - => V a -> CatOpts (V a) -> [a] -> a +cat' :: ( Juxtaposable a, Monoid' a, HasOrigin a, Vn a ~ v n, Metric v, OrderedField n) + => v n -> CatOpts n -> [a] -> a cat' v (CatOpts { _catMethod = Cat, _sep = s }) = foldB comb mempty where comb d1 d2 = d1 <> (juxtapose v d1 d2 # moveOriginBy vs) - vs = s *^ normalized (negateV v) + vs = s *^ signorm (negated v) cat' v (CatOpts { _catMethod = Distrib, _sep = s }) = - position . zip (iterate (.+^ (s *^ normalized v)) origin) + position . zip (iterate (.+^ (s *^ signorm v)) origin) + diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs index 651b4f9a..0dabe130 100644 --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -24,15 +24,15 @@ module Diagrams.CubicSpline ) where import Diagrams.Core -import Diagrams.Core.Points import Diagrams.CubicSpline.Internal import Diagrams.Located (Located, at, mapLoc) import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike (TrailLike (..)) -import Data.AffineSpace.Point -import Data.VectorSpace +import Linear.Affine +import Control.Lens (view) +import Linear.Metric -- | Construct a spline path-like thing of cubic segments from a list of -- vertices, with the first vertex as the starting point. The first @@ -48,15 +48,15 @@ import Data.VectorSpace -- > # centerXY # pad 1.1 -- -- For more information, see . -cubicSpline :: (TrailLike t, Fractional (V t)) => Bool -> [Point (V t)] -> t +cubicSpline :: (Vn t ~ v n, TrailLike t, Fractional (v n)) => Bool -> [Point v n] -> t cubicSpline closed [] = trailLike . closeIf closed $ emptyLine `at` origin -cubicSpline closed ps = flattenBeziers . map f . solveCubicSplineCoefficients closed . map unPoint $ ps +cubicSpline closed ps = flattenBeziers . map f . solveCubicSplineCoefficients closed . map (view lensP) $ ps where f [a,b,c,d] = [a, (3*a+b)/3, (3*a+2*b+c)/3, a+b+c+d] flattenBeziers bs@((b:_):_) = trailLike . closeIf closed $ lineFromSegments (map bez bs) `at` P b bez [a,b,c,d] = bezier3 (b - a) (c - a) (d - a) -closeIf :: (InnerSpace v, OrderedField (Scalar v)) - => Bool -> Located (Trail' Line v) -> Located (Trail v) +closeIf :: (Metric v, OrderedField n) + => Bool -> Located (Trail' Line v n) -> Located (Trail v n) closeIf c = mapLoc (if c then wrapLoop . glueLine else wrapLine) diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs index c5b9049e..6e2760d1 100644 --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -8,12 +8,8 @@ module Diagrams.Deform (Deformation(..), Deformable(..), asDeformation) where import Control.Lens (under, _Unwrapped) -import Data.AffineSpace -import Data.Basis -import Data.MemoTrie import Data.Monoid hiding ((<>)) import Data.Semigroup -import Data.VectorSpace import Diagrams.Core import Diagrams.Located @@ -22,6 +18,11 @@ import Diagrams.Path import Diagrams.Segment import Diagrams.Trail +import Linear.Affine +import Linear.Vector +import Linear.Metric +import Linear.Epsilon + ------------------------------------------------------------ -- Deformations @@ -30,41 +31,42 @@ import Diagrams.Trail -- invertable. @Deformation@s include projective transformations. -- @Deformation@ can represent other functions from points to points -- which are "well-behaved", in that they do not introduce small wiggles. -data Deformation v = Deformation (Point v -> Point v) +data Deformation v n = Deformation (Point v n -> Point v n) -instance Semigroup (Deformation v) where - (Deformation p1) <> (Deformation p2) = Deformation (p1 . p2) +instance Semigroup (Deformation v n) where + (Deformation p1) <> (Deformation p2) = Deformation (p1 . p2) -instance Monoid (Deformation v) where - mappend = (<>) - mempty = Deformation id +instance Monoid (Deformation v n) where + mappend = (<>) + mempty = Deformation id class Deformable a where - -- | @deform' epsilon d a@ transforms @a@ by the deformation @d@. - -- If the type of @a@ is not closed under projection, approximate - -- to accuracy @epsilon@. - deform' :: Scalar (V a) -> Deformation (V a) -> a -> a + -- | @deform' epsilon d a@ transforms @a@ by the deformation @d@. + -- If the type of @a@ is not closed under projection, approximate + -- to accuracy @epsilon@. + deform' :: Vn a ~ v n => n -> Deformation v n -> a -> a - -- | @deform d a@ transforms @a@ by the deformation @d@. - -- If the type of @a@ is not closed under projection, @deform@ - -- should call @deform'@ with some reasonable default value of - -- @epsilon@. - deform :: Deformation (V a) -> a -> a + -- | @deform d a@ transforms @a@ by the deformation @d@. + -- If the type of @a@ is not closed under projection, @deform@ + -- should call @deform'@ with some reasonable default value of + -- @epsilon@. + deform :: Deformation (V a) (N a) -> a -> a -- | @asDeformation@ converts a 'Transformation' to a 'Deformation' by -- discarding the inverse transform. This allows reusing -- @Transformation@s in the construction of @Deformation@s. -asDeformation - :: ( HasTrie (Basis v), HasBasis v) => Transformation v -> Deformation v -asDeformation t = Deformation f' where - f' = papply t +asDeformation :: (Additive v, Num n) => Transformation v n -> Deformation v n +asDeformation t = Deformation f' + where + f' = papply t ------------------------------------------------------------ -- Instances -instance Deformable (Point v) where - deform' = const deform - deform (Deformation l) = l +instance Deformable (Point v n) where + deform' = const deform + + deform (Deformation l) = l -- | Cubic curves are not closed under perspective projections. -- Therefore @Segment@s are not an instance of Deformable. However, @@ -72,47 +74,43 @@ instance Deformable (Point v) where -- precision by a series of @Segment@s. @deformSegment@ does this, -- which allows types built from lists of @Segment@s to themselves be -- @Deformable@. -deformSegment :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => - s -> Deformation v -> FixedSegment v -> [FixedSegment v] +deformSegment :: (Metric v, Ord n, Floating n, Epsilon n) => n -> Deformation v n -> FixedSegment v n -> [FixedSegment v n] deformSegment epsilon t s | goodEnough epsilon t s = [approx t s] - | otherwise = concatMap (deformSegment epsilon t) [s1, s2] + | otherwise = concatMap (deformSegment epsilon t) [s1, s2] where (s1, s2) = splitAtParam s 0.5 -approx :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => - Deformation v -> FixedSegment v -> FixedSegment v +approx :: (Metric v, Ord n, Floating n) => Deformation v n -> FixedSegment v n -> FixedSegment v n approx t (FLinear p0 p1) = FLinear (deform t p0) (deform t p1) approx t (FCubic p0 c1 c2 p1) = FCubic (f p0) (f c1) (f c2) (f p1) where f = deform t -goodEnough :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => - s -> Deformation v -> FixedSegment v -> Bool +goodEnough :: (Metric v, Ord n, Floating n, Epsilon n) => n -> Deformation v n -> FixedSegment v n -> Bool goodEnough e t s = - all (< e) [magnitude $ deform t (s `atParam` u) .-. approx t s `atParam` u + all (< e) [norm $ deform t (s `atParam` u) .-. approx t s `atParam` u | u <- [0.25, 0.5, 0.75]] -instance (VectorSpace v, InnerSpace v, - s ~ Scalar v, Ord s, Fractional s, Floating s, Show s, Show v) => - Deformable (Located (Trail v)) where - deform' eps p t - | isLine $ unLoc t = line `at` p0 - | otherwise = glueTrail line `at` p0 - where - segs = concatMap (deformSegment eps p) $ fixTrail t - p0 = case segs of - (FLinear start _:_) -> start - (FCubic start _ _ _:_) -> start - _ -> loc t -- default in case of empty trail - line = trailFromSegments $ map (unLoc . fromFixedSeg) segs - deform p t = deform' (0.01 * extent) p t where - -- estimate the "size" of the Trail' as - -- the maximum distance to any vertex - extent = maximum . map dist . trailVertices $ t - dist pt = magnitude $ pt .-. loc t - -instance (VectorSpace v, InnerSpace v, - s ~ Scalar v, Ord s, Fractional s, Floating s, Show s, Show v) => - Deformable (Path v) where - deform' eps p = under _Unwrapped $ map (deform' eps p) - deform p = under _Unwrapped $ map (deform p) +instance (Metric v, Ord n, Floating n, Epsilon n) => Deformable (Located (Trail v n)) where + deform' eps p t + | isLine $ unLoc t = line `at` p0 + | otherwise = glueTrail line `at` p0 + where + segs = concatMap (deformSegment eps p) $ fixTrail t + p0 = case segs of + (FLinear start _:_) -> start + (FCubic start _ _ _:_) -> start + _ -> loc t -- default in case of empty trail + line = trailFromSegments $ map (unLoc . fromFixedSeg) segs + + deform p t = deform' (0.01 * extent) p t + where + -- estimate the "size" of the Trail' as + -- the maximum distance to any vertex + extent = maximum . map dist . trailVertices $ t + dist pt = norm $ pt .-. loc t + +instance (Metric v, Ord n, Floating n, Epsilon n) => Deformable (Path v n) where + deform' eps p = under _Unwrapped $ map (deform' eps p) + deform p = under _Unwrapped $ map (deform p) + diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs index 88555582..410f4987 100644 --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -31,7 +31,6 @@ import Linear.Vector import Linear.Affine import Diagrams.Core -import Diagrams.Core.V import Diagrams.Core.Points () import Diagrams.Core.Transform import Diagrams.Parametric @@ -130,9 +129,9 @@ instance (Traced a, Num (N a)) => Traced (Located a) where instance Qualifiable a => Qualifiable (Located a) where n |> (Loc p a) = Loc p (n |> a) -type instance Codomain (Located a) (N a) = Point (Codomain a) (N a) +type instance Codomain (Located a) n = Point (Codomain a) n -instance (Codomain a ~ V a, Additive (V a), Num (N a), Parametric a) -- , Diff (Point (V a) (N a)) ~ V a (N a)) +instance (Vn a ~ v n, Codomain a ~ V a, Codomain a n ~ v n, Additive v, Num n, Parametric a) -- , Diff (Point (V a)) ~ V a) => Parametric (Located a) where (Loc x a) `atParam` p = x .+^ (a `atParam` p) @@ -140,12 +139,12 @@ instance DomainBounds a => DomainBounds (Located a) where domainLower (Loc _ a) = domainLower a domainUpper (Loc _ a) = domainUpper a -instance (Codomain a ~ V a, Additive (V a), Num (N a), EndValues a) +instance (Vn a ~ v n, Codomain a ~ v, Codomain a n ~ v n, Additive v, Num n, EndValues a) => EndValues (Located a) -instance ( Codomain a ~ V a, Fractional (N a), Additive (V a) - , Sectionable a, Parametric a - ) +-- not sure why Codomain a n ~ v n is needed as well. I've probably done something wrong. +instance ( Vn a ~ v n, Codomain a ~ v, Codomain a n ~ v n + , Fractional n, Additive v , Sectionable a, Parametric a) => Sectionable (Located a) where splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2) where (a1,a2) = splitAtParam a p @@ -153,9 +152,8 @@ instance ( Codomain a ~ V a, Fractional (N a), Additive (V a) reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a) where y = a `atParam` domainUpper a -instance ( Codomain a ~ V a, Additive (V a), Fractional (N a) - , HasArcLength a - ) +instance ( Vn a ~ v n, Codomain a ~ v, Codomain a n ~ v n + , Additive v, Fractional n , HasArcLength a) => HasArcLength (Located a) where arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a arcLengthToParam eps (Loc _ a) = arcLengthToParam eps a diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index e0e66e4c..0b656a3e 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -1,12 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -73,11 +71,13 @@ import Diagrams.Transform import Control.Arrow ((***)) import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, over, view, (%~), _Unwrapped', _Wrapped) -import Data.AffineSpace import qualified Data.Foldable as F import Data.List (partition) import Data.Semigroup -import Data.VectorSpace + +import Linear.Affine +import Linear.Vector +import Linear.Metric ------------------------------------------------------------ -- Paths ------------------------------------------------- @@ -87,37 +87,38 @@ import Data.VectorSpace -- Hence, unlike trails, paths are not translationally invariant, -- and they form a monoid under /superposition/ (placing one path on -- top of another) rather than concatenation. -newtype Path v = Path [Located (Trail v)] +newtype Path v n = Path [Located (Trail v n)] deriving (Semigroup, Monoid, Typeable) -instance Wrapped (Path v) where - type Unwrapped (Path v) = [Located (Trail v)] +instance Wrapped (Path v n) where + type Unwrapped (Path v n) = [Located (Trail v n)] _Wrapped' = iso (\(Path x) -> x) Path -instance Rewrapped (Path v) (Path v') +instance Rewrapped (Path v n) (Path v' n') -- | Extract the located trails making up a 'Path'. -pathTrails :: Path v -> [Located (Trail v)] +pathTrails :: Path v n -> [Located (Trail v n)] pathTrails = op Path -deriving instance Show v => Show (Path v) -deriving instance Eq v => Eq (Path v) -deriving instance Ord v => Ord (Path v) +deriving instance Show (v n) => Show (Path v n) +deriving instance Eq (v n) => Eq (Path v n) +deriving instance Ord (v n) => Ord (Path v n) -type instance V (Path v) = v +type instance V (Path v n) = v +type instance N (Path v n) = n -instance VectorSpace v => HasOrigin (Path v) where +instance (Additive v, Num n) => HasOrigin (Path v n) where moveOriginTo = over _Wrapped' . map . moveOriginTo --moveOriginTo = over pathTrails . map . moveOriginTo -- | Paths are trail-like; a trail can be used to construct a -- singleton path. -instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Path v) where +instance (Metric v, OrderedField n) => TrailLike (Path v n) where trailLike = Path . (:[]) -- See Note [Transforming paths] -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (Path v) where +instance (HasLinearMap v, Metric v, OrderedField n) + => Transformable (Path v n) where transform = over _Wrapped . map . transform {- ~~~~ Note [Transforming paths] @@ -130,20 +131,20 @@ but that doesn't take into account the fact that some of the v's are inside Points and hence ought to be translated. -} -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Path v) where +instance (Metric v, OrderedField n) => Enveloped (Path v n) where getEnvelope = F.foldMap trailEnvelope . op Path --view pathTrails -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 - where trailEnvelope :: Located (Trail v) -> Envelope v + where trailEnvelope :: Located (Trail v n) -> Envelope v n trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) -instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Path v) where +instance (Metric v, OrderedField n) => Juxtaposable (Path v n) where juxtapose = juxtaposeDefault -instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Path v) where +instance (Metric v, OrderedField n) => Alignable (Path v n) where defaultBoundary = envelopeBoundary -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Renderable (Path v) NullBackend where +instance (HasLinearMap v, Metric v, OrderedField n) + => Renderable (Path v n) NullBackend where render _ _ = mempty ------------------------------------------------------------ @@ -156,17 +157,17 @@ instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) -- section are provided for convenience. -- | Convert a trail to a path beginning at the origin. -pathFromTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Path v +pathFromTrail :: (Metric v, OrderedField n) => Trail v n -> Path v n pathFromTrail = trailLike . (`at` origin) -- | Convert a trail to a path with a particular starting point. -pathFromTrailAt :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Point v -> Path v +pathFromTrailAt :: (Metric v, OrderedField n) => Trail v n -> Point v n -> Path v n pathFromTrailAt t p = trailLike (t `at` p) -- | Convert a located trail to a singleton path. This is equivalent -- to 'trailLike', but provided with a more specific name and type -- for convenience. -pathFromLocTrail :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> Path v +pathFromLocTrail :: (Metric v, OrderedField n) => Located (Trail v n) -> Path v n pathFromLocTrail = trailLike ------------------------------------------------------------ @@ -175,36 +176,35 @@ pathFromLocTrail = trailLike -- | Extract the vertices of a path, resulting in a separate list of -- vertices for each component trail (see 'trailVertices'). -pathVertices :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[Point v]] +pathVertices :: (Metric v, OrderedField n) => Path v n -> [[Point v n]] pathVertices = map trailVertices . op Path -- | Compute the total offset of each trail comprising a path (see 'trailOffset'). -pathOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [v] +pathOffsets :: (Metric v, OrderedField n) => Path v n -> [v n] pathOffsets = map (trailOffset . unLoc) . op Path -- | Compute the /centroid/ of a path (/i.e./ the average location of -- its vertices). -pathCentroid :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Point v +pathCentroid :: (Metric v, OrderedField n) => Path v n -> Point v n pathCentroid = centroid . concat . pathVertices -- | Convert a path into a list of lists of located segments. -pathLocSegments :: (InnerSpace v, OrderedField (Scalar v)) - => Path v -> [[Located (Segment Closed v)]] +pathLocSegments :: (Metric v, OrderedField n) => Path v n -> [[Located (Segment Closed v n)]] pathLocSegments = map trailLocSegments . op Path -- | Convert a path into a list of lists of 'FixedSegment's. -fixPath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[FixedSegment v]] +fixPath :: (Metric v, OrderedField n) => Path v n -> [[FixedSegment v n]] fixPath = map fixTrail . op Path -- | \"Explode\" a path by exploding every component trail (see -- 'explodeTrail'). -explodePath :: (VectorSpace (V t), TrailLike t) => Path (V t) -> [[t]] +explodePath :: (Vn t ~ v n, Additive v, TrailLike t) => Path v n -> [[t]] explodePath = map explodeTrail . op Path -- | Partition a path into two paths based on a predicate on trails: -- the first containing all the trails for which the predicate returns -- @True@, and the second containing the remaining trails. -partitionPath :: (Located (Trail v) -> Bool) -> Path v -> (Path v, Path v) +partitionPath :: (Located (Trail v n) -> Bool) -> Path v n -> (Path v n, Path v n) partitionPath p = (view _Unwrapped' *** view _Unwrapped') . partition p . op Path ------------------------------------------------------------ @@ -213,11 +213,10 @@ partitionPath p = (view _Unwrapped' *** view _Unwrapped') . partition p . op Pat -- | Scale a path using its centroid (see 'pathCentroid') as the base -- point for the scale. -scalePath :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Scalar v -> Path v -> Path v +scalePath :: (HasLinearMap v, Metric v, OrderedField n) => n -> Path v n -> Path v n scalePath d p = (scale d `under` translation (origin .-. pathCentroid p)) p -- | Reverse all the component trails of a path. -reversePath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Path v +reversePath :: (Metric v, OrderedField n) => Path v n -> Path v n reversePath = _Wrapped . mapped %~ reverseLocTrail diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index 3a5bd97e..fc034c64 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -45,7 +45,7 @@ module Diagrams.Segment -- * Constructing and modifying segments - , Segment(..), straight, bezier3, bézier3, reverseSegment + , Segment(..), straight, bezier3, bézier3, reverseSegment, mapSegmentVectors -- * Fixed (absolutely located) segments , FixedSegment(..) @@ -63,8 +63,7 @@ module Diagrams.Segment ) where -import Control.Applicative (liftA2) -import Control.Lens (Rewrapped, Wrapped (..), iso, makeLenses, op) +import Control.Lens (Rewrapped, Wrapped (..), iso, makeLenses, op, Traversal, over) import Data.FingerTree import Data.Monoid.MList import Data.Semigroup @@ -76,10 +75,10 @@ import Linear.Vector import Linear.Metric import Diagrams.Core -import Diagrams.Core.V import Diagrams.Located import Diagrams.Parametric import Diagrams.Solve +import Control.Applicative ------------------------------------------------------------ @@ -117,6 +116,10 @@ instance Functor v => Functor (Offset c v) where fmap _ OffsetOpen = OffsetOpen fmap f (OffsetClosed v) = OffsetClosed (fmap f v) +offsetVector :: Traversal (Offset c v n) (Offset c v' n') (v n) (v' n') +offsetVector f (OffsetClosed v) = OffsetClosed <$> f v +offsetVector _ OffsetOpen = pure OffsetOpen + type instance V (Offset c v n) = v type instance N (Offset c v n) = n @@ -148,6 +151,22 @@ data Segment c v n deriving (Show, Functor, Eq, Ord) +-- this is provided as a replacement of the previous fmap functionality. (Now +-- fmap is only over the number type) + +-- Prehaps a traversal is overkill. Only really need to map over segment vectors. + +-- | A traversal of the vectors that make up a segment. +segmentVectors :: Traversal (Segment c v n) (Segment c v' n') (v n) (v' n') +segmentVectors f (Linear offset) = Linear <$> offsetVector f offset +segmentVectors f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> offsetVector f offset + +-- | Map over the vectors of each segment. +mapSegmentVectors :: (v n -> v' n') -> Segment c v n -> Segment c v' n' +mapSegmentVectors = over segmentVectors +-- mapSegmentVectors f (Linear offset) = Linear $ over offsetVector f offset +-- mapSegmentVectors f (Cubic v1 v2 offset) = Cubic (f v1) (f v2) (over offsetVector f offset) + -- Note, can't yet have Haddock comments on GADT constructors; see -- http://trac.haskell.org/haddock/ticket/43. For now we don't need -- Segment to be a GADT but we might in the future. (?) @@ -156,8 +175,7 @@ type instance V (Segment c v n) = v type instance N (Segment c v n) = n instance Transformable (Segment c v n) where - transform t (Linear v) = Linear (transform t v) - transform t (Cubic v1 v2 v3) = Cubic (apply t v1) (apply t v2) (transform t v3) + transform = mapSegmentVectors . apply instance Renderable (Segment c v n) NullBackend where render _ _ = mempty @@ -183,7 +201,7 @@ bezier3 c1 c2 x = Cubic c1 c2 (OffsetClosed x) bézier3 :: v n -> v n -> v n -> Segment Closed v n bézier3 = bezier3 -type instance Codomain (Segment Closed v n) = v +type instance Codomain (Segment Closed v n) n = v n -- | 'atParam' yields a parametrized view of segments as continuous -- functions @[0,1] -> v@, which give the offset from the start of @@ -369,7 +387,7 @@ fromFixedSeg :: (Num n, Additive v) => FixedSegment v n -> Located (Segment Clos fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 -type instance Codomain (FixedSegment v n) = Point v +type instance Codomain (FixedSegment v n) n = Point v n instance (Additive v, Num n) => Parametric (FixedSegment v n) where atParam (FLinear p1 p2) t = lerp t p1 p2 diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs index a8ef12e6..ee96f5f5 100644 --- a/src/Diagrams/Tangent.hs +++ b/src/Diagrams/Tangent.hs @@ -26,16 +26,12 @@ module Diagrams.Tangent ) where - -import Linear.Vector --- import Linear.Metric import Diagrams.Core -import Diagrams.Core.V import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment --- import Diagrams.TwoD.Types (R2Ish) --- import Diagrams.TwoD.Vector (perp) + +import Linear.Vector ------------------------------------------------------------ -- Tangent @@ -52,7 +48,7 @@ instance DomainBounds t => DomainBounds (Tangent t) where domainLower (Tangent t) = domainLower t domainUpper (Tangent t) = domainUpper t -type instance Codomain (Tangent (Located t)) = Codomain (Tangent t) +type instance Codomain (Tangent (Located t)) n = Codomain (Tangent t) n instance Parametric (Tangent t) => Parametric (Tangent (Located t)) where Tangent l `atParam` p = Tangent (unLoc l) `atParam` p @@ -88,7 +84,7 @@ tangentAtEnd = atEnd . Tangent -------------------------------------------------- -- Segment -type instance Codomain (Tangent (Segment Closed v n)) = Codomain (Segment Closed v n) +type instance Codomain (Tangent (Segment Closed v n)) n = Codomain (Segment Closed v n) n instance (Additive v, Num n) => Parametric (Tangent (Segment Closed v n)) where diff --git a/src/Diagrams/ThreeD/Align.hs b/src/Diagrams/ThreeD/Align.hs index e4b3f577..ba7b5e21 100644 --- a/src/Diagrams/ThreeD/Align.hs +++ b/src/Diagrams/ThreeD/Align.hs @@ -46,68 +46,68 @@ import Diagrams.Align import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector -import Data.VectorSpace +import Linear.Vector -- | Translate the diagram along unitX so that all points have -- positive x-values. -alignXMin :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a -alignXMin = align (negateV unitX) +alignXMin :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +alignXMin = align (negated unitX) -snugXMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a -snugXMin = snug (negateV unitX) +snugXMin :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +snugXMin = snug (negated unitX) -- | Translate the diagram along unitX so that all points have -- negative x-values. -alignXMax :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a +alignXMax :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a alignXMax = align unitX -snugXMax :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +snugXMax :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a snugXMax = snug unitX -- | Translate the diagram along unitY so that all points have -- negative y-values. -alignYMax :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a +alignYMax :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a alignYMax = align unitY -- | Move the origin along unitY until it touches the edge of the -- diagram. -snugYMax:: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +snugYMax:: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a snugYMax = snug unitY -- | Translate the diagram along unitY so that all points have -- positive y-values. -alignYMin :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a -alignYMin = align (negateV unitY) +alignYMin :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +alignYMin = align (negated unitY) -snugYMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a -snugYMin = snug (negateV unitY) +snugYMin :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +snugYMin = snug (negated unitY) -- | Translate the diagram along unitZ so that all points have -- negative z-values. -alignZMax :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a +alignZMax :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a alignZMax = align unitZ -- | Move the origin along unitZ until it touches the edge of the -- diagram. -snugZMax:: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +snugZMax:: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a snugZMax = snug unitZ -- | Translate the diagram along unitZ so that all points have -- positive z-values. -alignZMin :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a -alignZMin = align (negateV unitZ) +alignZMin :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +alignZMin = align (negated unitZ) -- | Move the origin along unit_Z until it touches the edge of the -- diagram. -snugZMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a -snugZMin = snug (negateV unitZ) +snugZMin :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +snugZMin = snug (negated unitZ) -- | @alignX@ and @snugX@ move the local origin along unitX as follows: -- @@ -121,90 +121,91 @@ snugZMin = snug (negateV unitZ) -- -- * @snugX@ works the same way. -alignX :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a +alignX :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a alignX = alignBy unitX -- | See the documentation for 'alignX'. -snugX :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a +snugX :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a snugX = snugBy unitX -- | Like 'alignX', but moving the local origin vertically, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignY :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a +alignY :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a alignY = alignBy unitY -snugY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a +snugY :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a snugY = snugBy unitY -- | Like 'alignX', but moving the local origin in the Z direction, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignZ :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a +alignZ :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a alignZ = alignBy unitZ -snugZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => Scalar v -> a -> a +snugZ :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a snugZ = snugBy unitZ -- | Center the local origin along the X-axis. -centerX :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a +centerX :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a centerX = alignBy unitX 0 -snugCenterX :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +snugCenterX :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a snugCenterX = snugBy unitX 0 -- | Center the local origin along the Y-axis. -centerY :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a +centerY :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a centerY = alignBy unitY 0 -snugCenterY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +snugCenterY :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a snugCenterY = snugBy unitY 0 -- | Center the local origin along the Z-axis. -centerZ :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a +centerZ :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a centerZ = alignBy unitZ 0 -snugCenterZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +snugCenterZ :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a snugCenterZ = snugBy unitZ 0 -- | Center along both the X- and Y-axes. -centerXY :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a +centerXY :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a centerXY = centerX . centerY -snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +snugCenterXY :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a snugCenterXY = snugCenterX . snugCenterY -- | Center along both the X- and Z-axes. -centerXZ :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a +centerXZ :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a centerXZ = centerX . centerZ -snugCenterXZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +snugCenterXZ :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a snugCenterXZ = snugCenterX . snugCenterZ -- | Center along both the Y- and Z-axes. -centerYZ :: (Alignable a, HasOrigin a, V a ~ v, R3Ish v) => a -> a +centerYZ :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a centerYZ = centerZ . centerY -snugCenterYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +snugCenterYZ :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a snugCenterYZ = snugCenterZ . snugCenterY -- | Center an object in three dimensions. -centerXYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +centerXYZ :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a centerXYZ = centerX . centerY . centerZ -snugCenterXYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R3Ish v) => a -> a +snugCenterXYZ :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a snugCenterXYZ = snugCenterX . snugCenterY . snugCenterZ + diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs index c3ce4ad4..61da0370 100644 --- a/src/Diagrams/ThreeD/Deform.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -11,32 +11,32 @@ import Diagrams.Coordinates import Diagrams.ThreeD.Types -- | The parallel projection onto the plane x=0 -parallelX0 :: (R3Ish v) => Deformation v +parallelX0 :: Floating n => Deformation V3 n parallelX0 = Deformation (& _x .~ 0) -- | The perspective division onto the plane x=1 along lines going -- through the origin. -perspectiveX1 :: (R3Ish v) => Deformation v +perspectiveX1 :: Floating n => Deformation V3 n perspectiveX1 = Deformation (\p -> let x = p^._x in p & _x .~ 1 & _y //~ x & _z //~ x ) -- | The parallel projection onto the plane y=0 -parallelY0 :: (R3Ish v) => Deformation v +parallelY0 :: Floating n => Deformation V3 n parallelY0 = Deformation (& _y .~ 0) -- | The perspective division onto the plane y=1 along lines going -- through the origin. -perspectiveY1 :: (R3Ish v) => Deformation v +perspectiveY1 :: Floating n => Deformation V3 n perspectiveY1 = Deformation (\p -> let y = p^._y in p & _x //~ y & _y .~ 1 & _z //~ y ) -- | The parallel projection onto the plane z=0 -parallelZ0 :: (R3Ish v) => Deformation v +parallelZ0 :: Floating n => Deformation V3 n parallelZ0 = Deformation (& _z .~ 0) -- | The perspective division onto the plane z=1 along lines going -- through the origin. -perspectiveZ1 :: (R3Ish v) => Deformation v +perspectiveZ1 :: Floating n => Deformation V3 n perspectiveZ1 = Deformation (\p -> let z = p^._z in p & _x //~ z & _y //~ z & _z .~ 1 ) @@ -44,11 +44,12 @@ perspectiveZ1 = Deformation (\p -> let z = p^._z in -- axis. X coördinates stay fixed, while Y coördinates are compressed -- with increasing distance. @asDeformation (translation unitX) <> -- parallelX0 <> frustrumX = perspectiveX1@ -facingX :: (R3Ish v) => Deformation v +facingX :: Floating n => Deformation V3 n facingX = Deformation (\v -> v & _y //~ (v^._x) & _z //~ (v^._x)) -facingY :: (R3Ish v) => Deformation v +facingY :: Floating n => Deformation V3 n facingY = Deformation (\v -> v & _x //~ (v^._y) & _z //~ (v^._y)) -facingZ :: (R3Ish v) => Deformation v +facingZ :: Floating n => Deformation V3 n facingZ = Deformation (\v -> v & _x //~ (v^._z) & _y //~ (v^._z)) + diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index 2c6a51eb..50c65335 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -116,11 +116,6 @@ instance Fractional n => Transformable (Frustum n) where instance Fractional n => Renderable (Frustum n) NullBackend where render _ _ = mempty --- | @project u v@ computes the projection of @v@ onto @u@. -project :: (Metric v, Fractional n) => v n -> v n -> v n -project u v = ((v `dot` u) / quadrance u) *^ u - - -- | A frustum of a right circular cone. It has height 1 oriented -- along the positive z axis, and radii r0 and r1 at Z=0 and Z=1. -- 'cone' and 'cylinder' are special cases. diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 0dfc34b3..5e2e7c66 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Transform @@ -42,11 +43,11 @@ module Diagrams.ThreeD.Transform , reflectionAbout, reflectAbout -- * Utilities for Backends - , onBasis + -- , onBasis ) where import Diagrams.Core -import qualified Diagrams.Core.Transform as T +import Diagrams.Core.Transform import Diagrams.Angle import Diagrams.Coordinates @@ -54,12 +55,15 @@ import Diagrams.Direction import Diagrams.ThreeD.Types import Diagrams.Transform -import Control.Lens (view, (*~), (//~)) +import Control.Lens (view, (*~), (//~), (&), (.~)) import Data.Semigroup +import Diagrams.TwoD.Transform hiding (rotationAbout, reflectAbout, reflectionAbout) -import Data.AffineSpace -import Data.Cross -import Data.VectorSpace +import Linear.Vector +import Linear.Affine +import Linear.Epsilon +import Linear.Metric +import Linear.V3 (cross) -- | Create a transformation which rotates by the given angle about -- a line parallel the Z axis passing through the local origin. @@ -75,53 +79,49 @@ import Data.VectorSpace -- Note that writing @aboutZ (1\/4)@, with no type annotation, will -- yield an error since GHC cannot figure out which sort of angle -- you want to use. -aboutZ :: (R3Ish v) => Angle (Scalar v) -> Transformation v -aboutZ ang = fromLinear r (linv r) where - r = rot theta <-> rot (-theta) - theta = view rad ang - rot th (coords -> x :& y :& z) = (cos th * x - sin th * y) ^& - (sin th * x + cos th * y) ^& - z +aboutZ :: Floating n => Angle n -> Transformation V3 n +aboutZ (view rad -> a) = fromOrthogonal r where + r = rot a <-> rot (-a) + rot θ (V3 x y z) = V3 (cos θ * x - sin θ * y) + (sin θ * x + cos θ * y) + z -- | Like 'aboutZ', but rotates about the X axis, bringing positive y-values -- towards the positive z-axis. -aboutX :: (R3Ish v) => Angle (Scalar v) -> Transformation v -aboutX ang = fromLinear r (linv r) where - r = rot theta <-> rot (-theta) - theta = view rad ang - rot th (coords -> x :& y :& z) = (x) ^& - (cos th * y - sin th * z) ^& - (sin th * y + cos th * z) +aboutX :: Floating n => Angle n -> Transformation V3 n +aboutX (view rad -> a) = fromOrthogonal r where + r = rot a <-> rot (-a) + rot θ (V3 x y z) = V3 x + (cos θ * y - sin θ * z) + (sin θ * y + cos θ * z) -- | Like 'aboutZ', but rotates about the Y axis, bringing postive -- x-values towards the negative z-axis. -aboutY :: (R3Ish v) => Angle (Scalar v) -> Transformation v -aboutY ang = fromLinear r (linv r) where - r = rot theta <-> rot (-theta) - theta = view rad ang - rot th (coords -> x :& y :& z) = (cos th * x + sin th * z) ^& - y ^& - (-sin th * x + cos th * z) +aboutY :: Floating n => Angle n -> Transformation V3 n +aboutY (view rad -> a) = fromOrthogonal r where + r = rot a <-> rot (-a) + rot θ (V3 x y z) = V3 (cos θ * x + sin θ * z) + y + (-sin θ * x + cos θ * z) -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. -rotationAbout :: (R3Ish v) => - Point v -- ^ origin of rotation - -> Direction v -- ^ direction of rotation axis - -> Angle (Scalar v) -- ^ angle of rotation - -> Transformation v -rotationAbout p d a - = mconcat [translation (negateV t), - fromLinear r (linv r), +rotationAbout + :: (Floating n, Epsilon n) + => Point V3 n -- ^ origin of rotation + -> Direction V3 n -- ^ direction of rotation axis + -> Angle n -- ^ angle of rotation + -> Transformation V3 n +rotationAbout (P t) d (view rad -> a) + = mconcat [translation (negated t), + fromOrthogonal r, translation t] where - r = rot theta <-> rot (-theta) - theta = view rad a + r = rot a <-> rot (-a) w = fromDirection d - -- rot :: Scalar v -> v -> v - rot th v = v ^* cos th ^+^ - cross3 w v ^* sin th ^+^ - w ^* ((w <.> v) * (1 - cos th)) - t = p .-. origin + + rot θ v = v ^* cos θ + ^+^ cross w v ^* sin θ + ^+^ w ^* ((w `dot` v) * (1 - cos θ)) -- | @pointAt about initial final@ produces a rotation which brings -- the direction @initial@ to point in the direction @final@ by first @@ -130,144 +130,87 @@ rotationAbout p d a -- without tilting, it will be, otherwise if only tilting is -- necessary, no panning will occur. The tilt will always be between -- ± 1/4 turn. -pointAt :: (R3Ish v) => Direction v -> Direction v -> Direction v -> Transformation v +pointAt :: (Floating n, Epsilon n) + => Direction V3 n -> Direction V3 n -> Direction V3 n + -> Transformation V3 n pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) -- | pointAt' has the same behavior as 'pointAt', but takes vectors -- instead of directions. -pointAt' :: (R3Ish v) => v -> v -> v -> Transformation v -pointAt' about initial final = pointAtUnit (normalized about) (normalized initial) (normalized final) +pointAt' :: (Floating n, Epsilon n) => V3 n -> V3 n -> V3 n -> Transformation V3 n +pointAt' about initial final = pointAtUnit (signorm about) (signorm initial) (signorm final) -- | pointAtUnit has the same behavior as @pointAt@, but takes unit vectors. -pointAtUnit :: (R3Ish v) => v -> v -> v -> Transformation v +pointAtUnit :: (Floating n, Epsilon n) => V3 n -> V3 n -> V3 n -> Transformation V3 n pointAtUnit about initial final = tilt <> pan where -- rotating u by (signedAngle rel u v) about rel gives a vector in the direction of v - signedAngle rel u v = signum (cross3 u v <.> rel) *^ angleBetween u v + signedAngle rel u v = signum (cross u v `dot` rel) *^ angleBetween u v inPanPlaneF = final ^-^ project about final inPanPlaneI = initial ^-^ project about initial - panAngle = signedAngle about inPanPlaneI inPanPlaneF - pan = rotationAbout origin (direction about) panAngle - tiltAngle = signedAngle tiltAxis (transform pan initial) final - tiltAxis = cross3 final about - tilt = rotationAbout origin (direction tiltAxis) tiltAngle + panAngle = signedAngle about inPanPlaneI inPanPlaneF + pan = rotationAbout origin (direction about) panAngle + tiltAngle = signedAngle tiltAxis (transform pan initial) final + tiltAxis = cross final about + tilt = rotationAbout origin (direction tiltAxis) tiltAngle -- Scaling ------------------------------------------------- --- | Construct a transformation which scales by the given factor in --- the x direction. -scalingX :: (R3Ish v) => Scalar v -> Transformation v -scalingX c = fromLinear s s - where s = (_x *~ c) <-> (_x //~ c) - --- | Scale a diagram by the given factor in the x (horizontal) --- direction. To scale uniformly, use 'scale'. -scaleX :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t -scaleX = transform . scalingX - --- | Construct a transformation which scales by the given factor in --- the y direction. -scalingY :: (R3Ish v) => Scalar v -> Transformation v -scalingY c = fromLinear s s - where s = (_y *~ c) <-> (_y //~ c) - --- | Scale a diagram by the given factor in the y (vertical) --- direction. To scale uniformly, use 'scale'. -scaleY :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t -scaleY = transform . scalingY - -- | Construct a transformation which scales by the given factor in -- the z direction. -scalingZ :: (R3Ish v) => Scalar v -> Transformation v -scalingZ c = fromLinear s s +scalingZ :: (HasZ v, Additive v, Floating n) => n -> Transformation v n +scalingZ c = fromSymmetric s where s = (_z *~ c) <-> (_z //~ c) -- | Scale a diagram by the given factor in the z direction. To scale -- uniformly, use 'scale'. -scaleZ :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t +scaleZ :: (Transformable t, Floating n, Vn t ~ V3 n) => n -> t -> t scaleZ = transform . scalingZ -- Translation ---------------------------------------- --- | Construct a transformation which translates by the given distance --- in the x direction. -translationX :: (R3Ish v) => Scalar v -> Transformation v -translationX x = translation (x ^& 0 ^& 0) - --- | Translate a diagram by the given distance in the x --- direction. -translateX :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t -translateX = transform . translationX - --- | Construct a transformation which translates by the given distance --- in the y direction. -translationY :: (R3Ish v) => Scalar v -> Transformation v -translationY y = translation (0 ^& y ^& 0) - --- | Translate a diagram by the given distance in the y --- direction. -translateY :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t -translateY = transform . translationY - -- | Construct a transformation which translates by the given distance -- in the z direction. -translationZ :: (R3Ish v) => Scalar v -> Transformation v -translationZ z = translation (0 ^& 0 ^& z) +translationZ :: (HasZ v, Additive v, Floating n) => n -> Transformation v n +translationZ z = translation (zero & _z .~ z) -- | Translate a diagram by the given distance in the y -- direction. -translateZ :: (R3Ish v, Transformable t, V t ~ v) => Scalar v -> t -> t +translateZ :: (HasZ v, Transformable t, Vn t ~ v n, Additive v, Floating n) => n -> t -> t translateZ = transform . translationZ -- Reflection ---------------------------------------------- --- | Construct a transformation which flips a diagram across x=0, --- i.e. sends the point (x,y,z) to (-x,y,z). -reflectionX :: (R3Ish v) => Transformation v -reflectionX = scalingX (-1) - --- | Flip a diagram across x=0, i.e. send the point (x,y,z) to (-x,y,z). -reflectX :: (R3Ish v, Transformable t, V t ~ v) => t -> t -reflectX = transform reflectionX - --- | Construct a transformation which flips a diagram across y=0, --- i.e. sends the point (x,y,z) to (x,-y,z). -reflectionY :: (R3Ish v) => Transformation v -reflectionY = scalingY (-1) - --- | Flip a diagram across y=0, i.e. send the point (x,y,z) to --- (x,-y,z). -reflectY :: (R3Ish v, Transformable t, V t ~ v) => t -> t -reflectY = transform reflectionY - -- | Construct a transformation which flips a diagram across z=0, -- i.e. sends the point (x,y,z) to (x,y,-z). -reflectionZ :: (R3Ish v) => Transformation v +reflectionZ :: (HasZ v, Additive v, Floating n) => Transformation v n reflectionZ = scalingZ (-1) -- | Flip a diagram across z=0, i.e. send the point (x,y,z) to -- (x,y,-z). -reflectZ :: (R3Ish v, Transformable t, V t ~ v) => t -> t +reflectZ :: (HasZ v, Transformable t, Vn t ~ v n, Additive v, Floating n) => t -> t reflectZ = transform reflectionZ -- | @reflectionAbout p v@ is a reflection across the plane through -- the point @p@ and normal to vector @v@. -reflectionAbout :: (R3Ish v) => Point v -> v -> Transformation v +reflectionAbout :: (HasLinearMap v, Metric v, Fractional n, HasZ v) => Point v n -> v n -> Transformation v n reflectionAbout p v = - conjugate (translation (origin .-. p)) reflect where - reflect = fromLinear t (linv t) - t = f v <-> f (negateV v) - f u w = w ^-^ 2 *^ project u w + conjugate (translation (origin .-. p)) reflect + where + reflect = fromLinear t (linv t) + t = f v <-> f (negated v) + f u w = w ^-^ 2 *^ project u w -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. -reflectAbout :: (R3Ish v, Transformable t, V t ~ v) => Point v -> v -> t -> t +reflectAbout :: (HasZ v, HasLinearMap v, Metric v, Fractional n, Transformable t, Vn t ~ v n) + => Point v n -> v n -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Utilities ---------------------------------------- --- | Get the matrix equivalent of an affine transform, as a triple of --- columns paired with the translation vector. This is mostly --- useful for implementing backends. -onBasis :: (R3Ish v) => Transformation v -> ((v, v, v), v) -onBasis t = ((x, y, z), v) - where (x:y:z:[], v) = T.onBasis t +-- -- | Get the matrix equivalent of an affine transform, as a triple of +-- -- columns paired with the translation vector. This is mostly +-- -- useful for implementing backends. +-- onBasis :: (R3Ish v) => Transformation v -> ((v, v, v), v) +-- onBasis t = ((x, y, z), v) +-- where (x:y:z:[], v) = T.onBasis t diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index a3f36d8a..7cf8cc60 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -16,7 +16,7 @@ module Diagrams.ThreeD.Types ( -- * 3D Euclidean space r3, unr3, mkR3 , p3, unp3, mkP3 - , r3Iso, p3Iso + , r3Iso, p3Iso, project , V3 (..) -- * other coördinate systems @@ -32,6 +32,7 @@ import Diagrams.Points import Linear.V3 as V import Linear.Affine import Linear.Metric +import Linear.Vector import Diagrams.Coordinates ------------------------------------------------------------ @@ -72,6 +73,11 @@ p3Iso = iso unp3 p3 mkP3 :: n -> n -> n -> P3 n mkP3 x y z = p3 (x, y, z) + +-- | @project u v@ computes the projection of @v@ onto @u@. +project :: (Metric v, Fractional n) => v n -> v n -> v n +project u v = ((v `dot` u) / quadrance u) *^ u + -- | Types which can be expressed in spherical 3D coordinates, as a -- triple (r,θ,φ), where θ is rotation about the Z axis, and φ is the -- angle from the Z axis. diff --git a/src/Diagrams/Trace.hs b/src/Diagrams/Trace.hs index 0f856327..42648dc4 100644 --- a/src/Diagrams/Trace.hs +++ b/src/Diagrams/Trace.hs @@ -33,21 +33,24 @@ import Diagrams.Core.Trace import Data.Maybe import Data.Semigroup -import Data.VectorSpace (InnerSpace, Scalar, negateV) import Diagrams.Combinators (withTrace) +import Linear.Vector +import Linear.Metric + -- | Compute the furthest point on the boundary of a subdiagram, -- beginning from the location (local origin) of the subdiagram and -- moving in the direction of the given vector. If there is no such -- point, the origin is returned; see also 'boundaryFromMay'. -boundaryFrom :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Semigroup m) - => Subdiagram b v m -> v -> Point v +boundaryFrom :: (HasLinearMap v, OrderedField n, Metric v, Semigroup m) + => Subdiagram b v n m -> v n -> Point v n boundaryFrom s v = fromMaybe origin $ boundaryFromMay s v -- | Compute the furthest point on the boundary of a subdiagram, -- beginning from the location (local origin) of the subdiagram and -- moving in the direction of the given vector, or @Nothing@ if -- there is no such point. -boundaryFromMay :: (HasLinearMap v, OrderedField (Scalar v), Semigroup m, InnerSpace v) - => Subdiagram b v m -> v -> Maybe (Point v) -boundaryFromMay s v = traceP (location s) (negateV v) s +boundaryFromMay :: (HasLinearMap v, Metric v, OrderedField n, Semigroup m) + => Subdiagram b v n m -> v n -> Maybe (Point v n) +boundaryFromMay s v = traceP (location s) (negated v) s + diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 465a0dcb..190affc0 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -115,7 +115,6 @@ import Data.Semigroup import qualified Numeric.Interval.Kaucher as I import Diagrams.Core hiding ((|>)) -import Diagrams.Core.V import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment @@ -175,7 +174,7 @@ deriving instance (OrderedField n, Metric v) deriving instance (Metric v, OrderedField n) => Transformable (SegTree v n) -type instance Codomain (SegTree v n) = v +type instance Codomain (SegTree v n) n = v n instance (Metric v, OrderedField n, RealFrac n) => Parametric (SegTree v n) where @@ -230,10 +229,10 @@ instance (Metric v, OrderedField n, RealFrac n) | otherwise = fun (eps / numSegs t) where i = trailMeasure (I.singleton 0) - (getArcLengthCached :: ArcLength (v n) -> I.Interval n) + getArcLengthCached t fun = trailMeasure (const 0) - (getArcLengthFun :: ArcLength v -> n -> I.Interval n) + getArcLengthFun t arcLengthToParam eps st@(SegTree t) l @@ -260,7 +259,7 @@ instance (Metric v, OrderedField n, RealFrac n) FT.split ((>= l) . trailMeasure 0 - (I.midpoint . (getArcLengthBounded eps :: ArcLength (v n) -> I.Interval n))) + (I.midpoint . getArcLengthBounded eps)) t -- | Given a default result (to be used in the case of an empty @@ -373,7 +372,7 @@ deriving instance Ord (v n) => Ord (Trail' l v n) type instance V (Trail' l v n) = v type instance N (Trail' l v n) = n -type instance Codomain (Trail' l v n) = v +type instance Codomain (Trail' l v n) n = v n instance (OrderedField n, Metric v) => Semigroup (Trail' Line v n) where (Line t1) <> (Line t2) = Line (t1 `mappend` t2) @@ -408,7 +407,7 @@ instance (Metric v, OrderedField n, RealFrac n) (\l -> cutLoop l `atParam` mod1 p) t -type instance Codomain (Tangent (Trail' c v n)) = Codomain (Trail' c v n) +type instance Codomain (Tangent (Trail' c v n)) n = Codomain (Trail' c v n) n instance ( Parametric (GetSegment (Trail' c v n)) , Additive v @@ -435,7 +434,7 @@ instance ( Parametric (GetSegment (Trail' c v n)) Nothing -> zero Just (_, seg, _) -> atEnd (Tangent seg) -type instance Codomain (Tangent (Trail v n)) = Codomain (Trail v n) +type instance Codomain (Tangent (Trail v n)) n = Codomain (Trail v n) n instance ( Metric v , OrderedField n @@ -536,12 +535,12 @@ getSegment = GetSegment type instance V (GetSegment t) = V t type instance N (GetSegment t) = N t -type instance Codomain (GetSegment t) (N t) +type instance Codomain (GetSegment t) n -- = V t = Maybe - ( V t (N t) -- offset from trail start to segment start - , Segment Closed (V t) (N t) -- the segment - , AnIso' (N t) (N t) -- reparameterization, trail <-> segment + ( V t n -- offset from trail start to segment start + , Segment Closed (V t) n -- the segment + , AnIso' n n -- reparameterization, trail <-> segment ) -- | Parameters less than 0 yield the first segment; parameters @@ -677,7 +676,7 @@ instance (OrderedField n, Metric v) => Monoid (Trail v n) where type instance V (Trail v n) = v type instance N (Trail v n) = n -type instance Codomain (Trail v n) = v +type instance Codomain (Trail v n) n = v n instance (HasLinearMap v, Metric v, OrderedField n) => Transformable (Trail v n) where diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs index af3e56b6..468cf1d2 100644 --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -37,6 +37,10 @@ import Diagrams.Located import Diagrams.Segment import Diagrams.Trail +import Linear.Affine +import Linear.Metric +import Linear.Vector + ------------------------------------------------------------ -- TrailLike class ------------------------------------------------------------ @@ -143,7 +147,7 @@ fromOffsets = trailLike . (`at` origin) . trailFromOffsets -- | Construct a trail-like thing of linear segments from a located -- list of offsets. -fromLocOffsets :: (V (V t) ~ V t, TrailLike t) => Located [Vn t] -> t +fromLocOffsets :: (Vn (Vn t) ~ Vn t, TrailLike t) => Located [Vn t] -> t fromLocOffsets = trailLike . mapLoc trailFromOffsets -- | Construct a trail-like thing connecting the given vertices with @@ -170,7 +174,7 @@ fromVertices :: TrailLike t => [Point (V t) (N t)] -> t fromVertices [] = trailLike (emptyTrail `at` origin) fromVertices ps@(p:_) = trailLike (trailFromSegments (segmentsFromVertices ps) `at` p) -segmentsFromVertices :: AdditiveGroup v => [Point v] -> [Segment Closed v] +segmentsFromVertices :: (Additive v, Num n) => [Point v n] -> [Segment Closed v n] segmentsFromVertices [] = [] segmentsFromVertices vvs@(_:vs) = map straight (zipWith (flip (.-.)) vvs vs) @@ -181,7 +185,7 @@ segmentsFromVertices vvs@(_:vs) = map straight (zipWith (flip (.-.)) vvs vs) -- > twiddleEx -- > = mconcat ((~~) <$> hexagon 1 <*> hexagon 1) -- > # centerXY # pad 1.1 -(~~) :: TrailLike t => Point (V t) (N t) -> Point (V t) (N t) -> t +(~~) :: (Vn t ~ v n, TrailLike t) => Point v n -> Point v n -> t p1 ~~ p2 = fromVertices [p1, p2] -- | Given a concretely located trail, \"explode\" it by turning each @@ -195,7 +199,8 @@ p1 ~~ p2 = fromVertices [p1, p2] -- > # explodeTrail -- generate a list of diagrams -- > # zipWith lc [orange, green, yellow, red, blue] -- > # mconcat # centerXY # pad 1.1 -explodeTrail :: (Vn ~ v n, Additive v, TrailLike t) => Located (Trail v n) -> [t] +explodeTrail :: (Vn t ~ v n, Additive v, TrailLike t) => Located (Trail v n) -> [t] explodeTrail = map (mkTrail . fromFixedSeg) . fixTrail where mkTrail = trailLike . mapLoc (trailFromSegments . (:[])) + diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs index dbbf4d75..afd2fbff 100644 --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -47,51 +47,49 @@ import Diagrams.Align import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -import Data.VectorSpace - -- | Align along the left edge, i.e. translate the diagram in a -- horizontal direction so that the local origin is on the left edge -- of the envelope. -alignL :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a -alignL = align (negateV unitX) +alignL :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +alignL = align unit_X -snugL :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R2Ish v) => a -> a -snugL = snug (negateV unitX) +snugL :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +snugL = snug unit_X -- | Align along the right edge. -alignR :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a +alignR :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a alignR = align unitX -snugR :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R2Ish v) => a -> a +snugR :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a snugR = snug unitX -- | Align along the top edge. -alignT :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a +alignT :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a alignT = align unitY -snugT:: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R2Ish v) => a -> a +snugT:: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a snugT = snug unitY -- | Align along the bottom edge. -alignB :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a -alignB = align (negateV unitY) +alignB :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +alignB = align unit_Y -snugB :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R2Ish v) => a -> a -snugB = snug (negateV unitY) +snugB :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +snugB = snug unit_Y -alignTL, alignTR, alignBL, alignBR :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a +alignTL, alignTR, alignBL, alignBR :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a alignTL = alignT . alignL alignTR = alignT . alignR alignBL = alignB . alignL alignBR = alignB . alignR snugTL, snugTR, snugBL, snugBR - :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a, V a ~ v, R2Ish v) + :: (Fractional n, Alignable a, Traced a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a snugTL = snugT . snugL snugTR = snugT . snugR @@ -110,44 +108,45 @@ snugBR = snugB . snugR -- -- * @snugX@ works the same way. -alignX :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => Scalar v -> a -> a +alignX :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => n -> a -> a alignX = alignBy unitX -- | See the documentation for 'alignX'. -snugX :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R2Ish v) => Scalar v -> a -> a +snugX :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V2 n, Floating n) => n -> a -> a snugX = snugBy unitX -- | Like 'alignX', but moving the local origin vertically, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignY :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => Scalar v -> a -> a +alignY :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => n -> a -> a alignY = alignBy unitY -snugY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R2Ish v) => Scalar v -> a -> a +snugY :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V2 n, Floating n) => n -> a -> a snugY = snugBy unitY -- | Center the local origin along the X-axis. -centerX :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a +centerX :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a centerX = alignBy unitX 0 -snugCenterX :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R2Ish v) => a -> a +snugCenterX :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a snugCenterX = snugBy unitX 0 -- | Center the local origin along the Y-axis. -centerY :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a +centerY :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a centerY = alignBy unitY 0 -snugCenterY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R2Ish v) => a -> a +snugCenterY :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a snugCenterY = snugBy unitY 0 -- | Center along both the X- and Y-axes. -centerXY :: (Alignable a, HasOrigin a, V a ~ v, R2Ish v) => a -> a +centerXY :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a centerXY = center -snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ v, R2Ish v) => a -> a +snugCenterXY :: (Fractional n, Alignable a, Traced a, + HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a snugCenterXY = snugCenter + diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index b015974e..2e4af14c 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -37,10 +37,12 @@ import Diagrams.TwoD.Vector (unitX, unitY, unit_Y) import Diagrams.Util (( # )) import Control.Lens ((&), (<>~), (^.)) -import Data.AffineSpace import Data.Semigroup ((<>)) -import Data.VectorSpace -import Diagrams.Coordinates + +import Linear.Epsilon +import Linear.Vector +import Linear.Metric +import Linear.Affine -- For details of this approximation see: -- http://www.tinaja.com/glib/bezcirc2.pdf @@ -49,12 +51,12 @@ import Diagrams.Coordinates -- the positive y direction and sweeps counterclockwise through an -- angle @s@. The approximation is only valid for angles in the -- first quadrant. -bezierFromSweepQ1 :: (R2Ish v) => Angle (Scalar v) -> Segment Closed v -bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 - where p0@(coords -> x :& y) = rotate (s ^/ 2) v - c1 = ((4-x)/3) ^& ((1-x)*(3-x)/(3*y)) - c2 = reflectY c1 - v = unitX +bezierFromSweepQ1 :: Floating n => Angle n -> Segment Closed V2 n +bezierFromSweepQ1 s = mapSegmentVectors (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 + where p0@(V2 x y) = rotate (s ^/ 2) v + c1 = V2 ((4-x)/3) ((1-x)*(3-x)/(3*y)) + c2 = reflectY c1 + v = unitX -- | @bezierFromSweep s@ constructs a series of 'Cubic' segments that -- start in the positive y direction and sweep counter clockwise @@ -62,13 +64,13 @@ bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 -- negative y direction and sweep clockwise. When @s@ is less than -- 0.0001 the empty list results. If the sweep is greater than @fullTurn@ -- later segments will overlap earlier segments. -bezierFromSweep :: (R2Ish v) => Angle (Scalar v) -> [Segment Closed v] +bezierFromSweep :: OrderedField n => Angle n -> [Segment Closed V2 n] bezierFromSweep s - | s < zeroV = fmap reflectY . bezierFromSweep $ (negateV s) - | s < 0.0001 @@ rad = [] - | s < fullTurn^/4 = [bezierFromSweepQ1 s] - | otherwise = bezierFromSweepQ1 (fullTurn^/4) - : map (rotateBy (1/4)) (bezierFromSweep (max (s ^-^ fullTurn^/4) zeroV)) + | s < zero = fmap reflectY . bezierFromSweep $ negated s + | s < 0.0001 @@ rad = [] + | s < fullTurn^/4 = [bezierFromSweepQ1 s] + | otherwise = bezierFromSweepQ1 (fullTurn^/4) + : map (rotateBy (1/4)) (bezierFromSweep (max (s ^-^ fullTurn^/4) zero)) {- ~~~~ Note [segment spacing] @@ -94,16 +96,16 @@ the approximation error. -- is the 'Trail' of a radius one arc starting at @d@ and sweeping out -- the angle @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arcT :: (R2Ish v) => Direction v -> Angle (Scalar v) -> Trail v +arcT :: (RealFloat n, Epsilon n) => Direction V2 n -> Angle n -> Trail V2 n arcT start sweep = trailFromSegments bs where - bs = map (rotate $ start ^. _theta) . bezierFromSweep $ sweep + bs = map (rotate $ start ^. _theta) . bezierFromSweep $ sweep --- | Given a start angle @d@ and a sweep angle @s@, @'arc' d s@ is the +-- | Given a start direction @d@ and a sweep angle @s@, @'arc' d s@ is the -- path of a radius one arc starting at @d@ and sweeping out the angle -- @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arc :: (R2Ish v, TrailLike t, V t ~ v) => Direction v -> Angle (Scalar v) -> t +arc :: (TrailLike t, Vn t ~ V2 n, RealFloat n, Epsilon n) => Direction V2 n -> Angle n -> t arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ p2 (1,0)) -- | Given a radus @r@, a start direction @d@ and an angle @s@, @@ -115,7 +117,7 @@ arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ -- -- > arc'Ex = mconcat [ arc' r (0 @@ turn) (1/4 @@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 -arc' :: (R2Ish v, TrailLike p, V p ~ v) => Scalar v -> Direction v -> Angle (Scalar v) -> p +arc' :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> Direction V2 n -> Angle n -> t arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) $ p2 (abs r,0)) where ts = arcT start sweep @@ -131,11 +133,11 @@ arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -wedge :: (R2Ish v, TrailLike p, V p ~ v) => Scalar v -> Direction v -> Angle (Scalar v) -> p +wedge :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> Direction V2 n -> Angle n -> t wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine $ fromOffsets [r *^ fromDirection d] <> arc d s # scale r - <> fromOffsets [r *^ negateV (rotate s $ fromDirection d)] + <> fromOffsets [r *^ negated (rotate s $ fromDirection d)] -- | @arcBetween p q height@ creates an arc beginning at @p@ and -- ending at @q@, with its midpoint at a distance of @abs height@ @@ -148,24 +150,24 @@ wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine -- > arcBetweenEx = mconcat -- > [ arcBetween origin (p2 (2,1)) ht | ht <- [-0.2, -0.1 .. 0.2] ] -- > # centerXY # pad 1.1 -arcBetween :: (R2Ish v, TrailLike t, V t ~ v) => Point v -> Point v -> Scalar v -> t +arcBetween :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => Point V2 n -> Point V2 n -> n -> t arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) where h = abs ht isStraight = h < 0.00001 v = q .-. p - d = magnitude (q .-. p) + d = norm (q .-. p) th = acosA ((d*d - 4*h*h)/(d*d + 4*h*h)) r = d/(2*sinA th) mid | ht >= 0 = direction unitY | otherwise = direction unit_Y - st = mid & _theta <>~ (negateV th) + st = mid & _theta <>~ negated th a | isStraight = fromOffsets [d *^ unitX] | otherwise = arc st (2 *^ th) # scale r - # translateY ((if ht > 0 then negate else id) (r-h)) + # translateY ((if ht > 0 then negate else id) (r - h)) # translateX (d/2) # (if ht > 0 then reverseLocTrail else id) @@ -182,12 +184,13 @@ arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -annularWedge :: (R2Ish v, TrailLike p, V p ~ v) => - Scalar v -> Scalar v -> Direction v -> Angle (Scalar v) -> p +annularWedge :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => + n -> n -> Direction V2 n -> Angle n -> t annularWedge r1' r2' d1 s = trailLike . (`at` o) . glueTrail . wrapLine - $ fromOffsets [(r1'-r2') *^ fromDirection d1] + $ fromOffsets [(r1' - r2') *^ fromDirection d1] <> arc d1 s # scale r1' - <> fromOffsets [(r1'-r2') *^ negateV (fromDirection d2)] - <> arc d2 (negateV s) # scale r2' + <> fromOffsets [(r1' - r2') *^ negated (fromDirection d2)] + <> arc d2 (negated s) # scale r2' where o = origin # translate (r2' *^ fromDirection d1) d2 = d1 & _theta <>~ s + diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 5f0ad5b3..7de8e7be 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -104,15 +104,14 @@ module Diagrams.TwoD.Arrow import Control.Applicative ((<*>)) import Control.Lens (Lens', Setter', Traversal', generateSignatures, lensRules, makeLensesWith, view, (%~), (&), (.~), (^.)) -import Data.AffineSpace import Data.Default.Class import Data.Functor ((<$>)) import Data.Maybe (fromMaybe) import Data.Monoid.Coproduct (untangle) import Data.Semigroup -import Data.VectorSpace import Data.Colour hiding (atop) +import Data.Data import Diagrams.Core import Diagrams.Core.Types (QDiaLeaf (..), mkQD') @@ -132,25 +131,32 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unit_X) import Diagrams.Util (( # )) -data ArrowOpts v +import Linear.Affine +import Linear.Epsilon +import Linear.Vector +import Linear.Metric + +type TypeableReal n = (Epsilon n, Typeable n, RealFloat n, Data n) + +data ArrowOpts n = ArrowOpts - { _arrowHead :: ArrowHT v - , _arrowTail :: ArrowHT v - , _arrowShaft :: Trail v - , _headGap :: Measure v - , _tailGap :: Measure v - , _headStyle :: Style v - , _headLength :: Measure v - , _tailStyle :: Style v - , _tailLength :: Measure v - , _shaftStyle :: Style v + { _arrowHead :: ArrowHT n + , _arrowTail :: ArrowHT n + , _arrowShaft :: Trail V2 n + , _headGap :: Measure n + , _tailGap :: Measure n + , _headStyle :: Style V2 n + , _headLength :: Measure n + , _tailStyle :: Style V2 n + , _tailLength :: Measure n + , _shaftStyle :: Style V2 n } -- | Straight line arrow shaft. -straightShaft :: (R2Ish v) => Trail v +straightShaft :: OrderedField n => Trail V2 n straightShaft = trailFromOffsets [unitX] -instance (R2Ish v) => Default (ArrowOpts v) where +instance (Epsilon n, RealFloat n) => Default (ArrowOpts n) where def = ArrowOpts { _arrowHead = dart , _arrowTail = noTail @@ -160,59 +166,59 @@ instance (R2Ish v) => Default (ArrowOpts v) where -- See note [Default arrow style attributes] , _headStyle = mempty - , _headLength = normal + , _headLength = normal , _tailStyle = mempty - , _tailLength = normal + , _tailLength = normal , _shaftStyle = mempty } makeLensesWith (lensRules & generateSignatures .~ False) ''ArrowOpts -- | A shape to place at the head of the arrow. -arrowHead :: Lens' (ArrowOpts v) (ArrowHT v) +arrowHead :: Lens' (ArrowOpts n) (ArrowHT n) -- | A shape to place at the tail of the arrow. -arrowTail :: Lens' (ArrowOpts v) (ArrowHT v) +arrowTail :: Lens' (ArrowOpts n) (ArrowHT n) -- | The trail to use for the arrow shaft. -arrowShaft :: Lens' (ArrowOpts v) (Trail v) +arrowShaft :: Lens' (ArrowOpts n) (Trail V2 n) -- | Distance to leave between the head and the target point. -headGap :: Lens' (ArrowOpts v) (Measure v) +headGap :: Lens' (ArrowOpts n) (Measure n) -- | Distance to leave between the starting point and the tail. -tailGap :: Lens' (ArrowOpts v) (Measure v) +tailGap :: Lens' (ArrowOpts n) (Measure n) -- | Set both the @headGap@ and @tailGap@ simultaneously. -gaps :: Traversal' (ArrowOpts v) (Measure v) +gaps :: Traversal' (ArrowOpts n) (Measure n) gaps f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap) -- | Same as gaps, provided for backward compatiiblity. -gap :: Traversal' (ArrowOpts v) (Measure v) +gap :: Traversal' (ArrowOpts n) (Measure n) gap = gaps -- | Style to apply to the head. @headStyle@ is modified by using the lens -- combinator @%~@ to change the current style. For example, to change -- an opaque black arrowhead to translucent orange: -- @(with & headStyle %~ fc orange . opacity 0.75)@. -headStyle :: Lens' (ArrowOpts v) (Style v) +headStyle :: Lens' (ArrowOpts n) (Style V2 n) -- | Style to apply to the tail. See `headStyle`. -tailStyle :: Lens' (ArrowOpts v) (Style v) +tailStyle :: Lens' (ArrowOpts n) (Style V2 n) -- | Style to apply to the shaft. See `headStyle`. -shaftStyle :: Lens' (ArrowOpts v) (Style v) +shaftStyle :: Lens' (ArrowOpts n) (Style V2 n) -- | The length from the start of the joint to the tip of the head. -headLength :: Lens' (ArrowOpts v) (Measure v) +headLength :: Lens' (ArrowOpts n) (Measure n) -- | The length of the tail plus its joint. -tailLength :: Lens' (ArrowOpts v) (Measure v) +tailLength :: Lens' (ArrowOpts n) (Measure n) -- | Set both the @headLength@ and @tailLength@ simultaneously. -lengths :: Traversal' (ArrowOpts v) (Measure v) +lengths :: Traversal' (ArrowOpts n) (Measure n) lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts ^. headLength) <*> f (opts ^. tailLength) @@ -222,71 +228,71 @@ lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts -- defined. Or @... (with & headTexture .~ solid blue@ to set the head -- color to blue. For more general control over the style of arrowheads, -- see 'headStyle'. -headTexture :: (R2Ish v) => Setter' (ArrowOpts v) (Texture v) +headTexture :: TypeableReal n => Setter' (ArrowOpts n) (Texture n) headTexture = headStyle . styleFillTexture -- | A lens for setting or modifying the texture of an arrow -- tail. -tailTexture :: (R2Ish v) => Setter' (ArrowOpts v) (Texture v) +tailTexture :: TypeableReal n => Setter' (ArrowOpts n) (Texture n) tailTexture = tailStyle . styleFillTexture -- | A lens for setting or modifying the texture of an arrow -- shaft. -shaftTexture :: (R2Ish v) => Setter' (ArrowOpts v) (Texture v) +shaftTexture :: TypeableReal n => Setter' (ArrowOpts n) (Texture n) shaftTexture = shaftStyle . styleLineTexture -- Set the default shaft style of an `ArrowOpts` record by applying the -- default style after all other styles have been applied. -- The semigroup stucture of the lw attribute will insure that the default -- is only used if it has not been set in @opts@. -shaftSty :: (R2Ish v) => ArrowOpts v -> Style v +shaftSty :: (Fractional n) => ArrowOpts n -> Style V2 n shaftSty opts = opts^.shaftStyle -- Set the default head style. See `shaftSty`. -headSty :: (R2Ish v) => ArrowOpts v -> Style v +headSty :: TypeableReal n => ArrowOpts n -> Style V2 n headSty opts = fc black (opts^.headStyle) -- Set the default tail style. See `shaftSty`. -tailSty :: (R2Ish v) => ArrowOpts v -> Style v +tailSty :: TypeableReal n => ArrowOpts n -> Style V2 n tailSty opts = fc black (opts^.tailStyle) -fromMeasure :: (R2Ish v) => Scalar v -> Scalar v -> Measure v -> Scalar v +fromMeasure :: TypeableReal n => n -> n -> Measure n -> n fromMeasure g n m = u where Output u = toOutput g n m -- | Calculate the length of the portion of the horizontal line that passes -- through the origin and is inside of p. -xWidth :: (R2Ish v) => (Traced t, V t ~ v) => t -> Scalar v +xWidth :: (Floating n) => (Traced t, Vn t ~ V2 n) => t -> n xWidth p = a + b where - a = fromMaybe 0 (magnitude <$> traceV origin unitX p) - b = fromMaybe 0 (magnitude <$> traceV origin unit_X p) + a = fromMaybe 0 (norm <$> traceV origin unitX p) + b = fromMaybe 0 (norm <$> traceV origin unit_X p) -- | Get the line color from the shaft to use as the fill color for the joint. -- And set the opacity of the shaft to the current opacity. -colorJoint :: (R2Ish v) => Style v -> Style v +colorJoint :: TypeableReal n => Style V2 n -> Style V2 n colorJoint sStyle = let c = fmap getLineTexture . getAttr $ sStyle o = fmap getOpacity . getAttr $ sStyle in case (c, o) of - (Nothing, Nothing) -> fillColor (black :: Colour Double) $ mempty - (Just t, Nothing) -> fillTexture t $ mempty - (Nothing, Just o') -> opacity o' . fillColor (black :: Colour Double) $ mempty - (Just t, Just o') -> opacity o' . fillTexture t $ mempty + (Nothing, Nothing) -> fillColor (black :: Colour Double) mempty + (Just t, Nothing) -> fillTexture t mempty + (Nothing, Just o') -> opacity o' . fillColor (black :: Colour Double) $ mempty + (Just t, Just o') -> opacity o' . fillTexture t $ mempty -- | Get line width from a style. -widthOfJoint :: forall v. (R2Ish v) => Style v -> Scalar v -> Scalar v -> Scalar v +widthOfJoint :: forall n. TypeableReal n => Style V2 n -> n -> n -> n widthOfJoint sStyle gToO nToO = - maybe (fromMeasure gToO nToO (Output 1 :: Measure v)) -- Should be same as default line width + maybe (fromMeasure gToO nToO (Output 1 :: Measure n)) -- Should be same as default line width (fromMeasure gToO nToO) - (fmap getLineWidth . getAttr $ sStyle :: Maybe (Measure v)) + (fmap getLineWidth . getAttr $ sStyle :: Maybe (Measure n)) -- | Combine the head and its joint into a single scale invariant diagram -- and move the origin to the attachment point. Return the diagram -- and its width. -mkHead :: (R2D v, Renderable (Path v) b) => - Scalar v -> ArrowOpts v -> Scalar v -> Scalar v -> (Diagram b v, Scalar v) +mkHead :: (TypeableReal n, Renderable (Path V2 n) b) => + n -> ArrowOpts n -> n -> n -> (Diagram b V2 n, n) mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 , hWidth + jWidth) where @@ -298,8 +304,8 @@ mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) -- | Just like mkHead only the attachment point is on the right. -mkTail :: (R2D v, Renderable (Path v) b) => - Scalar v -> ArrowOpts v -> Scalar v -> Scalar v -> (Diagram b v, Scalar v) +mkTail :: (TypeableReal n, Renderable (Path V2 n) b) => + n -> ArrowOpts n -> n -> n -> (Diagram b V2 n, n) mkTail size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 , tWidth + jWidth) where @@ -313,17 +319,17 @@ mkTail size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 -- | Make a trail with the same angles and offset as an arrow with tail width -- tw, head width hw and shaft of tr, such that the magnituted of the shaft -- offset is size. Used for calculating the offset of an arrow. -spine :: (R2Ish v) => Trail v -> Scalar v -> Scalar v -> Scalar v -> Trail v +spine :: TypeableReal n => Trail V2 n -> n -> n -> n -> Trail V2 n spine tr tw hw size = tS <> tr # scale size <> hS where - tSpine = trailFromOffsets [(normalized . tangentAtStart) $ tr] # scale tw - hSpine = trailFromOffsets [(normalized . tangentAtEnd) $ tr] # scale hw + tSpine = trailFromOffsets [normalize . tangentAtStart $ tr] # scale tw + hSpine = trailFromOffsets [normalize . tangentAtEnd $ tr] # scale hw hS = if hw > 0 then hSpine else mempty tS = if tw > 0 then tSpine else mempty -- | Calculate the amount required to scale a shaft trail so that an arrow with -- head width hw and tail width tw has offset t. -scaleFactor :: (R2Ish v) => Trail v -> Scalar v -> Scalar v -> Scalar v -> Scalar v +scaleFactor :: TypeableReal n => Trail V2 n -> n -> n -> n -> n scaleFactor tr tw hw t -- Let tv be a vector representing the tail width, i.e. a vector @@ -338,9 +344,9 @@ scaleFactor tr tw hw t -- dot product, resulting in a quadratic in k. = case quadForm - (magnitudeSq v) - (2* (v <.> (tv ^+^ hv))) - (magnitudeSq (tv ^+^ hv) - t*t) + (quadrance v) + (2* (v `dot` (tv ^+^ hv))) + (quadrance (tv ^+^ hv) - t*t) of [] -> 1 -- no scale works, just return 1 [s] -> s -- single solution @@ -348,31 +354,31 @@ scaleFactor tr tw hw t -- we will usually get both a positive and a negative solution; -- return the maximum (i.e. positive) solution where - tv = tw *^ (tangentAtStart tr # normalized) - hv = hw *^ (tangentAtEnd tr # normalized) + tv = tw *^ (tangentAtStart tr # normalize) + hv = hw *^ (tangentAtEnd tr # normalize) v = trailOffset tr -- Calculate the approximate envelope of a horizontal arrow -- as if the arrow were made only of a shaft. -arrowEnv :: (R2Ish v) => ArrowOpts v -> Scalar v -> Envelope v +arrowEnv :: TypeableReal n => ArrowOpts n -> n -> Envelope V2 n arrowEnv opts len = getEnvelope horizShaft where - horizShaft = shaft # rotate (negateV (v ^. _theta)) # scale (len / m) - m = magnitude v + horizShaft = shaft # rotate (negated (v ^. _theta)) # scale (len / m) + m = norm v v = trailOffset shaft shaft = opts ^. arrowShaft -- | @arrow len@ creates an arrow of length @len@ with default -- parameters, starting at the origin and ending at the point -- @(len,0)@. -arrow :: (R2D v, Renderable (Path v) b) => Scalar v -> Diagram b v -arrow len = arrow' def len +arrow :: (TypeableReal n, Renderable (Path V2 n) b) => n -> Diagram b V2 n +arrow = arrow' def -- | @arrow' opts len@ creates an arrow of length @len@ using the -- given options, starting at the origin and ending at the point -- @(len,0)@. In particular, it scales the given 'arrowShaft' so -- that the entire arrow has length @len@. -arrow' :: (R2D v, Renderable (Path v) b) => ArrowOpts v -> Scalar v -> Diagram b v +arrow' :: (TypeableReal n, Renderable (Path V2 n) b) => ArrowOpts n -> n -> Diagram b V2 n arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- Currently arrows have an empty envelope and trace. @@ -414,10 +420,15 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- The head size, tail size, head gap, and tail gap are obtained -- from the style and converted to output units. - hSize = fromMeasure gToO nToO . transform tr $ opts ^. headLength - tSize = fromMeasure gToO nToO . transform tr $ opts ^. tailLength - hGap = fromMeasure gToO nToO . transform tr $ opts ^. headGap - tGap = fromMeasure gToO nToO . transform tr $ opts ^. tailGap + scaleFromMeasure = fromMeasure gToO nToO . scaleFromTransform tr + hSize = scaleFromMeasure $ opts ^. headLength + tSize = scaleFromMeasure $ opts ^. tailLength + hGap = scaleFromMeasure $ opts ^. headGap + tGap = scaleFromMeasure $ opts ^. tailGap + -- hSize = fromMeasure gToO nToO . transform tr $ opts ^. headLength + -- tSize = fromMeasure gToO nToO . transform tr $ opts ^. tailLength + -- hGap = fromMeasure gToO nToO . transform tr $ opts ^. headGap + -- tGap = fromMeasure gToO nToO . transform tr $ opts ^. tailGap -- Make the head and tail and save their widths. (h, hWidth') = mkHead hSize opts' gToO nToO @@ -427,7 +438,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) shaftTrail = rawShaftTrail -- rotate it so it is pointing in the positive X direction - # rotate (negateV . view _theta . trailOffset $ rawShaftTrail) + # rotate (negated . view _theta . trailOffset $ rawShaftTrail) -- apply the context transformation -- in case it includes -- things like flips and shears (the possibility of shears -- is why we must rotate it to a neutral position first) @@ -444,7 +455,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- Calculte the scaling factor to apply to the shaft shaftTrail so that the entire -- arrow will be of length len. Then apply it to the shaft and make the -- shaft into a Diagram with using its style. - sf = scaleFactor shaftTrail tWidth hWidth (magnitude (q .-. p)) + sf = scaleFactor shaftTrail tWidth hWidth (norm (q .-. p)) shaftTrail' = shaftTrail # scale sf shaft = strokeT shaftTrail' # applyStyle (shaftSty opts) @@ -459,7 +470,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- | @arrowBetween s e@ creates an arrow pointing from @s@ to @e@ -- with default parameters. -arrowBetween :: (R2D v, Renderable (Path v) b) => Point v -> Point v -> Diagram b v +arrowBetween :: (TypeableReal n, Renderable (Path V2 n) b) => Point V2 n -> Point V2 n -> Diagram b V2 n arrowBetween = arrowBetween' def -- | @arrowBetween' opts s e@ creates an arrow pointing from @s@ to @@ -467,47 +478,47 @@ arrowBetween = arrowBetween' def -- rotates @arrowShaft@ to go between @s@ and @e@, taking head, -- tail, and gaps into account. arrowBetween' - :: (R2D v, Renderable (Path v) b) => - ArrowOpts v -> Point v -> Point v -> Diagram b v + :: (TypeableReal n, Renderable (Path V2 n) b) => + ArrowOpts n -> Point V2 n -> Point V2 n -> Diagram b V2 n arrowBetween' opts s e = arrowAt' opts s (e .-. s) -- | Create an arrow starting at s with length and direction determined by -- the vector v. -arrowAt :: (R2D v, Renderable (Path v) b) => Point v -> v -> Diagram b v -arrowAt s v = arrowAt' def s v +arrowAt :: (TypeableReal n, Renderable (Path V2 n) b) => Point V2 n -> V2 n -> Diagram b V2 n +arrowAt = arrowAt' def arrowAt' - :: (R2D v, Renderable (Path v) b) => - ArrowOpts v -> Point v -> v -> Diagram b v + :: (TypeableReal n, Renderable (Path V2 n) b) => + ArrowOpts n -> Point V2 n -> V2 n -> Diagram b V2 n arrowAt' opts s v = arrow' opts len # rotate dir # moveTo s where - len = magnitude v + len = norm v dir = v ^. _theta --- | @arrowV v@ creates an arrow with the direction and magnitude of +-- | @arrowV v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin), using default -- parameters. -arrowV :: (R2D v, Renderable (Path v) b) => v -> Diagram b v +arrowV :: (TypeableReal n, Renderable (Path V2 n) b) => V2 n -> Diagram b V2 n arrowV = arrowV' def --- | @arrowV' v@ creates an arrow with the direction and magnitude of +-- | @arrowV' v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin). arrowV' - :: (R2D v, Renderable (Path v) b) - => ArrowOpts v -> v -> Diagram b v + :: (TypeableReal n, Renderable (Path V2 n) b) + => ArrowOpts n -> V2 n -> Diagram b V2 n arrowV' opts = arrowAt' opts origin -- | Connect two diagrams with a straight arrow. connect - :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) - => n1 -> n2 -> (Diagram b v -> Diagram b v) + :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => n1 -> n2 -> Diagram b V2 n -> Diagram b V2 n connect = connect' def -- | Connect two diagrams with an arbitrary arrow. connect' - :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) - => ArrowOpts v -> n1 -> n2 -> (Diagram b v -> Diagram b v) + :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => ArrowOpts n -> n1 -> n2 -> Diagram b V2 n -> Diagram b V2 n connect' opts n1 n2 = withName n1 $ \sub1 -> withName n2 $ \sub2 -> @@ -517,15 +528,15 @@ connect' opts n1 n2 = -- | Connect two diagrams at point on the perimeter of the diagrams, choosen -- by angle. connectPerim - :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) - => n1 -> n2 -> Angle (Scalar v) -> Angle (Scalar v) - -> (Diagram b v -> Diagram b v) + :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => n1 -> n2 -> Angle n -> Angle n + -> Diagram b V2 n -> Diagram b V2 n connectPerim = connectPerim' def connectPerim' - :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) - => ArrowOpts v -> n1 -> n2 -> Angle (Scalar v) -> Angle (Scalar v) - -> (Diagram b v -> Diagram b v) + :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => ArrowOpts n -> n1 -> n2 -> Angle n -> Angle n + -> Diagram b V2 n -> Diagram b V2 n connectPerim' opts n1 n2 a1 a2 = withName n1 $ \sub1 -> withName n2 $ \sub2 -> @@ -539,19 +550,20 @@ connectPerim' opts n1 n2 a1 a2 = -- drawn so that it stops at the boundaries of the diagrams, using traces -- to find the intersection points. connectOutside - :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) - => n1 -> n2 -> (Diagram b v -> Diagram b v) + :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => n1 -> n2 -> Diagram b V2 n -> Diagram b V2 n connectOutside = connectOutside' def connectOutside' - :: (R2D v, Renderable (Path v) b, IsName n1, IsName n2) - => ArrowOpts v -> n1 -> n2 -> (Diagram b v -> Diagram b v) + :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => ArrowOpts n -> n1 -> n2 -> Diagram b V2 n -> Diagram b V2 n connectOutside' opts n1 n2 = withName n1 $ \b1 -> withName n2 $ \b2 -> let v = location b2 .-. location b1 midpoint = location b1 .+^ (v ^/ 2) - s' = fromMaybe (location b1) $ traceP midpoint (negateV v) b1 + s' = fromMaybe (location b1) $ traceP midpoint (negated v) b1 e' = fromMaybe (location b2) $ traceP midpoint v b2 in atop (arrowBetween' opts s' e') + diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 1e36ae71..b4aaaa21 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -57,15 +57,12 @@ module Diagrams.TwoD.Arrowheads ) where import Control.Lens ((&), (.~), (<>~), (^.)) -import Data.AffineSpace import Data.Default.Class import Data.Monoid (mempty, (<>)) -import Data.VectorSpace import Diagrams.Angle import Diagrams.Core -import Diagrams.Coordinates ((^&)) import Diagrams.Path import Diagrams.Segment import Diagrams.Trail @@ -80,11 +77,16 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unit_X, xDir) import Diagrams.Util (( # )) +import Linear.Affine +import Linear.Epsilon +import Linear.Vector +import Linear.Metric + ----------------------------------------------------------------------------- -type ArrowHT v = Scalar v -> Scalar v -> (Path v, Path v) +type ArrowHT n = n -> n -> (Path V2 n, Path V2 n) -closedPath :: (R2Ish v) => (Floating (Scalar v), Ord (Scalar v), InnerSpace v) => Trail v -> Path v +closedPath :: OrderedField n => Trail V2 n -> Path V2 n closedPath = pathFromTrail . closeTrail -- Heads ------------------------------------------------------------------ @@ -99,42 +101,42 @@ closedPath = pathFromTrail . closeTrail -- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 @@ turn) & shaftStyle %~ lw none) -- > origin (r2 (0.001, 0)) -- > <> square 0.6 # alignL # lw none -arrowheadTriangle :: (R2Ish v) => Angle (Scalar v) -> ArrowHT v +arrowheadTriangle :: (Epsilon n, RealFloat n) => Angle n -> ArrowHT n arrowheadTriangle theta = aHead where aHead len _ = (p, mempty) where psi = pi - (theta ^. rad) r = len / (1 + cos psi) - p = polygon (def & polyType .~ PolyPolar [theta, (negateV 2 *^ theta)] + p = polygon (def & polyType .~ PolyPolar [theta, (-2) *^ theta] (repeat r) & polyOrient .~ NoOrient) # alignL -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. -arrowheadDart :: (R2Ish v) => Angle (Scalar v) -> ArrowHT v +arrowheadDart :: (Epsilon n, RealFloat n) => Angle n -> ArrowHT n arrowheadDart theta len shaftWidth = (hd # scale size, jt) where hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] jt = pathFromTrail . glueTrail $ j <> reflectY j - j = closeTrail $ fromOffsets [((-jLength) ^& 0), (0 ^& (shaftWidth / 2))] + j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)] v = rotate theta unitX - (t1, t2) = (unit_X ^+^ v, ((-0.5) ^& 0) ^-^ v) - [b1, b2] = map (reflectY . negateV) [t1, t2] - psi = pi - (negateV t2) ^. _theta.rad + (t1, t2) = (unit_X ^+^ v, V2 (-0.5) 0 ^-^ v) + [b1, b2] = map (reflectY . negated) [t1, t2] + psi = pi - negated t2 ^. _theta . rad jLength = shaftWidth / (2 * tan psi) -- If the shaft if too wide, set the size to a default value of 1. - size = max 1 ((len - jLength) / (1.5)) + size = max 1 ((len - jLength) / 1.5) -- | Isoceles triangle with curved concave base. Inkscape type 2. -arrowheadSpike :: (R2Ish v) => Angle (Scalar v) -> ArrowHT v +arrowheadSpike :: (RealFloat n, Epsilon n) => Angle n -> ArrowHT n arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) where hd = snugL . closedPath $ l1 <> c <> l2 jt = alignR . centerY . pathFromTrail - . closeTrail $ arc' 1 (xDir & _theta <>~ (negateV phi)) (2 *^ phi) + . closeTrail $ arc' 1 (xDir & _theta <>~ negated phi) (2 *^ phi) l1 = trailFromSegments [straight $ unit_X ^+^ v] - l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ (reflectY v))] + l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ reflectY v)] c = arc' 1 (rotate α xDir) ((-2) *^ α) α = (1/2 @@ turn) ^-^ theta v = rotate theta unitX @@ -155,25 +157,25 @@ arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) phi = asinA (min 1 (y/r)) -- | Curved sides, linear concave base. Illustrator CS5 #3 -arrowheadThorn :: (R2Ish v) => Angle (Scalar v) -> ArrowHT v +arrowheadThorn :: (Epsilon n, RealFloat n) => Angle n -> ArrowHT n arrowheadThorn theta len shaftWidth = (hd # scale size, jt) where hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop hTop = closeTrail . trailFromSegments $ [c, l] jt = pathFromTrail . glueTrail $ j <> reflectY j - j = closeTrail $ fromOffsets [((-jLength) ^& 0), (0 ^& (shaftWidth / 2))] + j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)] c = curvedSide theta v = rotate theta unitX l = reverseSegment . straight $ t - t = v ^-^ ((-0.5) ^& 0) - psi = fullTurn ^/ 2 ^-^ ((negateV t) ^. _theta) + t = v ^-^ V2 (-0.5) 0 + psi = fullTurn ^/ 2 ^-^ (negated t ^. _theta) jLength = shaftWidth / (2 * tanA psi) -- If the shaft if too wide, set the size to a default value of 1. - size = max 1 ((len - jLength) / (1.5)) + size = max 1 ((len - jLength) / 1.5) -- | Make a side for the thorn head. -curvedSide :: (R2Ish v) => Angle (Scalar v) -> Segment Closed v +curvedSide :: (Floating n, Ord n) => Angle n -> Segment Closed V2 n curvedSide theta = bezier3 ctrl1 ctrl2 end where v0 = unit_X @@ -184,34 +186,34 @@ curvedSide theta = bezier3 ctrl1 ctrl2 end -- Standard heads --------------------------------------------------------- -- | A line the same width as the shaft. -lineHead :: (R2Ish v) => ArrowHT v +lineHead :: (Epsilon n, RealFloat n) => ArrowHT n lineHead s w = (square 1 # scaleX s # scaleY w # alignL, mempty) -noHead :: (R2Ish v) => ArrowHT v +noHead :: (Floating n, Ord n) => ArrowHT n noHead _ _ = (mempty, mempty) -- | <> -- > triEx = drawHead tri -tri :: (R2Ish v) => ArrowHT v +tri :: (Epsilon n, RealFloat n) => ArrowHT n tri = arrowheadTriangle (1/3 @@ turn) -- | <> -- > spikeEx = drawHead spike -spike :: (R2Ish v) => ArrowHT v +spike :: (Epsilon n, RealFloat n) => ArrowHT n spike = arrowheadSpike (3/8 @@ turn) -- | <> -- > thornEx = drawHead thorn -thorn :: (R2Ish v) => ArrowHT v +thorn :: (Epsilon n, RealFloat n) => ArrowHT n thorn = arrowheadThorn (3/8 @@ turn) -- | <> -- > dartEx = drawHead dart -dart :: (R2Ish v) => ArrowHT v +dart :: (Epsilon n, RealFloat n) => ArrowHT n dart = arrowheadDart (2/5 @@ turn) -- Tails ------------------------------------------------------------------ @@ -221,7 +223,7 @@ dart = arrowheadDart (2/5 @@ turn) -- | Utility function to convert any arrowhead to an arrowtail, i.e. -- attached at the start of the trail. -headToTail :: (R2Ish v) => ArrowHT v -> ArrowHT v +headToTail :: (OrderedField n) => ArrowHT n -> ArrowHT n headToTail hd = tl where tl size shaftWidth = (t, j) @@ -230,25 +232,25 @@ headToTail hd = tl t = reflectX t' j = reflectX j' -arrowtailBlock :: forall v. (R2Ish v) => Angle (Scalar v) -> ArrowHT v +arrowtailBlock :: forall n. (Epsilon n, RealFloat n) => Angle n -> ArrowHT n arrowtailBlock theta = aTail where aTail len _ = (t, mempty) where - t = rect len (len * x) # alignR - a' :: v - a' = rotate theta unitX - a = a' ^-^ (reflectY a') - x = magnitude a + t = rect len (len * x) # alignR + a' :: V2 n + a' = rotate theta unitX + a = a' ^-^ reflectY a' + x = norm a -- | The angle is where the top left corner intersects the circle. -arrowtailQuill :: (R2Ish v) => Angle (Scalar v) -> ArrowHT v +arrowtailQuill :: (Floating n, Ord n, Epsilon n) => Angle n -> ArrowHT n arrowtailQuill theta = aTail where aTail len shaftWidth = (t, j) where - t = ( closedPath $ trailFromVertices [v0, v1, v2, v3, v4, v5, v0] ) - # scale size # alignR + t = closedPath (trailFromVertices [v0, v1, v2, v3, v4, v5, v0]) + # scale size # alignR size = len / 0.6 v0 = p2 (0.5, 0) v2 = origin .+^ (rotate theta unitX # scale 0.5) @@ -256,54 +258,54 @@ arrowtailQuill theta = aTail v3 = p2 (-0.1, 0) v4 = v2 # reflectY v5 = v4 # translateX (5/8) - s = 1 - shaftWidth / magnitude (v1 .-. v5) + s = 1 - shaftWidth / norm (v1 .-. v5) n1 = v0 # translateY (0.5 * shaftWidth) n2 = v1 .-^ ((v1 .-. v0) # scale s) n3 = v5 .-^ ((v5 .-. v0) # scale s) n4 = n1 # reflectY - j = ( closedPath $ trailFromVertices - [ v0, n1, n2, v0, n3, n4, v0 ]) + j = closedPath $ trailFromVertices [v0, n1, n2, v0, n3, n4, v0] -- Standard tails --------------------------------------------------------- -- | A line the same width as the shaft. -lineTail :: (R2Ish v) => ArrowHT v +lineTail :: (RealFloat n, Epsilon n) => ArrowHT n lineTail s w = (square 1 # scaleY w # scaleX s # alignR, mempty) -noTail :: (R2Ish v) => ArrowHT v +noTail :: (Floating n, Ord n) => ArrowHT n noTail _ _ = (mempty, mempty) -- | <> -- > tri'Ex = drawTail tri' -tri' :: (R2Ish v) => ArrowHT v +tri' :: (RealFloat n, Epsilon n) => ArrowHT n tri' = headToTail tri -- | <> -- > spike'Ex = drawTail spike' -spike' :: (R2Ish v) => ArrowHT v +spike' :: (Epsilon n, RealFloat n) => ArrowHT n spike' = headToTail spike -- | <> -- > thorn'Ex = drawTail thorn' -thorn' :: (R2Ish v) => ArrowHT v +thorn' :: (Epsilon n, RealFloat n) => ArrowHT n thorn' = headToTail thorn -- | <> -- > dart'Ex = drawTail dart' -dart' :: (R2Ish v) => ArrowHT v +dart' :: (Epsilon n, RealFloat n) => ArrowHT n dart' = headToTail dart -- | <> -- > quillEx = drawTail quill -quill :: (R2Ish v) => ArrowHT v +quill :: (Floating n, Ord n, Epsilon n) => ArrowHT n quill = arrowtailQuill (2/5 @@ turn) -- | <> -- > blockEx = drawTail block -block :: (R2Ish v) => ArrowHT v +block :: (RealFloat n, Epsilon n) => ArrowHT n block = arrowtailBlock (7/16 @@ turn) + diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 9ec99698..c5bbeb4e 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -83,20 +84,20 @@ import Diagrams.Path (Path, pathTrails) import Diagrams.Trail (isLoop) import Control.Lens (Lens', Setter', generateSignatures, lensRules, - makeLensesWith, makePrisms, sets, (%~), (&), (.~)) + makeLensesWith, makePrisms, sets, (&), (.~), over) -import Data.Colour hiding (AffineSpace) +import Data.Colour hiding (AffineSpace, over) import Data.Data import Data.Default.Class import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup -import Data.VectorSpace + -- | Standard 'Measures'. none, ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, - tiny, verySmall, small, normal, large, veryLarge, huge :: (Floating (Scalar v)) => Measure v + tiny, verySmall, small, normal, large, veryLarge, huge :: Floating n => Measure n none = Output 0 ultraThin = Normalized 0.0005 `atLeast` Output 0.5 veryThin = Normalized 0.001 `atLeast` Output 0.5 @@ -120,50 +121,50 @@ huge = Normalized 0.10 -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. -newtype LineWidth v = LineWidth (Last (Measure v)) - deriving (Typeable, Semigroup) +newtype LineWidth n = LineWidth (Last (Measure n)) + deriving (Typeable, Semigroup, Functor) -deriving instance (Data (Scalar v), Data v) => Data (LineWidth v) -instance (Typeable v) => AttributeClass (LineWidth v) +deriving instance (Data n) => Data (LineWidth n) +instance (Typeable n) => AttributeClass (LineWidth n) -type instance V (LineWidth v) = v +type instance V (LineWidth n) = V2 +type instance N (LineWidth n) = n -instance (R2Ish v) => Transformable (LineWidth v) where - transform t (LineWidth (Last w)) = - LineWidth (Last (transform (scaling (avgScale t)) w)) +instance Floating n => Transformable (LineWidth n) where + transform = scaleFromTransform -instance (R2Ish v) => Default (LineWidth v) where +instance Floating n => Default (LineWidth n) where def = LineWidth (Last medium) -getLineWidth :: (R2Ish v) => LineWidth v -> Measure v +getLineWidth :: LineWidth n -> Measure n getLineWidth (LineWidth (Last w)) = w -- | Set the line (stroke) width. -lineWidth :: (R2D v, HasStyle a, V a ~ v) => Measure v -> a -> a +lineWidth :: (Data n, HasStyle a, Vn a ~ V2 n, Floating n) => Measure n -> a -> a lineWidth = applyGTAttr . LineWidth . Last -- | Apply a 'LineWidth' attribute. -lineWidthA :: (R2D v, HasStyle a, V a ~ v) => LineWidth v -> a -> a +lineWidthA :: (Data n, HasStyle a, Vn a ~ V2 n, Floating n) => LineWidth n -> a -> a lineWidthA = applyGTAttr -- | Default for 'lineWidth'. -lw :: (R2D v, HasStyle a, V a ~ v) => Measure v -> a -> a +lw :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => Measure n -> a -> a lw = lineWidth -- | A convenient synonym for 'lineWidth (Global w)'. -lwG :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a +lwG :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => n -> a -> a lwG w = lineWidth (Global w) -- | A convenient synonym for 'lineWidth (Normalized w)'. -lwN :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a +lwN :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => n -> a -> a lwN w = lineWidth (Normalized w) -- | A convenient synonym for 'lineWidth (Output w)'. -lwO :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a +lwO :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => n -> a -> a lwO w = lineWidth (Output w) -- | A convenient sysnonym for 'lineWidth (Local w)'. -lwL :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a +lwL :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => n -> a -> a lwL w = lineWidth (Local w) ----------------------------------------------------------------- @@ -171,71 +172,68 @@ lwL w = lineWidth (Local w) ----------------------------------------------------------------- -- | Create lines that are dashing... er, dashed. -data Dashing v = Dashing [Measure v] (Measure v) - deriving (Typeable) +data Dashing n = Dashing [Measure n] (Measure n) + deriving (Typeable, Functor) -deriving instance (Data (Scalar v), Data v) => Data (Dashing v) -deriving instance Eq (Scalar v) => Eq (Dashing v) +deriving instance Data n => Data (Dashing n) +deriving instance Eq n => Eq (Dashing n) -newtype DashingA v = DashingA (Last (Dashing v)) - deriving (Typeable, Semigroup) +newtype DashingA n = DashingA (Last (Dashing n)) + deriving (Typeable, Semigroup, Functor) -deriving instance (Data (Scalar v), Data v) => Data (DashingA v) -deriving instance Eq (Scalar v) => Eq (DashingA v) +deriving instance Data n => Data (DashingA n) +deriving instance Eq n => Eq (DashingA n) -instance (Typeable v) => AttributeClass (DashingA v) +instance Typeable n => AttributeClass (DashingA n) -type instance V (DashingA v) = v +type instance V (DashingA n) = V2 +type instance N (DashingA n) = n -instance (R2Ish v) => Transformable (DashingA v) where - transform t (DashingA (Last (Dashing w v))) = - DashingA (Last (Dashing r s)) - where - t' = scaling (avgScale t) - r = map (transform t') w - s = transform t' v +instance Floating n => Transformable (DashingA n) where + transform = scaleFromTransform -getDashing :: (R2Ish v) => DashingA v -> Dashing v +getDashing :: DashingA n -> Dashing n getDashing (DashingA (Last d)) = d -- | Set the line dashing style. -dashing :: (R2D v, HasStyle a, V a ~ v) => - [Measure v] -- ^ A list specifying alternate lengths of on +dashing :: (Floating n, Data n, HasStyle a, Vn a ~ V2 n) => + [Measure n] -- ^ A list specifying alternate lengths of on -- and off portions of the stroke. The empty -- list indicates no dashing. - -> Measure v -- ^ An offset into the dash pattern at which the + -> Measure n -- ^ An offset into the dash pattern at which the -- stroke should start. -> a -> a dashing ds offs = applyGTAttr (DashingA (Last (Dashing ds offs))) -- | A convenient synonym for 'dashing (Global w)'. -dashingG :: (R2D v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a +dashingG :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => [n] -> n -> a -> a dashingG w v = dashing (map Global w) (Global v) -- | A convenient synonym for 'dashing (Normalized w)'. -dashingN :: (R2D v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a +dashingN :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => [n] -> n -> a -> a dashingN w v = dashing (map Normalized w) (Normalized v) -- | A convenient synonym for 'dashing (Output w)'. -dashingO :: (R2D v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a +dashingO :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => [n] -> n -> a -> a dashingO w v = dashing (map Output w) (Output v) -- | A convenient sysnonym for 'dashing (Local w)'. -dashingL :: (R2D v, HasStyle a, V a ~ v) => [Scalar v] -> Scalar v -> a -> a +dashingL :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => [n] -> n -> a -> a dashingL w v = dashing (map Local w) (Local v) -- | A gradient stop contains a color and fraction (usually between 0 and 1) data GradientStop d = GradientStop { _stopColor :: SomeColor , _stopFraction :: d} + deriving Functor makeLensesWith (lensRules & generateSignatures .~ False) ''GradientStop -- | A color for the stop. -stopColor :: Lens' (GradientStop d) SomeColor +stopColor :: Lens' (GradientStop n) SomeColor -- | The fraction for stop. -stopFraction :: Lens' (GradientStop d) d +stopFraction :: Lens' (GradientStop n) n -- | The 'SpreadMethod' determines what happens before 'lGradStart' and after -- 'lGradEnd'. 'GradPad' fills the space before the start of the gradient @@ -245,108 +243,128 @@ stopFraction :: Lens' (GradientStop d) d data SpreadMethod = GradPad | GradReflect | GradRepeat -- | Linear Gradient -data LGradient v = LGradient - { _lGradStops :: [GradientStop (Scalar v)] - , _lGradStart :: Point v - , _lGradEnd :: Point v - , _lGradTrans :: Transformation v +data LGradient n = LGradient + { _lGradStops :: [GradientStop n] + , _lGradStart :: Point V2 n + , _lGradEnd :: Point V2 n + , _lGradTrans :: Transformation V2 n , _lGradSpreadMethod :: SpreadMethod } +type instance V (LGradient n) = V2 +type instance N (LGradient n) = n + makeLensesWith (lensRules & generateSignatures .~ False) ''LGradient +instance Fractional n => Transformable (LGradient n) where + transform = over lGradTrans . transform + -- | A list of stops (colors and fractions). -lGradStops :: (R2Ish v) => Lens' (LGradient v) [GradientStop (Scalar v)] +lGradStops :: Lens' (LGradient n) [GradientStop n] -- | A transformation to be applied to the gradient. Usually this field will -- start as the identity transform and capture the transforms that are applied -- to the gradient. -lGradTrans :: (R2Ish v) => Lens' (LGradient v) (Transformation v) +lGradTrans :: Lens' (LGradient n) (Transformation V2 n) -- | The starting point for the first gradient stop. The coordinates are in -- 'Local' units and the default is (-0.5, 0). -lGradStart :: (R2Ish v) => Lens' (LGradient v) (Point v) +lGradStart :: Lens' (LGradient n) (Point V2 n) -- | The ending point for the last gradient stop.The coordinates are in -- 'Local' units and the default is (0.5, 0). -lGradEnd :: (R2Ish v) => Lens' (LGradient v) (Point v) +lGradEnd :: Lens' (LGradient n) (Point V2 n) -- | For setting the spread method. -lGradSpreadMethod :: (R2Ish v) => Lens' (LGradient v) SpreadMethod +lGradSpreadMethod :: Lens' (LGradient n) SpreadMethod -- | Radial Gradient -data RGradient v = RGradient - { _rGradStops :: [GradientStop (Scalar v)] - , _rGradCenter0 :: Point v - , _rGradRadius0 :: Scalar v - , _rGradCenter1 :: Point v - , _rGradRadius1 :: Scalar v - , _rGradTrans :: Transformation v +data RGradient n = RGradient + { _rGradStops :: [GradientStop n] + , _rGradCenter0 :: Point V2 n + , _rGradRadius0 :: n + , _rGradCenter1 :: Point V2 n + , _rGradRadius1 :: n + , _rGradTrans :: Transformation V2 n , _rGradSpreadMethod :: SpreadMethod } makeLensesWith (lensRules & generateSignatures .~ False) ''RGradient +type instance V (RGradient n) = V2 +type instance N (RGradient n) = n + +instance Fractional n => Transformable (RGradient n) where + transform = over rGradTrans . transform + -- | A list of stops (colors and fractions). -rGradStops :: (R2Ish v) => Lens' (RGradient v) [GradientStop (Scalar v)] +rGradStops :: Lens' (RGradient n) [GradientStop n] -- | The center point of the inner circle. -rGradCenter0 :: (R2Ish v) => Lens' (RGradient v) (Point v) +rGradCenter0 :: Lens' (RGradient n) (Point V2 n) -- | The radius of the inner cirlce in 'Local' coordinates. -rGradRadius0 :: (R2Ish v) => Lens' (RGradient v) (Scalar v) +rGradRadius0 :: Lens' (RGradient n) n -- | The center of the outer circle. -rGradCenter1 :: (R2Ish v) => Lens' (RGradient v) (Point v) +rGradCenter1 :: Lens' (RGradient n) (Point V2 n) -- | The radius of the outer circle in 'Local' coordinates. -rGradRadius1 :: (R2Ish v) => Lens' (RGradient v) (Scalar v) +rGradRadius1 :: Lens' (RGradient n) n -- | A transformation to be applied to the gradient. Usually this field will -- start as the identity transform and capture the transforms that are applied -- to the gradient. -rGradTrans :: (R2Ish v) => Lens' (RGradient v) (Transformation v) +rGradTrans :: Lens' (RGradient n) (Transformation V2 n) -- | For setting the spread method. -rGradSpreadMethod :: (R2Ish v) => Lens' (RGradient v) SpreadMethod +rGradSpreadMethod :: Lens' (RGradient n) SpreadMethod -- | A Texture is either a color 'SC', linear gradient 'LG', or radial gradient 'RG'. -- An object can have only one texture which is determined by the 'Last' -- semigroup structure. -data Texture v = SC SomeColor | LG (LGradient v) | RG (RGradient v) - deriving (Typeable) +data Texture n = SC SomeColor | LG (LGradient n) | RG (RGradient n) + deriving Typeable + +type instance V (Texture n) = V2 +type instance N (Texture n) = n makePrisms ''Texture +instance Floating n => Transformable (Texture n) where + transform t (LG lg) = LG $ transform t lg + transform t (RG rg) = RG $ transform t rg + transform _ sc = sc + -- | Convert a solid colour into a texture. -solid :: (R2Ish v) => Color a => a -> Texture v +solid :: Color a => a -> Texture n solid = SC . SomeColor -- | A default is provided so that linear gradients can easily be created using -- lenses. For example, @lg = defaultLG & lGradStart .~ (0.25 ^& 0.33)@. Note that -- no default value is provided for @lGradStops@, this must be set before -- the gradient value is used, otherwise the object will appear transparent. -defaultLG :: (R2Ish v) => Texture v -defaultLG = LG (LGradient - { _lGradStops = [] - , _lGradStart = mkP2 (-0.5) 0 - , _lGradEnd = mkP2 (0.5) 0 - , _lGradTrans = mempty - , _lGradSpreadMethod = GradPad - }) +defaultLG :: Fractional n => Texture n +defaultLG = LG LGradient + { _lGradStops = [] + , _lGradStart = mkP2 (-0.5) 0 + , _lGradEnd = mkP2 0.5 0 + , _lGradTrans = mempty + , _lGradSpreadMethod = GradPad + } -- | A default is provided so that radial gradients can easily be created using -- lenses. For example, @rg = defaultRG & rGradRadius1 .~ 0.25@. Note that -- no default value is provided for @rGradStops@, this must be set before -- the gradient value is used, otherwise the object will appear transparent. -defaultRG :: (R2Ish v) => Texture v -defaultRG = RG (RGradient - { _rGradStops = [] - , _rGradCenter0 = mkP2 0 0 - , _rGradRadius0 = 0.0 - , _rGradCenter1 = mkP2 0 0 - , _rGradRadius1 = 0.5 - , _rGradTrans = mempty - , _rGradSpreadMethod = GradPad - }) +defaultRG :: Fractional n => Texture n +defaultRG = RG RGradient + { _rGradStops = [] + , _rGradCenter0 = mkP2 0 0 + , _rGradRadius0 = 0.0 + , _rGradCenter1 = mkP2 0 0 + , _rGradRadius1 = 0.5 + , _rGradTrans = mempty + , _rGradSpreadMethod = GradPad +} -- | A convenient function for making gradient stops from a list of triples. -- (An opaque color, a stop fraction, an opacity). @@ -356,15 +374,15 @@ mkStops = map (\(x, y, z) -> GradientStop (SomeColor (withOpacity x z)) y) -- | Make a linear gradient texture from a stop list, start point, end point, -- and 'SpreadMethod'. The 'lGradTrans' field is set to the identity -- transfrom, to change it use the 'lGradTrans' lens. -mkLinearGradient :: (R2Ish v) => [GradientStop (Scalar v)] -> Point v -> Point v -> SpreadMethod -> Texture v +mkLinearGradient :: Num n => [GradientStop n] -> Point V2 n -> Point V2 n -> SpreadMethod -> Texture n mkLinearGradient stops start end spreadMethod = LG (LGradient stops start end mempty spreadMethod) -- | Make a radial gradient texture from a stop list, radius, start point, -- end point, and 'SpreadMethod'. The 'rGradTrans' field is set to the identity -- transfrom, to change it use the 'rGradTrans' lens. -mkRadialGradient :: (R2Ish v) => [GradientStop (Scalar v)] -> Point v -> Scalar v - -> Point v -> Scalar v -> SpreadMethod -> Texture v +mkRadialGradient :: Num n => [GradientStop n] -> Point V2 n -> n + -> Point V2 n -> n -> SpreadMethod -> Texture n mkRadialGradient stops c0 r0 c1 r1 spreadMethod = RG (RGradient stops c0 r0 c1 r1 mempty spreadMethod) @@ -372,38 +390,34 @@ mkRadialGradient stops c0 r0 c1 r1 spreadMethod -- textures always override parent textures. -- More precisely, the semigroup structure on line texture attributes -- is that of 'Last'. -newtype LineTexture v = LineTexture (Last (Texture v)) +newtype LineTexture n = LineTexture (Last (Texture n)) deriving (Typeable, Semigroup) -instance (Typeable v) => AttributeClass (LineTexture v) +instance (Typeable n) => AttributeClass (LineTexture n) -type instance V (LineTexture v) = v +type instance V (LineTexture n) = V2 +type instance N (LineTexture n) = n -- Only gradients get transformed. The transform is applied to the gradients -- transform field. Colors are left unchanged. -instance (R2Ish v) => Transformable (LineTexture v) where - transform t (LineTexture (Last texture)) = LineTexture (Last tx) - where - tx = texture & lgt . rgt - lgt = _LG . lGradTrans %~ f - rgt = _RG . rGradTrans %~ f - f = transform t - -instance Default (LineTexture v) where +instance Floating n => Transformable (LineTexture n) where + transform t (LineTexture (Last tx)) = LineTexture (Last $ transform t tx) + +instance Default (LineTexture n) where def = LineTexture (Last (SC (SomeColor (black :: Colour Double)))) -getLineTexture :: (R2Ish v) => LineTexture v -> Texture v +getLineTexture :: LineTexture n -> Texture n getLineTexture (LineTexture (Last t)) = t -lineTexture :: (R2Ish v, HasStyle a, V a ~ v) => Texture v -> a -> a +lineTexture :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => Texture n -> a -> a lineTexture = applyTAttr . LineTexture . Last -lineTextureA :: (R2Ish v, HasStyle a, V a ~ v) => LineTexture v -> a -> a +lineTextureA :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => LineTexture n -> a -> a lineTextureA = applyTAttr -mkLineTexture :: (R2Ish v) => Texture v -> LineTexture v +mkLineTexture :: Texture v -> LineTexture v mkLineTexture = LineTexture . Last -styleLineTexture :: (R2Ish v) => Setter' (Style v) (Texture v) +styleLineTexture :: Typeable n => Setter' (Style V2 n) (Texture n) styleLineTexture = sets modifyLineTexture where modifyLineTexture f s @@ -419,63 +433,59 @@ styleLineTexture = sets modifyLineTexture -- 'AlphaColour'), but this can sometimes create problems for type -- inference, so the 'lc' and 'lcA' variants are provided with more -- concrete types. -lineColor :: (R2Ish v, Color c, HasStyle a, V a ~ v) => c -> a -> a +lineColor :: (Typeable n, Floating n, Color c, HasStyle a, Vn a ~ V2 n) => c -> a -> a lineColor = lineTexture . SC . SomeColor -- | A synonym for 'lineColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). See comment in 'lineColor' about backends. -lc :: (R2Ish v, HasStyle a, V a ~ v) => Colour Double -> a -> a +lc :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => Colour Double -> a -> a lc = lineColor -- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). See comment in 'lineColor' -- about backends. -lcA :: (R2Ish v, HasStyle a, V a ~ v) => AlphaColour Double -> a -> a +lcA :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => AlphaColour Double -> a -> a lcA = lineColor -- | Apply a linear gradient. -lineLGradient :: (R2Ish v, HasStyle a, V a ~ v) => LGradient v -> a -> a +lineLGradient :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => LGradient n -> a -> a lineLGradient g = lineTexture (LG g) -- | Apply a radial gradient. -lineRGradient :: (R2Ish v, HasStyle a, V a ~ v) => RGradient v -> a -> a +lineRGradient :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => RGradient n -> a -> a lineRGradient g = lineTexture (RG g) -- | The texture with which objects are filled. -- The semigroup structure on fill texture attributes -- is that of 'Recommed . Last'. -newtype FillTexture v = FillTexture (Recommend (Last (Texture v))) +newtype FillTexture n = FillTexture (Recommend (Last (Texture n))) deriving (Typeable, Semigroup) -instance (Typeable v) => AttributeClass (FillTexture v) +instance Typeable n => AttributeClass (FillTexture n) -type instance V (FillTexture v) = v +type instance V (FillTexture n) = V2 +type instance N (FillTexture n) = n -- Only gradients get transformed. The transform is applied to the gradients -- transform field. Colors are left unchanged. -instance (R2Ish v) => Transformable (FillTexture v) where - transform _ tx@(FillTexture (Recommend _)) = tx - transform t (FillTexture (Commit (Last texture))) = FillTexture (Commit (Last tx)) - where - tx = texture & lgt . rgt - lgt = _LG . lGradTrans %~ f - rgt = _RG . rGradTrans %~ f - f = transform t - -instance (R2Ish v) => Default (FillTexture v) where +instance Floating n => Transformable (FillTexture n) where + transform _ tx@(FillTexture (Recommend _)) = tx + transform t (FillTexture (Commit (Last tx))) = FillTexture (Commit (Last $ transform t tx)) + +instance Default (FillTexture n) where def = FillTexture (Recommend (Last (SC (SomeColor (transparent :: AlphaColour Double))))) -getFillTexture :: (R2Ish v) => FillTexture v -> Texture v +getFillTexture :: FillTexture n -> Texture n getFillTexture (FillTexture tx) = getLast . getRecommend $ tx -fillTexture :: (R2Ish v, HasStyle a, V a ~ v) => Texture v -> a -> a +fillTexture :: (HasStyle a, Vn a ~ V2 n, Typeable n, Floating n) => Texture n -> a -> a fillTexture = applyTAttr . FillTexture . Commit . Last -mkFillTexture :: (R2Ish v) => Texture v -> FillTexture v +mkFillTexture :: Texture n -> FillTexture n mkFillTexture = FillTexture . Commit . Last -styleFillTexture :: (R2Ish v) => Setter' (Style v) (Texture v) +styleFillTexture :: (Typeable n) => Setter' (Style V2 n) (Texture n) styleFillTexture = sets modifyFillTexture where modifyFillTexture f s @@ -490,32 +500,32 @@ styleFillTexture = sets modifyFillTexture -- type (so it can be used with either 'Colour' or 'AlphaColour'), -- but this can sometimes create problems for type inference, so the -- 'fc' and 'fcA' variants are provided with more concrete types. -fillColor :: (R2Ish v, Color c, HasStyle a, V a ~ v) => c -> a -> a +fillColor :: (Color c, HasStyle a, Vn a ~ V2 n, Typeable n, Floating n) => c -> a -> a fillColor = fillTexture . SC . SomeColor -- | Set a \"recommended\" fill color, to be used only if no explicit -- calls to 'fillColor' (or 'fc', or 'fcA') are used. -- See comment after 'fillColor' about backends. -recommendFillColor :: (R2Ish v, Color c, HasStyle a, V a ~ v) => c -> a -> a +recommendFillColor :: (Color c, HasStyle a, Vn a ~ V2 n, Typeable n, Floating n) => c -> a -> a recommendFillColor = applyTAttr . FillTexture . Recommend . Last . SC . SomeColor -- | A synonym for 'fillColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). See comment after 'fillColor' about backends. -fc :: (R2Ish v, HasStyle a, V a ~ v) => Colour Double -> a -> a +fc :: (HasStyle a, Vn a ~ V2 n, Floating n, Typeable n) => Colour Double -> a -> a fc = fillColor -- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). See comment after 'fillColor' about backends. -fcA :: (R2Ish v, HasStyle a, V a ~ v) => AlphaColour Double -> a -> a +fcA :: (HasStyle a, Vn a ~ V2 n, Floating n, Typeable n) => AlphaColour Double -> a -> a fcA = fillColor ------------------------------------------------------------ -data FillTextureLoops v = FillTextureLoops +data FillTextureLoops n = FillTextureLoops -instance Typeable v => SplitAttribute (FillTextureLoops v) where - type AttrType (FillTextureLoops v) = FillTexture v - type PrimType (FillTextureLoops v) = Path v +instance Typeable n => SplitAttribute (FillTextureLoops n) where + type AttrType (FillTextureLoops n) = FillTexture n + type PrimType (FillTextureLoops n) = Path V2 n primOK _ = all (isLoop . unLoc) . pathTrails @@ -525,5 +535,6 @@ instance Typeable v => SplitAttribute (FillTextureLoops v) where -- applied to lines/non-closed paths as well as loops/closed paths, -- whereas in the semantics of diagrams, fill attributes only apply -- to loops. -splitTextureFills :: forall b v a. Typeable v => RTree b v a -> RTree b v a -splitTextureFills = splitAttr (FillTextureLoops :: FillTextureLoops v) +splitTextureFills :: forall b v n a. (Typeable v, Typeable n) => RTree b v n a -> RTree b v n a +splitTextureFills = splitAttr (FillTextureLoops :: FillTextureLoops n) + diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs index 7d7e95bf..78aa09fc 100644 --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -21,14 +21,14 @@ module Diagrams.TwoD.Curvature ) where import Data.Monoid.Inf -import Data.VectorSpace - -import Control.Arrow (first, second) -import Control.Monad (join) import Diagrams.Segment import Diagrams.Tangent import Diagrams.TwoD.Types +import Diagrams.Coordinates + +import Linear.Vector +import Control.Lens (over) -- | Curvature measures how curved the segment is at a point. One intuition -- for the concept is how much you would turn the wheel when driving a car @@ -104,37 +104,46 @@ import Diagrams.TwoD.Types -- > vpr = r2 (normalized vp ^* r) -- > -- -curvature :: (R2Ish v) - => Segment Closed v -- ^ Segment to measure on. - -> Scalar v -- ^ Parameter to measure at. - -> PosInf (Scalar v) -- ^ Result is a @PosInf@ value where @PosInfty@ represents - -- infinite curvature or zero radius of curvature. -curvature s = toPosInf . second sqrt . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 +curvature :: RealFloat n + => Segment Closed V2 n -- ^ Segment to measure on. + -> n -- ^ Parameter to measure at. + -> PosInf n -- ^ Result is a @PosInf@ value where @PosInfty@ represents + -- infinite curvature or zero radius of curvature. +curvature s = toPosInf . over _y sqrt . curvaturePair s +-- curvature s = toPosInf . second sqrt . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 -- | With @squaredCurvature@ we can compute values in spaces that do not support -- 'sqrt' and it is just as useful for relative ordering of curvatures or looking -- for zeros. -squaredCurvature :: (R2Ish v) => Segment Closed v -> Scalar v -> PosInf (Scalar v) -squaredCurvature s = toPosInf . first (join (*)) . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 +squaredCurvature :: RealFloat n => Segment Closed V2 n -> n -> PosInf n +-- squaredCurvature s = toPosInf . first (join (*)) . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 +squaredCurvature s = toPosInf . over _x sq . curvaturePair s -- TODO: Use the generalized unr2 -- | Reciprocal of @curvature@. -radiusOfCurvature :: (R2Ish v) - => Segment Closed v -- ^ Segment to measure on. - -> Scalar v -- ^ Parameter to measure at. - -> PosInf (Scalar v) -- ^ Result is a @PosInf@ value where @PosInfty@ represents - -- infinite radius of curvature or zero curvature. -radiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . second sqrt . curvaturePair (fmap unr2 s) +radiusOfCurvature :: RealFloat n + => Segment Closed V2 n -- ^ Segment to measure on. + -> n -- ^ Parameter to measure at. + -> PosInf n -- ^ Result is a @PosInf@ value where @PosInfty@ represents + -- infinite radius of curvature or zero curvature. +-- radiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . second sqrt . curvaturePair (fmap unr2 s) +radiusOfCurvature s = toPosInf . (\(V2 p q) -> V2 (sqrt q) p) . curvaturePair s -- | Reciprocal of @squaredCurvature@ -squaredRadiusOfCurvature :: (R2Ish v) => Segment Closed v -> Scalar v -> PosInf (Scalar v) -squaredRadiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . first (join (*)) . curvaturePair (fmap unr2 s) +squaredRadiusOfCurvature :: RealFloat n => Segment Closed V2 n -> n -> PosInf n +-- squaredRadiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . first (join (*)) . curvaturePair +squaredRadiusOfCurvature s = toPosInf . (\(V2 p q) -> (V2 q (sq p))) . curvaturePair s + +sq :: Num a => a -> a +sq x = x * x +{-# INLINE sq #-} + -- Package up problematic values with the appropriate infinity. -toPosInf :: RealFloat a => (a,a) -> PosInf a -toPosInf (_,0) = Infinity -toPosInf (p,q) +toPosInf :: RealFloat a => V2 a -> PosInf a +toPosInf (V2 _ 0) = Infinity +toPosInf (V2 p q) | isInfinite r || isNaN r = Infinity | otherwise = Finite r where r = p / q @@ -142,13 +151,13 @@ toPosInf (p,q) -- Internal function that is not quite curvature or squaredCurvature but lets -- us get there by either taking the square root of the numerator or squaring -- the denominator respectively. -curvaturePair :: (Num t, Num (Scalar t), VectorSpace t) - => Segment Closed (t, t) -> Scalar t -> (t, t) -curvaturePair (Linear _) _ = (0,1) -- Linear segments always have zero curvature (infinite radius). -curvaturePair seg@(Cubic b c (OffsetClosed d)) t = ((x'*y'' - y'*x''), (x'*x' + y'*y')^(3 :: Integer)) +curvaturePair :: (Num n) + => Segment Closed V2 n -> n -> V2 n +curvaturePair (Linear _) _ = V2 0 1 -- Linear segments always have zero curvature (infinite radius). +curvaturePair seg@(Cubic b c (OffsetClosed d)) t = V2 (x'*y'' - y'*x'') ((x'*x' + y'*y')^(3 :: Integer)) where - (x' ,y' ) = seg `tangentAtParam` t - (x'',y'') = secondDerivative + (V2 x' y' ) = seg `tangentAtParam` t + (V2 x'' y'') = secondDerivative secondDerivative = (6*(3*t-2))*^b ^+^ (6-18*t)*^c ^+^ (6*t)*^d -- TODO: We should be able to generalize this to higher dimensions. See @@ -156,3 +165,11 @@ curvaturePair seg@(Cubic b c (OffsetClosed d)) t = ((x'*y'' - y'*x''), (x'*x' + -- -- TODO: I'm not sure what the best way to generalize squaredCurvature to other spaces is. +-- curvaturePair :: (Num t, Num (Scalar t), VectorSpace t) +-- => Segment Closed (t, t) -> Scalar t -> (t, t) +-- curvaturePair (Linear _) _ = (0,1) -- Linear segments always have zero curvature (infinite radius). +-- curvaturePair seg@(Cubic b c (OffsetClosed d)) t = ((x'*y'' - y'*x''), (x'*x' + y'*y')^(3 :: Integer)) +-- where +-- (x' ,y' ) = seg `tangentAtParam` t +-- (x'',y'') = secondDerivative +-- secondDerivative = (6*(3*t-2))*^b ^+^ (6-18*t)*^c ^+^ (6*t)*^d diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs index 95a9be68..54b6810f 100644 --- a/src/Diagrams/TwoD/Deform.hs +++ b/src/Diagrams/TwoD/Deform.hs @@ -11,29 +11,30 @@ import Diagrams.Coordinates import Diagrams.TwoD.Types -- | The parallel projection onto the line x=0 -parallelX0 :: (R2Ish v) => Deformation v +parallelX0 :: Floating n => Deformation V2 n parallelX0 = Deformation (& _x .~ 0) -- | The perspective division onto the line x=1 along lines going -- through the origin. -perspectiveX1 :: (R2Ish v) => Deformation v +perspectiveX1 :: Floating n => Deformation V2 n perspectiveX1 = Deformation (\p -> p & _y //~ (p^._x) & _x .~ 1) -- | The parallel projection onto the line y=0 -parallelY0 :: (R2Ish v) => Deformation v +parallelY0 :: Floating n => Deformation V2 n parallelY0 = Deformation (& _y .~ 0) -- | The perspective division onto the line y=1 along lines going -- through the origin. -perspectiveY1 :: (R2Ish v) => Deformation v +perspectiveY1 :: Floating n => Deformation V2 n perspectiveY1 = Deformation (\p -> p & _x //~ (p^._y) & _y .~ 1) -- | The viewing transform for a viewer facing along the positive X -- axis. X coördinates stay fixed, while Y coördinates are compressed -- with increasing distance. @asDeformation (translation unitX) <> -- parallelX0 <> frustrumX = perspectiveX1@ -facingX :: (R2Ish v) => Deformation v +facingX :: Floating n => Deformation V2 n facingX = Deformation (\v -> v & _y //~ (v^._x)) -facingY :: (R2Ish v) => Deformation v +facingY :: Floating n => Deformation V2 n facingY = Deformation (\v -> v & _x //~ (v^._y)) + diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index 8c3c5378..5816f372 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -25,7 +25,6 @@ module Diagrams.TwoD.Ellipse import Diagrams.Core -import Data.VectorSpace import Diagrams.Angle import Diagrams.Located (at) import Diagrams.Trail (glueTrail) @@ -37,18 +36,18 @@ import Diagrams.TwoD.Vector (xDir) import Diagrams.Util -- | A circle of radius 1, with center at the origin. -unitCircle :: (TrailLike t, R2Ish (V t)) => t -unitCircle = trailLike $ glueTrail (arcT xDir fullTurn) `at` (p2 (1,0)) +unitCircle :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => t +unitCircle = trailLike $ glueTrail (arcT xDir fullTurn) `at` p2 (1,0) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). -circle :: (TrailLike t, R2Ish (V t), Transformable t) => Scalar (V t) -> t +circle :: (TrailLike t, Vn t ~ V2 n, RealFloat n, Transformable t) => n -> t circle d = unitCircle # scale d -- | @ellipse e@ constructs an ellipse with eccentricity @e@ by -- scaling the unit circle in the X direction. The eccentricity must -- be within the interval [0,1). -ellipse :: (TrailLike t, R2Ish (V t), Transformable t) => Scalar (V t) -> t +ellipse :: (TrailLike t, Vn t ~ V2 n, RealFloat n, Transformable t) => n -> t ellipse e | e >= 0 && e < 1 = scaleX (sqrt (1 - e*e)) unitCircle | otherwise = error "Eccentricity of ellipse must be >= 0 and < 1." @@ -56,5 +55,5 @@ ellipse e -- | @ellipseXY x y@ creates an axis-aligned ellipse, centered at the -- origin, with radius @x@ along the x-axis and radius @y@ along the -- y-axis. -ellipseXY :: (TrailLike t, R2Ish (V t), Transformable t) => Scalar (V t) -> Scalar (V t) -> t +ellipseXY :: (TrailLike t, Vn t ~ V2 n, RealFloat n, Transformable t) => n -> n -> t ellipseXY x y = unitCircle # scaleX x # scaleY y diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 38cfbbf7..7d3d7790 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -54,12 +54,10 @@ import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable -import Data.AffineSpace import Data.Default.Class -import Data.VectorSpace +import Diagrams.Angle import Diagrams.Combinators (withEnvelope, withTrace) -import Diagrams.Coordinates import Diagrams.Core import Diagrams.Core.Trace import Diagrams.Located (Located, mapLoc, unLoc) @@ -73,6 +71,12 @@ import Diagrams.TwoD.Segment () import Diagrams.TwoD.Types import Diagrams.Util (tau) +import Linear.Vector +import Linear.Affine +import Linear.Epsilon + +type TypeableReal n = (Epsilon n, RealFloat n, Typeable n) + ------------------------------------------------------------ -- Trail and path traces --------------------------------- ------------------------------------------------------------ @@ -81,14 +85,14 @@ import Diagrams.Util (tau) -- XXX can the efficiency of this be improved? See the comment in -- Diagrams.Path on the Enveloped instance for Trail. -instance (R2Ish v) => Traced (Trail v) where +instance (OrderedField n, RealFloat n) => Traced (Trail V2 n) where getTrace = withLine $ foldr - (\seg bds -> moveOriginBy (negateV . atEnd $ seg) bds <> getTrace seg) + (\seg bds -> moveOriginBy (negated . atEnd $ seg) bds <> getTrace seg) mempty . lineSegments -instance (R2Ish v) => Traced (Path v) where +instance (OrderedField n, RealFloat n) => Traced (Path V2 n) where getTrace = F.foldMap getTrace . op Path ------------------------------------------------------------ @@ -159,11 +163,11 @@ instance Default (StrokeOpts a) where -- inferring the type of @stroke@. The solution is to give a type -- signature to expressions involving @stroke@, or (recommended) -- upgrade GHC (the bug is fixed in 7.0.2 onwards). -stroke :: (R2Ish v, Renderable (Path v) b) - => Path v -> Diagram b v +stroke :: (TypeableReal n, Renderable (Path V2 n) b) + => Path V2 n -> Diagram b V2 n stroke = stroke' (def :: StrokeOpts ()) -instance (R2Ish v, Renderable (Path v) b) => TrailLike (QDiagram b v Any) where +instance (OrderedField n, Typeable n, RealFloat n, Renderable (Path V2 n) b) => TrailLike (Diagram b V2 n) where trailLike = stroke . trailLike -- | A variant of 'stroke' that takes an extra record of options to @@ -173,7 +177,7 @@ instance (R2Ish v, Renderable (Path v) b) => TrailLike (QDiagram b v Any) where -- -- 'StrokeOpts' is an instance of 'Default', so @stroke' ('with' & -- ... )@ syntax may be used. -stroke' :: (R2Ish v, Renderable (Path v) b, IsName a) => StrokeOpts a -> Path v -> Diagram b v +stroke' :: (TypeableReal n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Path V2 n -> Diagram b V2 n stroke' opts path | null (pLines ^. _Wrapped') = mkP pLoops | null (pLoops ^. _Wrapped') = mkP pLines @@ -198,51 +202,51 @@ stroke' opts path -- The solution is to give a type signature to expressions involving -- @strokeTrail@, or (recommended) upgrade GHC (the bug is fixed in 7.0.2 -- onwards). -strokeTrail :: (R2Ish v, Renderable (Path v) b) => Trail v -> Diagram b v +strokeTrail :: (TypeableReal n, Renderable (Path V2 n) b) => Trail V2 n -> Diagram b V2 n strokeTrail = stroke . pathFromTrail -- | Deprecated synonym for 'strokeTrail'. -strokeT :: (R2Ish v, Renderable (Path v) b) => Trail v -> Diagram b v +strokeT :: (TypeableReal n, Renderable (Path V2 n) b) => Trail V2 n -> Diagram b V2 n strokeT = strokeTrail -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. -strokeTrail' :: (R2Ish v, Renderable (Path v) b, IsName a) - => StrokeOpts a -> Trail v -> Diagram b v +strokeTrail' :: (TypeableReal n, Renderable (Path V2 n) b, IsName a) + => StrokeOpts a -> Trail V2 n -> Diagram b V2 n strokeTrail' opts = stroke' opts . pathFromTrail -- | Deprecated synonym for 'strokeTrail''. -strokeT' :: (R2Ish v, Renderable (Path v) b, IsName a) - => StrokeOpts a -> Trail v -> Diagram b v +strokeT' :: (TypeableReal n, Renderable (Path V2 n) b, IsName a) + => StrokeOpts a -> Trail V2 n -> Diagram b V2 n strokeT' = strokeTrail' -- | A composition of 'strokeT' and 'wrapLine' for conveniently -- converting a line directly into a diagram. -strokeLine :: (R2Ish v, Renderable (Path v) b) => Trail' Line v -> Diagram b v +strokeLine :: (TypeableReal n, Renderable (Path V2 n) b) => Trail' Line V2 n -> Diagram b V2 n strokeLine = strokeT . wrapLine -- | A composition of 'strokeT' and 'wrapLoop' for conveniently -- converting a loop directly into a diagram. -strokeLoop :: (R2Ish v, Renderable (Path v) b) => Trail' Loop v -> Diagram b v +strokeLoop :: (TypeableReal n, Renderable (Path V2 n) b) => Trail' Loop V2 n -> Diagram b V2 n strokeLoop = strokeT . wrapLoop -- | A convenience function for converting a @Located Trail@ directly -- into a diagram; @strokeLocTrail = stroke . trailLike@. -strokeLocTrail :: (R2Ish v, Renderable (Path v) b) => Located (Trail v) -> Diagram b v +strokeLocTrail :: (TypeableReal n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> Diagram b V2 n strokeLocTrail = stroke . trailLike -- | Deprecated synonym for 'strokeLocTrail'. -strokeLocT :: (R2Ish v, Renderable (Path v) b) => Located (Trail v) -> Diagram b v +strokeLocT :: (TypeableReal n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> Diagram b V2 n strokeLocT = strokeLocTrail -- | A convenience function for converting a @Located@ line directly -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. -strokeLocLine :: (R2Ish v, Renderable (Path v) b) => Located (Trail' Line v) -> Diagram b v +strokeLocLine :: (TypeableReal n, Renderable (Path V2 n) b) => Located (Trail' Line V2 n) -> Diagram b V2 n strokeLocLine = stroke . trailLike . mapLoc wrapLine -- | A convenience function for converting a @Located@ loop directly -- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@. -strokeLocLoop :: (R2Ish v, Renderable (Path v) b) => Located (Trail' Loop v) -> Diagram b v +strokeLocLoop :: (TypeableReal n, Renderable (Path V2 n) b) => Located (Trail' Loop V2 n) -> Diagram b V2 n strokeLocLoop = stroke . trailLike . mapLoc wrapLoop ------------------------------------------------------------ @@ -251,7 +255,7 @@ strokeLocLoop = stroke . trailLike . mapLoc wrapLoop -runFillRule :: (R2Ish v) => FillRule -> Point v -> Path v -> Bool +runFillRule :: (Epsilon n, RealFloat n) => FillRule -> Point V2 n -> Path V2 n -> Bool runFillRule Winding = isInsideWinding runFillRule EvenOdd = isInsideEvenOdd @@ -260,7 +264,7 @@ newtype FillRuleA = FillRuleA (Last FillRule) instance AttributeClass FillRuleA instance Default FillRuleA where - def = FillRuleA $ Last $ def + def = FillRuleA $ Last def -- | Extract the fill rule from a 'FillRuleA' attribute. getFillRule :: FillRuleA -> FillRule @@ -271,8 +275,8 @@ getFillRule (FillRuleA (Last r)) = r fillRule :: HasStyle a => FillRule -> a -> a fillRule = applyAttr . FillRuleA . Last -cross :: (R2Ish v) => v -> v -> Scalar v -cross (coords -> x :& y) (coords -> x' :& y') = x * y' - y * x' +cross2 :: Num n => V2 n -> V2 n -> n +cross2 (V2 x y) (V2 x' y') = x * y' - y * x' -- XXX link to more info on this @@ -280,7 +284,7 @@ cross (coords -> x :& y) (coords -> x' :& y') = x * y' - y * x' -- by testing whether the point's /winding number/ is nonzero. Note -- that @False@ is /always/ returned for /open/ paths, regardless of -- the winding number. -isInsideWinding :: (R2Ish v) => Point v -> Path v -> Bool +isInsideWinding :: (Epsilon n, RealFloat n) => Point V2 n -> Path V2 n -> Bool isInsideWinding p = (/= 0) . crossings p -- | Test whether the given point is inside the given (closed) path, @@ -288,17 +292,17 @@ isInsideWinding p = (/= 0) . crossings p -- x direction crosses the path an even (outside) or odd (inside) -- number of times. Note that @False@ is /always/ returned for -- /open/ paths, regardless of the number of crossings. -isInsideEvenOdd :: (R2Ish v) => Point v -> Path v -> Bool +isInsideEvenOdd :: (Epsilon n, RealFloat n) => Point V2 n -> Path V2 n -> Bool isInsideEvenOdd p = odd . crossings p -- | Compute the sum of /signed/ crossings of a path as we travel in the -- positive x direction from a given point. -crossings :: (R2Ish v) => Point v -> Path v -> Int +crossings :: (Epsilon n, RealFloat n) => Point V2 n -> Path V2 n -> Int crossings p = F.sum . map (trailCrossings p) . op Path -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. -trailCrossings :: (R2Ish v) => Point v -> Located (Trail v) -> Int +trailCrossings :: (RealFloat n, Epsilon n) => Point V2 n -> Located (Trail V2 n) -> Int -- non-loop trails have no inside or outside, so don't contribute crossings trailCrossings _ t | not (isLoop (unLoc t)) = 0 @@ -311,10 +315,15 @@ trailCrossings p@(unp2 -> (x,y)) tr | by <= y && ay > y && isLeft a b < 0 = -1 | otherwise = 0 - test c@(FCubic (unp2 -> x1@(_,x1y)) - (unp2 -> c1@(_,c1y)) - (unp2 -> c2@(_,c2y)) - (unp2 -> x2@(_,x2y)) + -- test c@(FCubic (unp2 -> x1@(_,x1y)) + -- (unp2 -> c1@(_,c1y)) + -- (unp2 -> c2@(_,c2y)) + -- (unp2 -> x2@(_,x2y)) + -- ) = + test c@(FCubic (P x1@(V2 _ x1y)) + (P c1@(V2 _ c1y)) + (P c2@(V2 _ c2y)) + (P x2@(V2 _ x2y)) ) = sum . map testT $ ts where ts = filter (liftA2 (&&) (>=0) (<=1)) @@ -325,15 +334,15 @@ trailCrossings p@(unp2 -> (x,y)) tr testT t = let (unp2 -> (px,_)) = c `atParam` t in if px > x then signFromDerivAt t else 0 signFromDerivAt t = - let (dx,dy) = (3*t*t) *^ ((-1)*^x1 ^+^ 3*^c1 ^-^ 3*^c2 ^+^ x2) - ^+^ (2*t) *^ (3*^x1 ^-^ 6*^c1 ^+^ 3*^c2) - ^+^ ((-3)*^x1 ^+^ 3*^c1) - ang = atan2 dy dx + let v = (3*t*t) *^ ((-1)*^x1 ^+^ 3*^c1 ^-^ 3*^c2 ^+^ x2) + ^+^ (2*t) *^ (3*^x1 ^-^ 6*^c1 ^+^ 3*^c2) + ^+^ ((-3)*^x1 ^+^ 3*^c1) + ang = v ^. _theta . rad in case () of _ | 0 < ang && ang < tau/2 && t < 1 -> 1 | -tau/2 < ang && ang < 0 && t > 0 -> -1 | otherwise -> 0 - isLeft a b = cross (b .-. a) (p .-. a) + isLeft a b = cross2 (b .-. a) (p .-. a) ------------------------------------------------------------ -- Clipping ---------------------------------------------- @@ -344,16 +353,17 @@ trailCrossings p@(unp2 -> (x,y)) tr -- concatenation, so applying multiple clipping paths is sensible. -- The clipping region is the intersection of all the applied -- clipping paths. -newtype Clip v = Clip [Path v] +newtype Clip n = Clip [Path V2 n] deriving (Typeable, Semigroup) makeWrapped ''Clip -instance (Typeable v) => AttributeClass (Clip v) +instance (Typeable n) => AttributeClass (Clip n) -type instance V (Clip v) = v +type instance V (Clip n) = V2 +type instance N (Clip n) = n -instance (R2Ish v) => Transformable (Clip v) where +instance (OrderedField n) => Transformable (Clip n) where transform t (Clip ps) = Clip (transform t ps) -- | Clip a diagram by the given path: @@ -362,7 +372,7 @@ instance (R2Ish v) => Transformable (Clip v) where -- path will be drawn. -- -- * The envelope of the diagram is unaffected. -clipBy :: (R2Ish v, HasStyle a, V a ~ v) => Path v -> a -> a +clipBy :: (HasStyle a, Vn a ~ V2 n, Epsilon n, RealFloat n, Typeable n) => Path V2 n -> a -> a clipBy = applyTAttr . Clip . (:[]) -- | Clip a diagram to the given path setting its envelope to the @@ -370,7 +380,7 @@ clipBy = applyTAttr . Clip . (:[]) -- trace consists of those parts of the original diagram's trace -- which fall within the clipping path, or parts of the path's trace -- within the original diagram. -clipTo :: (R2Ish v, Renderable (Path v) b) => Path v -> Diagram b v -> Diagram b v +clipTo :: (Typeable n, Epsilon n, RealFloat n, Renderable (Path V2 n) b) => Path V2 n -> Diagram b V2 n -> Diagram b V2 n clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d where envP = appEnvelope . getEnvelope $ p @@ -390,6 +400,6 @@ clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d -- | Clip a diagram to the clip path taking the envelope and trace of the clip -- path. -clipped :: (R2Ish v, Renderable (Path v) b) => Path v -> Diagram b v -> Diagram b v -clipped p = (withTrace p) . (withEnvelope p) . (clipBy p) +clipped :: (Typeable n, Epsilon n, RealFloat n, Renderable (Path V2 n) b) => Path V2 n -> Diagram b V2 n -> Diagram b V2 n +clipped p = withTrace p . withEnvelope p . clipBy p diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index 2657ca2e..8c979621 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -59,9 +59,7 @@ import Data.Maybe (catMaybes) import Data.Monoid (mconcat, mempty) import Data.Ord (comparing) -import Data.AffineSpace ((.+^), (.-.)) import Data.Default.Class -import Data.VectorSpace import Diagrams.Angle import Diagrams.Core @@ -75,8 +73,13 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) import Diagrams.Util (tau, ( # )) +import Linear.Affine +import Linear.Vector +import Linear.Metric +import Linear.Epsilon + -- | Method used to determine the vertices of a polygon. -data PolyType d = PolyPolar [Angle d] [d] +data PolyType n = PolyPolar [Angle n] [n] -- ^ A \"polar\" polygon. -- -- * The first argument is a list of /central/ @@ -93,7 +96,7 @@ data PolyType d = PolyPolar [Angle d] [d] -- circle) can be constructed using a second -- argument of @(repeat r)@. - | PolySides [Angle d] [d] + | PolySides [Angle n] [n] -- ^ A polygon determined by the distance between -- successive vertices and the angles formed by -- each three successive vertices. In other @@ -118,54 +121,54 @@ data PolyType d = PolyPolar [Angle d] [d] -- angles and /n-1/ edge lengths. Extra angles or -- lengths are ignored. - | PolyRegular Int d + | PolyRegular Int n -- ^ A regular polygon with the given number of -- sides (first argument) and the given radius -- (second argument). -- | Determine how a polygon should be oriented. -data PolyOrientation v = NoOrient -- ^ No special orientation; the first - -- vertex will be at (1,0). - -- This is the default. - | OrientH -- ^ Orient /horizontally/, so the - -- bottommost edge is parallel to - -- the x-axis. - | OrientV -- ^ Orient /vertically/, so the - -- leftmost edge is parallel to the - -- y-axis. - | OrientTo v -- ^ Orient so some edge is - -- /facing/ /in/ /the/ /direction/ - -- /of/, that is, perpendicular - -- to, the given vector. +data PolyOrientation n = NoOrient -- ^ No special orientation; the first + -- vertex will be at (1,0). + -- This is the default. + | OrientH -- ^ Orient /horizontally/, so the + -- bottommost edge is parallel to + -- the x-axis. + | OrientV -- ^ Orient /vertically/, so the + -- leftmost edge is parallel to the + -- y-axis. + | OrientTo (V2 n) -- ^ Orient so some edge is + -- /facing/ /in/ /the/ /direction/ + -- /of/, that is, perpendicular + -- to, the given vector. deriving (Eq, Ord, Show, Read) -- | Options for specifying a polygon. -data PolygonOpts v = PolygonOpts - { _polyType :: PolyType (Scalar v) - , _polyOrient :: PolyOrientation v - , _polyCenter :: Point v +data PolygonOpts n = PolygonOpts + { _polyType :: PolyType n + , _polyOrient :: PolyOrientation n + , _polyCenter :: Point V2 n } makeLensesWith (generateSignatures .~ False $ lensRules) ''PolygonOpts -- | Specification for the polygon's vertices. -polyType :: Lens' (PolygonOpts v) (PolyType (Scalar v)) +polyType :: Lens' (PolygonOpts n) (PolyType n) -- | Should a rotation be applied to the polygon in order to orient it in a -- particular way? -polyOrient :: Lens' (PolygonOpts v) (PolyOrientation v) +polyOrient :: Lens' (PolygonOpts n) (PolyOrientation n) -- | Should a translation be applied to the polygon in order to place the center -- at a particular location? -polyCenter :: Lens' (PolygonOpts v) (Point v) +polyCenter :: Lens' (PolygonOpts n) (Point V2 n) -- | The default polygon is a regular pentagon of radius 1, centered -- at the origin, aligned to the x-axis. -instance (R2Ish v) => Default (PolygonOpts v) where +instance Num n => Default (PolygonOpts n) where def = PolygonOpts (PolyRegular 5 1) OrientH origin -- | Generate a polygon. See 'PolygonOpts' for more information. -polyTrail :: (R2Ish v) => PolygonOpts v -> Located (Trail v) +polyTrail :: (RealFloat n, Epsilon n) => PolygonOpts n -> Located (Trail V2 n) polyTrail po = transform ori tr where tr = case po^.polyType of @@ -179,12 +182,12 @@ polyTrail po = transform ori tr NoOrient -> mempty -- | Generate the polygon described by the given options. -polygon :: (R2Ish v, TrailLike t, V t ~ v) => PolygonOpts v -> t +polygon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => PolygonOpts n -> t polygon = trailLike . polyTrail -- | Generate the located trail of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'. -polyPolarTrail :: (R2Ish v) => [Angle (Scalar v)] -> [Scalar v] -> Located (Trail v) +polyPolarTrail :: (RealFloat n, Epsilon n) => [Angle n] -> [n] -> Located (Trail V2 n) polyPolarTrail [] _ = emptyTrail `at` origin polyPolarTrail _ [] = emptyTrail `at` origin polyPolarTrail ans (r:rs) = tr `at` p1 @@ -193,51 +196,51 @@ polyPolarTrail ans (r:rs) = tr `at` p1 tr = closeTrail . trailFromVertices $ zipWith (\a l -> rotate a . scale l $ p2 (1,0)) - (scanl (^+^) zeroV ans) + (scanl (^+^) zero ans) (r:rs) -- | Generate the vertices of a polygon specified by side length and -- angles, and a starting point for the trail such that the origin -- is at the centroid of the vertices. See 'PolySides'. -polySidesTrail :: (R2Ish v) => [Angle (Scalar v)] -> [Scalar v] -> Located (Trail v) +polySidesTrail :: (RealFloat n, Epsilon n) => [Angle n] -> [n] -> Located (Trail V2 n) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) where - ans' = scanl (^+^) zeroV ans + ans' = scanl (^+^) zero ans offsets = zipWith rotate ans' (map (unitY ^*) ls) ps = scanl (.+^) origin offsets tr = closeTrail . trailFromOffsets $ offsets -- | Generate the vertices of a regular polygon. See 'PolyRegular'. -polyRegularTrail :: (R2Ish v) => Int -> Scalar v -> Located (Trail v) +polyRegularTrail :: (RealFloat n, Epsilon n) => Int -> n -> Located (Trail V2 n) polyRegularTrail n r = polyPolarTrail - (take (n-1) . repeat $ fullTurn ^/ fromIntegral n) + (replicate (n - 1) $ fullTurn ^/ fromIntegral n) (repeat r) -- | Generate a transformation to orient a trail. @orient v t@ -- generates the smallest rotation such that one of the segments -- adjacent to the vertex furthest in the direction of @v@ is -- perpendicular to @v@. -orient :: (R2Ish v) => v -> Located (Trail v) -> Transformation v +orient :: (RealFloat n, Epsilon n) => V2 n -> Located (Trail V2 n) -> Transformation V2 n orient v = orientPoints v . trailVertices -orientPoints :: (R2Ish v) => v -> [Point v] -> Transformation v +orientPoints :: (Floating n, Ord n) => V2 n -> [Point V2 n] -> Transformation V2 n orientPoints v xs = rotation a where (n1,x,n2) = maximumBy (comparing (distAlong v . sndOf3)) (zip3 (tail (cycle xs)) xs (last xs : init xs)) - distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p) + distAlong w ((.-. origin) -> p) = signum (w `dot` p) * norm (project w p) sndOf3 (_,b,_) = b -- a :: Angle (Scalar v) a = minimumBy (comparing $ abs . view rad) . map (angleFromNormal . (.-. x)) $ [n1,n2] - v' = normalized v + v' = signorm v -- angleFromNormal :: v -> Angle (Scalar v) angleFromNormal o | leftTurn o' v' = phi - | otherwise = negateV phi + | otherwise = negated phi where - o' = normalized o - theta = acos (v' <.> o') + o' = signorm o + theta = acos (v' `dot` o') -- phi :: Angle (Scalar v) phi | theta <= tau/4 = tau/4 - theta @@ rad @@ -278,10 +281,10 @@ orbits f n = runST genOrbits markRho :: Int -> STUArray s Int Bool -> ST s [Int] markRho i marks = do isMarked <- readArray marks i - case isMarked of - True -> return [] - False -> writeArray marks i True >> - liftM (i:) (markRho (f_n i) marks) + if isMarked + then return [] + else writeArray marks i True >> + liftM (i:) (markRho (f_n i) marks) splitParts :: [Int] -> [GraphPart Int] splitParts tr = hair ++ cyc @@ -326,7 +329,7 @@ data StarOpts = StarFun (Int -> Int) -- returned (instead of any 'TrailLike') because the resulting path -- may have more than one component, for example if the vertices are -- to be connected in several disjoint cycles. -star :: (R2Ish v) => StarOpts -> [Point v] -> Path v +star :: OrderedField n => StarOpts -> [Point V2 n] -> Path V2 n star sOpts vs = graphToPath $ mkGraph f vs where f = case sOpts of StarFun g -> g @@ -339,3 +342,4 @@ star sOpts vs = graphToPath $ mkGraph f vs $ ps partToPath (Hair ps) = fromVertices ps + diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index a510ba00..6c11d943 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -26,9 +26,6 @@ module Diagrams.TwoD.Segment where import Control.Applicative (liftA2) import Control.Lens ((^.)) -import Data.AffineSpace -import Data.VectorSpace - import Diagrams.Core import Diagrams.Angle @@ -41,14 +38,18 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Diagrams.Util +import Linear.Affine +import Linear.Vector +import Linear.Metric + {- All instances of Traced should maintain the invariant that the list of traces is sorted in increasing order. -} -instance (R2Ish v) => Traced (Segment Closed v) where +instance RealFloat n => Traced (Segment Closed V2 n) where getTrace = getTrace . mkFixedSeg . (`at` origin) -instance (R2Ish v) => Traced (FixedSegment v) where +instance RealFloat n => Traced (FixedSegment V2 n) where {- Given lines defined by p0 + t0 * v0 and p1 + t1 * v1, their point of intersection in 2D is given by @@ -74,14 +75,15 @@ instance (R2Ish v) => Traced (FixedSegment v) where getTrace (FLinear p0 p0') = mkTrace $ \p1 v1 -> let v0 = p0' .-. p0 - det = perp v1 <.> v0 + det = perp v1 `dot` v0 p = p1 .-. p0 - t0 = (perp v1 <.> p) / det - t1 = (perp v0 <.> p) / det + t0 = (perp v1 `dot` p) / det + t1 = (perp v0 `dot` p) / det in - if det == 0 || t0 < 0 || t0 > 1 - then mkSortedList [] - else mkSortedList [t1] + mkSortedList $ + if det == 0 || t0 < 0 || t0 > 1 + then [] + else [t1] {- To do intersection of a line with a cubic Bezier, we first rotate and scale everything so that the line has parameters (origin, unitX); @@ -97,8 +99,8 @@ instance (R2Ish v) => Traced (FixedSegment v) where let bez'@(FCubic x1 c1 c2 x2) = bez # moveOriginTo p1 - # rotate (negateV (v1^._theta)) - # scale (1/magnitude v1) + # rotate (negated (v1^._theta)) + # scale (1/norm v1) [y0,y1,y2,y3] = map (snd . unp2) [x1,c1,c2,x2] a = -y0 + 3*y1 - 3*y2 + y3 b = 3*y0 - 6*y1 + 3*y2 diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index 7a0dada0..4acc34ba 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -65,7 +65,6 @@ import Diagrams.Util import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.)) import Data.Default.Class import Data.Semigroup -import Data.VectorSpace -- | Create a centered horizontal (L-R) line of the given length. -- @@ -73,8 +72,8 @@ import Data.VectorSpace -- -- > hruleEx = vcat' (with & sep .~ 0.2) (map hrule [1..5]) -- > # centerXY # pad 1.1 -hrule :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t -hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` (p2 (-d/2,0)) +hrule :: (TrailLike t, Vn t ~ V2 n) => n -> t +hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` p2 (-d/2,0) -- | Create a centered vertical (T-B) line of the given length. -- @@ -82,14 +81,14 @@ hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` (p2 (-d/2,0) -- -- > vruleEx = hcat' (with & sep .~ 0.2) (map vrule [1, 1.2 .. 2]) -- > # centerXY # pad 1.1 -vrule :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t -vrule d = trailLike $ trailFromSegments [straight $ r2 (0, (-d))] `at` (p2 (0,d/2)) +vrule :: (TrailLike t, Vn t ~ V2 n) => n -> t +vrule d = trailLike $ trailFromSegments [straight $ r2 (0, -d)] `at` p2 (0,d/2) -- | A square with its center at the origin and sides of length 1, -- oriented parallel to the axes. -- -- <> -unitSquare :: (TrailLike t, V t ~ v, R2Ish v) => t +unitSquare :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => t unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2) & polyOrient .~ OrientH) @@ -99,7 +98,7 @@ unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2) -- length, oriented parallel to the axes. -- -- <> -square :: (TrailLike t, Transformable t, V t ~ v, R2Ish v) => Scalar v -> t +square :: (TrailLike t, Transformable t, Vn t ~ V2 n, RealFloat n) => n -> t square d = rect d d -- > squareEx = hcat' (with & sep .~ 0.5) [square 1, square 2, square 3] @@ -109,7 +108,7 @@ square d = rect d d -- @h@, centered at the origin. -- -- <> -rect :: (TrailLike t, Transformable t, V t ~ v, R2Ish v) => Scalar v -> Scalar v -> t +rect :: (TrailLike t, Transformable t, Vn t ~ V2 n, RealFloat n) => n -> n -> t rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h -- > rectEx = rect 1 0.7 # pad 1.1 @@ -141,7 +140,7 @@ rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h -- polygons of a given /radius/). -- -- The polygon will be oriented with one edge parallel to the x-axis. -regPoly :: (TrailLike t, V t ~ v, R2Ish v) => Int -> Scalar v -> t +regPoly :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => Int -> n -> t regPoly n l = polygon (def & polyType .~ PolySides (repeat (1/fromIntegral n @@ turn)) @@ -161,76 +160,76 @@ regPoly n l = polygon (def & polyType .~ -- > dodecagonEx = shapeEx dodecagon -- | A synonym for 'triangle', provided for backwards compatibility. -eqTriangle :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +eqTriangle :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t eqTriangle = triangle -- | An equilateral triangle, with sides of the given length and base -- parallel to the x-axis. -- -- <> -triangle :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +triangle :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t triangle = regPoly 3 -- | A regular pentagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -pentagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +pentagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t pentagon = regPoly 5 -- | A regular hexagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -hexagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +hexagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t hexagon = regPoly 6 -- | A regular heptagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -heptagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +heptagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t heptagon = regPoly 7 -- | A synonym for 'heptagon'. It is, however, completely inferior, -- being a base admixture of the Latin /septum/ (seven) and the -- Greek γωνία (angle). -septagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +septagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t septagon = heptagon -- | A regular octagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -octagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +octagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t octagon = regPoly 8 -- | A regular nonagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -nonagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +nonagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t nonagon = regPoly 9 -- | A regular decagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -decagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +decagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t decagon = regPoly 10 -- | A regular hendecagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -hendecagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +hendecagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t hendecagon = regPoly 11 -- | A regular dodecagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -dodecagon :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> t +dodecagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t dodecagon = regPoly 12 ------------------------------------------------------------ @@ -268,7 +267,7 @@ instance (Num d) => Default (RoundedRectOpts d) where -- > & radiusBR .~ 0.1) -- > ] -roundedRect :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> Scalar v -> Scalar v -> t +roundedRect :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> n -> n -> t roundedRect w h r = roundedRect' w h (def & radiusTL .~ r & radiusBR .~ r & radiusTR .~ r @@ -278,10 +277,10 @@ roundedRect w h r = roundedRect' w h (def & radiusTL .~ r -- each corner indivually, using @RoundedRectOpts@. The default corner radius is 0. -- Each radius can also be negative, which results in the curves being reversed -- to be inward instead of outward. -roundedRect' :: (TrailLike t, V t ~ v, R2Ish v) => Scalar v -> Scalar v -> RoundedRectOpts (Scalar v) -> t +roundedRect' :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> n -> RoundedRectOpts n -> t roundedRect' w h opts = trailLike - . (`at` (p2 (w/2, abs rBR - h/2))) + . (`at` p2 (w/2, abs rBR - h/2)) . wrapTrail . glueLine $ seg (0, h - abs rTR - abs rBR) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 67a4186d..ede88e05 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -16,7 +16,7 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space V2 (..), R2, P2, r2, unr2, mkR2, r2Iso - , p2, mkP2, unp2, p2Iso + , p2, mkP2, unp2, p2Iso, project , Polar(..) ) where @@ -27,6 +27,7 @@ import Diagrams.Angle import Diagrams.Points import Linear.Affine +import Linear.Vector import Linear.Metric import Linear.V2 hiding (R2) import qualified Linear.V2 as V @@ -34,6 +35,7 @@ import Diagrams.Coordinates import Diagrams.Core.V import Diagrams.Core.Transform + type R2 = V2 type P2 = Point V2 @@ -82,6 +84,11 @@ class Polar t where instance Polar v => Polar (Point v) where polar = _pIso . polar +-- | @project u v@ computes the projection of @v@ onto @u@. +project :: (Metric v, Fractional n) => v n -> v n -> v n +project u v = ((v `dot` u) / quadrance u) *^ u +-- find somewhere better for this + -- TODO: coordinate instance for V2 instance Transformable (V2 n) where From 996103621e93f148f0a8be71b7b6a9cbab39816c Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sat, 23 Aug 2014 12:28:06 +0100 Subject: [PATCH 24/58] Some Bergey sugestions. (and combinators) --- src/Diagrams/Located.hs | 12 ++--- src/Diagrams/Parametric.hs | 3 +- src/Diagrams/Segment.hs | 4 +- src/Diagrams/Tangent.hs | 4 +- src/Diagrams/ThreeD/Camera.hs | 44 ++++++++-------- src/Diagrams/Trail.hs | 86 +++++++++++++++----------------- src/Diagrams/TwoD/Combinators.hs | 84 ++++++++++++++++--------------- 7 files changed, 116 insertions(+), 121 deletions(-) diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs index 410f4987..6dbbe8f9 100644 --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -129,9 +129,9 @@ instance (Traced a, Num (N a)) => Traced (Located a) where instance Qualifiable a => Qualifiable (Located a) where n |> (Loc p a) = Loc p (n |> a) -type instance Codomain (Located a) n = Point (Codomain a) n +type instance Codomain (Located a) = Point (Codomain a) -instance (Vn a ~ v n, Codomain a ~ V a, Codomain a n ~ v n, Additive v, Num n, Parametric a) -- , Diff (Point (V a)) ~ V a) +instance (Vn a ~ v n, Codomain a ~ v, Additive v, Num n, Parametric a) => Parametric (Located a) where (Loc x a) `atParam` p = x .+^ (a `atParam` p) @@ -139,12 +139,11 @@ instance DomainBounds a => DomainBounds (Located a) where domainLower (Loc _ a) = domainLower a domainUpper (Loc _ a) = domainUpper a -instance (Vn a ~ v n, Codomain a ~ v, Codomain a n ~ v n, Additive v, Num n, EndValues a) +instance (Vn a ~ v n, Codomain a ~ v, Additive v, Num n, EndValues a) => EndValues (Located a) -- not sure why Codomain a n ~ v n is needed as well. I've probably done something wrong. -instance ( Vn a ~ v n, Codomain a ~ v, Codomain a n ~ v n - , Fractional n, Additive v , Sectionable a, Parametric a) +instance (Vn a ~ v n, Codomain a ~ v, Fractional n, Additive v , Sectionable a, Parametric a) => Sectionable (Located a) where splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2) where (a1,a2) = splitAtParam a p @@ -152,8 +151,7 @@ instance ( Vn a ~ v n, Codomain a ~ v, Codomain a n ~ v n reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a) where y = a `atParam` domainUpper a -instance ( Vn a ~ v n, Codomain a ~ v, Codomain a n ~ v n - , Additive v, Fractional n , HasArcLength a) +instance (Vn a ~ v n, Codomain a ~ v, Additive v, Fractional n , HasArcLength a) => HasArcLength (Located a) where arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a arcLengthToParam eps (Loc _ a) = arcLengthToParam eps a diff --git a/src/Diagrams/Parametric.hs b/src/Diagrams/Parametric.hs index f2d26f7a..50eaaf01 100644 --- a/src/Diagrams/Parametric.hs +++ b/src/Diagrams/Parametric.hs @@ -27,7 +27,7 @@ import qualified Numeric.Interval.Kaucher as I -- | Codomain of parametric classes. This is usually either @(V p)@, for relative -- vector results, or @(Point (V p))@, for functions with absolute coordinates. -type family Codomain p n :: * +type family Codomain p :: * -> * -- | Type class for parametric functions. class Parametric p where @@ -175,3 +175,4 @@ class Parametric p => HasArcLength p where -- default stdArcLengthToParam :: Fractional n -- => p n -> n -> n -- stdArcLengthToParam = arcLengthToParam stdTolerance + diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index fc034c64..7ec515f3 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -201,7 +201,7 @@ bezier3 c1 c2 x = Cubic c1 c2 (OffsetClosed x) bézier3 :: v n -> v n -> v n -> Segment Closed v n bézier3 = bezier3 -type instance Codomain (Segment Closed v n) n = v n +type instance Codomain (Segment Closed v n) = v -- | 'atParam' yields a parametrized view of segments as continuous -- functions @[0,1] -> v@, which give the offset from the start of @@ -387,7 +387,7 @@ fromFixedSeg :: (Num n, Additive v) => FixedSegment v n -> Located (Segment Clos fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 -type instance Codomain (FixedSegment v n) n = Point v n +type instance Codomain (FixedSegment v n) = Point v instance (Additive v, Num n) => Parametric (FixedSegment v n) where atParam (FLinear p1 p2) t = lerp t p1 p2 diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs index ee96f5f5..9835475d 100644 --- a/src/Diagrams/Tangent.hs +++ b/src/Diagrams/Tangent.hs @@ -48,7 +48,7 @@ instance DomainBounds t => DomainBounds (Tangent t) where domainLower (Tangent t) = domainLower t domainUpper (Tangent t) = domainUpper t -type instance Codomain (Tangent (Located t)) n = Codomain (Tangent t) n +type instance Codomain (Tangent (Located t)) = Codomain (Tangent t) instance Parametric (Tangent t) => Parametric (Tangent (Located t)) where Tangent l `atParam` p = Tangent (unLoc l) `atParam` p @@ -84,7 +84,7 @@ tangentAtEnd = atEnd . Tangent -------------------------------------------------- -- Segment -type instance Codomain (Tangent (Segment Closed v n)) n = Codomain (Segment Closed v n) n +type instance Codomain (Tangent (Segment Closed v n)) = Codomain (Segment Closed v n) instance (Additive v, Num n) => Parametric (Tangent (Segment Closed v n)) where diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index 3c1895ca..edb2ac72 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -45,17 +45,20 @@ import Linear.V3 -- Parameterize Camera on the lens type, so that Backends can express which -- lenses they handle. -data Camera l = Camera - { camLoc :: Point (V l) (N l) - , forward :: Vn l - , up :: Vn l - , lens :: l +data Camera l n = Camera + { camLoc :: Point V3 n + , forward :: V3 n + , up :: V3 n + , lens :: l n } deriving Typeable -class (Typeable l, Typeable (Vn l)) => CameraLens l where +type instance V (Camera l n) = V3 +type instance N (Camera l n) = n + +class Typeable l => CameraLens l where -- | The natural aspect ratio of the projection. - aspect :: l -> N l + aspect :: Floating n => l n -> n -- | A perspective projection data PerspectiveLens n = PerspectiveLens @@ -69,7 +72,7 @@ makeLenses ''PerspectiveLens type instance V (PerspectiveLens n) = V3 type instance N (PerspectiveLens n) = n -instance (Floating n, Typeable n) => CameraLens (PerspectiveLens n) where +instance CameraLens PerspectiveLens where aspect (PerspectiveLens h v) = angleRatio h v -- | An orthographic projection @@ -84,35 +87,32 @@ makeLenses ''OrthoLens type instance V (OrthoLens n) = V3 type instance N (OrthoLens n) = n -instance (Typeable n, Fractional n) => CameraLens (OrthoLens n) where +instance CameraLens OrthoLens where aspect (OrthoLens h v) = h / v -type instance V (Camera l) = V l -type instance N (Camera l) = N l - -instance (Vn l ~ V3 n, Num n) => Transformable (Camera l) where +instance Num n => Transformable (Camera l n) where transform t (Camera p f u l) = Camera (transform t p) (transform t f) (transform t u) l -instance (Vn l ~ V3 n, Num n) => Renderable (Camera l) NullBackend where +instance Num n => Renderable (Camera l n) NullBackend where render _ _ = mempty -- | A camera at the origin facing along the negative Z axis, with its -- up-axis coincident with the positive Y axis. The field of view is -- chosen to match a 50mm camera on 35mm film. Note that Cameras take -- up no space in the Diagram. -mm50Camera :: (Typeable n, Floating n, Ord n, Backend b V3 n, Renderable (Camera (PerspectiveLens n)) b) +mm50Camera :: (Typeable n, Floating n, Ord n, Renderable (Camera PerspectiveLens n) b) => Diagram b V3 n mm50Camera = facing_ZCamera mm50 -- | 'facing_ZCamera l' is a camera at the origin facing along the -- negative Z axis, with its up-axis coincident with the positive Y -- axis, with the projection defined by l. -facing_ZCamera :: (Vn l ~ V3 n, Floating n, Ord n, CameraLens l, Backend b V3 n, Renderable (Camera l) b) => - l -> Diagram b V3 n +facing_ZCamera :: (Floating n, Ord n, Typeable n, CameraLens l, Renderable (Camera l n) b) => + l n -> Diagram b V3 n facing_ZCamera l = mkQD (Prim $ Camera origin unit_Z unitY l) mempty mempty mempty (Query . const . Any $ False) @@ -130,20 +130,20 @@ mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) -- aspect ratio of 4:3, for VGA and similar computer resolutions. mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) -camForward :: (Vn l ~ V3 n, Fractional n) => Camera l -> Direction V3 n +camForward :: Fractional n => Camera l n -> Direction V3 n camForward = direction . forward -camUp :: (Vn l ~ V3 n, Fractional n) => Camera l -> Direction V3 n +camUp :: Fractional n => Camera l n -> Direction V3 n camUp = direction . up -camRight :: (Vn l ~ V3 n, Fractional n) => Camera l -> Direction V3 n +camRight :: Fractional n => Camera l n -> Direction V3 n camRight c = direction right where right = cross (forward c) (up c) -camLens :: (V3 ~ V l) => Camera l -> l +camLens :: Camera l n -> l n camLens = lens -camAspect :: (Vn l ~ V3 n, CameraLens l) => Camera l -> n +camAspect :: Floating n => CameraLens l => Camera l n -> n camAspect = aspect . camLens {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 190affc0..475b1db8 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -174,7 +174,7 @@ deriving instance (OrderedField n, Metric v) deriving instance (Metric v, OrderedField n) => Transformable (SegTree v n) -type instance Codomain (SegTree v n) n = v n +type instance Codomain (SegTree v n) = v instance (Metric v, OrderedField n, RealFrac n) => Parametric (SegTree v n) where @@ -185,8 +185,7 @@ instance Num n => DomainBounds (SegTree v n) instance (Metric v, OrderedField n, RealFrac n, Num n) => EndValues (SegTree v n) -instance (Metric v, RealFrac n, Floating n, Epsilon n) - => Sectionable (SegTree v n) where +instance (Metric v, RealFrac n, Floating n, Epsilon n) => Sectionable (SegTree v n) where splitAtParam (SegTree t) p | p < 0 = case FT.viewl t of EmptyL -> emptySplit @@ -372,7 +371,7 @@ deriving instance Ord (v n) => Ord (Trail' l v n) type instance V (Trail' l v n) = v type instance N (Trail' l v n) = n -type instance Codomain (Trail' l v n) n = v n +type instance Codomain (Trail' l v n) = v instance (OrderedField n, Metric v) => Semigroup (Trail' Line v n) where (Line t1) <> (Line t2) = Line (t1 `mappend` t2) @@ -407,17 +406,14 @@ instance (Metric v, OrderedField n, RealFrac n) (\l -> cutLoop l `atParam` mod1 p) t -type instance Codomain (Tangent (Trail' c v n)) n = Codomain (Trail' c v n) n +type instance Codomain (Tangent (Trail' c v n)) = Codomain (Trail' c v n) -instance ( Parametric (GetSegment (Trail' c v n)) - , Additive v - , Num n - ) +instance (Parametric (GetSegment (Trail' c v n)), Additive v, Num n) => Parametric (Tangent (Trail' c v n)) where Tangent tr `atParam` p = case GetSegment tr `atParam` p of - Nothing -> zero - Just (_, seg, reparam) -> Tangent seg `atParam` (p ^. cloneIso reparam) + GetSegmentCodomain Nothing -> zero + GetSegmentCodomain (Just (_, seg, reparam)) -> Tangent seg `atParam` (p ^. cloneIso reparam) instance ( Parametric (GetSegment (Trail' c v n)) , EndValues (GetSegment (Trail' c v n)) @@ -427,19 +423,16 @@ instance ( Parametric (GetSegment (Trail' c v n)) => EndValues (Tangent (Trail' c v n)) where atStart (Tangent tr) = case atStart (GetSegment tr) of - Nothing -> zero - Just (_, seg, _) -> atStart (Tangent seg) + GetSegmentCodomain Nothing -> zero + GetSegmentCodomain (Just (_, seg, _)) -> atStart (Tangent seg) atEnd (Tangent tr) = case atEnd (GetSegment tr) of - Nothing -> zero - Just (_, seg, _) -> atEnd (Tangent seg) + GetSegmentCodomain Nothing -> zero + GetSegmentCodomain (Just (_, seg, _)) -> atEnd (Tangent seg) -type instance Codomain (Tangent (Trail v n)) n = Codomain (Trail v n) n +type instance Codomain (Tangent (Trail v n)) = Codomain (Trail v n) -instance ( Metric v - , OrderedField n - , RealFrac n - ) +instance (Metric v , OrderedField n, RealFrac n) => Parametric (Tangent (Trail v n)) where Tangent tr `atParam` p = withTrail @@ -528,6 +521,13 @@ instance (Metric v, OrderedField n, RealFrac n) -- you can use. newtype GetSegment t = GetSegment t +newtype GetSegmentCodomain v n = + GetSegmentCodomain + (Maybe ( v n -- offset from trail start to segment start + , Segment Closed v n -- the segment + , AnIso' n n -- reparameterization, trail <-> segment + )) + -- | Create a 'GetSegment' wrapper around a trail, after which you can -- call 'atParam', 'atStart', or 'atEnd' to extract a segment. getSegment :: t -> GetSegment t @@ -535,36 +535,28 @@ getSegment = GetSegment type instance V (GetSegment t) = V t type instance N (GetSegment t) = N t -type instance Codomain (GetSegment t) n - -- = V t - = Maybe - ( V t n -- offset from trail start to segment start - , Segment Closed (V t) n -- the segment - , AnIso' n n -- reparameterization, trail <-> segment - ) + +type instance Codomain (GetSegment t) = GetSegmentCodomain (V t) -- | Parameters less than 0 yield the first segment; parameters -- greater than 1 yield the last. A parameter exactly at the -- junction of two segments yields the second segment (/i.e./ the -- one with higher parameter values). -instance (Metric v, OrderedField n) - => Parametric (GetSegment (Trail' Line v n)) where +instance (Metric v, OrderedField n) => Parametric (GetSegment (Trail' Line v n)) where atParam (GetSegment (Line (SegTree ft))) p - | p <= 0 - = case FT.viewl ft of - EmptyL -> Nothing - seg :< _ -> Just (zero, seg, reparam 0) + | p <= 0 = case FT.viewl ft of + EmptyL -> GetSegmentCodomain Nothing + seg :< _ -> GetSegmentCodomain $ Just (zero, seg, reparam 0) - | p >= 1 - = case FT.viewr ft of - EmptyR -> Nothing - ft' :> seg -> Just (offset ft', seg, reparam (n-1)) + | p >= 1 = case FT.viewr ft of + EmptyR -> GetSegmentCodomain Nothing + ft' :> seg -> GetSegmentCodomain $ Just (offset ft', seg, reparam (n-1)) | otherwise = let (before, after) = FT.split ((p*n <) . numSegs) ft in case FT.viewl after of - EmptyL -> Nothing - seg :< _ -> Just (offset before, seg, reparam (numSegs before)) + EmptyL -> GetSegmentCodomain Nothing + seg :< _ -> GetSegmentCodomain $ Just (offset before, seg, reparam (numSegs before)) where n = numSegs ft reparam k = iso (subtract k . (*n)) @@ -572,8 +564,7 @@ instance (Metric v, OrderedField n) -- | The parameterization for loops wraps around, /i.e./ parameters -- are first reduced \"mod 1\". -instance (Metric v, OrderedField n, RealFrac n) - => Parametric (GetSegment (Trail' Loop v n)) where +instance (Metric v, OrderedField n, RealFrac n) => Parametric (GetSegment (Trail' Loop v n)) where atParam (GetSegment l) p = atParam (GetSegment (cutLoop l)) (mod1 p) instance (Metric v, OrderedField n, RealFrac n) @@ -592,19 +583,20 @@ instance (Metric v, OrderedField n) => EndValues (GetSegment (Trail' Line v n)) where atStart (GetSegment (Line (SegTree ft))) = case FT.viewl ft of - EmptyL -> Nothing + EmptyL -> GetSegmentCodomain Nothing seg :< _ -> let n = numSegs ft - in Just (zero, seg, iso (*n) (/n)) + in GetSegmentCodomain $ Just (zero, seg, iso (*n) (/n)) atEnd (GetSegment (Line (SegTree ft))) = case FT.viewr ft of - EmptyR -> Nothing + EmptyR -> GetSegmentCodomain Nothing ft' :> seg -> let n = numSegs ft - in Just (offset ft', seg, iso (subtract (n-1) . (*n)) + in GetSegmentCodomain $ + Just (offset ft', seg, iso (subtract (n-1) . (*n)) ((/n) . (+ (n-1))) - ) + ) instance (Metric v, OrderedField n, RealFrac n) => EndValues (GetSegment (Trail' Loop v n)) where @@ -676,7 +668,7 @@ instance (OrderedField n, Metric v) => Monoid (Trail v n) where type instance V (Trail v n) = v type instance N (Trail v n) = n -type instance Codomain (Trail v n) n = v n +type instance Codomain (Trail v n) = v instance (HasLinearMap v, Metric v, OrderedField n) => Transformable (Trail v n) where diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 3a58e317..c14d5a4a 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -3,7 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Combinators @@ -40,17 +39,14 @@ module Diagrams.TwoD.Combinators ) where import Control.Lens ((&), (.~)) -import Data.AffineSpace import Data.Colour import Data.Default.Class import Data.Semigroup -import Data.VectorSpace import Diagrams.Core import Diagrams.BoundingBox import Diagrams.Combinators -import Diagrams.Coordinates import Diagrams.Path import Diagrams.Segment import Diagrams.TrailLike @@ -60,9 +56,16 @@ import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform (scaleX, scaleY) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unitY) +import Diagrams.TwoD.Vector import Diagrams.Util (( # )) +import Data.Typeable +import Data.Data +import Linear.Affine +import Linear.Epsilon +import Linear.Vector + +type TypeableReal a = (Epsilon a, RealFloat a, Typeable a, Data a) infixl 6 === infixl 6 ||| @@ -81,8 +84,8 @@ infixl 6 ||| -- combined diagram is the same as the local origin of the first. -- @(===)@ is associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. -(===) :: (Juxtaposable a, V a ~ v, R2Ish v, Semigroup a) => a -> a -> a -(===) = beside (negateV unitY) +(===) :: (Juxtaposable a, Vn a ~ V2 n, TypeableReal n, Semigroup a) => a -> a -> a +(===) = beside unit_Y -- | Place two diagrams (or other juxtaposable objects) horizontally -- adjacent to one another, with the first diagram to the left of @@ -90,7 +93,7 @@ infixl 6 ||| -- is the same as the local origin of the first. @(|||)@ is -- associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. -(|||) :: (Juxtaposable a, V a ~ v, R2Ish v, Semigroup a) => a -> a -> a +(|||) :: (Juxtaposable a, Vn a ~ V2 n, TypeableReal n, Semigroup a) => a -> a -> a (|||) = beside unitX -- | Lay out a list of juxtaposable objects in a row from left to right, @@ -104,7 +107,7 @@ infixl 6 ||| -- "Diagrams.TwoD.Align" before applying 'hcat'. -- -- * For non-axis-aligned layout, see 'cat'. -hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) +hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) => [a] -> a hcat = hcat' def @@ -112,14 +115,14 @@ hcat = hcat' def -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. For the common case of setting just a -- separation amount, see 'hsep'. -hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) - => CatOpts v -> [a] -> a +hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) + => CatOpts n -> [a] -> a hcat' = cat' unitX -- | A convenient synonym for horizontal concatenation with -- separation: @hsep s === hcat' (with & sep .~ s)@. -hsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) - => Scalar v -> [a] -> a +hsep :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) + => n -> [a] -> a hsep s = hcat' (def & sep .~ s) -- | Lay out a list of juxtaposable objects in a column from top to @@ -133,7 +136,7 @@ hsep s = hcat' (def & sep .~ s) -- "Diagrams.TwoD.Align" before applying 'vcat'. -- -- * For non-axis-aligned layout, see 'cat'. -vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) +vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) => [a] -> a vcat = vcat' def @@ -141,14 +144,14 @@ vcat = vcat' def -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. For the common case of setting just a -- separation amount, see 'vsep'. -vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) - => CatOpts v -> [a] -> a -vcat' = cat' (negateV unitY) +vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) + => CatOpts n -> [a] -> a +vcat' = cat' unit_Y -- | A convenient synonym for vertical concatenation with -- separation: @vsep s === vcat' (with & sep .~ s)@. -vsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ v, R2Ish v) - => Scalar v -> [a] -> a +vsep :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) + => n -> [a] -> a vsep s = vcat' (def & sep .~ s) -- | @strutR2 v@ is a two-dimensional diagram which produces no @@ -157,7 +160,7 @@ vsep s = vcat' (def & sep .~ s) -- local origin at its center. If you don't care about the trace -- then there's no difference between @strutR2@ and the more general -- 'strut'. -strutR2 :: (Backend b v, Monoid' m, R2Ish v) => v -> QDiagram b v m +strutR2 :: (Monoid' m, TypeableReal n) => V2 n -> QDiagram b V2 n m strutR2 v = phantom seg where seg = FLinear (origin .+^ 0.5 *^ v) (origin .+^ (-0.5) *^ v) @@ -165,14 +168,14 @@ strutR2 v = phantom seg -- | @strutX w@ is an empty diagram with width @w@, height 0, and a -- centered local origin. Note that @strutX (-w)@ behaves the same as -- @strutX w@. -strutX :: (Backend b v, Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m -strutX d = strut (d ^& 0) +strutX :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m +strutX d = strut (V2 d 0) -- | @strutY h@ is an empty diagram with height @h@, width 0, and a -- centered local origin. Note that @strutY (-h)@ behaves the same as -- @strutY h@. -strutY :: (Backend b v, Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m -strutY d = strut (0 ^& d) +strutY :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m +strutY d = strut (V2 0 d) -- | @padX s@ \"pads\" a diagram in the x-direction, expanding its -- envelope horizontally by a factor of @s@ (factors between 0 and 1 @@ -181,8 +184,8 @@ strutY d = strut (0 ^& d) -- centered horizontally the padding may appear \"uneven\". If this -- is not desired, the origin can be centered (using 'centerX') -- before applying @padX@. -padX :: ( Backend b v, Monoid' m, R2Ish v ) - => Scalar v -> QDiagram b v m -> QDiagram b v m +padX :: (Monoid' m, TypeableReal n ) + => n -> QDiagram b V2 n m -> QDiagram b V2 n m padX s d = withEnvelope (d # scaleX s) d -- | @padY s@ \"pads\" a diagram in the y-direction, expanding its @@ -192,8 +195,8 @@ padX s d = withEnvelope (d # scaleX s) d -- so if the origin is not centered vertically the padding may appear -- \"uneven\". If this is not desired, the origin can be centered -- (using 'centerY') before applying @padY@. -padY :: ( Backend b v, Monoid' m, R2Ish v ) - => Scalar v -> QDiagram b v m -> QDiagram b v m +padY :: (Monoid' m, TypeableReal n ) + => n -> QDiagram b V2 n m -> QDiagram b V2 n m padY s d = withEnvelope (d # scaleY s) d -- | @extrudeLeft s@ \"extrudes\" a diagram in the negative x-direction, @@ -201,7 +204,7 @@ padY s d = withEnvelope (d # scaleY s) d -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeLeft :: (Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m -> QDiagram b v m +extrudeLeft :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeLeft s | s >= 0 = extrudeEnvelope $ unitX ^* negate s | otherwise = intrudeEnvelope $ unitX ^* negate s @@ -211,7 +214,7 @@ extrudeLeft s -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeRight :: (Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m -> QDiagram b v m +extrudeRight :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeRight s | s >= 0 = extrudeEnvelope $ unitX ^* s | otherwise = intrudeEnvelope $ unitX ^* s @@ -221,7 +224,7 @@ extrudeRight s -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeBottom :: (Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m -> QDiagram b v m +extrudeBottom :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeBottom s | s >= 0 = extrudeEnvelope $ unitY ^* negate s | otherwise = intrudeEnvelope $ unitY ^* negate s @@ -231,7 +234,7 @@ extrudeBottom s -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeTop :: (Monoid' m, R2Ish v) => Scalar v -> QDiagram b v m -> QDiagram b v m +extrudeTop :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeTop s | s >= 0 = extrudeEnvelope $ unitY ^* s | otherwise = intrudeEnvelope $ unitY ^* s @@ -241,26 +244,27 @@ extrudeTop s -- .+^ v@. Useful for selecting the rectangular portion of a -- diagram which should actually be \"viewed\" in the final render, -- if you don't want to see the entire diagram. -view :: forall v b m. ( Backend b v, Monoid' m, R2Ish v ) - => Point v -> v -> QDiagram b v m -> QDiagram b v m -view p (coords -> w :& h) = withEnvelope (rect w h # alignBL # moveTo p :: D v) +view :: forall b n m. (Monoid' m, TypeableReal n) + => Point V2 n -> V2 n -> QDiagram b V2 n m -> QDiagram b V2 n m +view p (V2 w h) = withEnvelope (rect w h # alignBL # moveTo p :: D V2 n) -- | Construct a bounding rectangle for an enveloped object, that is, -- the smallest axis-aligned rectangle which encloses the object. -boundingRect :: ( Enveloped t, Transformable t, TrailLike t, Monoid t, V t ~ v - , Enveloped a, V a ~ v, R2Ish v +boundingRect :: ( Enveloped t, Transformable t, TrailLike t, Monoid t, Vn a ~ Vn t + , Enveloped a, Vn a ~ V2 n, TypeableReal n ) => a -> t boundingRect = (`boxFit` rect 1 1) . boundingBox -- | \"Set the background color\" of a diagram. That is, place a -- diagram atop a bounding rectangle of the given color. -bg :: (R2D v, Renderable (Path v) b) => Colour Double -> Diagram b v -> Diagram b v +bg :: (TypeableReal n, Renderable (Path V2 n) b) => Colour Double -> Diagram b V2 n -> Diagram b V2 n bg c d = d <> boundingRect d # lineWidth (Output 0) # fc c -- | Similar to 'bg' but makes the colored background rectangle larger than -- the diagram. The first parameter is used to set how far the background -- extends beyond the diagram. -bgFrame :: (R2D v, Renderable (Path v) b, Backend b v) - => Scalar v -> Colour Double -> Diagram b v -> Diagram b v +bgFrame :: (TypeableReal n, Renderable (Path V2 n) b) + => n -> Colour Double -> Diagram b V2 n -> Diagram b V2 n bgFrame f c d = d <> boundingRect (frame f d) # lineWidth (Output 0) # fc c + From 3a5ff43b812865b7a182a7010c5dfe33e6f5a087 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sat, 23 Aug 2014 16:05:17 +0100 Subject: [PATCH 25/58] Builds without vector-space. --- diagrams-lib.cabal | 3 - src/Diagrams/Backend/CmdLine.hs | 46 +++++------ src/Diagrams/Prelude/ThreeD.hs | 9 +- src/Diagrams/TwoD/Adjust.hs | 36 ++++---- src/Diagrams/TwoD/Image.hs | 35 ++++---- src/Diagrams/TwoD/Model.hs | 31 +++---- src/Diagrams/TwoD/Offset.hs | 142 ++++++++++++++++---------------- src/Diagrams/TwoD/Size.hs | 2 +- src/Diagrams/TwoD/Text.hs | 62 +++++++------- 9 files changed, 191 insertions(+), 175 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 205c632f..deff4384 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -98,9 +98,6 @@ Library dual-tree >= 0.2 && < 0.3, diagrams-core >= 1.2 && < 1.3, active >= 0.1 && < 0.2, - vector-space >= 0.7.7 && < 0.9, - vector-space-points >= 0.1.2 && < 0.3, - MemoTrie >= 0.6 && < 0.7, colour >= 2.3.2 && < 2.4, data-default-class < 0.1, fingertree >= 0.1 && < 0.2, diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index 66d392ef..94c8990b 100644 --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -88,7 +88,6 @@ import Data.Colour import Data.Colour.Names import Data.Colour.SRGB import Data.Data -import Data.List (intercalate) import Data.Monoid import Numeric @@ -339,30 +338,30 @@ class ToResult d where -- | A diagram can always produce a diagram when given @()@ as an argument. -- This is our base case. -instance ToResult (Diagram b v) where - type Args (Diagram b v) = () - type ResultOf (Diagram b v) = Diagram b v +instance ToResult (Diagram b v n) where + type Args (Diagram b v n) = () + type ResultOf (Diagram b v n) = Diagram b v n toResult d _ = d -- | A list of diagrams can produce pages. -instance ToResult [Diagram b v] where - type Args [Diagram b v] = () - type ResultOf [Diagram b v] = [Diagram b v] +instance ToResult [Diagram b v n] where + type Args [Diagram b v n] = () + type ResultOf [Diagram b v n] = [Diagram b v n] toResult ds _ = ds -- | A list of named diagrams can give the multi-diagram interface. -instance ToResult [(String,Diagram b v)] where - type Args [(String,Diagram b v)] = () - type ResultOf [(String,Diagram b v)] = [(String,Diagram b v)] +instance ToResult [(String, Diagram b v n)] where + type Args [(String,Diagram b v n)] = () + type ResultOf [(String,Diagram b v n)] = [(String,Diagram b v n)] toResult ds _ = ds -- | An animation is another suitable base case. -instance ToResult (Animation b v) where - type Args (Animation b v) = () - type ResultOf (Animation b v) = Animation b v +instance ToResult (Animation b v n) where + type Args (Animation b v n) = () + type ResultOf (Animation b v n) = Animation b v n toResult a _ = a @@ -468,11 +467,11 @@ instance Mainable d => Mainable (IO d) where -- specifying the name of the diagram that should be rendered. The list of -- available diagrams may also be printed by passing the option @--list@. -- --- Typically a backend can write its @[(String,Diagram B V)]@ instance as +-- Typically a backend can write its @[(String,Diagram b v n)]@ instance as -- -- @ --- instance Mainable [(String,Diagram B V)] where --- type MainOpts [(String,Diagram B V)] = (DiagramOpts, DiagramMultiOpts) +-- instance Mainable [(String,Diagram b v n)] where +-- type MainOpts [(String,Diagram b v n)] = (DiagramOpts, DiagramMultiOpts) -- mainRender = defaultMultiMainRender -- @ -- @@ -492,7 +491,7 @@ defaultMultiMainRender (opts,multi) ds = showDiaList :: [String] -> IO () showDiaList ds = do putStrLn "Available diagrams:" - putStrLn $ " " ++ intercalate " " ds + putStrLn $ " " ++ unwords ds -- | @defaultAnimMainRender@ is an implementation of 'mainRender' which renders -- an animation as numbered frames, named by extending the given output file @@ -510,7 +509,7 @@ showDiaList ds = do -- be output for each second (unit time) of animation. -- -- This function requires a lens into the structure that the particular backend --- uses for it's diagram base case. If @MainOpts (Diagram b v) ~ DiagramOpts@ +-- uses for it's diagram base case. If @MainOpts (Diagram b v n) ~ DiagramOpts@ -- then this lens will simply be 'output'. For a backend supporting looping -- it will most likely be @_1 . output@. This lens is required because the -- implementation works by modifying the output field and running the base @mainRender@. @@ -524,10 +523,10 @@ showDiaList ds = do -- -- We do not provide this instance in general so that backends can choose to -- opt-in to this form or provide a different instance that makes more sense. -defaultAnimMainRender :: (Mainable (Diagram b v)) - => (Lens' (MainOpts (Diagram b v)) FilePath) -- ^ A lens into the output path. - -> (MainOpts (Diagram b v),DiagramAnimOpts) - -> Animation b v +defaultAnimMainRender :: (Mainable (Diagram b v n)) + => Lens' (MainOpts (Diagram b v n)) FilePath -- ^ A lens into the output path. + -> (MainOpts (Diagram b v n) ,DiagramAnimOpts) + -> Animation b v n -> IO () defaultAnimMainRender out (opts,animOpts) anim = do let frames = simulate (toRational $ animOpts^.fpu) anim @@ -537,8 +536,9 @@ defaultAnimMainRender out (opts,animOpts) anim = do -- | @indexize d n@ adds the integer index @n@ to the end of the -- output file name, padding with zeros if necessary so that it uses -- at least @d@ digits. -indexize :: Lens' s FilePath -> Int -> Integer -> s -> s +indexize :: Lens' s FilePath -> Int -> Integer -> s -> s indexize out nDigits i opts = opts & out .~ output' where fmt = "%0" ++ show nDigits ++ "d" output' = addExtension (base ++ printf fmt (i::Integer)) ext (base, ext) = splitExtension (opts^.out) + diff --git a/src/Diagrams/Prelude/ThreeD.hs b/src/Diagrams/Prelude/ThreeD.hs index eca9416d..fdac6c85 100644 --- a/src/Diagrams/Prelude/ThreeD.hs +++ b/src/Diagrams/Prelude/ThreeD.hs @@ -112,9 +112,9 @@ module Diagrams.Prelude.ThreeD -- Data.Semigroup and Data.Monoid often come in handy. , module Data.Semigroup -- | For computing with vectors. - , module Data.VectorSpace + , module Linear.Vector -- | For computing with points and vectors. - , module Data.AffineSpace + , module Linear.Affine -- | For working with 'Active' (i.e. animated) things. , module Data.Active @@ -156,8 +156,9 @@ import Diagrams.Util import Control.Applicative import Control.Lens ((%~), (&), (.~)) import Data.Active -import Data.AffineSpace import Data.Colour hiding (AffineSpace (..), atop, over) import Data.Colour.Names hiding (tan) import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) + +import Linear.Affine +import Linear.Vector hiding (unit) diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs index 0470484e..ba84fa52 100644 --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -27,14 +27,18 @@ import Diagrams.Core import Diagrams.TwoD.Attributes (lineTextureA, lineWidthA) import Diagrams.TwoD.Size (SizeSpec2D (..), center2D, requiredScale, size2D) import Diagrams.TwoD.Text (fontSizeA) -import Diagrams.TwoD.Types (R2Ish, R2D, p2) +import Diagrams.TwoD.Types import Diagrams.Util (( # )) -import Control.Lens (Lens', (&), (.~), (^.)) -import Data.AffineSpace ((.-.)) +import Control.Lens (Lens', (&), (.~), (^.), over, both) import Data.Default.Class import Data.Semigroup -import Data.VectorSpace (Scalar) + +import Data.Data +import Linear.Affine +import Linear.Epsilon + +type TypeableFloat n = (Data n, Typeable n, RealFloat n, Epsilon n) -- | Set default attributes of a 2D diagram (in case they have not -- been set): @@ -50,7 +54,7 @@ import Data.VectorSpace (Scalar) -- * line join miter -- -- * Miter limit 10 -setDefault2DAttributes :: (Semigroup m, R2D v) => QDiagram b v m -> QDiagram b v m +setDefault2DAttributes :: (TypeableFloat n, Semigroup m) => QDiagram b V2 n m -> QDiagram b V2 n m setDefault2DAttributes d = d # lineWidthA def # lineTextureA def # fontSizeA def # lineCap def # lineJoin def # lineMiterLimitA def @@ -62,14 +66,14 @@ setDefault2DAttributes d = d # lineWidthA def # lineTextureA def # fontSizeA def -- inverse of which can be used, say, to translate output/device -- coordinates back into local diagram coordinates), and the -- modified diagram itself. -adjustDiaSize2D :: (Monoid' m, R2Ish v) - => Lens' (Options b v) (SizeSpec2D (Scalar v)) - -> b -> Options b v -> QDiagram b v m - -> (Options b v, Transformation v, QDiagram b v m) +adjustDiaSize2D :: (TypeableFloat n, Monoid' m) + => Lens' (Options b V2 n) (SizeSpec2D n) + -> b -> Options b V2 n -> QDiagram b V2 n m + -> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m) adjustDiaSize2D szL _ opts d = ( case spec of - Dims _ _ -> opts - _ -> opts & szL .~ (uncurry Dims . scale s $ size) + Dims _ _ -> opts + _ -> opts & szL .~ (uncurry Dims . over both (*s) $ size) , adjustT , d # transform adjustT ) @@ -78,7 +82,7 @@ adjustDiaSize2D szL _ opts d = s = requiredScale spec size finalSz = case spec of Dims w h -> (w,h) - _ -> scale s size + _ -> over both (*s) size tr = (0.5 *. p2 finalSz) .-. (s *. center2D d) adjustT = translation tr <> scaling s @@ -99,10 +103,10 @@ adjustDiaSize2D szL _ opts d = -- to the diagram (the inverse of which can be used, say, to -- translate output/device coordinates back into local diagram -- coordinates), and the modified diagram itself. -adjustDia2D :: (Monoid' m, R2D v) - => Lens' (Options b v) (SizeSpec2D (Scalar v)) - -> b -> Options b v -> QDiagram b v m - -> (Options b v, Transformation v, QDiagram b v m) +adjustDia2D :: (TypeableFloat n, Monoid' m) + => Lens' (Options b V2 n) (SizeSpec2D n) + -> b -> Options b V2 n -> QDiagram b V2 n m + -> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m) adjustDia2D szL b opts d = adjustDiaSize2D szL b opts (d # setDefault2DAttributes) diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs index fe98386c..7f51a9fa 100644 --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -44,11 +44,12 @@ import Diagrams.Core import Diagrams.Attributes (colorToSRGBA) import Diagrams.TwoD.Path (isInsideEvenOdd) import Diagrams.TwoD.Shapes (rect) -import Diagrams.TwoD.Types (R2Ish) +import Diagrams.TwoD.Types -import Data.AffineSpace ((.-.)) import Data.Semigroup +import Linear.Affine + data Embedded deriving Typeable data External deriving Typeable data Native (t :: *) deriving Typeable @@ -58,7 +59,7 @@ data Native (t :: *) deriving Typeable -- external libraries to hook into. data ImageData :: * -> * where ImageRaster :: DynamicImage -> ImageData Embedded - ImageRef :: FilePath -> ImageData External + ImageRef :: FilePath -> ImageData External ImageNative :: t -> ImageData (Native t) ------------------------------------------------------------------------------- @@ -67,20 +68,22 @@ data ImageData :: * -> * where -- will handle setting the width and heigh to the actual width and height -- of the image. data DImage :: * -> * -> * where - DImage :: ImageData t -> Int -> Int -> Transformation v -> DImage v t + DImage :: ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t deriving Typeable -type instance V (DImage v a) = v +type instance V (DImage n a) = V2 +type instance N (DImage n a) = n -instance (R2Ish v) => Transformable (DImage v a) where +instance Fractional n => Transformable (DImage n a) where transform t1 (DImage iD w h t2) = DImage iD w h (t1 <> t2) -instance (R2Ish v) => HasOrigin (DImage v a) where +instance Fractional n => HasOrigin (DImage n a) where moveOriginTo p = translate (origin .-. p) -- | Make a 'DImage' into a 'Diagram'. -image :: (Typeable a, Renderable (DImage v a) b, R2Ish v) => DImage v a -> Diagram b v -image img = mkQD (Prim (img)) (getEnvelope r) (getTrace r) mempty +image :: (OrderedField n, RealFloat n, Typeable a, Renderable (DImage n a) b, Typeable n) + => DImage n a -> Diagram b V2 n +image img = mkQD (Prim img) (getEnvelope r) (getTrace r) mempty (Query $ \p -> Any (isInsideEvenOdd p r)) where -- r :: Path v @@ -89,7 +92,7 @@ image img = mkQD (Prim (img)) (getEnvelope r) (getTrace r) mempty -- | Use JuicyPixels to read an image in any format and wrap it in a 'DImage'. -- The width and height of the image are set to their actual values. -loadImageEmb :: (R2Ish v) => FilePath -> IO (Either String (DImage v Embedded)) +loadImageEmb :: (Num n) => FilePath -> IO (Either String (DImage n Embedded)) loadImageEmb path = do dImg <- readImage path return $ case dImg of @@ -102,7 +105,7 @@ loadImageEmb path = do -- | Check that a file exists, and use JuicyPixels to figure out -- the right size, but save a reference to the image instead -- of the raster data -loadImageExt :: (R2Ish v) => FilePath -> IO (Either String (DImage v External)) +loadImageExt :: Num n => FilePath -> IO (Either String (DImage n External)) loadImageExt path = do dImg <- readImage path return $ case dImg of @@ -115,16 +118,16 @@ loadImageExt path = do -- | Make an "unchecked" image reference; have to specify a -- width and height. Unless the aspect ratio of the external -- image is the w :: h, then the image will be distorted. -uncheckedImageRef :: (R2Ish v) => FilePath -> Int -> Int -> DImage v External +uncheckedImageRef :: Num n => FilePath -> Int -> Int -> DImage n External uncheckedImageRef path w h = DImage (ImageRef path) w h mempty -- | Crate a diagram from raw raster data. -rasterDia :: (Renderable (DImage v Embedded) b, R2Ish v) - => (Int -> Int -> AlphaColour Double) -> Int -> Int -> Diagram b v +rasterDia :: (OrderedField n, Typeable n, RealFloat n, Renderable (DImage n Embedded) b) + => (Int -> Int -> AlphaColour Double) -> Int -> Int -> Diagram b V2 n rasterDia f w h = image $ raster f w h -- | Create an image "from scratch" by specifying the pixel data -raster :: (R2Ish v) => (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage v Embedded +raster :: Num n => (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage n Embedded raster f w h = DImage (ImageRaster (ImageRGBA8 img)) w h mempty where img = generateImage g w h @@ -137,5 +140,5 @@ fromAlphaColour c = PixelRGBA8 r g b a (r', g', b', a') = colorToSRGBA c int x = round (255 * x) -instance (R2Ish v) => Renderable (DImage v a) NullBackend where +instance Fractional n => (Renderable (DImage n a) NullBackend) where render _ _ = mempty diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs index 67c6b318..5438ed4e 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -35,53 +35,56 @@ import Diagrams.TwoD.Types import Diagrams.Util import Control.Arrow (second) -import Data.AffineSpace ((.-.)) import Data.Default.Class import Data.Semigroup -import Data.VectorSpace (Scalar, (^*)) import qualified Data.Map as M import Data.Colour (Colour) import Data.Colour.Names +import Linear.Affine +import Linear.Vector +import Data.Data + ------------------------------------------------------------ -- Marking the origin ------------------------------------------------------------ -data OriginOpts d = OriginOpts { _oColor :: Colour Double - , _oScale :: d - , _oMinSize :: d - } +data OriginOpts n = OriginOpts + { _oColor :: Colour Double + , _oScale :: n + , _oMinSize :: n + } makeLenses ''OriginOpts -instance (Fractional d) => Default (OriginOpts d) where +instance Fractional n => Default (OriginOpts n) where def = OriginOpts red (1/50) 0.001 -- | Mark the origin of a diagram by placing a red dot 1/50th its size. -showOrigin :: (Renderable (Path v) b, R2D v, Backend b v, Monoid' m) - => QDiagram b v m -> QDiagram b v m +showOrigin :: (RealFloat n, OrderedField n, Renderable (Path V2 n) b, Data n, Monoid' m) + => QDiagram b V2 n m -> QDiagram b V2 n m showOrigin = showOrigin' def -- | Mark the origin of a diagram, with control over colour and scale -- of marker dot. -showOrigin' :: (Renderable (Path v) b, R2D v, Backend b v, Monoid' m) - => OriginOpts (Scalar v) -> QDiagram b v m -> QDiagram b v m +showOrigin' :: (RealFloat n, OrderedField n, Renderable (Path V2 n) b, Data n, Monoid' m) + => OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m showOrigin' oo d = o <> d where o = stroke (circle sz) # fc (oo^.oColor) # lineWidth (Output 0) # fmap (const mempty) (w,h) = size2D d ^* oo^.oScale - sz = maximum [w, h, oo^.oMinSize] + sz = maximum [w, h, oo^.oMinSize] ------------------------------------------------------------ -- Labeling named points ------------------------------------------------------------ -showLabels :: (Renderable (Text v) b, R2Ish v, Backend b v, Semigroup m) - => QDiagram b v m -> QDiagram b v Any +showLabels :: (Typeable n, OrderedField n, Renderable (Text n) b, Semigroup m) + => QDiagram b V2 n m -> QDiagram b V2 n Any showLabels d = ( mconcat . map (\(n,p) -> text (show n) # translate (p .-. origin)) diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index 30597a99..0813f5a4 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -44,11 +44,9 @@ module Diagrams.TwoD.Offset import Control.Applicative import Control.Lens hiding (at) -import Data.AffineSpace import Data.Maybe (catMaybes) import Data.Monoid import Data.Monoid.Inf -import Data.VectorSpace import Data.Default.Class @@ -69,14 +67,18 @@ import Diagrams.TwoD.Path () import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (perp) -unitPerp :: (R2Ish v) => v -> v -unitPerp = normalized . perp +import Linear.Metric +import Linear.Affine +import Linear.Vector -perpAtParam :: (R2Ish v) => Segment Closed v -> Scalar v -> v -perpAtParam (Linear (OffsetClosed a)) _ = negateV $ unitPerp a -perpAtParam s@(Cubic _ _ _) t = negateV $ unitPerp a +unitPerp :: OrderedField n => V2 n -> V2 n +unitPerp = signorm . perp + +perpAtParam :: OrderedField n => Segment Closed V2 n -> n -> V2 n +perpAtParam (Linear (OffsetClosed a)) _ = negated $ unitPerp a +perpAtParam cubic t = negated $ unitPerp a where - (Cubic a _ _) = snd $ splitAtParam s t + (Cubic a _ _) = snd $ splitAtParam cubic t -- | Compute the offset of a segment. Given a segment compute the offset -- curve that is a fixed distance from the original curve. For linear @@ -162,8 +164,8 @@ expandEpsilon :: Lens' (ExpandOpts d) d instance (Fractional d) => Default (ExpandOpts d) where def = ExpandOpts def 10 def 0.01 -offsetSegment :: (R2Ish v) - => Scalar v -- ^ Epsilon factor that when multiplied to the +offsetSegment :: (OrderedField n, RealFloat n) + => n -- ^ Epsilon factor that when multiplied to the -- absolute value of the radius gives a -- value that represents the maximum -- allowed deviation from the true offset. In @@ -171,11 +173,11 @@ offsetSegment :: (R2Ish v) -- should be bounded by arcs that are plus or -- minus epsilon factor from the radius of curvature of -- the offset. - -> Scalar v -- ^ Offset from the original segment, positive is + -> n -- ^ Offset from the original segment, positive is -- on the right of the curve, negative is on the -- left. - -> Segment Closed v -- ^ Original segment - -> Located (Trail v) -- ^ Resulting located (at the offset) trail. + -> Segment Closed V2 n -- ^ Original segment + -> Located (Trail V2 n) -- ^ Resulting located (at the offset) trail. offsetSegment _ r s@(Linear (OffsetClosed a)) = trailFromSegments [s] `at` origin .+^ va where va = (-r) *^ unitPerp a @@ -208,7 +210,7 @@ offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va Infinity -> 1 -- Do the right thing. Finite sr -> 1 + r / sr - close = and [epsilon * abs r > (magnitude (p o ^+^ va ^-^ p s ^-^ pp s)) + close = and [epsilon * abs r > norm (p o ^+^ va ^-^ p s ^-^ pp s) | t' <- [0.25, 0.5, 0.75] , let p = (`atParam` t') , let pp = (r *^) . (`perpAtParam` t') @@ -217,7 +219,7 @@ offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va -- > import Diagrams.TwoD.Offset -- > --- > showExample :: (R2Ish v) => Segment Closed v -> Diagram SVG v +-- > showExample :: (OrderedField n) => Segment Closed v -> Diagram SVG v -- > showExample s = pad 1.1 . centerXY $ d # lc blue # lw thick <> d' # lw thick -- > where -- > d = stroke . fromSegments $ [s] @@ -226,7 +228,7 @@ offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va -- > -- > colors = cycle [green, red] -- > --- > cubicOffsetExample :: (R2Ish v) => Diagram SVG v +-- > cubicOffsetExample :: (OrderedField n) => Diagram SVG v -- > cubicOffsetExample = hcat . map showExample $ -- > [ bezier3 (10 ^& 0) ( 5 ^& 18) (10 ^& 20) -- > , bezier3 ( 0 ^& 20) ( 10 ^& 10) ( 5 ^& 10) @@ -239,15 +241,15 @@ offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va -- collapse the Located into the result. This assumes that Located has the -- meaning of merely taking something that cannot be translated and lifting -- it into a space with translation. -bindLoc :: (Transformable b, V a ~ V b) => (a -> b) -> Located a -> b +bindLoc :: (Transformable b, Vn a ~ Vn b, Vn a ~ V2 n, Num n) => (a -> b) -> Located a -> b bindLoc f = join' . mapLoc f where join' (viewLoc -> (p,a)) = translate (p .-. origin) a -- While we build offsets and expansions we will use the [Located (Segment Closed v)] --- and [Located (Trail v)] intermediate representations. -locatedTrailSegments :: (R2Ish v, InnerSpace v, OrderedField (Scalar v)) - => Located (Trail v) -> [Located (Segment Closed v)] +-- and [Located (Trail V2 n)] intermediate representations. +locatedTrailSegments :: OrderedField n + => Located (Trail V2 n) -> [Located (Segment Closed V2 n)] locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints t) -- | Offset a 'Trail' with options and by a given radius. This generates a new @@ -268,13 +270,13 @@ locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints t) -- -- <> -- -offsetTrail' :: (R2Ish v) - => OffsetOpts (Scalar v) - -> Scalar v -- ^ Radius of offset. A negative value gives an offset on +offsetTrail' :: (OrderedField n, RealFloat n) + => OffsetOpts n + -> n -- ^ Radius of offset. A negative value gives an offset on -- the left for a line and on the inside for a counter-clockwise -- loop. - -> Located (Trail v) - -> Located (Trail v) + -> Located (Trail V2 n) + -> Located (Trail V2 n) offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r ends . offset $ t where eps = opts^.offsetEpsilon @@ -286,17 +288,17 @@ offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r end isLoop = withTrail (const False) (const True) (unLoc t) -- | Offset a 'Trail' with the default options and a given radius. See 'offsetTrail''. -offsetTrail :: (R2Ish v) => Scalar v -> Located (Trail v) -> Located (Trail v) +offsetTrail :: (OrderedField n, RealFloat n) => n -> Located (Trail V2 n) -> Located (Trail V2 n) offsetTrail = offsetTrail' def -- | Offset a 'Path' by applying 'offsetTrail'' to each trail in the path. -offsetPath' :: (R2Ish v) => OffsetOpts (Scalar v) -> Scalar v -> Path v -> Path v +offsetPath' :: (OrderedField n, RealFloat n) => OffsetOpts n -> n -> Path V2 n -> Path V2 n offsetPath' opts r = mconcat . map (bindLoc (trailLike . offsetTrail' opts r) . (`at` origin)) . op Path -- | Offset a 'Path' with the default options and given radius. See 'offsetPath''. -offsetPath :: (R2Ish v) => Scalar v -> Path v -> Path v +offsetPath :: (OrderedField n, RealFloat n) => n -> Path V2 n -> Path V2 n offsetPath = offsetPath' def -- TODO: Include arrowheads on examples to indicate direction so the "left" and @@ -305,10 +307,10 @@ offsetPath = offsetPath' def -- > import Diagrams.TwoD.Offset -- > import Data.Default.Class -- > --- > corner :: (R2Ish v) => Located (Trail v) +-- > corner :: (OrderedField n) => Located (Trail V2 n) -- > corner = fromVertices (map p2 [(0, 0), (10, 0), (5, 6)]) `at` origin -- > --- > offsetTrailExample :: (R2Ish v) => Diagram SVG v +-- > offsetTrailExample :: (OrderedField n) => Diagram SVG v -- > offsetTrailExample = pad 1.1 . centerXY . lwO 3 . hcat' (def & sep .~ 1 ) -- > . map (uncurry showStyle) -- > $ [ (LineJoinMiter, "LineJoinMiter") @@ -320,7 +322,7 @@ offsetPath = offsetPath' def -- > <> trailLike (offsetTrail' (def & offsetJoin .~ j) 2 corner) # lc green) -- > === (strutY 3 <> text s # font "Helvetica" # bold) -- > --- > offsetTrailLeftExample :: (R2Ish v) => Diagram SVG v +-- > offsetTrailLeftExample :: (OrderedField n) => Diagram SVG v -- > offsetTrailLeftExample = pad 1.1 . centerXY . lwO 3 -- > $ (trailLike c # lc blue) -- > <> (lc green . trailLike @@ -328,7 +330,7 @@ offsetPath = offsetPath' def -- > where -- > c = reflectY corner -- > --- > offsetTrailOuterExample :: (R2Ish v) => Diagram SVG v +-- > offsetTrailOuterExample :: (OrderedField n) => Diagram SVG v -- > offsetTrailOuterExample = pad 1.1 . centerXY . lwO 3 -- > $ (trailLike c # lc blue) -- > <> (lc green . trailLike @@ -336,7 +338,7 @@ offsetPath = offsetPath' def -- > where -- > c = hexagon 5 -withTrailL :: (R2Ish v) => (Located (Trail' Line v) -> r) -> (Located (Trail' Loop v) -> r) -> Located (Trail v) -> r +withTrailL :: (OrderedField n) => (Located (Trail' Line V2 n) -> r) -> (Located (Trail' Loop V2 n) -> r) -> Located (Trail V2 n) -> r withTrailL f g l = withTrail (f . (`at` p)) (g . (`at` p)) (unLoc l) where p = loc l @@ -354,20 +356,20 @@ withTrailL f g l = withTrail (f . (`at` p)) (g . (`at` p)) (unLoc l) -- -- <> -- -expandTrail' :: (R2Ish v) - => ExpandOpts (Scalar v) - -> Scalar v -- ^ Radius of offset. Only non-negative values allowed. +expandTrail' :: (OrderedField n, RealFloat n, RealFrac n) + => ExpandOpts n + -> n -- ^ Radius of offset. Only non-negative values allowed. -- For a line this gives a loop of the offset. For a -- loop this gives two loops, the outer counter-clockwise -- and the inner clockwise. - -> Located (Trail v) - -> Path v + -> Located (Trail V2 n) + -> Path V2 n expandTrail' o r t | r < 0 = error "expandTrail' with negative radius" -- TODO: consider just reversing the path instead of this error. | otherwise = withTrailL (pathFromLocTrail . expandLine o r) (expandLoop o r) t -expandLine :: (R2Ish v) => ExpandOpts (Scalar v) -> Scalar v -> Located (Trail' Line v) -> Located (Trail v) +expandLine :: (OrderedField n, RealFloat n) => ExpandOpts n -> n -> Located (Trail' Line V2 n) -> Located (Trail V2 n) expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) where eps = opts^.expandEpsilon @@ -379,8 +381,8 @@ expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) e = atEnd t cap = fromLineCap (opts^.expandCap) -expandLoop :: (R2Ish v) => ExpandOpts (Scalar v) -> Scalar v -> Located (Trail' Loop v) -> Path v -expandLoop opts r (mapLoc wrapLoop -> t) = (trailLike $ f r) <> (trailLike . reverseDomain . f $ -r) +expandLoop :: (OrderedField n, RealFloat n) => ExpandOpts n -> n -> Located (Trail' Loop V2 n) -> Path V2 n +expandLoop opts r (mapLoc wrapLoop -> t) = trailLike (f r) <> (trailLike . reverseDomain . f $ -r) where eps = opts^.expandEpsilon offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments @@ -389,23 +391,23 @@ expandLoop opts r (mapLoc wrapLoop -> t) = (trailLike $ f r) <> (trailLike . rev ends = (\(a:as) -> as ++ [a]) . trailVertices $ t -- | Expand a 'Trail' with the given radius and default options. See 'expandTrail''. -expandTrail :: (R2Ish v) => Scalar v -> Located (Trail v) -> Path v +expandTrail :: (OrderedField n, RealFloat n) => n -> Located (Trail V2 n) -> Path V2 n expandTrail = expandTrail' def -- | Expand a 'Path' using 'expandTrail'' on each trail in the path. -expandPath' :: (R2Ish v) => ExpandOpts (Scalar v) -> Scalar v -> Path v -> Path v +expandPath' :: (OrderedField n, RealFloat n) => ExpandOpts n -> n -> Path V2 n -> Path V2 n expandPath' opts r = mconcat . map (bindLoc (expandTrail' opts r) . (`at` origin)) . op Path -- | Expand a 'Path' with the given radius and default options. See 'expandPath''. -expandPath :: (R2Ish v) => Scalar v -> Path v -> Path v +expandPath :: (OrderedField n, RealFloat n) => n -> Path V2 n -> Path V2 n expandPath = expandPath' def -- > import Diagrams.TwoD.Offset -- > import Data.Default.Class -- > --- > expandTrailExample :: (R2Ish v) => Diagram SVG v +-- > expandTrailExample :: (OrderedField n) => Diagram SVG v -- > expandTrailExample = pad 1.1 . centerXY . hcat' (def & sep .~ 1) -- > . map (uncurry showStyle) -- > $ [ (LineCapButt, "LineCapButt") @@ -421,7 +423,7 @@ expandPath = expandPath' def -- > # lw none # fc green) -- > === (strutY 3 <> text s # font "Helvetica" # bold) -- > --- > expandLoopExample :: (R2Ish v) => Diagram SVG v +-- > expandLoopExample :: (OrderedField n) => Diagram SVG v -- > expandLoopExample = pad 1.1 . centerXY $ ((strokeLocT t # lw veryThick # lc white) -- > <> (stroke t' # lw none # fc green)) -- > where @@ -438,8 +440,8 @@ expandPath = expandPath' def -- caps takes the radius and the start and end points of the original line and -- the offset trails going out and coming back. The result is a new list of -- trails with the caps included. -caps :: (R2Ish v) => (Scalar v -> Point v -> Point v -> Point v -> Trail v) - -> Scalar v -> Point v -> Point v -> Located (Trail v) -> Located (Trail v) -> Located (Trail v) +caps :: (OrderedField n, RealFloat n) => (n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n) + -> n -> Point V2 n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Located (Trail V2 n) caps cap r s e fs bs = mapLoc glueTrail $ mconcat [ cap r s (atStart bs) (atStart fs) , unLoc fs @@ -448,25 +450,25 @@ caps cap r s e fs bs = mapLoc glueTrail $ mconcat ] `at` atStart bs -- | Take a LineCap style and give a function for building the cap from -fromLineCap :: (R2Ish v) => LineCap -> Scalar v -> Point v -> Point v -> Point v -> Trail v +fromLineCap :: (OrderedField n, RealFloat n) => LineCap -> n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n fromLineCap c = case c of LineCapButt -> capCut LineCapRound -> capArc LineCapSquare -> capSquare -- | Builds a cap that directly connects the ends. -capCut :: (R2Ish v) => Scalar v -> Point v -> Point v -> Point v -> Trail v +capCut :: (OrderedField n, RealFloat n) => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n capCut _r _c a b = fromSegments [straight (b .-. a)] -- | Builds a cap with a square centered on the end. -capSquare :: (R2Ish v) => Scalar v -> Point v -> Point v -> Point v -> Trail v +capSquare :: (OrderedField n, RealFloat n) => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n capSquare _r c a b = unLoc $ fromVertices [ a, a .+^ v, b .+^ v, b ] where v = perp (a .-. c) -- | Builds an arc to fit with a given radius, center, start, and end points. -- A Negative r means a counter-clockwise arc -capArc :: (R2Ish v) => Scalar v -> Point v -> Point v -> Point v -> Trail v +capArc :: (OrderedField n, RealFloat n) => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n capArc r c a b = trailLike . moveTo c $ fs where fs | r < 0 = scale (-r) $ arcVCW (a .-. c) (b .-. c) @@ -474,11 +476,11 @@ capArc r c a b = trailLike . moveTo c $ fs -- Arc helpers -- always picks the shorter arc (< τ/2) -arcV :: (R2Ish v, TrailLike t, V t ~ v) => v -> v -> t +arcV :: (OrderedField n, RealFloat n, TrailLike t, Vn t ~ V2 n) => V2 n -> V2 n -> t arcV u v = arc (direction u) (angleBetween v u) -arcVCW :: (R2Ish v, TrailLike t, V t ~ v) => v -> v -> t -arcVCW u v = arc (direction u) (negateV $ angleBetween v u) +arcVCW :: (OrderedField n, RealFloat n, TrailLike t, Vn t ~ V2 n) => V2 n -> V2 n -> t +arcVCW u v = arc (direction u) (negated $ angleBetween v u) -- | Join together a list of located trails with the given join style. The -- style is given as a function to compute the join given the local information @@ -488,15 +490,15 @@ arcVCW u v = arc (direction u) (negateV $ angleBetween v u) -- Note: this is not a general purpose join and assumes that we are joining an -- offset trail. For instance, a fixed radius arc will not fit between arbitrary -- trails without trimming or extending. -joinSegments :: (R2Ish v) - => Scalar v - -> (Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v) +joinSegments :: (OrderedField n, RealFloat n) + => n + -> (n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n) -> Bool - -> Scalar v - -> Scalar v - -> [Point v] - -> [Located (Trail v)] - -> Located (Trail v) + -> n + -> n + -> [Point V2 n] + -> [Located (Trail V2 n)] + -> Located (Trail V2 n) joinSegments _ _ _ _ _ _ [] = mempty `at` origin joinSegments _ _ _ _ _ [] _ = mempty `at` origin joinSegments epsilon j isLoop ml r es ts@(t:_) = t' @@ -511,7 +513,7 @@ joinSegments epsilon j isLoop ml r es ts@(t:_) = t' -- | Take a join style and give the join function to be used by joinSegments. fromLineJoin - :: (R2Ish v) => LineJoin -> Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v + :: (OrderedField n, RealFloat n) => LineJoin -> n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n fromLineJoin j = case j of LineJoinMiter -> joinSegmentIntersect LineJoinRound -> joinSegmentArc @@ -521,7 +523,7 @@ fromLineJoin j = case j of -- how useful it is graphically, I mostly had it as it was useful for debugging {- -- | Join with segments going back to the original corner. -joinSegmentCut :: (R2Ish v) => Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v +joinSegmentCut :: (OrderedField n) => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentCut _ _ e a b = fromSegments [ straight (e .-. atEnd a) , straight (atStart b .-. e) @@ -531,18 +533,18 @@ joinSegmentCut _ _ e a b = fromSegments -- | Join by directly connecting the end points. On an inside corner this -- creates negative space for even-odd fill. Here is where we would want to -- use an arc or something else in the future. -joinSegmentClip :: (R2Ish v) => Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v +joinSegmentClip :: (OrderedField n, RealFloat n) => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentClip _ _ _ a b = fromSegments [straight $ atStart b .-. atEnd a] -- | Join with a radius arc. On an inside corner this will loop around the interior -- of the offset trail. With a winding fill this will not be visible. -joinSegmentArc :: (R2Ish v) => Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v +joinSegmentArc :: (OrderedField n, RealFloat n) => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentArc _ r e a b = capArc r e (atEnd a) (atStart b) -- | Join to the intersection of the incoming trails projected tangent to their ends. -- If the intersection is beyond the miter limit times the radius, stop at the limit. joinSegmentIntersect - :: (R2Ish v) => Scalar v -> Scalar v -> Point v -> Located (Trail v) -> Located (Trail v) -> Trail v + :: (OrderedField n, RealFloat n) => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentIntersect miterLimit r e a b = if cross < 0.000001 then clip @@ -558,10 +560,10 @@ joinSegmentIntersect miterLimit r e a b = where t = straight (miter vb) `at` pb va = unitPerp (pa .-. e) - vb = negateV $ unitPerp (pb .-. e) + vb = negated $ unitPerp (pb .-. e) pa = atEnd a pb = atStart b - miter v = (abs (miterLimit * r)) *^ v + miter v = abs (miterLimit * r) *^ v clip = joinSegmentClip miterLimit r e a b cross = let (xa,ya) = unr2 va; (xb,yb) = unr2 vb in abs (xa * yb - xb * ya) diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index 9f4f4885..8a13bb2b 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -36,7 +36,7 @@ import Diagrams.Core import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -import Control.Applicative (liftA2, (<$>)) +import Control.Applicative import Control.Arrow ((&&&), (***)) import Data.Hashable (Hashable) import GHC.Generics (Generic) diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index d882ef17..5ab33247 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -40,12 +40,12 @@ import Diagrams.Core.Envelope (pointEnvelope) import Diagrams.TwoD.Attributes (recommendFillColor) import Diagrams.TwoD.Types -import Data.AffineSpace ((.-.)) import Data.Colour import Data.Data import Data.Default.Class import Data.Semigroup -import Data.VectorSpace + +import Linear.Affine ------------------------------------------------------------ -- Text diagrams @@ -57,12 +57,13 @@ import Data.VectorSpace -- text; the second accumulates normalized, "anti-scaled" versions -- of the transformations which have had their average scaling -- component removed. -data Text v = Text (Transformation v) (Transformation v) (TextAlignment (Scalar v)) String +data Text n = Text (Transformation V2 n) (Transformation V2 n) (TextAlignment n) String deriving Typeable -type instance V (Text v) = v +type instance V (Text n) = V2 +type instance N (Text n) = n -instance (R2Ish v) => Transformable (Text v) where +instance Floating n => Transformable (Text n) where transform t (Text tt tn a s) = Text (t <> tt) (t <> tn <> t') a s where t' = scaling (1 / avgScale t) @@ -70,16 +71,17 @@ instance (R2Ish v) => Transformable (Text v) where -- followed by the old transformation tn and then the new -- transformation t. That way translation is handled properly. -instance (R2Ish v) => HasOrigin (Text v) where +instance Floating n => HasOrigin (Text n) where moveOriginTo p = translate (origin .-. p) -instance (R2Ish v) => Renderable (Text v) NullBackend where +instance Floating n => Renderable (Text n) NullBackend where render _ _ = mempty -- | @TextAlignment@ specifies the alignment of the text's origin. data TextAlignment d = BaselineText | BoxAlignedText d d -mkText :: (R2Ish v, Renderable (Text v) b) => TextAlignment (Scalar v) -> String -> Diagram b v +mkText :: (OrderedField n, Typeable n, Renderable (Text n) b) + => TextAlignment n -> String -> Diagram b V2 n mkText a t = recommendFillColor (black :: Colour Double) -- See Note [recommendFillColor] @@ -116,7 +118,7 @@ mkText a t = recommendFillColor (black :: Colour Double) -- -- Note that it /takes up no space/, as text size information is not -- available. -text :: (R2Ish v, Renderable (Text v) b) => String -> Diagram b v +text :: (OrderedField n, Typeable n) => (Renderable (Text n) b) => String -> Diagram b V2 n text = alignedText 0.5 0.5 -- | Create a primitive text diagram from the given string, origin at @@ -124,7 +126,7 @@ text = alignedText 0.5 0.5 -- @'alignedText' 0 1@. -- -- Note that it /takes up no space/. -topLeftText :: (R2Ish v, Renderable (Text v) b) => String -> Diagram b v +topLeftText :: (OrderedField n, Typeable n) => (Renderable (Text n) b) => String -> Diagram b V2 n topLeftText = alignedText 0 1 -- | Create a primitive text diagram from the given string, with the @@ -136,7 +138,8 @@ topLeftText = alignedText 0 1 -- and descent, rather than the height of the particular string. -- -- Note that it /takes up no space/. -alignedText :: (R2Ish v, Renderable (Text v) b) => Scalar v -> Scalar v -> String -> Diagram b v +alignedText :: (OrderedField n, Typeable n, Renderable (Text n) b) + => n -> n -> String -> Diagram b V2 n alignedText w h = mkText (BoxAlignedText w h) -- | Create a primitive text diagram from the given string, with the @@ -145,7 +148,8 @@ alignedText w h = mkText (BoxAlignedText w h) -- graphics library. -- -- Note that it /takes up no space/. -baselineText :: (R2Ish v, Renderable (Text v) b) => String -> Diagram b v +baselineText :: (OrderedField n, Typeable n, Renderable (Text n) b) + => String -> Diagram b V2 n baselineText = mkText BaselineText ------------------------------------------------------------ @@ -174,19 +178,21 @@ font = applyAttr . Font . Last -- | The @FontSize@ attribute specifies the size of a font's -- em-square. Inner @FontSize@ attributes override outer ones. -newtype FontSize v = FontSize (Last (Measure v, Bool)) +newtype FontSize n = FontSize (Last (Measure n, Bool)) deriving (Typeable, Semigroup) -deriving instance (Data (Scalar v), Data v) => Data (FontSize v) -instance (Typeable v) => AttributeClass (FontSize v) + +deriving instance Data n => Data (FontSize n) +instance Typeable n => AttributeClass (FontSize n) -- Note, the Bool stored in the FontSize indicates whether it started -- life as Local. Typically, if the Bool is True, backends should use -- the first (Transformation v) value stored in a Text object; otherwise, the second -- (anti-scaled) (Transformation v) value should be used. -type instance V (FontSize v) = v +type instance V (FontSize n) = V2 +type instance N (FontSize n) = n -instance (R2Ish v) => Default (FontSize v) where +instance Num n => Default (FontSize n) where def = FontSize (Last (Local 1, True)) -- FontSize has to be Transformable + also have an instance of Data, @@ -194,43 +200,43 @@ instance (R2Ish v) => Default (FontSize v) where -- However, we don't actually want the Transformable instance to do -- anything. All the scaling of text happens not by manipulating the -- font size but by accumulating (Transformation v) values in Text objects. -instance (R2Ish v) => Transformable (FontSize v) where +instance Transformable (FontSize n) where transform _ f = f -- | Extract the size from a @FontSize@ attribute. -getFontSize :: FontSize v -> Measure v +getFontSize :: FontSize n -> Measure n getFontSize (FontSize (Last (s,_))) = s -- | Determine whether a @FontSize@ attribute began its life measured -- in 'Local' units. -getFontSizeIsLocal :: FontSize v -> Bool +getFontSizeIsLocal :: FontSize n -> Bool getFontSizeIsLocal (FontSize (Last (_,b))) = b -- | Set the font size, that is, the size of the font's em-square as -- measured within the current local vector space. The default size -- is @1@. -fontSize :: (R2D v, HasStyle a, V a ~ v) => Measure v -> a -> a +fontSize :: (Data n, HasStyle a, Vn a ~ V2 n) => Measure n -> a -> a fontSize m@(Local {}) = applyGTAttr . FontSize . Last $ (m,True) fontSize m = applyGTAttr . FontSize . Last $ (m,False) -- | A convenient synonym for 'fontSize (Global w)'. -fontSizeG :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a +fontSizeG :: (Data n, HasStyle a, Vn a ~ V2 n) => n -> a -> a fontSizeG w = fontSize (Global w) -- | A convenient synonym for 'fontSize (Normalized w)'. -fontSizeN :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a +fontSizeN :: (Data n, HasStyle a, Vn a ~ V2 n) => n -> a -> a fontSizeN w = fontSize (Normalized w) -- | A convenient synonym for 'fontSize (Output w)'. -fontSizeO :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a +fontSizeO :: (Data n, HasStyle a, Vn a ~ V2 n) => n -> a -> a fontSizeO w = fontSize (Output w) -- | A convenient sysnonym for 'fontSize (Local w)'. -fontSizeL :: (R2D v, HasStyle a, V a ~ v) => Scalar v -> a -> a +fontSizeL :: (Data n, HasStyle a, Vn a ~ V2 n) => n -> a -> a fontSizeL w = fontSize (Local w) -- | Apply a 'FontSize' attribute. -fontSizeA :: (R2D v, HasStyle a, V a ~ v) => FontSize v -> a -> a +fontSizeA :: (Data n, HasStyle a, Vn a ~ V2 n) => FontSize n -> a -> a fontSizeA = applyGTAttr -------------------------------------------------- @@ -239,7 +245,7 @@ fontSizeA = applyGTAttr data FontSlant = FontSlantNormal | FontSlantItalic | FontSlantOblique - deriving (Eq) + deriving (Eq, Show) -- | The @FontSlantA@ attribute specifies the slant (normal, italic, -- or oblique) that should be used for all text within a diagram. @@ -271,7 +277,7 @@ oblique = fontSlant FontSlantOblique data FontWeight = FontWeightNormal | FontWeightBold - deriving (Eq) + deriving (Eq, Show) -- | The @FontWeightA@ attribute specifies the weight (normal or bold) -- that should be used for all text within a diagram. Inner From e1894c67c1f0ae1e8ff7b9edd3ed1b14e077c69e Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sat, 23 Aug 2014 20:11:59 +0100 Subject: [PATCH 26/58] Update for new lenses. --- diagrams-lib.cabal | 2 +- src/Diagrams/Combinators.hs | 26 ++++-------- src/Diagrams/Parametric/Adjust.hs | 40 ++++++++---------- src/Diagrams/TwoD/Polygons.hs | 67 +++++++++++++++---------------- 4 files changed, 58 insertions(+), 77 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index deff4384..d797cd9a 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -102,7 +102,7 @@ Library data-default-class < 0.1, fingertree >= 0.1 && < 0.2, intervals >= 0.7 && < 0.8, - lens >= 4.0 && < 4.4, + lens >= 4.0 && < 4.5, tagged >= 0.7, optparse-applicative >= 0.7 && < 0.10, filepath, diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 490d9eb7..82263391 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -41,7 +41,7 @@ module Diagrams.Combinators import Data.Typeable -import Control.Lens (Lens', generateSignatures, lensField, lensRules, +import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, (%~), (&), (.~), (^.), _Wrapping) import Data.Default.Class import Data.Monoid.Deletable (toDeletable) @@ -288,9 +288,9 @@ data CatMethod = Cat -- ^ Normal catenation: simply put diagrams -- of separation, diagrams may overlap. -- | Options for 'cat''. -data CatOpts n = CatOpts { _catMethod :: CatMethod - , _sep :: n - , _catOptsvProxy__ :: Proxy n +data CatOpts n = CatOpts { _catMethod :: CatMethod + , _sep :: n + , catOptsvProxy :: Proxy n } -- The reason the proxy field is necessary is that without it, @@ -304,17 +304,7 @@ data CatOpts n = CatOpts { _catMethod :: CatMethod -- this is not a problem when using the 'sep' lens, as its type is -- more restricted. -makeLensesWith - ( lensRules - -- don't make a lens for the proxy field - & lensField .~ (\label -> - case label of - "_catOptsvProxy__" -> Nothing - _ -> Just (drop 1 label) - ) - & generateSignatures .~ False - ) - ''CatOpts +makeLensesWith (lensRules & generateSignatures .~ False) ''CatOpts -- | Which 'CatMethod' should be used: -- normal catenation (default), or distribution? @@ -327,9 +317,9 @@ catMethod :: forall n. Lens' (CatOpts n) CatMethod sep :: forall n. Lens' (CatOpts n) n instance Num n => Default (CatOpts n) where - def = CatOpts { _catMethod = Cat - , _sep = 0 - , _catOptsvProxy__ = Proxy + def = CatOpts { _catMethod = Cat + , _sep = 0 + , catOptsvProxy = Proxy } -- | @cat v@ positions a list of objects so that their local origins diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs index 599c6526..bf5a4ac8 100644 --- a/src/Diagrams/Parametric/Adjust.hs +++ b/src/Diagrams/Parametric/Adjust.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Parametric.Adjust @@ -21,14 +21,14 @@ module Diagrams.Parametric.Adjust ) where -import Control.Lens (Lens', generateSignatures, lensField, lensRules, - makeLensesWith, (&), (.~), (^.)) -import Data.Proxy +import Control.Lens (Lens', generateSignatures, lensRules, + makeLensesWith, (&), (.~), (^.)) +import Data.Proxy -import Data.Default.Class +import Data.Default.Class -import Diagrams.Core.V -import Diagrams.Parametric +import Diagrams.Core.V +import Diagrams.Parametric -- | What method should be used for adjusting a segment, trail, or -- path? @@ -46,23 +46,13 @@ data AdjustSide = Start -- ^ Adjust only the beginning deriving (Show, Read, Eq, Ord, Bounded, Enum) -- | How should a segment, trail, or path be adjusted? -data AdjustOpts v n = AO { _adjMethod :: AdjustMethod n - , _adjSide :: AdjustSide - , _adjEps :: n - , _adjOptsvProxy__ :: Proxy (v n) +data AdjustOpts v n = AO { _adjMethod :: AdjustMethod n + , _adjSide :: AdjustSide + , _adjEps :: n + , adjOptsvProxy :: Proxy (v n) } -makeLensesWith - ( lensRules - -- don't make a lens for the proxy field - & lensField .~ (\label -> - case label of - "_adjOptsvProxy__" -> Nothing - _ -> Just (drop 1 label) - ) - & generateSignatures .~ False - ) - ''AdjustOpts +makeLensesWith (lensRules & generateSignatures .~ False) ''AdjustOpts -- | Which method should be used for adjusting? adjMethod :: Lens' (AdjustOpts v n) (AdjustMethod n) @@ -80,7 +70,11 @@ instance Default AdjustSide where def = Both instance Fractional n => Default (AdjustOpts v n) where - def = AO def def stdTolerance Proxy + def = AO { _adjMethod = def + , _adjSide = def + , _adjEps = stdTolerance + , adjOptsvProxy = Proxy + } -- | Adjust the length of a parametric object such as a segment or -- trail. The second parameter is an option record which controls how diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index 8c979621..00b163ef 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -1,13 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -49,34 +46,34 @@ module Diagrams.TwoD.Polygons( ) where -import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, - view, (.~), (^.)) -import Control.Monad (forM, liftM) -import Control.Monad.ST (ST, runST) -import Data.Array.ST (STUArray, newArray, readArray, writeArray) -import Data.List (maximumBy, minimumBy) -import Data.Maybe (catMaybes) -import Data.Monoid (mconcat, mempty) -import Data.Ord (comparing) - -import Data.Default.Class - -import Diagrams.Angle -import Diagrams.Core -import Diagrams.Located -import Diagrams.Path -import Diagrams.Points (centroid) -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) -import Diagrams.Util (tau, ( # )) +import Control.Lens (Lens', generateSignatures, lensRules, + makeLensesWith, view, (.~), (^.)) +import Control.Monad (forM, liftM) +import Control.Monad.ST (ST, runST) +import Data.Array.ST (STUArray, newArray, readArray, writeArray) +import Data.List (maximumBy, minimumBy) +import Data.Maybe (catMaybes) +import Data.Monoid (mconcat, mempty) +import Data.Ord (comparing) + +import Data.Default.Class + +import Diagrams.Angle +import Diagrams.Core +import Diagrams.Located +import Diagrams.Path +import Diagrams.Points (centroid) +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) +import Diagrams.Util (tau, ( # )) import Linear.Affine -import Linear.Vector -import Linear.Metric import Linear.Epsilon +import Linear.Metric +import Linear.Vector -- | Method used to determine the vertices of a polygon. data PolyType n = PolyPolar [Angle n] [n] From f237e033fbeb936e91fb3cd5ba02eb55d48f039f Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 24 Aug 2014 00:09:16 +0100 Subject: [PATCH 27/58] Coordinate instances for linear types. --- diagrams-lib.cabal | 3 ++- src/Diagrams/Coordinates.hs | 39 +++++++++++++++++++++++++++++++------ src/Diagrams/Points.hs | 2 +- 3 files changed, 36 insertions(+), 8 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index d797cd9a..7f4e2b72 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -25,7 +25,8 @@ Source-repository head location: http://github.com/diagrams/diagrams-lib.git Library - Exposed-modules: Diagrams.Prelude.ThreeD, + Exposed-modules: Diagrams.Prelude, + Diagrams.Prelude.ThreeD, Diagrams.Align, Diagrams.Angle, Diagrams.Combinators, diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index 56ef6308..6340762a 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -23,7 +23,8 @@ module Diagrams.Coordinates import Control.Lens (Lens') import Diagrams.Points -import Linear.Affine + +import Linear (V2 (..), V3 (..), V4 (..)) -- | Types which are instances of the @Coordinates@ class can be -- constructed using '^&' (for example, a three-dimensional vector @@ -53,7 +54,7 @@ class Coordinates c where -- -- @ -- 2 ^& 3 :: P2 - -- 3 ^& 5 ^& 6 :: R3 + -- 3 ^& 5 ^& 6 :: V3 -- @ -- -- Note that @^&@ is left-associative. @@ -119,6 +120,32 @@ instance Coordinates (v n) => Coordinates (Point v n) where x ^& y = P (x ^& y) coords (P v) = coords v +-- instances for linear + +instance Coordinates (V2 n) where + type FinalCoord (V2 n) = n + type PrevDim (V2 n) = n + type Decomposition (V2 n) = n :& n + + x ^& y = V2 x y + coords (V2 x y) = x :& y + +instance Coordinates (V3 n) where + type FinalCoord (V3 n) = n + type PrevDim (V3 n) = V2 n + type Decomposition (V3 n) = n :& n :& n + + V2 x y ^& z = V3 x y z + coords (V3 x y z) = x :& y :& z + +instance Coordinates (V4 n) where + type FinalCoord (V4 n) = n + type PrevDim (V4 n) = V3 n + type Decomposition (V4 n) = n :& n :& n :& n + + V3 x y z ^& w = V4 x y z w + coords (V4 x y z w) = x :& y :& z :& w + -- | The class of types with at least one coordinate, called _x. class HasX t where _x :: Floating n => Lens' (t n) n @@ -137,14 +164,14 @@ class HasR t where _r :: Lens' (t n) n instance HasX v => HasX (Point v) where - _x = _pIso . _x + _x = lensP . _x instance HasY v => HasY (Point v) where - _y = _pIso . _y + _y = lensP . _y instance HasZ v => HasZ (Point v) where - _z = _pIso . _z + _z = lensP . _z instance HasR v => HasR (Point v) where - _r = _pIso . _r + _r = lensP . _r diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs index d99934fd..2c605175 100644 --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -15,7 +15,7 @@ module Diagrams.Points ( -- * Points - Point, origin, (*.) + Point (..), origin, (*.) -- * Point-related utilities , centroid From 79c9a2e83a522c43b739a711aa328df90dd6bdb9 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 24 Aug 2014 00:17:16 +0100 Subject: [PATCH 28/58] Remove unused types. --- src/Diagrams/Coordinates.hs | 6 +- src/Diagrams/ThreeD/Types/Double.hs | 114 ---------------- src/Diagrams/TwoD/Types/Double.hs | 186 -------------------------- src/Diagrams/TwoD/Types/Float.hs | 195 ---------------------------- src/Diagrams/TwoD/Types/Generic.hs | 122 ----------------- 5 files changed, 3 insertions(+), 620 deletions(-) delete mode 100644 src/Diagrams/ThreeD/Types/Double.hs delete mode 100644 src/Diagrams/TwoD/Types/Double.hs delete mode 100644 src/Diagrams/TwoD/Types/Float.hs delete mode 100644 src/Diagrams/TwoD/Types/Generic.hs diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index 6340762a..778631d9 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -148,15 +148,15 @@ instance Coordinates (V4 n) where -- | The class of types with at least one coordinate, called _x. class HasX t where - _x :: Floating n => Lens' (t n) n + _x :: Floating n => Lens' (t n) n -- | The class of types with at least two coordinates, the second called _y. class HasX t => HasY t where - _y :: Floating n => Lens' (t n) n + _y :: Floating n => Lens' (t n) n -- | The class of types with at least three coordinates, the third called _z. class HasY t => HasZ t where - _z :: Floating n => Lens' (t n) n + _z :: Floating n => Lens' (t n) n -- | The class of types with a single length coordinate _r. _r is -- magnitude of a vector, or the distance from the origin of a point. diff --git a/src/Diagrams/ThreeD/Types/Double.hs b/src/Diagrams/ThreeD/Types/Double.hs deleted file mode 100644 index 6880e95e..00000000 --- a/src/Diagrams/ThreeD/Types/Double.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - ------------------------------------------------------------------------------ --- | --- Module : Diagrams.ThreeD.Types.Double --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Basic types for three-dimensional Euclidean space using Double. --- ------------------------------------------------------------------------------ - -module Diagrams.ThreeD.Types.Double - ( -- * 3D Euclidean space - R3(..), P3, T3 - ) where - -import Control.Lens (iso, over, (^.), _1, _2, _3) - -import Diagrams.Angle -import Diagrams.Coordinates -import Diagrams.Core -import Diagrams.ThreeD.Types -import Diagrams.TwoD.Types.Double (R2) - -import Data.Basis -import Data.Cross -import Data.Typeable -import Data.VectorSpace - ------------------------------------------------------------- --- 3D Euclidean space - --- | The three-dimensional Euclidean vector space R^3. -data R3 = R3 !Double !Double !Double - deriving (Eq, Ord, Show, Read, Typeable) - -instance AdditiveGroup R3 where - zeroV = R3 0 0 0 - R3 x1 y1 z1 ^+^ R3 x2 y2 z2 = R3 (x1 + x2) (y1 + y2) (z1 + z2) - negateV (R3 x y z) = R3 (-x) (-y) (-z) - -type instance V R3 = R3 - -instance VectorSpace R3 where - type Scalar R3 = Double - (*^) = over r3Iso . (*^) - -instance HasBasis R3 where - type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) - basisValue = r3 . basisValue - decompose = decompose . unr3 - decompose' = decompose' . unr3 - -instance InnerSpace R3 where - (R3 x1 y1 z1) <.> (R3 x2 y2 z2) = x1*x2 + y1*y2 + z1*z2 - -instance Coordinates R3 where - type FinalCoord R3 = Double - type PrevDim R3 = R2 - type Decomposition R3 = Double :& Double :& Double - - (coords -> x :& y) ^& z = R3 x y z - coords (R3 x y z) = x :& y :& z - --- | Points in R^3. -type P3 = Point R3 - --- | Transformations in R^3. -type T3 = Transformation R3 - -instance Transformable R3 where - transform = apply - -instance HasCross3 R3 where - cross3 u v = r3 $ cross3 (unr3 u) (unr3 v) - -instance HasX R3 where - _x = r3Iso . _1 - -instance HasY R3 where - _y = r3Iso . _2 - -instance HasZ R3 where - _z = r3Iso . _3 - -instance Cylindrical R3 where - cylindrical = iso (\(R3 x y z) -> (sqrt (x^(2::Int)+y^(2::Int)), atanA (y/x), z)) - (\(r,θ,z) -> R3 (r*cosA θ) (r*sinA θ) z) - -instance Spherical R3 where - spherical = iso - (\v@(R3 x y z) -> (magnitude v, atanA (y/x), atanA (v^._r/z))) - (\(r,θ,φ) -> R3 (r*cosA θ*sinA φ) (r*sinA θ*sinA φ) (r*cosA φ)) - --- We'd like to write: instance Spherical t => HasR t --- But GHC can't work out that the instance won't overlap. Just write them explicitly: -instance HasR R3 where - _r = spherical . _1 - -instance HasTheta R3 where - _theta = cylindrical . _2 - -instance HasPhi R3 where - _phi = spherical . _3 diff --git a/src/Diagrams/TwoD/Types/Double.hs b/src/Diagrams/TwoD/Types/Double.hs deleted file mode 100644 index 245c7d58..00000000 --- a/src/Diagrams/TwoD/Types/Double.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------ --- | --- Module : Diagrams.TwoD.Types.Double --- Copyright : (c) 2014 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- 2D Euclidean space in Double precision --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Types.Double where - -import Control.Lens (Rewrapped, Wrapped (..), iso, (^.), _1, _2) - - -import Diagrams.Angle -import Diagrams.Coordinates -import Diagrams.Core -import Diagrams.TwoD.Types - -import Data.Basis -import Data.VectorSpace - -import Data.Data ------------------------------------------------------------- --- 2D Euclidean space - --- | The two-dimensional Euclidean vector space R^2. This type is --- intentionally abstract, but uses Doubles as the scalar type. --- --- * To construct a vector, use 'r2', or '^&' (from "Diagrams.Coordinates"): --- --- @ --- r2 (3,4) :: R2 --- 3 ^& 4 :: R2 --- @ --- --- Note that "Diagrams.Coordinates" is not re-exported by --- "Diagrams.Prelude" and must be explicitly imported. --- --- * To construct the vector from the origin to a point @p@, use --- @p 'Data.AffineSpace..-.' 'origin'@. --- --- * To convert a vector @v@ into the point obtained by following --- @v@ from the origin, use @'origin' 'Data.AffineSpace..+^' v@. --- --- * To convert a vector back into a pair of components, use 'unv2' --- or 'coords' (from "Diagrams.Coordinates"). These are typically --- used in conjunction with the @ViewPatterns@ extension: --- --- @ --- foo (unr2 -> (x,y)) = ... --- foo (coords -> x :& y) = ... --- @ - -data R2 = R2 {-# UNPACK #-} !Double - {-# UNPACK #-} !Double - deriving (Eq, Ord, Typeable, Data) - -instance AdditiveGroup R2 where - zeroV = R2 0 0 - R2 x1 y1 ^+^ R2 x2 y2 = R2 (x1 + x2) (y1 + y2) - negateV (R2 x y) = R2 (-x) (-y) - -instance Num R2 where - (+) = (^+^) - R2 x1 y1 * R2 x2 y2 = R2 (x1 * x2) (y1 * y2) -- this is sort of bogus - (-) = (^-^) - negate = negateV - abs (R2 x y) = R2 (abs x) (abs y) - signum (R2 x y) = R2 (signum x) (signum y) - fromInteger i = R2 i' i' - where i' = fromInteger i - -instance Fractional R2 where - R2 x1 y1 / R2 x2 y2 = R2 (x1/x2) (y1/y2) - recip (R2 x y) = R2 (recip x) (recip y) - fromRational r = R2 r' r' - where r' = fromRational r - -instance Show R2 where - showsPrec p (R2 x y) = showParen (p >= 7) $ - showCoord x . showString " ^& " . showCoord y - where - showCoord c | c < 0 = showParen True (shows c) - | otherwise = shows c - -instance Read R2 where - readsPrec d r = readParen (d > app_prec) - (\rr -> [ (R2 x y, r''') - | (x,r') <- readsPrec (amp_prec + 1) rr - , ("^&",r'') <- lex r' - , (y,r''') <- readsPrec (amp_prec + 1) r'' - ]) - r - where - app_prec = 10 - amp_prec = 7 - --- | Lens wrapped isomorphisms for R2. -instance Wrapped R2 where - type Unwrapped R2 = (Double, Double) - _Wrapped' = iso unr2 r2 - {-# INLINE _Wrapped' #-} - -instance Rewrapped R2 R2 - -type instance V R2 = R2 - -instance VectorSpace R2 where - type Scalar R2 = Double - s *^ R2 x y = R2 (s*x) (s*y) - -instance HasBasis R2 where - type Basis R2 = R2Basis - basisValue XB = R2 1 0 - basisValue YB = R2 0 1 - - decompose (R2 x y) = [(XB, x), (YB, y)] - - decompose' (R2 x _) (XB) = x - decompose' (R2 _ y) (YB) = y - -instance InnerSpace R2 where - (R2 x1 y1) <.> (R2 x2 y2) = x1*x2 + y1*y2 - -instance Coordinates R2 where - type FinalCoord R2 = Double - type PrevDim R2 = Double - type Decomposition R2 = Double :& Double - - x ^& y = R2 x y - coords (R2 x y) = x :& y - -instance HasX R2 where - _x = r2Iso . _1 - -instance HasY R2 where - _y = r2Iso . _2 - -instance HasTheta R2 where - _theta = polar._2 - -instance HasR R2 where - _r = polar._1 - -instance Polar R2 where - polar = - iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) - (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) - -instance Transformable R2 where - transform = apply - --- | Points in R^2. This type is intentionally abstract. --- --- * To construct a point, use 'p2', or '^&' (see --- "Diagrams.Coordinates"): --- --- @ --- p2 (3,4) :: P2 --- 3 ^& 4 :: P2 --- @ --- --- * To construct a point from a vector @v@, use @'origin' 'Data.AffineSpace..+^' v@. --- --- * To convert a point @p@ into the vector from the origin to @p@, --- use @p 'Data.AffineSpace..-.' 'origin'@. --- --- * To convert a point back into a pair of coordinates, use 'unp2', --- or 'coords' (from "Diagrams.Coordinates"). It's common to use --- these in conjunction with the @ViewPatterns@ extension: --- --- @ --- foo (unp2 -> (x,y)) = ... --- foo (coords -> x :& y) = ... --- @ -type P2 = Point R2 - --- | Transformations in R^2. -type T2 = Transformation R2 diff --git a/src/Diagrams/TwoD/Types/Float.hs b/src/Diagrams/TwoD/Types/Float.hs deleted file mode 100644 index bb2d3f69..00000000 --- a/src/Diagrams/TwoD/Types/Float.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Diagrams.TwoD.Types.Float --- Copyright : (c) 2014 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- 2D Euclidean space in Float precision --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Types.Float where - -import Control.Lens (Rewrapped, Wrapped (..), iso, (^.), _1, _2) - - -import Diagrams.Angle -import Diagrams.Coordinates -import Diagrams.Core -import Diagrams.TwoD.Types - -import Data.Basis -import Data.VectorSpace - -import Data.Data - - --- Orphan instances that should be in diagrams-core -type instance V Float = Float - -instance Transformable Float where - transform = apply - ------------------------------------------------------------- --- 2D Euclidean space - --- | The two-dimensional Euclidean vector space R^2. This type is --- intentionally abstract, but uses Floats as the scalar type. --- --- * To construct a vector, use 'r2', or '^&' (from "Diagrams.Coordinates"): --- --- @ --- r2 (3,4) :: R2 --- 3 ^& 4 :: R2 --- @ --- --- Note that "Diagrams.Coordinates" is not re-exported by --- "Diagrams.Prelude" and must be explicitly imported. --- --- * To construct the vector from the origin to a point @p@, use --- @p 'Data.AffineSpace..-.' 'origin'@. --- --- * To convert a vector @v@ into the point obtained by following --- @v@ from the origin, use @'origin' 'Data.AffineSpace..+^' v@. --- --- * To convert a vector back into a pair of components, use 'unv2' --- or 'coords' (from "Diagrams.Coordinates"). These are typically --- used in conjunction with the @ViewPatterns@ extension: --- --- @ --- foo (unr2 -> (x,y)) = ... --- foo (coords -> x :& y) = ... --- @ -data R2 = R2 {-# UNPACK #-} !Float - {-# UNPACK #-} !Float - deriving (Eq, Ord, Typeable, Data) - -instance AdditiveGroup R2 where - zeroV = R2 0 0 - R2 x1 y1 ^+^ R2 x2 y2 = R2 (x1 + x2) (y1 + y2) - negateV (R2 x y) = R2 (-x) (-y) - -instance Num R2 where - (+) = (^+^) - R2 x1 y1 * R2 x2 y2 = R2 (x1 * x2) (y1 * y2) -- this is sort of bogus - (-) = (^-^) - negate = negateV - abs (R2 x y) = R2 (abs x) (abs y) - signum (R2 x y) = R2 (signum x) (signum y) - fromInteger i = R2 i' i' - where i' = fromInteger i - -instance Fractional R2 where - R2 x1 y1 / R2 x2 y2 = R2 (x1/x2) (y1/y2) - recip (R2 x y) = R2 (recip x) (recip y) - fromRational r = R2 r' r' - where r' = fromRational r - -instance Show R2 where - showsPrec p (R2 x y) = showParen (p >= 7) $ - showCoord x . showString " ^& " . showCoord y - where - showCoord c | c < 0 = showParen True (shows c) - | otherwise = shows c - -instance Read R2 where - readsPrec d r = readParen (d > app_prec) - (\rr -> [ (R2 x y, r''') - | (x,r') <- readsPrec (amp_prec + 1) rr - , ("^&",r'') <- lex r' - , (y,r''') <- readsPrec (amp_prec + 1) r'' - ]) - r - where - app_prec = 10 - amp_prec = 7 - --- | Lens wrapped isomorphisms for R2. -instance Wrapped R2 where - type Unwrapped R2 = (Float, Float) - _Wrapped' = iso unr2 r2 - {-# INLINE _Wrapped' #-} - -instance Rewrapped R2 R2 - -type instance V R2 = R2 - -instance VectorSpace R2 where - type Scalar R2 = Float - s *^ R2 x y = R2 (s*x) (s*y) - -instance HasBasis R2 where - type Basis R2 = R2Basis - basisValue XB = R2 1 0 - basisValue YB = R2 0 1 - - decompose (R2 x y) = [(XB, x), (YB, y)] - - decompose' (R2 x _) (XB) = x - decompose' (R2 _ y) (YB) = y - -instance InnerSpace R2 where - (R2 x1 y1) <.> (R2 x2 y2) = x1*x2 + y1*y2 - -instance Coordinates R2 where - type FinalCoord R2 = Float - type PrevDim R2 = Float - type Decomposition R2 = Float :& Float - - x ^& y = R2 x y - coords (R2 x y) = x :& y - -instance HasX R2 where - _x = r2Iso . _1 - -instance HasY R2 where - _y = r2Iso . _2 - -instance HasTheta R2 where - _theta = polar._2 - -instance HasR R2 where - _r = polar._1 - -instance Polar R2 where - polar = - iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) - (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) - -instance Transformable R2 where - transform = apply - --- | Points in R^2. This type is intentionally abstract. --- --- * To construct a point, use 'p2', or '^&' (see --- "Diagrams.Coordinates"): --- --- @ --- p2 (3,4) :: P2 --- 3 ^& 4 :: P2 --- @ --- --- * To construct a point from a vector @v@, use @'origin' 'Data.AffineSpace..+^' v@. --- --- * To convert a point @p@ into the vector from the origin to @p@, --- use @p 'Data.AffineSpace..-.' 'origin'@. --- --- * To convert a point back into a pair of coordinates, use 'unp2', --- or 'coords' (from "Diagrams.Coordinates"). It's common to use --- these in conjunction with the @ViewPatterns@ extension: --- --- @ --- foo (unp2 -> (x,y)) = ... --- foo (coords -> x :& y) = ... --- @ -type P2 = Point R2 - --- | Transformations in R^2. -type T2 = Transformation R2 diff --git a/src/Diagrams/TwoD/Types/Generic.hs b/src/Diagrams/TwoD/Types/Generic.hs deleted file mode 100644 index 250613d2..00000000 --- a/src/Diagrams/TwoD/Types/Generic.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Diagrams.TwoD.Types.Generic --- Copyright : (c) 2014 diagrams team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Generic type for two-dimensional Euclidean space. ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Types.Generic where - -import Control.Lens (Rewrapped, Wrapped (..), iso, (^.), _1, _2) - - -import Diagrams.Angle -import Diagrams.Coordinates -import Diagrams.Core -import Diagrams.TwoD.Types - -import Data.Basis -import Data.VectorSpace - -import Data.Data -import Data.Foldable -import Data.Traversable - -data V2 a = V2 a a - deriving (Eq, Typeable, Functor, Foldable, Traversable, Data) - -instance (ScalarR2Ish a) => AdditiveGroup (V2 a) where - zeroV = V2 0 0 - V2 x1 y1 ^+^ V2 x2 y2 = V2 (x1 + x2) (y1 + y2) - negateV (V2 x y) = V2 (-x) (-y) - -instance (ScalarR2Ish a) => Num (V2 a) where - (+) = (^+^) - V2 x1 y1 * V2 x2 y2 = V2 (x1 * x2) (y1 * y2) -- this is sort of bogus - (-) = (^-^) - negate = negateV - abs (V2 x y) = V2 (abs x) (abs y) - signum (V2 x y) = V2 (signum x) (signum y) - fromInteger i = V2 i' i' - where i' = fromInteger i - -instance (ScalarR2Ish a) => Fractional (V2 a) where - V2 x1 y1 / V2 x2 y2 = V2 (x1/x2) (y1/y2) - recip (V2 x y) = V2 (recip x) (recip y) - fromRational r = V2 r' r' - where r' = fromRational r - -instance (ScalarR2Ish a, Show a) => Show (V2 a) where - showsPrec p (V2 x y) = showParen (p >= 7) $ - showCoord x . showString " ^& " . showCoord y - where - showCoord = showParen True . shows - --- | Lens wrapped isomorphisms for V2. -instance (ScalarR2Ish a) => Wrapped (V2 a) where - type Unwrapped (V2 a) = (a, a) - _Wrapped' = iso unr2 r2 - {-# INLINE _Wrapped' #-} - -instance (ScalarR2Ish a) => Rewrapped (V2 a) (V2 a) - -type instance V (V2 a) = V2 a - -instance (ScalarR2Ish a) => VectorSpace (V2 a) where - type Scalar (V2 a) = a - s *^ V2 x y = V2 (s*x) (s*y) - -instance (ScalarR2Ish a) => HasBasis (V2 a) where - type Basis (V2 a) = R2Basis - basisValue XB = V2 1 0 - basisValue YB = V2 0 1 - - decompose (V2 x y) = [(XB, x), (YB, y)] - - decompose' (V2 x _) (XB) = x - decompose' (V2 _ y) (YB) = y - -instance (ScalarR2Ish a) => InnerSpace (V2 a) where - (V2 x1 y1) <.> (V2 x2 y2) = x1*x2 + y1*y2 - -instance (ScalarR2Ish a) => Coordinates (V2 a) where - type FinalCoord (V2 a) = a - type PrevDim (V2 a) = a - type Decomposition (V2 a) = a :& a - - x ^& y = V2 x y - coords (V2 x y) = x :& y - -instance (ScalarR2Ish a) => HasX (V2 a) where - _x = r2Iso . _1 - -instance (ScalarR2Ish a) => HasY (V2 a) where - _y = r2Iso . _2 - -instance (ScalarR2Ish a) => HasTheta (V2 a) where - _theta = polar._2 - -instance (ScalarR2Ish a) => HasR (V2 a) where - _r = polar._1 - -instance (ScalarR2Ish a) => Polar (V2 a) where - polar = - iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) - (\(r,θ) -> V2 (r * cosA θ) (r * sinA θ)) - -instance (ScalarR2Ish a) => Transformable (V2 a) where - transform = apply - From cf195d07f3686c8dcfdab0b51680fb9898bcdecd Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 24 Aug 2014 00:38:18 +0100 Subject: [PATCH 29/58] Use linear's classes for _x, _y, _z. --- src/Diagrams/Coordinates.hs | 26 +--------------- src/Diagrams/ThreeD/Deform.hs | 11 ++----- src/Diagrams/ThreeD/Shapes.hs | 25 ++++++++-------- src/Diagrams/ThreeD/Transform.hs | 40 ++++++++++++------------- src/Diagrams/ThreeD/Types.hs | 12 +------- src/Diagrams/ThreeD/Vector.hs | 8 ++--- src/Diagrams/TwoD/Deform.hs | 11 ++----- src/Diagrams/TwoD/Offset.hs | 51 ++++++++++++++++---------------- src/Diagrams/TwoD/Segment.hs | 25 ++++++++-------- src/Diagrams/TwoD/Transform.hs | 27 ++++++++--------- src/Diagrams/TwoD/Types.hs | 16 ++-------- src/Diagrams/TwoD/Vector.hs | 15 +++++----- 12 files changed, 104 insertions(+), 163 deletions(-) diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index 778631d9..41152b6d 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -17,7 +17,7 @@ module Diagrams.Coordinates ( (:&)(..), Coordinates(..) -- * Lenses for particular axes - , HasX(..), HasY(..), HasZ(..), HasR(..) + , HasR(..) ) where @@ -146,32 +146,8 @@ instance Coordinates (V4 n) where V3 x y z ^& w = V4 x y z w coords (V4 x y z w) = x :& y :& z :& w --- | The class of types with at least one coordinate, called _x. -class HasX t where - _x :: Floating n => Lens' (t n) n - --- | The class of types with at least two coordinates, the second called _y. -class HasX t => HasY t where - _y :: Floating n => Lens' (t n) n - --- | The class of types with at least three coordinates, the third called _z. -class HasY t => HasZ t where - _z :: Floating n => Lens' (t n) n - -- | The class of types with a single length coordinate _r. _r is -- magnitude of a vector, or the distance from the origin of a point. class HasR t where _r :: Lens' (t n) n -instance HasX v => HasX (Point v) where - _x = lensP . _x - -instance HasY v => HasY (Point v) where - _y = lensP . _y - -instance HasZ v => HasZ (Point v) where - _z = lensP . _z - -instance HasR v => HasR (Point v) where - _r = lensP . _r - diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs index 61da0370..396e264b 100644 --- a/src/Diagrams/ThreeD/Deform.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -1,14 +1,9 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} module Diagrams.ThreeD.Deform where -import Control.Lens +import Control.Lens -import Diagrams.Deform - -import Diagrams.Coordinates -import Diagrams.ThreeD.Types +import Diagrams.Deform +import Diagrams.ThreeD.Types -- | The parallel projection onto the plane x=0 parallelX0 :: Floating n => Deformation V3 n diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index 50c65335..ec422048 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -2,9 +2,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Shapes @@ -23,21 +23,20 @@ module Diagrams.ThreeD.Shapes , Frustum(..) , frustum, cone, cylinder ) where -import Control.Applicative -import Control.Lens (review, (^.), _1) -import Data.Typeable +import Control.Applicative +import Control.Lens (review, (^.), _1) +import Data.Typeable -import Data.Semigroup -import Diagrams.Angle -import Diagrams.Coordinates -import Diagrams.Core -import Diagrams.Solve -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector +import Data.Semigroup +import Diagrams.Angle +import Diagrams.Core +import Diagrams.Solve +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector import Linear.Affine -import Linear.Vector import Linear.Metric +import Linear.Vector data Ellipsoid n = Ellipsoid (Transformation V3 n) deriving Typeable @@ -68,7 +67,7 @@ sphere = mkQD (Prim $ Ellipsoid mempty) sphereQuery v = Any $ quadrance (v .-. origin) <= 1 data Box n = Box (Transformation V3 n) - deriving (Typeable) + deriving Typeable type instance V (Box n) = V3 type instance N (Box n) = n diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 5e2e7c66..61f298b6 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -4,8 +4,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Transform @@ -46,24 +46,24 @@ module Diagrams.ThreeD.Transform -- , onBasis ) where -import Diagrams.Core -import Diagrams.Core.Transform +import Diagrams.Core +import Diagrams.Core.Transform -import Diagrams.Angle -import Diagrams.Coordinates -import Diagrams.Direction -import Diagrams.ThreeD.Types -import Diagrams.Transform +import Diagrams.Angle +import Diagrams.Direction +import Diagrams.ThreeD.Types +import Diagrams.Transform -import Control.Lens (view, (*~), (//~), (&), (.~)) -import Data.Semigroup -import Diagrams.TwoD.Transform hiding (rotationAbout, reflectAbout, reflectionAbout) +import Control.Lens (view, (&), (*~), (.~), (//~)) +import Data.Semigroup +import Diagrams.TwoD.Transform hiding (reflectAbout, reflectionAbout, + rotationAbout) -import Linear.Vector import Linear.Affine import Linear.Epsilon import Linear.Metric -import Linear.V3 (cross) +import Linear.V3 (cross) +import Linear.Vector -- | Create a transformation which rotates by the given angle about -- a line parallel the Z axis passing through the local origin. @@ -157,7 +157,7 @@ pointAtUnit about initial final = tilt <> pan where -- | Construct a transformation which scales by the given factor in -- the z direction. -scalingZ :: (HasZ v, Additive v, Floating n) => n -> Transformation v n +scalingZ :: (R3 v, Additive v, Floating n) => n -> Transformation v n scalingZ c = fromSymmetric s where s = (_z *~ c) <-> (_z //~ c) @@ -170,29 +170,29 @@ scaleZ = transform . scalingZ -- | Construct a transformation which translates by the given distance -- in the z direction. -translationZ :: (HasZ v, Additive v, Floating n) => n -> Transformation v n +translationZ :: (R3 v, Additive v, Floating n) => n -> Transformation v n translationZ z = translation (zero & _z .~ z) -- | Translate a diagram by the given distance in the y -- direction. -translateZ :: (HasZ v, Transformable t, Vn t ~ v n, Additive v, Floating n) => n -> t -> t +translateZ :: (R3 v, Transformable t, Vn t ~ v n, Additive v, Floating n) => n -> t -> t translateZ = transform . translationZ -- Reflection ---------------------------------------------- -- | Construct a transformation which flips a diagram across z=0, -- i.e. sends the point (x,y,z) to (x,y,-z). -reflectionZ :: (HasZ v, Additive v, Floating n) => Transformation v n +reflectionZ :: (R3 v, Additive v, Floating n) => Transformation v n reflectionZ = scalingZ (-1) -- | Flip a diagram across z=0, i.e. send the point (x,y,z) to -- (x,y,-z). -reflectZ :: (HasZ v, Transformable t, Vn t ~ v n, Additive v, Floating n) => t -> t +reflectZ :: (R3 v, Transformable t, Vn t ~ v n, Additive v, Floating n) => t -> t reflectZ = transform reflectionZ -- | @reflectionAbout p v@ is a reflection across the plane through -- the point @p@ and normal to vector @v@. -reflectionAbout :: (HasLinearMap v, Metric v, Fractional n, HasZ v) => Point v n -> v n -> Transformation v n +reflectionAbout :: (HasLinearMap v, Metric v, Fractional n, R3 v) => Point v n -> v n -> Transformation v n reflectionAbout p v = conjugate (translation (origin .-. p)) reflect where @@ -202,7 +202,7 @@ reflectionAbout p v = -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. -reflectAbout :: (HasZ v, HasLinearMap v, Metric v, Fractional n, Transformable t, Vn t ~ v n) +reflectAbout :: (R3 v, HasLinearMap v, Metric v, Fractional n, Transformable t, Vn t ~ v n) => Point v n -> v n -> t -> t reflectAbout p v = transform (reflectionAbout p v) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 7cf8cc60..bda157e8 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -18,6 +18,7 @@ module Diagrams.ThreeD.Types , p3, unp3, mkP3 , r3Iso, p3Iso, project , V3 (..) + , R1 (..), R2 (..), R3 (..) -- * other coördinate systems , Spherical(..), Cylindrical(..), HasPhi(..) @@ -30,10 +31,8 @@ import Diagrams.Core import Diagrams.Points import Linear.V3 as V -import Linear.Affine import Linear.Metric import Linear.Vector -import Diagrams.Coordinates ------------------------------------------------------------ -- 3D Euclidean space @@ -94,15 +93,6 @@ instance Cylindrical v => Cylindrical (Point v) where instance Spherical v => Spherical (Point v) where spherical = _pIso . spherical -instance HasX V3 where - _x = V._x - -instance HasY V3 where - _y = V._y - -instance HasZ V3 where - _z = V._z - type instance V (V3 n) = V3 type instance N (V3 n) = n diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 309f3770..1d4a260e 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -16,15 +16,15 @@ module Diagrams.ThreeD.Vector unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, unit, unit_ ) where -import Diagrams.Coordinates -import Diagrams.TwoD.Vector +import Diagrams.TwoD.Vector +import Diagrams.ThreeD.Types import Linear.Vector hiding (unit) -- | The unit vector in the positive Y direction. -unitZ :: (HasZ v, Additive v, Floating n) => v n +unitZ :: (R3 v, Additive v, Num n) => v n unitZ = unit _y -- | The unit vector in the negative X direction. -unit_Z :: (HasZ v, Additive v, Floating n) => v n +unit_Z :: (R3 v, Additive v, Num n) => v n unit_Z = unit_ _z diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs index 54b6810f..eb55e833 100644 --- a/src/Diagrams/TwoD/Deform.hs +++ b/src/Diagrams/TwoD/Deform.hs @@ -1,14 +1,9 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} module Diagrams.TwoD.Deform where -import Control.Lens +import Control.Lens -import Diagrams.Deform - -import Diagrams.Coordinates -import Diagrams.TwoD.Types +import Diagrams.Deform +import Diagrams.TwoD.Types -- | The parallel projection onto the line x=0 parallelX0 :: Floating n => Deformation V2 n diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index 0813f5a4..bcc0873c 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -41,34 +41,33 @@ module Diagrams.TwoD.Offset ) where -import Control.Applicative -import Control.Lens hiding (at) - -import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Monoid.Inf - -import Data.Default.Class - -import Diagrams.Core - -import Diagrams.Angle -import Diagrams.Attributes -import Diagrams.Direction (direction) -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Trail hiding (isLoop, offset) -import Diagrams.TrailLike -import Diagrams.TwoD.Arc -import Diagrams.TwoD.Curvature -import Diagrams.TwoD.Path () -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (perp) +import Control.Applicative +import Control.Lens hiding (at) + +import Data.Maybe (catMaybes) +import Data.Monoid +import Data.Monoid.Inf + +import Data.Default.Class + +import Diagrams.Core + +import Diagrams.Angle +import Diagrams.Attributes +import Diagrams.Direction (direction) +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail hiding (isLoop, offset) +import Diagrams.TrailLike +import Diagrams.TwoD.Arc +import Diagrams.TwoD.Curvature +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Types -import Linear.Metric import Linear.Affine +import Linear.Metric import Linear.Vector unitPerp :: OrderedField n => V2 n -> V2 n diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index 6c11d943..d573ccdd 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -23,24 +23,23 @@ module Diagrams.TwoD.Segment where -import Control.Applicative (liftA2) -import Control.Lens ((^.)) +import Control.Applicative (liftA2) +import Control.Lens ((^.)) -import Diagrams.Core +import Diagrams.Core -import Diagrams.Angle -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Segment -import Diagrams.Solve -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector -import Diagrams.Util +import Diagrams.Angle +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment +import Diagrams.Solve +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.Util import Linear.Affine -import Linear.Vector import Linear.Metric +import Linear.Vector {- All instances of Traced should maintain the invariant that the list of traces is sorted in increasing order. diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index f6fa268a..f8cadcd5 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -61,9 +61,8 @@ import Diagrams.TwoD.Types import Control.Lens (review, (^.), (*~), (//~), (&), (.~)) import Data.Semigroup -import Diagrams.Coordinates -import Linear.Vector import Linear.Affine +import Linear.Vector @@ -116,25 +115,25 @@ rotateAbout p angle = rotate angle `under` translation (origin .-. p) -- | Construct a transformation which scales by the given factor in -- the x (horizontal) direction. -scalingX :: (HasX v, Additive v, Floating n) => n -> Transformation v n +scalingX :: (R1 v, Additive v, Floating n) => n -> Transformation v n scalingX c = fromLinear s s where s = (_x *~ c) <-> (_x //~ c) -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. -scaleX :: (Vn t ~ v n, Transformable t, HasX v, Additive v, Floating n) +scaleX :: (Vn t ~ v n, Transformable t, R1 v, Additive v, Floating n) => n -> t -> t scaleX = transform . scalingX -- | Construct a transformation which scales by the given factor in -- the y (vertical) direction. -scalingY :: (HasY v, Additive v, Floating n) => n -> Transformation v n +scalingY :: (R2 v, Additive v, Floating n) => n -> Transformation v n scalingY c = fromLinear s s where s = (_y *~ c) <-> (_y //~ c) -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. -scaleY :: (Vn t ~ v n, Transformable t, HasY v, Additive v, Floating n) +scaleY :: (Vn t ~ v n, Transformable t, R2 v, Additive v, Floating n) => n -> t -> t scaleY = transform . scalingY @@ -168,23 +167,23 @@ scaleUToY h d = scale (h / height d) d -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. -translationX :: (HasX v, Additive v, Floating n) => n -> Transformation v n +translationX :: (R1 v, Additive v, Floating n) => n -> Transformation v n translationX x = translation (zero & _x .~ x) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. -translateX :: (Vn t ~ v n, Transformable t, HasX v, Additive v, Floating n) +translateX :: (Vn t ~ v n, Transformable t, R1 v, Additive v, Floating n) => n -> t -> t translateX = transform . translationX -- | Construct a transformation which translates by the given distance -- in the y (vertical) direction. -translationY :: (HasY v, Additive v, Floating n) => n -> Transformation v n +translationY :: (R2 v, Additive v, Floating n) => n -> Transformation v n translationY y = translation (zero & _y .~ y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. -translateY :: (Vn t ~ v n, Transformable t, HasY v, Additive v, Floating n) +translateY :: (Vn t ~ v n, Transformable t, R2 v, Additive v, Floating n) => n -> t -> t translateY = transform . translationY @@ -192,22 +191,22 @@ translateY = transform . translationY -- | Construct a transformation which flips a diagram from left to -- right, i.e. sends the point (x,y) to (-x,y). -reflectionX :: (HasX v, Additive v, Floating n) => Transformation v n +reflectionX :: (R1 v, Additive v, Floating n) => Transformation v n reflectionX = scalingX (-1) -- | Flip a diagram from left to right, i.e. send the point (x,y) to -- (-x,y). -reflectX :: (Vn t ~ v n, Transformable t, HasX v, Additive v, Floating n) => t -> t +reflectX :: (Vn t ~ v n, Transformable t, R1 v, Additive v, Floating n) => t -> t reflectX = transform reflectionX -- | Construct a transformation which flips a diagram from top to -- bottom, i.e. sends the point (x,y) to (x,-y). -reflectionY :: (HasY v, Additive v, Floating n) => Transformation v n +reflectionY :: (R2 v, Additive v, Floating n) => Transformation v n reflectionY = scalingY (-1) -- | Flip a diagram from top to bottom, i.e. send the point (x,y) to -- (x,-y). -reflectY :: (Vn t ~ v n, Transformable t, HasY v, Additive v, Floating n) +reflectY :: (Vn t ~ v n, Transformable t, R2 v, Additive v, Floating n) => t -> t reflectY = transform reflectionY diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index ede88e05..838f1ba1 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -15,8 +15,8 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space - V2 (..), R2, P2, r2, unr2, mkR2, r2Iso - , p2, mkP2, unp2, p2Iso, project + V2 (..), R1 (..), R2 (..), P2, r2, unr2, mkR2, r2Iso + , p2, mkP2, unp2, p2Iso, project, perp , Polar(..) ) where @@ -26,17 +26,13 @@ import Diagrams.Angle -- import Diagrams.Coordinates import Diagrams.Points -import Linear.Affine import Linear.Vector import Linear.Metric -import Linear.V2 hiding (R2) -import qualified Linear.V2 as V -import Diagrams.Coordinates +import Linear.V2 import Diagrams.Core.V import Diagrams.Core.Transform -type R2 = V2 type P2 = Point V2 type instance V (V2 n) = V2 @@ -94,12 +90,6 @@ project u v = ((v `dot` u) / quadrance u) *^ u instance Transformable (V2 n) where transform = apply -instance HasX V2 where - _x = V._x - -instance HasY V2 where - _y = V._y - instance Polar V2 where polar = iso (\v@(V2 x y) -> (norm v, atan2A y x)) (\(r,θ) -> V2 (r * cosA θ) (r * sinA θ)) diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 11e8dca2..473d4fac 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -28,9 +28,8 @@ import Diagrams.Angle import Diagrams.Direction import Linear.Vector hiding (unit) -import Linear.V2 hiding (_x,_y) +import Diagrams.TwoD.Types import Linear.Metric -import Diagrams.Coordinates unit :: (Additive v, Num n) => ASetter' (v n) n -> v n unit l = set' l 1 zero @@ -40,29 +39,29 @@ unit_ l = set' l (-1) zero -- | The unit vector in the positive X direction. -unitX :: (HasX v, Additive v, Floating n) => v n +unitX :: (R1 v, Additive v, Num n) => v n unitX = unit _x -- | The unit vector in the positive Y direction. -unitY :: (HasY v, Additive v, Floating n) => v n +unitY :: (R2 v, Additive v, Num n) => v n unitY = unit _y -- | The unit vector in the negative X direction. -unit_X :: (HasX v, Additive v, Floating n) => v n +unit_X :: (R1 v, Additive v, Num n) => v n unit_X = unit_ _x -- | The unit vector in the negative Y direction. -unit_Y :: (HasY v, Additive v, Floating n) => v n +unit_Y :: (R2 v, Additive v, Num n) => v n unit_Y = unit_ _y -- | The origin of the direction AffineSpace. For all d, @d .-. xDir -- = d^._theta@. -xDir :: (HasX v, Additive v, Floating n) => Direction v n +xDir :: (R1 v, Additive v, Num n) => Direction v n xDir = direction unitX -- | A unit vector at a specified angle counterclockwise from the -- positive X axis. -e :: (HasTheta v, HasX v, Additive v, RealFloat n) => Angle n -> v n +e :: (HasTheta v, R1 v, Additive v, RealFloat n) => Angle n -> v n e a = unitX & _theta .~ a -- -- | @perp v@ is perpendicular to and has the same magnitude as @v@. From c989031efa83c9245e12dc0a51a57532afaad9d9 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 24 Aug 2014 00:49:25 +0100 Subject: [PATCH 30/58] Uncomment default pragma. --- src/Diagrams/Parametric.hs | 27 +++++++++++++-------------- src/Diagrams/Query.hs | 3 ++- src/Diagrams/TwoD/Curvature.hs | 11 +++++------ src/Diagrams/TwoD/Deform.hs | 2 +- 4 files changed, 21 insertions(+), 22 deletions(-) diff --git a/src/Diagrams/Parametric.hs b/src/Diagrams/Parametric.hs index 50eaaf01..0ee35782 100644 --- a/src/Diagrams/Parametric.hs +++ b/src/Diagrams/Parametric.hs @@ -48,15 +48,15 @@ class DomainBounds p where -- numeric scalars). domainLower :: p -> N p - -- default domainLower :: Num n => p n -> n - -- domainLower = const 0 + default domainLower :: Num (N p) => p -> N p + domainLower = const 0 -- | 'domainUpper' defaults to being constantly 1 (for vector spaces -- with numeric scalars). domainUpper :: p -> N p - -- default domainUpper :: Num n => p n -> n - -- domainUpper = const 1 + default domainUpper :: Num n => p -> n + domainUpper = const 1 -- | Type class for querying the values of a parametric object at the -- ends of its domain. @@ -127,9 +127,9 @@ class DomainBounds p => Sectionable p where -- -- That is, the section should have the same domain as the -- original, and the reparameterization should be linear. - section :: p -> n -> n -> p - -- default section :: Fractional n => p n -> n -> n -> p n - -- section x t1 t2 = snd (splitAtParam (fst (splitAtParam x t2)) (t1/t2)) + section :: p -> N p -> N p -> p + default section :: Fractional (N p) => p -> N p -> N p -> p + section x t1 t2 = snd (splitAtParam (fst (splitAtParam x t2)) (t1/t2)) -- | Flip the parameterization on the domain. reverseDomain :: p -> p @@ -151,14 +151,14 @@ class Parametric p => HasArcLength p where -- | @arcLength eps s@ approximates the arc length of @x@ up to the -- accuracy @eps@ (plus or minus). arcLength :: N p -> p -> N p - -- default arcLength :: Fractional n => n -> p n -> n - -- arcLength eps = I.midpoint . arcLengthBounded eps + default arcLength :: Fractional (N p) => N p -> p -> N p + arcLength eps = I.midpoint . arcLengthBounded eps -- | Approximate the arc length up to a standard accuracy of -- 'stdTolerance' (@1e-6@). stdArcLength :: p -> N p - -- default stdArcLength :: Fractional n => p n -> n - -- stdArcLength = arcLength stdTolerance + default stdArcLength :: Fractional (N p) => p -> N p + stdArcLength = arcLength stdTolerance -- | @'arcLengthToParam' eps s l@ converts the absolute arc length -- @l@, measured from the start of the domain, to a parameter on @@ -172,7 +172,6 @@ class Parametric p => HasArcLength p where -- | A simple interface to convert arc length to a parameter, -- guaranteed to be accurate within 'stdTolerance', or @1e-6@. stdArcLengthToParam :: p -> N p -> N p - -- default stdArcLengthToParam :: Fractional n - -- => p n -> n -> n - -- stdArcLengthToParam = arcLengthToParam stdTolerance + default stdArcLengthToParam :: Fractional (N p) => p -> N p -> N p + stdArcLengthToParam = arcLengthToParam stdTolerance diff --git a/src/Diagrams/Query.hs b/src/Diagrams/Query.hs index 3f670d4c..dc976a0a 100644 --- a/src/Diagrams/Query.hs +++ b/src/Diagrams/Query.hs @@ -16,4 +16,5 @@ module Diagrams.Query ) where -import Diagrams.Core +import Diagrams.Core + diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs index 78aa09fc..a8bb49b0 100644 --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -20,15 +20,14 @@ module Diagrams.TwoD.Curvature , squaredRadiusOfCurvature ) where -import Data.Monoid.Inf +import Data.Monoid.Inf -import Diagrams.Segment -import Diagrams.Tangent -import Diagrams.TwoD.Types -import Diagrams.Coordinates +import Diagrams.Segment +import Diagrams.Tangent +import Diagrams.TwoD.Types +import Control.Lens (over) import Linear.Vector -import Control.Lens (over) -- | Curvature measures how curved the segment is at a point. One intuition -- for the concept is how much you would turn the wheel when driving a car diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs index eb55e833..16b456f7 100644 --- a/src/Diagrams/TwoD/Deform.hs +++ b/src/Diagrams/TwoD/Deform.hs @@ -7,7 +7,7 @@ import Diagrams.TwoD.Types -- | The parallel projection onto the line x=0 parallelX0 :: Floating n => Deformation V2 n -parallelX0 = Deformation (& _x .~ 0) +parallelX0 = Deformation (_x .~ 0) -- | The perspective division onto the line x=1 along lines going -- through the origin. From 26582ffff4ff4ec2b82264c10a49ef755d045bdb Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 24 Aug 2014 11:12:27 +0100 Subject: [PATCH 31/58] Bring back prelude. --- diagrams-lib.cabal | 4 +- src/Diagrams/Angle.hs | 25 ++++------ src/Diagrams/Combinators.hs | 9 ++-- src/Diagrams/Deform.hs | 31 ++++++------ src/Diagrams/Direction.hs | 13 +++-- src/Diagrams/Segment.hs | 16 +++--- src/Diagrams/ThreeD/Camera.hs | 2 +- src/Diagrams/ThreeD/Light.hs | 4 +- src/Diagrams/ThreeD/Transform.hs | 9 ++-- src/Diagrams/Trail.hs | 86 +++++++++++++++----------------- src/Diagrams/TwoD/Adjust.hs | 8 +-- src/Diagrams/TwoD/Arc.hs | 5 +- src/Diagrams/TwoD/Arrow.hs | 67 ++++++++++++------------- src/Diagrams/TwoD/Arrowheads.hs | 37 +++++++------- src/Diagrams/TwoD/Combinators.hs | 49 +++++++++--------- src/Diagrams/TwoD/Path.hs | 45 ++++++++--------- src/Diagrams/TwoD/Polygons.hs | 11 ++-- 17 files changed, 195 insertions(+), 226 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 7f4e2b72..e7bcd071 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -25,8 +25,8 @@ Source-repository head location: http://github.com/diagrams/diagrams-lib.git Library - Exposed-modules: Diagrams.Prelude, - Diagrams.Prelude.ThreeD, + Exposed-modules: Diagrams.Prelude + Diagrams.Prelude.ThreeD Diagrams.Align, Diagrams.Angle, Diagrams.Combinators, diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 9a7a2966..ba808485 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -2,9 +2,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} -- {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Angle @@ -28,21 +28,16 @@ module Diagrams.Angle , HasPhi(..) ) where -import Control.Lens (Iso', Lens', iso, review, (^.)) +import Control.Applicative +import Control.Lens (Iso', Lens', iso, review, (^.)) +import Data.Monoid hiding ((<>)) +import Data.Semigroup + +import Diagrams.Core.V +import Diagrams.Points -import Data.Monoid hiding ((<>)) -import Data.Semigroup --- import Data.VectorSpace -import Linear.Affine import Linear.Metric import Linear.Vector -import Linear.Epsilon - -import Control.Applicative - -import Diagrams.Core.V -import Diagrams.Points --- import Data.Fixed -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. @@ -159,8 +154,8 @@ infixl 5 @@ -- | compute the positive angle between the two vectors in their common plane -- | N.B.: currently discards the common plane information -angleBetween :: (Metric v, Floating n, Epsilon n) => v n -> v n -> Angle n -angleBetween v1 v2 = acos (normalize v1 `dot` normalize v2) @@ rad +angleBetween :: (Metric v, Floating n) => v n -> v n -> Angle n +angleBetween v1 v2 = acos (signorm v1 `dot` signorm v2) @@ rad -- | Normalize an angle so that is lies in the [0,tau) range. -- normalizeAngle :: (Floating n, Real n) => Angle n -> Angle n diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 82263391..d3952b8f 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -59,7 +59,6 @@ import Diagrams.Segment (straight) import Diagrams.Util import Linear.Affine -import Linear.Epsilon import Linear.Metric import Linear.Vector @@ -148,7 +147,7 @@ strut v = QD $ D.leafU (inj . toDeletable $ env) -- the cosine of the difference in angle, and leaving it unchanged -- when this factor is negative. extrudeEnvelope - :: (HasLinearMap v, Ord n, Floating n, Epsilon n, Metric v, Monoid' m) + :: (HasLinearMap v, Ord n, Floating n, Metric v, Monoid' m) => v n -> QDiagram b v n m -> QDiagram b v n m extrudeEnvelope = deformEnvelope 0.5 @@ -160,13 +159,13 @@ extrudeEnvelope = deformEnvelope 0.5 -- Note that this could create strange inverted envelopes, where -- @ diameter v d < 0 @. intrudeEnvelope - :: (HasLinearMap v, Ord n, Floating n, Epsilon n, Metric v, Monoid' m) + :: (HasLinearMap v, Ord n, Floating n, Metric v, Monoid' m) => v n -> QDiagram b v n m -> QDiagram b v n m intrudeEnvelope = deformEnvelope (-0.5) -- Utility for extrudeEnvelope / intrudeEnvelope deformEnvelope - :: (HasLinearMap v, Ord n, Epsilon n, Floating n, Metric v, Monoid' m) + :: (HasLinearMap v, Ord n, Floating n, Metric v, Monoid' m) => n -> v n -> QDiagram b v n m -> QDiagram b v n m deformEnvelope s v d = setEnvelope (getEnvelope d & _Wrapping Envelope %~ deformE) d where @@ -233,7 +232,7 @@ beside v d1 d2 = d1 <> juxtapose v d1 d2 -- from the first. The local origin of the resulting combined -- diagram is the same as the local origin of the first. See the -- documentation of 'beside' for more information. -atDirection :: (Juxtaposable a, Semigroup a, Vn a ~ v n, Metric v, Floating n, Epsilon n) +atDirection :: (Juxtaposable a, Semigroup a, Vn a ~ v n, Metric v, Floating n) => Direction v n -> a -> a -> a atDirection = beside . fromDirection diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs index 6e2760d1..6ca3ca84 100644 --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -7,21 +7,20 @@ module Diagrams.Deform (Deformation(..), Deformable(..), asDeformation) where -import Control.Lens (under, _Unwrapped) -import Data.Monoid hiding ((<>)) -import Data.Semigroup +import Control.Lens (under, _Unwrapped) +import Data.Monoid hiding ((<>)) +import Data.Semigroup -import Diagrams.Core -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Trail +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail import Linear.Affine -import Linear.Vector import Linear.Metric -import Linear.Epsilon +import Linear.Vector ------------------------------------------------------------ -- Deformations @@ -74,24 +73,24 @@ instance Deformable (Point v n) where -- precision by a series of @Segment@s. @deformSegment@ does this, -- which allows types built from lists of @Segment@s to themselves be -- @Deformable@. -deformSegment :: (Metric v, Ord n, Floating n, Epsilon n) => n -> Deformation v n -> FixedSegment v n -> [FixedSegment v n] +deformSegment :: (Metric v, OrderedField n) => n -> Deformation v n -> FixedSegment v n -> [FixedSegment v n] deformSegment epsilon t s | goodEnough epsilon t s = [approx t s] | otherwise = concatMap (deformSegment epsilon t) [s1, s2] where (s1, s2) = splitAtParam s 0.5 -approx :: (Metric v, Ord n, Floating n) => Deformation v n -> FixedSegment v n -> FixedSegment v n +approx :: (Metric v, OrderedField n) => Deformation v n -> FixedSegment v n -> FixedSegment v n approx t (FLinear p0 p1) = FLinear (deform t p0) (deform t p1) approx t (FCubic p0 c1 c2 p1) = FCubic (f p0) (f c1) (f c2) (f p1) where f = deform t -goodEnough :: (Metric v, Ord n, Floating n, Epsilon n) => n -> Deformation v n -> FixedSegment v n -> Bool +goodEnough :: (Metric v, Ord n, Floating n) => n -> Deformation v n -> FixedSegment v n -> Bool goodEnough e t s = all (< e) [norm $ deform t (s `atParam` u) .-. approx t s `atParam` u | u <- [0.25, 0.5, 0.75]] -instance (Metric v, Ord n, Floating n, Epsilon n) => Deformable (Located (Trail v n)) where +instance (Metric v, OrderedField n) => Deformable (Located (Trail v n)) where deform' eps p t | isLine $ unLoc t = line `at` p0 | otherwise = glueTrail line `at` p0 @@ -110,7 +109,7 @@ instance (Metric v, Ord n, Floating n, Epsilon n) => Deformable (Located (Trail extent = maximum . map dist . trailVertices $ t dist pt = norm $ pt .-. loc t -instance (Metric v, Ord n, Floating n, Epsilon n) => Deformable (Path v n) where +instance (Metric v, OrderedField n) => Deformable (Path v n) where deform' eps p = under _Unwrapped $ map (deform' eps p) deform p = under _Unwrapped $ map (deform p) diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index 9c8696d1..4e2901c9 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -19,12 +19,11 @@ module Diagrams.Direction , angleBetweenDirs ) where -import Control.Lens (Iso', iso) +import Control.Lens (Iso', iso) -import Diagrams.Angle -import Diagrams.Core +import Diagrams.Angle +import Diagrams.Core import Linear.Metric -import Linear.Epsilon -------------------------------------------------------------------------------- -- Direction @@ -61,11 +60,11 @@ direction :: v n -> Direction v n direction = Direction -- | @fromDirection d@ is the unit vector in the direction @d@. -fromDirection :: (Metric v, Floating n, Epsilon n) => Direction v n -> v n -fromDirection (Direction v) = normalize v +fromDirection :: (Metric v, Floating n) => Direction v n -> v n +fromDirection (Direction v) = signorm v -- | compute the positive angle between the two directions in their common plane -angleBetweenDirs :: (Metric v, Floating n, Epsilon n) => +angleBetweenDirs :: (Metric v, Floating n) => Direction v n -> Direction v n -> Angle n angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index 7ec515f3..bb896bc5 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -63,7 +63,9 @@ module Diagrams.Segment ) where -import Control.Lens (Rewrapped, Wrapped (..), iso, makeLenses, op, Traversal, over) +import Control.Lens (Rewrapped, Traversal, + Wrapped (..), iso, + makeLenses, op, over) import Data.FingerTree import Data.Monoid.MList import Data.Semigroup @@ -71,14 +73,14 @@ import Numeric.Interval.Kaucher (Interval (..)) import qualified Numeric.Interval.Kaucher as I import Linear.Affine -import Linear.Vector import Linear.Metric +import Linear.Vector -import Diagrams.Core -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Solve import Control.Applicative +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Solve ------------------------------------------------------------ @@ -151,7 +153,7 @@ data Segment c v n deriving (Show, Functor, Eq, Ord) --- this is provided as a replacement of the previous fmap functionality. (Now +-- this is provided as a replacement of the previous fmap functionality. (Now -- fmap is only over the number type) -- Prehaps a traversal is overkill. Only really need to map over segment vectors. diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index edb2ac72..e784fcaf 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -143,7 +143,7 @@ camRight c = direction right where camLens :: Camera l n -> l n camLens = lens -camAspect :: Floating n => CameraLens l => Camera l n -> n +camAspect :: (Floating n, CameraLens l) => Camera l n -> n camAspect = aspect . camLens {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs index 5acbaab9..56e76022 100644 --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -48,14 +48,14 @@ instance Fractional n => Transformable (ParallelLight n) where -- | Construct a Diagram with a single PointLight at the origin, which -- takes up no space. -pointLight :: (Typeable n, Num n, Ord n, Backend b V3 n, Renderable (PointLight n) b) +pointLight :: (Typeable n, Num n, Ord n, Renderable (PointLight n) b) => Colour Double -- ^ The color of the light -> Diagram b V3 n pointLight c = mkQD (Prim $ PointLight origin c) mempty mempty mempty (Query . const . Any $ False) -- | Construct a Diagram with a single ParallelLight, which takes up no space. -parallelLight :: (Typeable n, OrderedField n, Backend b V3 n, Renderable (ParallelLight n) b) +parallelLight :: (Typeable n, OrderedField n, Renderable (ParallelLight n) b) => Direction V3 n -- ^ The direction in which the light travels. -> Colour Double -- ^ The color of the light. -> Diagram b V3 n diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 61f298b6..7d08ca5e 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -60,7 +60,6 @@ import Diagrams.TwoD.Transform hiding (reflectAbout, reflectionAbout, rotationAbout) import Linear.Affine -import Linear.Epsilon import Linear.Metric import Linear.V3 (cross) import Linear.Vector @@ -107,7 +106,7 @@ aboutY (view rad -> a) = fromOrthogonal r where -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. rotationAbout - :: (Floating n, Epsilon n) + :: (Floating n) => Point V3 n -- ^ origin of rotation -> Direction V3 n -- ^ direction of rotation axis -> Angle n -- ^ angle of rotation @@ -130,18 +129,18 @@ rotationAbout (P t) d (view rad -> a) -- without tilting, it will be, otherwise if only tilting is -- necessary, no panning will occur. The tilt will always be between -- ± 1/4 turn. -pointAt :: (Floating n, Epsilon n) +pointAt :: (Floating n) => Direction V3 n -> Direction V3 n -> Direction V3 n -> Transformation V3 n pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) -- | pointAt' has the same behavior as 'pointAt', but takes vectors -- instead of directions. -pointAt' :: (Floating n, Epsilon n) => V3 n -> V3 n -> V3 n -> Transformation V3 n +pointAt' :: (Floating n) => V3 n -> V3 n -> V3 n -> Transformation V3 n pointAt' about initial final = pointAtUnit (signorm about) (signorm initial) (signorm final) -- | pointAtUnit has the same behavior as @pointAt@, but takes unit vectors. -pointAtUnit :: (Floating n, Epsilon n) => V3 n -> V3 n -> V3 n -> Transformation V3 n +pointAtUnit :: (Floating n) => V3 n -> V3 n -> V3 n -> Transformation V3 n pointAtUnit about initial final = tilt <> pan where -- rotating u by (signedAngle rel u v) about rel gives a vector in the direction of v signedAngle rel u v = signum (cross u v `dot` rel) *^ angleBetween u v diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 475b1db8..bf8998cd 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -103,27 +103,27 @@ module Diagrams.Trail ) where import Control.Arrow ((***)) -import Control.Lens (AnIso', Rewrapped, Wrapped (..), cloneIso, iso, op, view, - (^.)) --- import Data.AffineSpace -import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), (|>)) +import Control.Lens (AnIso', Rewrapped, + Wrapped (..), cloneIso, iso, + op, view, (^.)) +import Data.FingerTree (FingerTree, ViewL (..), + ViewR (..), (<|), (|>)) import qualified Data.FingerTree as FT +import Data.Fixed import qualified Data.Foldable as F import Data.Monoid.MList import Data.Semigroup --- import Data.Additive hiding (Sum (..)) import qualified Numeric.Interval.Kaucher as I -import Diagrams.Core hiding ((|>)) -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Segment -import Diagrams.Tangent +import Diagrams.Core hiding ((|>)) +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment +import Diagrams.Tangent import Linear.Affine -import Linear.Vector import Linear.Metric -import Linear.Epsilon +import Linear.Vector -- $internals -- @@ -176,16 +176,16 @@ deriving instance (Metric v, OrderedField n) type instance Codomain (SegTree v n) = v -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => Parametric (SegTree v n) where atParam t p = offset . fst $ splitAtParam t p instance Num n => DomainBounds (SegTree v n) -instance (Metric v, OrderedField n, RealFrac n, Num n) +instance (Metric v, OrderedField n, Real n) => EndValues (SegTree v n) -instance (Metric v, RealFrac n, Floating n, Epsilon n) => Sectionable (SegTree v n) where +instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where splitAtParam (SegTree t) p | p < 0 = case FT.viewl t of EmptyL -> emptySplit @@ -204,7 +204,7 @@ instance (Metric v, RealFrac n, Floating n, Epsilon n) => Sectionable (SegTree v | otherwise = case FT.viewl after of EmptyL -> emptySplit seg :< after' -> - case seg `splitAtParam` (snd . propFrac $ p * tSegs) of + case seg `splitAtParam` mod1 (p * tSegs) of (seg1, seg2) -> ( SegTree $ before |> seg1 , SegTree $ seg2 <| after' ) @@ -219,7 +219,7 @@ instance (Metric v, RealFrac n, Floating n, Epsilon n) => Sectionable (SegTree v -- XXX seems like it should be possible to collapse some of the -- above cases into one? -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => HasArcLength (SegTree v n) where arcLengthBounded eps t -- Use the cached value if it is accurate enough; otherwise fall @@ -399,7 +399,7 @@ instance (HasLinearMap v, Metric v, OrderedField n) => Renderable (Trail' o v n) NullBackend where render _ _ = mempty -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => Parametric (Trail' l v n) where atParam t p = withTrail' (\(Line segT) -> segT `atParam` p) @@ -432,7 +432,7 @@ instance ( Parametric (GetSegment (Trail' c v n)) type instance Codomain (Tangent (Trail v n)) = Codomain (Trail v n) -instance (Metric v , OrderedField n, RealFrac n) +instance (Metric v , OrderedField n, Real n) => Parametric (Tangent (Trail v n)) where Tangent tr `atParam` p = withTrail @@ -440,30 +440,22 @@ instance (Metric v , OrderedField n, RealFrac n) ((`atParam` p) . Tangent) tr -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => EndValues (Tangent (Trail v n)) where atStart (Tangent tr) = withTrail (atStart . Tangent) (atStart . Tangent) tr atEnd (Tangent tr) = withTrail (atEnd . Tangent) (atEnd . Tangent) tr -- | Compute the remainder mod 1. Convenient for constructing loop -- parameterizations that wrap around. -mod1 :: RealFrac a => a -> a -mod1 p = p' - where - pf = snd . propFrac $ p - p' | p >= 0 = pf - | otherwise = 1 + pf - --- Get rid of defaulting warnings -propFrac :: RealFrac a => a -> (Int, a) -propFrac = properFraction +mod1 :: Real a => a -> a +mod1 = (`mod'` 1) instance Num n => DomainBounds (Trail' l v n) -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => EndValues (Trail' l v n) -instance (Metric v, RealFrac n, Floating n, Epsilon n) +instance (Metric v, OrderedField n, Real n) => Sectionable (Trail' Line v n) where splitAtParam (Line t) p = (Line t1, Line t2) where @@ -471,7 +463,7 @@ instance (Metric v, RealFrac n, Floating n, Epsilon n) reverseDomain = reverseLine -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => HasArcLength (Trail' l v n) where arcLengthBounded eps = withTrail' @@ -564,10 +556,10 @@ instance (Metric v, OrderedField n) => Parametric (GetSegment (Trail' Line v n)) -- | The parameterization for loops wraps around, /i.e./ parameters -- are first reduced \"mod 1\". -instance (Metric v, OrderedField n, RealFrac n) => Parametric (GetSegment (Trail' Loop v n)) where +instance (Metric v, OrderedField n, Real n) => Parametric (GetSegment (Trail' Loop v n)) where atParam (GetSegment l) p = atParam (GetSegment (cutLoop l)) (mod1 p) -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => Parametric (GetSegment (Trail v n)) where atParam (GetSegment t) p = withTrail @@ -579,7 +571,7 @@ instance DomainBounds t => DomainBounds (GetSegment t) where domainLower (GetSegment t) = domainLower t domainUpper (GetSegment t) = domainUpper t -instance (Metric v, OrderedField n) +instance (Metric v, OrderedField n, Real n) => EndValues (GetSegment (Trail' Line v n)) where atStart (GetSegment (Line (SegTree ft))) = case FT.viewl ft of @@ -593,17 +585,17 @@ instance (Metric v, OrderedField n) EmptyR -> GetSegmentCodomain Nothing ft' :> seg -> let n = numSegs ft - in GetSegmentCodomain $ + in GetSegmentCodomain $ Just (offset ft', seg, iso (subtract (n-1) . (*n)) ((/n) . (+ (n-1))) ) -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => EndValues (GetSegment (Trail' Loop v n)) where atStart (GetSegment l) = atStart (GetSegment (cutLoop l)) atEnd (GetSegment l) = atEnd (GetSegment (cutLoop l)) -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => EndValues (GetSegment (Trail v n)) where atStart (GetSegment t) = withTrail @@ -677,13 +669,13 @@ instance (HasLinearMap v, Metric v, OrderedField n) instance (Metric v, OrderedField n) => Enveloped (Trail v n) where getEnvelope = withTrail getEnvelope getEnvelope -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => Parametric (Trail v n) where atParam t p = withTrail (`atParam` p) (`atParam` p) t instance Num n => DomainBounds (Trail v n) -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => EndValues (Trail v n) -- | Note that there is no @Sectionable@ instance for @Trail' Loop@, @@ -695,13 +687,13 @@ instance (Metric v, OrderedField n, RealFrac n) -- semantically a bit silly, so please don't rely on it. (*E.g.* if -- this is really the behavior you want, consider first calling -- 'cutLoop' yourself.) -instance (Metric v, RealFrac n, Floating n, Epsilon n) +instance (Metric v, OrderedField n, Real n) => Sectionable (Trail v n) where splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t reverseDomain = reverseTrail -instance (Metric v, OrderedField n, RealFrac n) +instance (Metric v, OrderedField n, Real n) => HasArcLength (Trail v n) where arcLengthBounded = withLine . arcLengthBounded arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr @@ -1088,8 +1080,8 @@ loopVertices' toler (viewLoc -> (p,t)) | length segs > 1 = if far > toler then init ps else init . drop 1 $ ps | otherwise = ps where - far = quadrance ((normalize . tangentAtStart . head $ segs) ^-^ - (normalize . tangentAtEnd . last $ segs)) + far = quadrance ((signorm . tangentAtStart . head $ segs) ^-^ + (signorm . tangentAtEnd . last $ segs)) segs = lineSegments . cutLoop $ t ps = segmentVertices' toler p segs @@ -1112,8 +1104,8 @@ segmentVertices' toler p ts = _ -> ps where ds = zipWith far tans (drop 1 tans) - tans = [(normalize . tangentAtStart $ s - ,normalize . tangentAtEnd $ s) | s <- ts] + tans = [(signorm . tangentAtStart $ s + ,signorm . tangentAtEnd $ s) | s <- ts] ps = scanl (.+^) p . map segOffset $ ts far p2 q2 = quadrance (snd p2 ^-^ fst q2) > toler diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs index ba84fa52..0f9d0eff 100644 --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -34,11 +34,7 @@ import Control.Lens (Lens', (&), (.~), (^.), over, both) import Data.Default.Class import Data.Semigroup -import Data.Data import Linear.Affine -import Linear.Epsilon - -type TypeableFloat n = (Data n, Typeable n, RealFloat n, Epsilon n) -- | Set default attributes of a 2D diagram (in case they have not -- been set): @@ -54,7 +50,7 @@ type TypeableFloat n = (Data n, Typeable n, RealFloat n, Epsilon n) -- * line join miter -- -- * Miter limit 10 -setDefault2DAttributes :: (TypeableFloat n, Semigroup m) => QDiagram b V2 n m -> QDiagram b V2 n m +setDefault2DAttributes :: (DataFloat n, Semigroup m) => QDiagram b V2 n m -> QDiagram b V2 n m setDefault2DAttributes d = d # lineWidthA def # lineTextureA def # fontSizeA def # lineCap def # lineJoin def # lineMiterLimitA def @@ -103,7 +99,7 @@ adjustDiaSize2D szL _ opts d = -- to the diagram (the inverse of which can be used, say, to -- translate output/device coordinates back into local diagram -- coordinates), and the modified diagram itself. -adjustDia2D :: (TypeableFloat n, Monoid' m) +adjustDia2D :: (DataFloat n, Monoid' m) => Lens' (Options b V2 n) (SizeSpec2D n) -> b -> Options b V2 n -> QDiagram b V2 n m -> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m) diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index 2e4af14c..0069143f 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -39,7 +39,6 @@ import Diagrams.Util (( # )) import Control.Lens ((&), (<>~), (^.)) import Data.Semigroup ((<>)) -import Linear.Epsilon import Linear.Vector import Linear.Metric import Linear.Affine @@ -96,7 +95,7 @@ the approximation error. -- is the 'Trail' of a radius one arc starting at @d@ and sweeping out -- the angle @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arcT :: (RealFloat n, Epsilon n) => Direction V2 n -> Angle n -> Trail V2 n +arcT :: RealFloat n => Direction V2 n -> Angle n -> Trail V2 n arcT start sweep = trailFromSegments bs where bs = map (rotate $ start ^. _theta) . bezierFromSweep $ sweep @@ -105,7 +104,7 @@ arcT start sweep = trailFromSegments bs -- path of a radius one arc starting at @d@ and sweeping out the angle -- @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arc :: (TrailLike t, Vn t ~ V2 n, RealFloat n, Epsilon n) => Direction V2 n -> Angle n -> t +arc :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => Direction V2 n -> Angle n -> t arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ p2 (1,0)) -- | Given a radus @r@, a start direction @d@ and an angle @s@, diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 7de8e7be..8ca326e0 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -111,7 +111,6 @@ import Data.Monoid.Coproduct (untangle) import Data.Semigroup import Data.Colour hiding (atop) -import Data.Data import Diagrams.Core import Diagrams.Core.Types (QDiaLeaf (..), mkQD') @@ -132,11 +131,9 @@ import Diagrams.TwoD.Vector (unitX, unit_X) import Diagrams.Util (( # )) import Linear.Affine -import Linear.Epsilon import Linear.Vector import Linear.Metric -type TypeableReal n = (Epsilon n, Typeable n, RealFloat n, Data n) data ArrowOpts n = ArrowOpts @@ -156,7 +153,7 @@ data ArrowOpts n straightShaft :: OrderedField n => Trail V2 n straightShaft = trailFromOffsets [unitX] -instance (Epsilon n, RealFloat n) => Default (ArrowOpts n) where +instance RealFloat n => Default (ArrowOpts n) where def = ArrowOpts { _arrowHead = dart , _arrowTail = noTail @@ -228,17 +225,17 @@ lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts -- defined. Or @... (with & headTexture .~ solid blue@ to set the head -- color to blue. For more general control over the style of arrowheads, -- see 'headStyle'. -headTexture :: TypeableReal n => Setter' (ArrowOpts n) (Texture n) +headTexture :: TypeableFloat n => Setter' (ArrowOpts n) (Texture n) headTexture = headStyle . styleFillTexture -- | A lens for setting or modifying the texture of an arrow -- tail. -tailTexture :: TypeableReal n => Setter' (ArrowOpts n) (Texture n) +tailTexture :: TypeableFloat n => Setter' (ArrowOpts n) (Texture n) tailTexture = tailStyle . styleFillTexture -- | A lens for setting or modifying the texture of an arrow -- shaft. -shaftTexture :: TypeableReal n => Setter' (ArrowOpts n) (Texture n) +shaftTexture :: TypeableFloat n => Setter' (ArrowOpts n) (Texture n) shaftTexture = shaftStyle . styleLineTexture -- Set the default shaft style of an `ArrowOpts` record by applying the @@ -249,14 +246,14 @@ shaftSty :: (Fractional n) => ArrowOpts n -> Style V2 n shaftSty opts = opts^.shaftStyle -- Set the default head style. See `shaftSty`. -headSty :: TypeableReal n => ArrowOpts n -> Style V2 n +headSty :: TypeableFloat n => ArrowOpts n -> Style V2 n headSty opts = fc black (opts^.headStyle) -- Set the default tail style. See `shaftSty`. -tailSty :: TypeableReal n => ArrowOpts n -> Style V2 n +tailSty :: TypeableFloat n => ArrowOpts n -> Style V2 n tailSty opts = fc black (opts^.tailStyle) -fromMeasure :: TypeableReal n => n -> n -> Measure n -> n +fromMeasure :: TypeableFloat n => n -> n -> Measure n -> n fromMeasure g n m = u where Output u = toOutput g n m @@ -270,7 +267,7 @@ xWidth p = a + b -- | Get the line color from the shaft to use as the fill color for the joint. -- And set the opacity of the shaft to the current opacity. -colorJoint :: TypeableReal n => Style V2 n -> Style V2 n +colorJoint :: TypeableFloat n => Style V2 n -> Style V2 n colorJoint sStyle = let c = fmap getLineTexture . getAttr $ sStyle o = fmap getOpacity . getAttr $ sStyle @@ -282,7 +279,7 @@ colorJoint sStyle = (Just t, Just o') -> opacity o' . fillTexture t $ mempty -- | Get line width from a style. -widthOfJoint :: forall n. TypeableReal n => Style V2 n -> n -> n -> n +widthOfJoint :: forall n. TypeableFloat n => Style V2 n -> n -> n -> n widthOfJoint sStyle gToO nToO = maybe (fromMeasure gToO nToO (Output 1 :: Measure n)) -- Should be same as default line width (fromMeasure gToO nToO) @@ -291,7 +288,7 @@ widthOfJoint sStyle gToO nToO = -- | Combine the head and its joint into a single scale invariant diagram -- and move the origin to the attachment point. Return the diagram -- and its width. -mkHead :: (TypeableReal n, Renderable (Path V2 n) b) => +mkHead :: (DataFloat n, Renderable (Path V2 n) b) => n -> ArrowOpts n -> n -> n -> (Diagram b V2 n, n) mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 , hWidth + jWidth) @@ -304,7 +301,7 @@ mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) -- | Just like mkHead only the attachment point is on the right. -mkTail :: (TypeableReal n, Renderable (Path V2 n) b) => +mkTail :: (DataFloat n, Renderable (Path V2 n) b) => n -> ArrowOpts n -> n -> n -> (Diagram b V2 n, n) mkTail size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 , tWidth + jWidth) @@ -319,17 +316,17 @@ mkTail size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 -- | Make a trail with the same angles and offset as an arrow with tail width -- tw, head width hw and shaft of tr, such that the magnituted of the shaft -- offset is size. Used for calculating the offset of an arrow. -spine :: TypeableReal n => Trail V2 n -> n -> n -> n -> Trail V2 n +spine :: TypeableFloat n => Trail V2 n -> n -> n -> n -> Trail V2 n spine tr tw hw size = tS <> tr # scale size <> hS where - tSpine = trailFromOffsets [normalize . tangentAtStart $ tr] # scale tw - hSpine = trailFromOffsets [normalize . tangentAtEnd $ tr] # scale hw + tSpine = trailFromOffsets [signorm . tangentAtStart $ tr] # scale tw + hSpine = trailFromOffsets [signorm . tangentAtEnd $ tr] # scale hw hS = if hw > 0 then hSpine else mempty tS = if tw > 0 then tSpine else mempty -- | Calculate the amount required to scale a shaft trail so that an arrow with -- head width hw and tail width tw has offset t. -scaleFactor :: TypeableReal n => Trail V2 n -> n -> n -> n -> n +scaleFactor :: TypeableFloat n => Trail V2 n -> n -> n -> n -> n scaleFactor tr tw hw t -- Let tv be a vector representing the tail width, i.e. a vector @@ -354,13 +351,13 @@ scaleFactor tr tw hw t -- we will usually get both a positive and a negative solution; -- return the maximum (i.e. positive) solution where - tv = tw *^ (tangentAtStart tr # normalize) - hv = hw *^ (tangentAtEnd tr # normalize) + tv = tw *^ (tangentAtStart tr # signorm) + hv = hw *^ (tangentAtEnd tr # signorm) v = trailOffset tr -- Calculate the approximate envelope of a horizontal arrow -- as if the arrow were made only of a shaft. -arrowEnv :: TypeableReal n => ArrowOpts n -> n -> Envelope V2 n +arrowEnv :: TypeableFloat n => ArrowOpts n -> n -> Envelope V2 n arrowEnv opts len = getEnvelope horizShaft where horizShaft = shaft # rotate (negated (v ^. _theta)) # scale (len / m) @@ -371,14 +368,14 @@ arrowEnv opts len = getEnvelope horizShaft -- | @arrow len@ creates an arrow of length @len@ with default -- parameters, starting at the origin and ending at the point -- @(len,0)@. -arrow :: (TypeableReal n, Renderable (Path V2 n) b) => n -> Diagram b V2 n +arrow :: (DataFloat n, Renderable (Path V2 n) b) => n -> Diagram b V2 n arrow = arrow' def -- | @arrow' opts len@ creates an arrow of length @len@ using the -- given options, starting at the origin and ending at the point -- @(len,0)@. In particular, it scales the given 'arrowShaft' so -- that the entire arrow has length @len@. -arrow' :: (TypeableReal n, Renderable (Path V2 n) b) => ArrowOpts n -> n -> Diagram b V2 n +arrow' :: (DataFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> n -> Diagram b V2 n arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- Currently arrows have an empty envelope and trace. @@ -470,7 +467,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- | @arrowBetween s e@ creates an arrow pointing from @s@ to @e@ -- with default parameters. -arrowBetween :: (TypeableReal n, Renderable (Path V2 n) b) => Point V2 n -> Point V2 n -> Diagram b V2 n +arrowBetween :: (DataFloat n, Renderable (Path V2 n) b) => Point V2 n -> Point V2 n -> Diagram b V2 n arrowBetween = arrowBetween' def -- | @arrowBetween' opts s e@ creates an arrow pointing from @s@ to @@ -478,17 +475,17 @@ arrowBetween = arrowBetween' def -- rotates @arrowShaft@ to go between @s@ and @e@, taking head, -- tail, and gaps into account. arrowBetween' - :: (TypeableReal n, Renderable (Path V2 n) b) => + :: (DataFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> Point V2 n -> Point V2 n -> Diagram b V2 n arrowBetween' opts s e = arrowAt' opts s (e .-. s) -- | Create an arrow starting at s with length and direction determined by -- the vector v. -arrowAt :: (TypeableReal n, Renderable (Path V2 n) b) => Point V2 n -> V2 n -> Diagram b V2 n +arrowAt :: (DataFloat n, Renderable (Path V2 n) b) => Point V2 n -> V2 n -> Diagram b V2 n arrowAt = arrowAt' def arrowAt' - :: (TypeableReal n, Renderable (Path V2 n) b) => + :: (DataFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> Point V2 n -> V2 n -> Diagram b V2 n arrowAt' opts s v = arrow' opts len # rotate dir # moveTo s @@ -499,25 +496,25 @@ arrowAt' opts s v = arrow' opts len -- | @arrowV v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin), using default -- parameters. -arrowV :: (TypeableReal n, Renderable (Path V2 n) b) => V2 n -> Diagram b V2 n +arrowV :: (DataFloat n, Renderable (Path V2 n) b) => V2 n -> Diagram b V2 n arrowV = arrowV' def -- | @arrowV' v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin). arrowV' - :: (TypeableReal n, Renderable (Path V2 n) b) + :: (DataFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> V2 n -> Diagram b V2 n arrowV' opts = arrowAt' opts origin -- | Connect two diagrams with a straight arrow. connect - :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + :: (DataFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => n1 -> n2 -> Diagram b V2 n -> Diagram b V2 n connect = connect' def -- | Connect two diagrams with an arbitrary arrow. connect' - :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + :: (DataFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => ArrowOpts n -> n1 -> n2 -> Diagram b V2 n -> Diagram b V2 n connect' opts n1 n2 = withName n1 $ \sub1 -> @@ -528,13 +525,13 @@ connect' opts n1 n2 = -- | Connect two diagrams at point on the perimeter of the diagrams, choosen -- by angle. connectPerim - :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + :: (DataFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => n1 -> n2 -> Angle n -> Angle n -> Diagram b V2 n -> Diagram b V2 n connectPerim = connectPerim' def connectPerim' - :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + :: (DataFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => ArrowOpts n -> n1 -> n2 -> Angle n -> Angle n -> Diagram b V2 n -> Diagram b V2 n connectPerim' opts n1 n2 a1 a2 = @@ -550,12 +547,12 @@ connectPerim' opts n1 n2 a1 a2 = -- drawn so that it stops at the boundaries of the diagrams, using traces -- to find the intersection points. connectOutside - :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + :: (DataFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => n1 -> n2 -> Diagram b V2 n -> Diagram b V2 n connectOutside = connectOutside' def connectOutside' - :: (TypeableReal n, Renderable (Path V2 n) b, IsName n1, IsName n2) + :: (DataFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => ArrowOpts n -> n1 -> n2 -> Diagram b V2 n -> Diagram b V2 n connectOutside' opts n1 n2 = withName n1 $ \b1 -> diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index b4aaaa21..2d24daaf 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -78,7 +78,6 @@ import Diagrams.TwoD.Vector (unitX, unit_X, xDir) import Diagrams.Util (( # )) import Linear.Affine -import Linear.Epsilon import Linear.Vector import Linear.Metric @@ -101,7 +100,7 @@ closedPath = pathFromTrail . closeTrail -- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 @@ turn) & shaftStyle %~ lw none) -- > origin (r2 (0.001, 0)) -- > <> square 0.6 # alignL # lw none -arrowheadTriangle :: (Epsilon n, RealFloat n) => Angle n -> ArrowHT n +arrowheadTriangle :: RealFloat n => Angle n -> ArrowHT n arrowheadTriangle theta = aHead where aHead len _ = (p, mempty) @@ -113,7 +112,7 @@ arrowheadTriangle theta = aHead -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. -arrowheadDart :: (Epsilon n, RealFloat n) => Angle n -> ArrowHT n +arrowheadDart :: RealFloat n => Angle n -> ArrowHT n arrowheadDart theta len shaftWidth = (hd # scale size, jt) where hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] @@ -129,7 +128,7 @@ arrowheadDart theta len shaftWidth = (hd # scale size, jt) size = max 1 ((len - jLength) / 1.5) -- | Isoceles triangle with curved concave base. Inkscape type 2. -arrowheadSpike :: (RealFloat n, Epsilon n) => Angle n -> ArrowHT n +arrowheadSpike :: RealFloat n => Angle n -> ArrowHT n arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) where hd = snugL . closedPath $ l1 <> c <> l2 @@ -157,7 +156,7 @@ arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) phi = asinA (min 1 (y/r)) -- | Curved sides, linear concave base. Illustrator CS5 #3 -arrowheadThorn :: (Epsilon n, RealFloat n) => Angle n -> ArrowHT n +arrowheadThorn :: RealFloat n => Angle n -> ArrowHT n arrowheadThorn theta len shaftWidth = (hd # scale size, jt) where hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop @@ -186,7 +185,7 @@ curvedSide theta = bezier3 ctrl1 ctrl2 end -- Standard heads --------------------------------------------------------- -- | A line the same width as the shaft. -lineHead :: (Epsilon n, RealFloat n) => ArrowHT n +lineHead :: RealFloat n => ArrowHT n lineHead s w = (square 1 # scaleX s # scaleY w # alignL, mempty) noHead :: (Floating n, Ord n) => ArrowHT n @@ -195,25 +194,25 @@ noHead _ _ = (mempty, mempty) -- | <> -- > triEx = drawHead tri -tri :: (Epsilon n, RealFloat n) => ArrowHT n +tri :: RealFloat n => ArrowHT n tri = arrowheadTriangle (1/3 @@ turn) -- | <> -- > spikeEx = drawHead spike -spike :: (Epsilon n, RealFloat n) => ArrowHT n +spike :: RealFloat n => ArrowHT n spike = arrowheadSpike (3/8 @@ turn) -- | <> -- > thornEx = drawHead thorn -thorn :: (Epsilon n, RealFloat n) => ArrowHT n +thorn :: RealFloat n => ArrowHT n thorn = arrowheadThorn (3/8 @@ turn) -- | <> -- > dartEx = drawHead dart -dart :: (Epsilon n, RealFloat n) => ArrowHT n +dart :: RealFloat n => ArrowHT n dart = arrowheadDart (2/5 @@ turn) -- Tails ------------------------------------------------------------------ @@ -232,7 +231,7 @@ headToTail hd = tl t = reflectX t' j = reflectX j' -arrowtailBlock :: forall n. (Epsilon n, RealFloat n) => Angle n -> ArrowHT n +arrowtailBlock :: forall n. (RealFloat n) => Angle n -> ArrowHT n arrowtailBlock theta = aTail where aTail len _ = (t, mempty) @@ -244,7 +243,7 @@ arrowtailBlock theta = aTail x = norm a -- | The angle is where the top left corner intersects the circle. -arrowtailQuill :: (Floating n, Ord n, Epsilon n) => Angle n -> ArrowHT n +arrowtailQuill :: (Floating n, Ord n) => Angle n -> ArrowHT n arrowtailQuill theta = aTail where aTail len shaftWidth = (t, j) @@ -267,7 +266,7 @@ arrowtailQuill theta = aTail -- Standard tails --------------------------------------------------------- -- | A line the same width as the shaft. -lineTail :: (RealFloat n, Epsilon n) => ArrowHT n +lineTail :: (RealFloat n) => ArrowHT n lineTail s w = (square 1 # scaleY w # scaleX s # alignR, mempty) noTail :: (Floating n, Ord n) => ArrowHT n @@ -276,36 +275,36 @@ noTail _ _ = (mempty, mempty) -- | <> -- > tri'Ex = drawTail tri' -tri' :: (RealFloat n, Epsilon n) => ArrowHT n +tri' :: RealFloat n => ArrowHT n tri' = headToTail tri -- | <> -- > spike'Ex = drawTail spike' -spike' :: (Epsilon n, RealFloat n) => ArrowHT n +spike' :: RealFloat n => ArrowHT n spike' = headToTail spike -- | <> -- > thorn'Ex = drawTail thorn' -thorn' :: (Epsilon n, RealFloat n) => ArrowHT n +thorn' :: RealFloat n => ArrowHT n thorn' = headToTail thorn -- | <> -- > dart'Ex = drawTail dart' -dart' :: (Epsilon n, RealFloat n) => ArrowHT n +dart' :: RealFloat n => ArrowHT n dart' = headToTail dart -- | <> -- > quillEx = drawTail quill -quill :: (Floating n, Ord n, Epsilon n) => ArrowHT n +quill :: (Floating n, Ord n) => ArrowHT n quill = arrowtailQuill (2/5 @@ turn) -- | <> -- > blockEx = drawTail block -block :: (RealFloat n, Epsilon n) => ArrowHT n +block :: RealFloat n => ArrowHT n block = arrowtailBlock (7/16 @@ turn) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index c14d5a4a..f9089a7a 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -59,14 +59,11 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Diagrams.Util (( # )) -import Data.Typeable -import Data.Data +-- import Data.Typeable +-- import Data.Data import Linear.Affine -import Linear.Epsilon import Linear.Vector -type TypeableReal a = (Epsilon a, RealFloat a, Typeable a, Data a) - infixl 6 === infixl 6 ||| @@ -84,7 +81,7 @@ infixl 6 ||| -- combined diagram is the same as the local origin of the first. -- @(===)@ is associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. -(===) :: (Juxtaposable a, Vn a ~ V2 n, TypeableReal n, Semigroup a) => a -> a -> a +(===) :: (Juxtaposable a, Vn a ~ V2 n, TypeableFloat n, Semigroup a) => a -> a -> a (===) = beside unit_Y -- | Place two diagrams (or other juxtaposable objects) horizontally @@ -93,7 +90,7 @@ infixl 6 ||| -- is the same as the local origin of the first. @(|||)@ is -- associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. -(|||) :: (Juxtaposable a, Vn a ~ V2 n, TypeableReal n, Semigroup a) => a -> a -> a +(|||) :: (Juxtaposable a, Vn a ~ V2 n, TypeableFloat n, Semigroup a) => a -> a -> a (|||) = beside unitX -- | Lay out a list of juxtaposable objects in a row from left to right, @@ -107,7 +104,7 @@ infixl 6 ||| -- "Diagrams.TwoD.Align" before applying 'hcat'. -- -- * For non-axis-aligned layout, see 'cat'. -hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) +hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) => [a] -> a hcat = hcat' def @@ -115,13 +112,13 @@ hcat = hcat' def -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. For the common case of setting just a -- separation amount, see 'hsep'. -hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) +hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) => CatOpts n -> [a] -> a hcat' = cat' unitX -- | A convenient synonym for horizontal concatenation with -- separation: @hsep s === hcat' (with & sep .~ s)@. -hsep :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) +hsep :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) => n -> [a] -> a hsep s = hcat' (def & sep .~ s) @@ -136,7 +133,7 @@ hsep s = hcat' (def & sep .~ s) -- "Diagrams.TwoD.Align" before applying 'vcat'. -- -- * For non-axis-aligned layout, see 'cat'. -vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) +vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) => [a] -> a vcat = vcat' def @@ -144,13 +141,13 @@ vcat = vcat' def -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. For the common case of setting just a -- separation amount, see 'vsep'. -vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) +vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) => CatOpts n -> [a] -> a vcat' = cat' unit_Y -- | A convenient synonym for vertical concatenation with -- separation: @vsep s === vcat' (with & sep .~ s)@. -vsep :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableReal n) +vsep :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) => n -> [a] -> a vsep s = vcat' (def & sep .~ s) @@ -160,7 +157,7 @@ vsep s = vcat' (def & sep .~ s) -- local origin at its center. If you don't care about the trace -- then there's no difference between @strutR2@ and the more general -- 'strut'. -strutR2 :: (Monoid' m, TypeableReal n) => V2 n -> QDiagram b V2 n m +strutR2 :: (Monoid' m, TypeableFloat n) => V2 n -> QDiagram b V2 n m strutR2 v = phantom seg where seg = FLinear (origin .+^ 0.5 *^ v) (origin .+^ (-0.5) *^ v) @@ -168,13 +165,13 @@ strutR2 v = phantom seg -- | @strutX w@ is an empty diagram with width @w@, height 0, and a -- centered local origin. Note that @strutX (-w)@ behaves the same as -- @strutX w@. -strutX :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m +strutX :: (Monoid' m, TypeableFloat n) => n -> QDiagram b V2 n m strutX d = strut (V2 d 0) -- | @strutY h@ is an empty diagram with height @h@, width 0, and a -- centered local origin. Note that @strutY (-h)@ behaves the same as -- @strutY h@. -strutY :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m +strutY :: (Monoid' m, TypeableFloat n) => n -> QDiagram b V2 n m strutY d = strut (V2 0 d) -- | @padX s@ \"pads\" a diagram in the x-direction, expanding its @@ -184,7 +181,7 @@ strutY d = strut (V2 0 d) -- centered horizontally the padding may appear \"uneven\". If this -- is not desired, the origin can be centered (using 'centerX') -- before applying @padX@. -padX :: (Monoid' m, TypeableReal n ) +padX :: (Monoid' m, TypeableFloat n ) => n -> QDiagram b V2 n m -> QDiagram b V2 n m padX s d = withEnvelope (d # scaleX s) d @@ -195,7 +192,7 @@ padX s d = withEnvelope (d # scaleX s) d -- so if the origin is not centered vertically the padding may appear -- \"uneven\". If this is not desired, the origin can be centered -- (using 'centerY') before applying @padY@. -padY :: (Monoid' m, TypeableReal n ) +padY :: (Monoid' m, TypeableFloat n ) => n -> QDiagram b V2 n m -> QDiagram b V2 n m padY s d = withEnvelope (d # scaleY s) d @@ -204,7 +201,7 @@ padY s d = withEnvelope (d # scaleY s) d -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeLeft :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m +extrudeLeft :: (Monoid' m, TypeableFloat n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeLeft s | s >= 0 = extrudeEnvelope $ unitX ^* negate s | otherwise = intrudeEnvelope $ unitX ^* negate s @@ -214,7 +211,7 @@ extrudeLeft s -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeRight :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m +extrudeRight :: (Monoid' m, TypeableFloat n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeRight s | s >= 0 = extrudeEnvelope $ unitX ^* s | otherwise = intrudeEnvelope $ unitX ^* s @@ -224,7 +221,7 @@ extrudeRight s -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeBottom :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m +extrudeBottom :: (Monoid' m, TypeableFloat n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeBottom s | s >= 0 = extrudeEnvelope $ unitY ^* negate s | otherwise = intrudeEnvelope $ unitY ^* negate s @@ -234,7 +231,7 @@ extrudeBottom s -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. -extrudeTop :: (Monoid' m, TypeableReal n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m +extrudeTop :: (Monoid' m, TypeableFloat n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeTop s | s >= 0 = extrudeEnvelope $ unitY ^* s | otherwise = intrudeEnvelope $ unitY ^* s @@ -244,27 +241,27 @@ extrudeTop s -- .+^ v@. Useful for selecting the rectangular portion of a -- diagram which should actually be \"viewed\" in the final render, -- if you don't want to see the entire diagram. -view :: forall b n m. (Monoid' m, TypeableReal n) +view :: forall b n m. (Monoid' m, TypeableFloat n) => Point V2 n -> V2 n -> QDiagram b V2 n m -> QDiagram b V2 n m view p (V2 w h) = withEnvelope (rect w h # alignBL # moveTo p :: D V2 n) -- | Construct a bounding rectangle for an enveloped object, that is, -- the smallest axis-aligned rectangle which encloses the object. boundingRect :: ( Enveloped t, Transformable t, TrailLike t, Monoid t, Vn a ~ Vn t - , Enveloped a, Vn a ~ V2 n, TypeableReal n + , Enveloped a, Vn a ~ V2 n, TypeableFloat n ) => a -> t boundingRect = (`boxFit` rect 1 1) . boundingBox -- | \"Set the background color\" of a diagram. That is, place a -- diagram atop a bounding rectangle of the given color. -bg :: (TypeableReal n, Renderable (Path V2 n) b) => Colour Double -> Diagram b V2 n -> Diagram b V2 n +bg :: (DataFloat n, Renderable (Path V2 n) b) => Colour Double -> Diagram b V2 n -> Diagram b V2 n bg c d = d <> boundingRect d # lineWidth (Output 0) # fc c -- | Similar to 'bg' but makes the colored background rectangle larger than -- the diagram. The first parameter is used to set how far the background -- extends beyond the diagram. -bgFrame :: (TypeableReal n, Renderable (Path V2 n) b) +bgFrame :: (DataFloat n, Renderable (Path V2 n) b) => n -> Colour Double -> Diagram b V2 n -> Diagram b V2 n bgFrame f c d = d <> boundingRect (frame f d) # lineWidth (Output 0) # fc c diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 7d3d7790..4fa4397a 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -73,9 +73,6 @@ import Diagrams.Util (tau) import Linear.Vector import Linear.Affine -import Linear.Epsilon - -type TypeableReal n = (Epsilon n, RealFloat n, Typeable n) ------------------------------------------------------------ -- Trail and path traces --------------------------------- @@ -163,7 +160,7 @@ instance Default (StrokeOpts a) where -- inferring the type of @stroke@. The solution is to give a type -- signature to expressions involving @stroke@, or (recommended) -- upgrade GHC (the bug is fixed in 7.0.2 onwards). -stroke :: (TypeableReal n, Renderable (Path V2 n) b) +stroke :: (TypeableFloat n, Renderable (Path V2 n) b) => Path V2 n -> Diagram b V2 n stroke = stroke' (def :: StrokeOpts ()) @@ -177,7 +174,7 @@ instance (OrderedField n, Typeable n, RealFloat n, Renderable (Path V2 n) b) => -- -- 'StrokeOpts' is an instance of 'Default', so @stroke' ('with' & -- ... )@ syntax may be used. -stroke' :: (TypeableReal n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Path V2 n -> Diagram b V2 n +stroke' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Path V2 n -> Diagram b V2 n stroke' opts path | null (pLines ^. _Wrapped') = mkP pLoops | null (pLoops ^. _Wrapped') = mkP pLines @@ -202,51 +199,51 @@ stroke' opts path -- The solution is to give a type signature to expressions involving -- @strokeTrail@, or (recommended) upgrade GHC (the bug is fixed in 7.0.2 -- onwards). -strokeTrail :: (TypeableReal n, Renderable (Path V2 n) b) => Trail V2 n -> Diagram b V2 n +strokeTrail :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail V2 n -> Diagram b V2 n strokeTrail = stroke . pathFromTrail -- | Deprecated synonym for 'strokeTrail'. -strokeT :: (TypeableReal n, Renderable (Path V2 n) b) => Trail V2 n -> Diagram b V2 n +strokeT :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail V2 n -> Diagram b V2 n strokeT = strokeTrail -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. -strokeTrail' :: (TypeableReal n, Renderable (Path V2 n) b, IsName a) +strokeTrail' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Trail V2 n -> Diagram b V2 n strokeTrail' opts = stroke' opts . pathFromTrail -- | Deprecated synonym for 'strokeTrail''. -strokeT' :: (TypeableReal n, Renderable (Path V2 n) b, IsName a) +strokeT' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Trail V2 n -> Diagram b V2 n strokeT' = strokeTrail' -- | A composition of 'strokeT' and 'wrapLine' for conveniently -- converting a line directly into a diagram. -strokeLine :: (TypeableReal n, Renderable (Path V2 n) b) => Trail' Line V2 n -> Diagram b V2 n +strokeLine :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail' Line V2 n -> Diagram b V2 n strokeLine = strokeT . wrapLine -- | A composition of 'strokeT' and 'wrapLoop' for conveniently -- converting a loop directly into a diagram. -strokeLoop :: (TypeableReal n, Renderable (Path V2 n) b) => Trail' Loop V2 n -> Diagram b V2 n +strokeLoop :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail' Loop V2 n -> Diagram b V2 n strokeLoop = strokeT . wrapLoop -- | A convenience function for converting a @Located Trail@ directly -- into a diagram; @strokeLocTrail = stroke . trailLike@. -strokeLocTrail :: (TypeableReal n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> Diagram b V2 n +strokeLocTrail :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> Diagram b V2 n strokeLocTrail = stroke . trailLike -- | Deprecated synonym for 'strokeLocTrail'. -strokeLocT :: (TypeableReal n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> Diagram b V2 n +strokeLocT :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> Diagram b V2 n strokeLocT = strokeLocTrail -- | A convenience function for converting a @Located@ line directly -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. -strokeLocLine :: (TypeableReal n, Renderable (Path V2 n) b) => Located (Trail' Line V2 n) -> Diagram b V2 n +strokeLocLine :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail' Line V2 n) -> Diagram b V2 n strokeLocLine = stroke . trailLike . mapLoc wrapLine -- | A convenience function for converting a @Located@ loop directly -- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@. -strokeLocLoop :: (TypeableReal n, Renderable (Path V2 n) b) => Located (Trail' Loop V2 n) -> Diagram b V2 n +strokeLocLoop :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail' Loop V2 n) -> Diagram b V2 n strokeLocLoop = stroke . trailLike . mapLoc wrapLoop ------------------------------------------------------------ @@ -255,7 +252,7 @@ strokeLocLoop = stroke . trailLike . mapLoc wrapLoop -runFillRule :: (Epsilon n, RealFloat n) => FillRule -> Point V2 n -> Path V2 n -> Bool +runFillRule :: RealFloat n => FillRule -> Point V2 n -> Path V2 n -> Bool runFillRule Winding = isInsideWinding runFillRule EvenOdd = isInsideEvenOdd @@ -284,7 +281,7 @@ cross2 (V2 x y) (V2 x' y') = x * y' - y * x' -- by testing whether the point's /winding number/ is nonzero. Note -- that @False@ is /always/ returned for /open/ paths, regardless of -- the winding number. -isInsideWinding :: (Epsilon n, RealFloat n) => Point V2 n -> Path V2 n -> Bool +isInsideWinding :: RealFloat n => Point V2 n -> Path V2 n -> Bool isInsideWinding p = (/= 0) . crossings p -- | Test whether the given point is inside the given (closed) path, @@ -292,17 +289,17 @@ isInsideWinding p = (/= 0) . crossings p -- x direction crosses the path an even (outside) or odd (inside) -- number of times. Note that @False@ is /always/ returned for -- /open/ paths, regardless of the number of crossings. -isInsideEvenOdd :: (Epsilon n, RealFloat n) => Point V2 n -> Path V2 n -> Bool +isInsideEvenOdd :: RealFloat n => Point V2 n -> Path V2 n -> Bool isInsideEvenOdd p = odd . crossings p -- | Compute the sum of /signed/ crossings of a path as we travel in the -- positive x direction from a given point. -crossings :: (Epsilon n, RealFloat n) => Point V2 n -> Path V2 n -> Int +crossings :: RealFloat n => Point V2 n -> Path V2 n -> Int crossings p = F.sum . map (trailCrossings p) . op Path -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. -trailCrossings :: (RealFloat n, Epsilon n) => Point V2 n -> Located (Trail V2 n) -> Int +trailCrossings :: RealFloat n => Point V2 n -> Located (Trail V2 n) -> Int -- non-loop trails have no inside or outside, so don't contribute crossings trailCrossings _ t | not (isLoop (unLoc t)) = 0 @@ -358,7 +355,7 @@ newtype Clip n = Clip [Path V2 n] makeWrapped ''Clip -instance (Typeable n) => AttributeClass (Clip n) +instance Typeable n => AttributeClass (Clip n) type instance V (Clip n) = V2 type instance N (Clip n) = n @@ -372,7 +369,7 @@ instance (OrderedField n) => Transformable (Clip n) where -- path will be drawn. -- -- * The envelope of the diagram is unaffected. -clipBy :: (HasStyle a, Vn a ~ V2 n, Epsilon n, RealFloat n, Typeable n) => Path V2 n -> a -> a +clipBy :: (HasStyle a, Vn a ~ V2 n, TypeableFloat n) => Path V2 n -> a -> a clipBy = applyTAttr . Clip . (:[]) -- | Clip a diagram to the given path setting its envelope to the @@ -380,7 +377,7 @@ clipBy = applyTAttr . Clip . (:[]) -- trace consists of those parts of the original diagram's trace -- which fall within the clipping path, or parts of the path's trace -- within the original diagram. -clipTo :: (Typeable n, Epsilon n, RealFloat n, Renderable (Path V2 n) b) => Path V2 n -> Diagram b V2 n -> Diagram b V2 n +clipTo :: (TypeableFloat n, Renderable (Path V2 n) b) => Path V2 n -> Diagram b V2 n -> Diagram b V2 n clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d where envP = appEnvelope . getEnvelope $ p @@ -400,6 +397,6 @@ clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d -- | Clip a diagram to the clip path taking the envelope and trace of the clip -- path. -clipped :: (Typeable n, Epsilon n, RealFloat n, Renderable (Path V2 n) b) => Path V2 n -> Diagram b V2 n -> Diagram b V2 n +clipped :: (TypeableFloat n, Renderable (Path V2 n) b) => Path V2 n -> Diagram b V2 n -> Diagram b V2 n clipped p = withTrace p . withEnvelope p . clipBy p diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index 00b163ef..b640d9a0 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -71,7 +71,6 @@ import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) import Diagrams.Util (tau, ( # )) import Linear.Affine -import Linear.Epsilon import Linear.Metric import Linear.Vector @@ -165,7 +164,7 @@ instance Num n => Default (PolygonOpts n) where def = PolygonOpts (PolyRegular 5 1) OrientH origin -- | Generate a polygon. See 'PolygonOpts' for more information. -polyTrail :: (RealFloat n, Epsilon n) => PolygonOpts n -> Located (Trail V2 n) +polyTrail :: RealFloat n => PolygonOpts n -> Located (Trail V2 n) polyTrail po = transform ori tr where tr = case po^.polyType of @@ -184,7 +183,7 @@ polygon = trailLike . polyTrail -- | Generate the located trail of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'. -polyPolarTrail :: (RealFloat n, Epsilon n) => [Angle n] -> [n] -> Located (Trail V2 n) +polyPolarTrail :: RealFloat n => [Angle n] -> [n] -> Located (Trail V2 n) polyPolarTrail [] _ = emptyTrail `at` origin polyPolarTrail _ [] = emptyTrail `at` origin polyPolarTrail ans (r:rs) = tr `at` p1 @@ -199,7 +198,7 @@ polyPolarTrail ans (r:rs) = tr `at` p1 -- | Generate the vertices of a polygon specified by side length and -- angles, and a starting point for the trail such that the origin -- is at the centroid of the vertices. See 'PolySides'. -polySidesTrail :: (RealFloat n, Epsilon n) => [Angle n] -> [n] -> Located (Trail V2 n) +polySidesTrail :: RealFloat n => [Angle n] -> [n] -> Located (Trail V2 n) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) where ans' = scanl (^+^) zero ans @@ -208,7 +207,7 @@ polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) tr = closeTrail . trailFromOffsets $ offsets -- | Generate the vertices of a regular polygon. See 'PolyRegular'. -polyRegularTrail :: (RealFloat n, Epsilon n) => Int -> n -> Located (Trail V2 n) +polyRegularTrail :: RealFloat n => Int -> n -> Located (Trail V2 n) polyRegularTrail n r = polyPolarTrail (replicate (n - 1) $ fullTurn ^/ fromIntegral n) (repeat r) @@ -217,7 +216,7 @@ polyRegularTrail n r = polyPolarTrail -- generates the smallest rotation such that one of the segments -- adjacent to the vertex furthest in the direction of @v@ is -- perpendicular to @v@. -orient :: (RealFloat n, Epsilon n) => V2 n -> Located (Trail V2 n) -> Transformation V2 n +orient :: RealFloat n => V2 n -> Located (Trail V2 n) -> Transformation V2 n orient v = orientPoints v . trailVertices orientPoints :: (Floating n, Ord n) => V2 n -> [Point V2 n] -> Transformation V2 n From 15751d7e28b7917a33eb6aae46b55df9dc02d381 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 24 Aug 2014 23:14:39 +0100 Subject: [PATCH 32/58] lerp has arguments reversed in linear. --- diagrams-lib.cabal | 4 +-- src/Diagrams/Segment.hs | 42 ++++++++++++------------- src/Diagrams/Trail.hs | 2 +- src/Diagrams/TwoD/Arrow.hs | 64 ++++++++++++++++++++------------------ 4 files changed, 57 insertions(+), 55 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index e7bcd071..7f4e2b72 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -25,8 +25,8 @@ Source-repository head location: http://github.com/diagrams/diagrams-lib.git Library - Exposed-modules: Diagrams.Prelude - Diagrams.Prelude.ThreeD + Exposed-modules: Diagrams.Prelude, + Diagrams.Prelude.ThreeD, Diagrams.Align, Diagrams.Angle, Diagrams.Combinators, diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index bb896bc5..442d033d 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -279,16 +279,16 @@ instance (Additive v, Fractional n) => Sectionable (Segment Closed v n) where splitAtParam (Linear (OffsetClosed x1)) t = (left, right) where left = straight p right = straight (x1 ^-^ p) - p = lerp t zero x1 + p = lerp t x1 zero splitAtParam (Cubic c1 c2 (OffsetClosed x2)) t = (left, right) where left = bezier3 a b e right = bezier3 (c ^-^ e) (d ^-^ e) (x2 ^-^ e) - p = lerp t c1 c2 - a = lerp t zero c1 - b = lerp t a p - d = lerp t c2 x2 - c = lerp t p d - e = lerp t b c + p = lerp t c2 c1 + a = lerp t c1 zero + b = lerp t p a + d = lerp t x2 c2 + c = lerp t d p + e = lerp t c b reverseDomain = reverseSegment @@ -392,16 +392,16 @@ fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) type instance Codomain (FixedSegment v n) = Point v instance (Additive v, Num n) => Parametric (FixedSegment v n) where - atParam (FLinear p1 p2) t = lerp t p1 p2 + atParam (FLinear p1 p2) t = lerp t p2 p1 atParam (FCubic x1 c1 c2 x2) t = p3 - where p11 = lerp t x1 c1 - p12 = lerp t c1 c2 - p13 = lerp t c2 x2 + where p11 = lerp t c1 x1 + p12 = lerp t c2 c1 + p13 = lerp t x2 c2 - p21 = lerp t p11 p12 - p22 = lerp t p12 p13 + p21 = lerp t p12 p11 + p22 = lerp t p13 p12 - p3 = lerp t p21 p22 + p3 = lerp t p22 p21 instance Num n => DomainBounds (FixedSegment v n) @@ -415,19 +415,19 @@ instance (Additive v, Fractional n) => Sectionable (FixedSegment v n) where splitAtParam (FLinear p0 p1) t = (left, right) where left = FLinear p0 p right = FLinear p p1 - p = lerp t p0 p1 + p = lerp t p1 p0 splitAtParam (FCubic p0 c1 c2 p1) t = (left, right) where left = FCubic p0 a b cut right = FCubic cut c d p1 -- first round - a = lerp t p0 c1 - p = lerp t c1 c2 - d = lerp t c2 p1 + a = lerp t c1 p0 + p = lerp t c2 c1 + d = lerp t p1 c2 -- second round - b = lerp t a p - c = lerp t p d + b = lerp t p a + c = lerp t d p -- final round - cut = lerp t b c + cut = lerp t c b reverseDomain (FLinear p0 p1) = FLinear p1 p0 reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0 diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index bf8998cd..c8eb08ec 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -202,7 +202,7 @@ instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where , SegTree $ FT.singleton seg2 ) | otherwise = case FT.viewl after of - EmptyL -> emptySplit + EmptyL -> emptySplit seg :< after' -> case seg `splitAtParam` mod1 (p * tSegs) of (seg1, seg2) -> ( SegTree $ before |> seg1 diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 8ca326e0..deee10a3 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -101,38 +101,40 @@ module Diagrams.TwoD.Arrow , module Diagrams.TwoD.Arrowheads ) where -import Control.Applicative ((<*>)) -import Control.Lens (Lens', Setter', Traversal', generateSignatures, - lensRules, makeLensesWith, view, (%~), (&), (.~), (^.)) -import Data.Default.Class -import Data.Functor ((<$>)) -import Data.Maybe (fromMaybe) -import Data.Monoid.Coproduct (untangle) -import Data.Semigroup - -import Data.Colour hiding (atop) -import Diagrams.Core -import Diagrams.Core.Types (QDiaLeaf (..), mkQD') - -import Diagrams.Angle -import Diagrams.Attributes -import Diagrams.Direction -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Solve (quadForm) -import Diagrams.Tangent (tangentAtEnd, tangentAtStart) -import Diagrams.Trail -import Diagrams.TwoD.Arrowheads -import Diagrams.TwoD.Attributes -import Diagrams.TwoD.Path (stroke, strokeT) -import Diagrams.TwoD.Transform (rotate, translateX) -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unit_X) -import Diagrams.Util (( # )) +import Control.Applicative ((<*>)) +import Control.Lens (Lens', Setter', Traversal', + generateSignatures, lensRules, + makeLensesWith, view, (%~), (&), (.~), + (^.)) +import Data.Default.Class +import Data.Functor ((<$>)) +import Data.Maybe (fromMaybe) +import Data.Monoid.Coproduct (untangle) +import Data.Semigroup + +import Data.Colour hiding (atop) +import Diagrams.Core +import Diagrams.Core.Types (QDiaLeaf (..), mkQD') + +import Diagrams.Angle +import Diagrams.Attributes +import Diagrams.Direction +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Solve (quadForm) +import Diagrams.Tangent (tangentAtEnd, tangentAtStart) +import Diagrams.Trail +import Diagrams.TwoD.Arrowheads +import Diagrams.TwoD.Attributes +import Diagrams.TwoD.Path (stroke, strokeT) +import Diagrams.TwoD.Transform (rotate, translateX) +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (unitX, unit_X) +import Diagrams.Util (( # )) import Linear.Affine -import Linear.Vector import Linear.Metric +import Linear.Vector data ArrowOpts n @@ -420,8 +422,8 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) scaleFromMeasure = fromMeasure gToO nToO . scaleFromTransform tr hSize = scaleFromMeasure $ opts ^. headLength tSize = scaleFromMeasure $ opts ^. tailLength - hGap = scaleFromMeasure $ opts ^. headGap - tGap = scaleFromMeasure $ opts ^. tailGap + hGap = scaleFromMeasure $ opts ^. headGap + tGap = scaleFromMeasure $ opts ^. tailGap -- hSize = fromMeasure gToO nToO . transform tr $ opts ^. headLength -- tSize = fromMeasure gToO nToO . transform tr $ opts ^. tailLength -- hGap = fromMeasure gToO nToO . transform tr $ opts ^. headGap From 507309afd4c49b3e7d1d2c7829c1e02022f5ca2f Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 25 Aug 2014 17:01:39 +0100 Subject: [PATCH 33/58] Added (poor) Traced instances for Bounding box. --- src/Diagrams/BoundingBox.hs | 34 +++++++++++---- src/Diagrams/TwoD/Path.hs | 84 +++++++++++++++++++++---------------- 2 files changed, 74 insertions(+), 44 deletions(-) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index d7a320e6..3d383769 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -5,6 +5,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -34,7 +35,7 @@ module Diagrams.BoundingBox , isEmptyBox , getCorners, getAllCorners , boxExtents, boxTransform, boxFit - , contains, contains' + , contains, contains', boundingBoxQuery , inside, inside', outside, outside' -- * Operations on bounding boxes @@ -44,13 +45,16 @@ module Diagrams.BoundingBox import Data.Data (Data, Typeable) import Data.Foldable as F import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid (..)) -import Data.Semigroup (Option (..), Semigroup (..)) +import Data.Semigroup -import Diagrams.Core.Envelope -import Diagrams.Core.HasOrigin (HasOrigin (..)) import Diagrams.Core.Transform -import Diagrams.Core.V +import Diagrams.Core +import Diagrams.TwoD.Types +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Shapes +import Diagrams.ThreeD.Shapes +import Diagrams.ThreeD.Types +import Diagrams.Path import Control.Applicative import Data.Traversable as T @@ -91,7 +95,7 @@ deriving instance (Additive v, Ord n) => Monoid (BoundingBox v n) type instance V (BoundingBox v n) = v type instance N (BoundingBox v n) = n --- Map a function on a homogenous 2-tuple. (unexported utility) +-- Map a function on a homogeneous 2-tuple. (unexported utility) mapT :: (a -> b) -> (a, a) -> (b, b) mapT f (x, y) = (f x, f y) @@ -104,6 +108,18 @@ instance (Metric v, Traversable v, OrderedField n) => Enveloped (BoundingBox v n) where getEnvelope = getEnvelope . getAllCorners +-- Feels like cheating. +-- Should be possible to generalise this. +instance RealFloat n => Traced (BoundingBox V2 n) where + getTrace = getTrace + . ((`boxFit` rect 1 1) . boundingBox :: Envelope V2 n -> Path V2 n) + . getEnvelope + +instance TypeableFloat n => Traced (BoundingBox V3 n) where + getTrace = getTrace + . ((`boxFit` cube) . boundingBox :: Envelope V3 n -> D V3 n) + . getEnvelope + instance Show (v n) => Show (BoundingBox v n) where show = maybe "emptyBox" (\(l, u) -> "fromCorners " ++ show l ++ " " ++ show u) @@ -193,6 +209,10 @@ contains' b p = maybe False check $ getCorners b check (l, h) = F.and (liftI2 (<) l p) && F.and (liftI2 (<) p h) +boundingBoxQuery :: (Additive v, Foldable v, Ord n) + => BoundingBox v n -> Query v n Any +boundingBoxQuery bb = Query $ Any . contains bb + -- | Test whether the first bounding box is contained inside -- the second. inside :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 4fa4397a..439254ed 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -47,32 +47,34 @@ module Diagrams.TwoD.Path , Clip(..), clipBy, clipTo, clipped ) where -import Control.Applicative (liftA2) -import Control.Lens (Lens, Lens', generateSignatures, lensRules, makeLensesWith, - makeWrapped, op, (.~), (^.), _Wrapped') -import qualified Data.Foldable as F +import Control.Applicative (liftA2) +import Control.Lens (Lens, Lens', generateSignatures, + lensRules, makeLensesWith, + makeWrapped, op, (.~), (^.), + _Wrapped') +import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable -import Data.Default.Class - -import Diagrams.Angle -import Diagrams.Combinators (withEnvelope, withTrace) -import Diagrams.Core -import Diagrams.Core.Trace -import Diagrams.Located (Located, mapLoc, unLoc) -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Solve -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.TwoD.Segment () -import Diagrams.TwoD.Types -import Diagrams.Util (tau) +import Data.Default.Class + +import Diagrams.Angle +import Diagrams.Combinators (withEnvelope, withTrace) +import Diagrams.Core +import Diagrams.Core.Trace +import Diagrams.Located (Located, mapLoc, unLoc) +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Solve +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Segment () +import Diagrams.TwoD.Types +import Diagrams.Util (tau) -import Linear.Vector import Linear.Affine +import Linear.Vector ------------------------------------------------------------ -- Trail and path traces --------------------------------- @@ -82,14 +84,14 @@ import Linear.Affine -- XXX can the efficiency of this be improved? See the comment in -- Diagrams.Path on the Enveloped instance for Trail. -instance (OrderedField n, RealFloat n) => Traced (Trail V2 n) where +instance RealFloat n => Traced (Trail V2 n) where getTrace = withLine $ foldr (\seg bds -> moveOriginBy (negated . atEnd $ seg) bds <> getTrace seg) mempty . lineSegments -instance (OrderedField n, RealFloat n) => Traced (Path V2 n) where +instance RealFloat n => Traced (Path V2 n) where getTrace = F.foldMap getTrace . op Path ------------------------------------------------------------ @@ -164,7 +166,8 @@ stroke :: (TypeableFloat n, Renderable (Path V2 n) b) => Path V2 n -> Diagram b V2 n stroke = stroke' (def :: StrokeOpts ()) -instance (OrderedField n, Typeable n, RealFloat n, Renderable (Path V2 n) b) => TrailLike (Diagram b V2 n) where +instance (TypeableFloat n, Renderable (Path V2 n) b) + => TrailLike (Diagram b V2 n) where trailLike = stroke . trailLike -- | A variant of 'stroke' that takes an extra record of options to @@ -174,11 +177,12 @@ instance (OrderedField n, Typeable n, RealFloat n, Renderable (Path V2 n) b) => -- -- 'StrokeOpts' is an instance of 'Default', so @stroke' ('with' & -- ... )@ syntax may be used. -stroke' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Path V2 n -> Diagram b V2 n +stroke' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) + => StrokeOpts a -> Path V2 n -> Diagram b V2 n stroke' opts path - | null (pLines ^. _Wrapped') = mkP pLoops + | null (pLines ^. _Wrapped') = mkP pLoops | null (pLoops ^. _Wrapped') = mkP pLines - | otherwise = mkP pLines <> mkP pLoops + | otherwise = mkP pLines <> mkP pLoops where (pLines,pLoops) = partitionPath (isLine . unLoc) path mkP p @@ -199,11 +203,13 @@ stroke' opts path -- The solution is to give a type signature to expressions involving -- @strokeTrail@, or (recommended) upgrade GHC (the bug is fixed in 7.0.2 -- onwards). -strokeTrail :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail V2 n -> Diagram b V2 n +strokeTrail :: (TypeableFloat n, Renderable (Path V2 n) b) + => Trail V2 n -> Diagram b V2 n strokeTrail = stroke . pathFromTrail -- | Deprecated synonym for 'strokeTrail'. -strokeT :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail V2 n -> Diagram b V2 n +strokeT :: (TypeableFloat n, Renderable (Path V2 n) b) + => Trail V2 n -> Diagram b V2 n strokeT = strokeTrail -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently @@ -219,39 +225,43 @@ strokeT' = strokeTrail' -- | A composition of 'strokeT' and 'wrapLine' for conveniently -- converting a line directly into a diagram. -strokeLine :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail' Line V2 n -> Diagram b V2 n +strokeLine :: (TypeableFloat n, Renderable (Path V2 n) b) + => Trail' Line V2 n -> Diagram b V2 n strokeLine = strokeT . wrapLine -- | A composition of 'strokeT' and 'wrapLoop' for conveniently -- converting a loop directly into a diagram. -strokeLoop :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail' Loop V2 n -> Diagram b V2 n +strokeLoop :: (TypeableFloat n, Renderable (Path V2 n) b) + => Trail' Loop V2 n -> Diagram b V2 n strokeLoop = strokeT . wrapLoop -- | A convenience function for converting a @Located Trail@ directly -- into a diagram; @strokeLocTrail = stroke . trailLike@. -strokeLocTrail :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> Diagram b V2 n +strokeLocTrail :: (TypeableFloat n, Renderable (Path V2 n) b) + => Located (Trail V2 n) -> Diagram b V2 n strokeLocTrail = stroke . trailLike -- | Deprecated synonym for 'strokeLocTrail'. -strokeLocT :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> Diagram b V2 n +strokeLocT :: (TypeableFloat n, Renderable (Path V2 n) b) + => Located (Trail V2 n) -> Diagram b V2 n strokeLocT = strokeLocTrail -- | A convenience function for converting a @Located@ line directly -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. -strokeLocLine :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail' Line V2 n) -> Diagram b V2 n +strokeLocLine :: (TypeableFloat n, Renderable (Path V2 n) b) + => Located (Trail' Line V2 n) -> Diagram b V2 n strokeLocLine = stroke . trailLike . mapLoc wrapLine -- | A convenience function for converting a @Located@ loop directly -- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@. -strokeLocLoop :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail' Loop V2 n) -> Diagram b V2 n +strokeLocLoop :: (TypeableFloat n, Renderable (Path V2 n) b) + => Located (Trail' Loop V2 n) -> Diagram b V2 n strokeLocLoop = stroke . trailLike . mapLoc wrapLoop ------------------------------------------------------------ -- Inside/outside testing ------------------------------------------------------------ - - runFillRule :: RealFloat n => FillRule -> Point V2 n -> Path V2 n -> Bool runFillRule Winding = isInsideWinding runFillRule EvenOdd = isInsideEvenOdd From 46a5a9ed73909d171c57bf2cf9dd3eedd1ae99b0 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Fri, 29 Aug 2014 18:45:20 +0100 Subject: [PATCH 34/58] General cleanup. --- src/Diagrams/Align.hs | 2 +- src/Diagrams/Animation.hs | 23 +++++++------- src/Diagrams/Attributes.hs | 17 +++++----- src/Diagrams/Direction.hs | 4 +-- src/Diagrams/Located.hs | 31 ++++++++++-------- src/Diagrams/Parametric.hs | 2 +- src/Diagrams/Path.hs | 52 +++++++++++++----------------- src/Diagrams/Points.hs | 13 +++----- src/Diagrams/ThreeD.hs | 19 +++++------ src/Diagrams/ThreeD/Transform.hs | 15 ++++----- src/Diagrams/ThreeD/Types.hs | 2 +- src/Diagrams/ThreeD/Vector.hs | 16 +++++----- src/Diagrams/TwoD.hs | 4 ++- src/Diagrams/TwoD/Curvature.hs | 26 +++++---------- src/Diagrams/TwoD/Image.hs | 54 +++++++++++++++++--------------- src/Diagrams/TwoD/Model.hs | 4 +-- src/Diagrams/TwoD/Offset.hs | 45 +++++++++++++------------- src/Diagrams/TwoD/Segment.hs | 1 + src/Diagrams/TwoD/Transform.hs | 4 ++- src/Diagrams/TwoD/Types.hs | 26 ++++++--------- src/Diagrams/TwoD/Vector.hs | 41 +++++++++--------------- 21 files changed, 186 insertions(+), 215 deletions(-) diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs index e56071ac..b42de8e2 100644 --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -137,7 +137,7 @@ snugBy = alignBy' traceBoundary -- | Like align but uses trace. snug :: (Vn a ~ v n, Fractional n, Alignable a, Traced a, HasOrigin a) => v n -> a -> a -snug v = snugBy v 1 +snug v = snugBy v 1 -- | @centerV v@ centers an enveloped object along the direction of -- @v@. diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs index bd2eca1c..fc217bee 100644 --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -30,20 +29,20 @@ module Diagrams.Animation ) where -import Diagrams.Core +import Diagrams.Core -import Diagrams.Animation.Active () -import Diagrams.BoundingBox -import Diagrams.Combinators -import Diagrams.TrailLike -import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Types +import Diagrams.Animation.Active () +import Diagrams.BoundingBox +import Diagrams.Combinators +import Diagrams.TrailLike +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Types -import Data.Active -import Data.Semigroup +import Data.Active +import Data.Semigroup -import Control.Applicative ((<$>)) -import Data.Foldable (foldMap) +import Control.Applicative ((<$>)) +import Data.Foldable (foldMap) import Linear.Metric diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 379e9644..444267c9 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -47,15 +47,15 @@ module Diagrams.Attributes ( ) where -import Data.Colour -import Data.Colour.RGBSpace (RGB (..)) -import Data.Colour.SRGB (toSRGB) -import Data.Default.Class +import Data.Colour +import Data.Colour.RGBSpace (RGB (..)) +import Data.Colour.SRGB (toSRGB) +import Data.Default.Class -import Data.Semigroup -import Data.Typeable +import Data.Semigroup +import Data.Typeable -import Diagrams.Core +import Diagrams.Core ------------------------------------------------------------ -- Color ------------------------------------------------- @@ -167,7 +167,6 @@ getLineCap (LineCapA (Last c)) = c lineCap :: HasStyle a => LineCap -> a -> a lineCap = applyAttr . LineCapA . Last - -- | How should the join points between line segments be drawn? data LineJoin = LineJoinMiter -- ^ Use a \"miter\" shape (whatever that is). | LineJoinRound -- ^ Use rounded join points. @@ -190,7 +189,6 @@ getLineJoin (LineJoinA (Last j)) = j lineJoin :: HasStyle a => LineJoin -> a -> a lineJoin = applyAttr . LineJoinA . Last - -- | Miter limit attribute affecting the 'LineJoinMiter' joins. -- For some backends this value may have additional effects. newtype LineMiterLimit = LineMiterLimit (Last Double) @@ -210,3 +208,4 @@ lineMiterLimit = applyAttr . LineMiterLimit . Last -- | Apply a 'LineMiterLimit' attribute. lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a lineMiterLimitA = applyAttr + diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index 4e2901c9..b2ae1156 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -64,7 +64,7 @@ fromDirection :: (Metric v, Floating n) => Direction v n -> v n fromDirection (Direction v) = signorm v -- | compute the positive angle between the two directions in their common plane -angleBetweenDirs :: (Metric v, Floating n) => - Direction v n -> Direction v n -> Angle n +angleBetweenDirs :: (Metric v, Floating n) + => Direction v n -> Direction v n -> Angle n angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs index 6dbbe8f9..9ea28ef5 100644 --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -19,21 +19,20 @@ module Diagrams.Located ( Located - , at, viewLoc, unLoc, loc, mapLoc, located + , at, viewLoc, unLoc, loc, mapLoc, located, _location, _Loc ) where -import Control.Lens (Lens) --- import Data.AffineSpace -import Data.Functor ((<$>)) +import Control.Lens (Iso', Lens, Lens', iso, lens) +import Data.Functor ((<$>)) -import Linear.Vector import Linear.Affine +import Linear.Vector -import Diagrams.Core -import Diagrams.Core.Points () -import Diagrams.Core.Transform -import Diagrams.Parametric +import Diagrams.Core +import Diagrams.Core.Points () +import Diagrams.Core.Transform +import Diagrams.Parametric -- for GHC 7.4 type family bug -- | \"Located\" things, /i.e./ things with a concrete location: @@ -89,9 +88,15 @@ mapLoc :: (V a ~ V b, N a ~ N b) => (a -> b) -> Located a -> Located b mapLoc f (Loc p a) = Loc p (f a) -- | A lens giving access to the object within a 'Located' wrapper. -located :: (V a ~ V a', N a ~ N a') => Lens (Located a) (Located a') a a' +located :: (Vn a ~ Vn a') => Lens (Located a) (Located a') a a' located f (Loc p a) = Loc p <$> f a +_location :: (Vn a ~ v n) => Lens' (Located a) (Point v n) +_location = lens (\(Loc l _) -> l) (\(Loc _ a) l -> Loc l a) + +_Loc :: (Vn a ~ v n) => Iso' (Located a) (Point v n, a) +_Loc = iso viewLoc (uncurry Loc) + deriving instance (Eq (V a (N a)), Eq a ) => Eq (Located a) deriving instance (Ord (V a (N a)), Ord a ) => Ord (Located a) deriving instance (Show (V a (N a)), Show a) => Show (Located a) @@ -142,8 +147,7 @@ instance DomainBounds a => DomainBounds (Located a) where instance (Vn a ~ v n, Codomain a ~ v, Additive v, Num n, EndValues a) => EndValues (Located a) --- not sure why Codomain a n ~ v n is needed as well. I've probably done something wrong. -instance (Vn a ~ v n, Codomain a ~ v, Fractional n, Additive v , Sectionable a, Parametric a) +instance (Vn a ~ v n, Codomain a ~ v, Fractional n, Additive v, Sectionable a, Parametric a) => Sectionable (Located a) where splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2) where (a1,a2) = splitAtParam a p @@ -151,7 +155,8 @@ instance (Vn a ~ v n, Codomain a ~ v, Fractional n, Additive v , Sectionable a, reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a) where y = a `atParam` domainUpper a -instance (Vn a ~ v n, Codomain a ~ v, Additive v, Fractional n , HasArcLength a) +instance (Vn a ~ v n, Codomain a ~ v, Additive v, Fractional n, HasArcLength a) => HasArcLength (Located a) where arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a arcLengthToParam eps (Loc _ a) = arcLengthToParam eps a + diff --git a/src/Diagrams/Parametric.hs b/src/Diagrams/Parametric.hs index 0ee35782..709e70d3 100644 --- a/src/Diagrams/Parametric.hs +++ b/src/Diagrams/Parametric.hs @@ -22,7 +22,7 @@ module Diagrams.Parametric ) where -import Diagrams.Core.V +import Diagrams.Core.V import qualified Numeric.Interval.Kaucher as I -- | Codomain of parametric classes. This is usually either @(V p)@, for relative diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 0b656a3e..7157d949 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -56,28 +56,29 @@ module Diagrams.Path ) where -import Data.Typeable - -import Diagrams.Align -import Diagrams.Core -import Diagrams.Core.Points () -import Diagrams.Located -import Diagrams.Points -import Diagrams.Segment -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.Transform - -import Control.Arrow ((***)) -import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, over, view, (%~), - _Unwrapped', _Wrapped) -import qualified Data.Foldable as F -import Data.List (partition) +import Data.Typeable + +import Diagrams.Align +import Diagrams.Core +import Diagrams.Core.Points () +import Diagrams.Located +import Diagrams.Points +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.Transform + +import Control.Arrow ((***)) +import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, + op, over, view, (%~), _Unwrapped', + _Wrapped) +import qualified Data.Foldable as F +import Data.List (partition) import Data.Semigroup import Linear.Affine -import Linear.Vector import Linear.Metric +import Linear.Vector ------------------------------------------------------------ -- Paths ------------------------------------------------- @@ -91,8 +92,8 @@ newtype Path v n = Path [Located (Trail v n)] deriving (Semigroup, Monoid, Typeable) instance Wrapped (Path v n) where - type Unwrapped (Path v n) = [Located (Trail v n)] - _Wrapped' = iso (\(Path x) -> x) Path + type Unwrapped (Path v n) = [Located (Trail v n)] + _Wrapped' = iso (\(Path x) -> x) Path instance Rewrapped (Path v n) (Path v' n') @@ -109,7 +110,6 @@ type instance N (Path v n) = n instance (Additive v, Num n) => HasOrigin (Path v n) where moveOriginTo = over _Wrapped' . map . moveOriginTo - --moveOriginTo = over pathTrails . map . moveOriginTo -- | Paths are trail-like; a trail can be used to construct a -- singleton path. @@ -121,16 +121,6 @@ instance (HasLinearMap v, Metric v, OrderedField n) => Transformable (Path v n) where transform = over _Wrapped . map . transform -{- ~~~~ Note [Transforming paths] - -Careful! It's tempting to just define - -> transform = fmap . transform - -but that doesn't take into account the fact that some -of the v's are inside Points and hence ought to be translated. --} - instance (Metric v, OrderedField n) => Enveloped (Path v n) where getEnvelope = F.foldMap trailEnvelope . op Path --view pathTrails -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs index 2c605175..f03fa132 100644 --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Points @@ -9,7 +6,7 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Points in space. For more tools for working with points and --- vectors, see "Data.AffineSpace" and "Diagrams.Coordinates". +-- vectors, see "Linear.Affine". -- ----------------------------------------------------------------------------- @@ -23,14 +20,14 @@ module Diagrams.Points , _pIso, lensP ) where -import Diagrams.Core (pointDiagram) -import Diagrams.Core.Points +import Diagrams.Core (pointDiagram) +import Diagrams.Core.Points -import Control.Lens (Iso', iso) +import Control.Lens (Iso', iso) +import Data.Foldable as F import Linear.Affine import Linear.Vector -import Data.Foldable as F -- Point v <-> v _pIso :: Iso' (Point v n) (v n) diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs index a6c87875..83c3521a 100644 --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -43,12 +43,13 @@ module Diagrams.ThreeD , module Diagrams.ThreeD.Vector ) where -import Diagrams.ThreeD.Align -import Diagrams.ThreeD.Attributes -import Diagrams.ThreeD.Camera -import Diagrams.ThreeD.Deform -import Diagrams.ThreeD.Light -import Diagrams.ThreeD.Shapes -import Diagrams.ThreeD.Transform -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector +import Diagrams.ThreeD.Align +import Diagrams.ThreeD.Attributes +import Diagrams.ThreeD.Camera +import Diagrams.ThreeD.Deform +import Diagrams.ThreeD.Light +import Diagrams.ThreeD.Shapes +import Diagrams.ThreeD.Transform +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector + diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 7d08ca5e..b354183d 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -162,7 +162,7 @@ scalingZ c = fromSymmetric s -- | Scale a diagram by the given factor in the z direction. To scale -- uniformly, use 'scale'. -scaleZ :: (Transformable t, Floating n, Vn t ~ V3 n) => n -> t -> t +scaleZ :: (Vn t ~ v n, R3 v, Additive v, Transformable t, Floating n) => n -> t -> t scaleZ = transform . scalingZ -- Translation ---------------------------------------- @@ -174,7 +174,7 @@ translationZ z = translation (zero & _z .~ z) -- | Translate a diagram by the given distance in the y -- direction. -translateZ :: (R3 v, Transformable t, Vn t ~ v n, Additive v, Floating n) => n -> t -> t +translateZ :: (Vn t ~ v n, R3 v, Transformable t, Additive v, Floating n) => n -> t -> t translateZ = transform . translationZ -- Reflection ---------------------------------------------- @@ -186,22 +186,23 @@ reflectionZ = scalingZ (-1) -- | Flip a diagram across z=0, i.e. send the point (x,y,z) to -- (x,y,-z). -reflectZ :: (R3 v, Transformable t, Vn t ~ v n, Additive v, Floating n) => t -> t +reflectZ :: (Vn t ~ v n, R3 v, Transformable t, Additive v, Floating n) => t -> t reflectZ = transform reflectionZ -- | @reflectionAbout p v@ is a reflection across the plane through -- the point @p@ and normal to vector @v@. -reflectionAbout :: (HasLinearMap v, Metric v, Fractional n, R3 v) => Point v n -> v n -> Transformation v n +reflectionAbout :: (R3 v, HasLinearMap v, Metric v, Fractional n) + => Point v n -> v n -> Transformation v n reflectionAbout p v = conjugate (translation (origin .-. p)) reflect where reflect = fromLinear t (linv t) - t = f v <-> f (negated v) - f u w = w ^-^ 2 *^ project u w + t = f v <-> f (negated v) + f u w = w ^-^ 2 *^ project u w -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. -reflectAbout :: (R3 v, HasLinearMap v, Metric v, Fractional n, Transformable t, Vn t ~ v n) +reflectAbout :: (Vn t ~ v n, R3 v, HasLinearMap v, Metric v, Fractional n, Transformable t) => Point v n -> v n -> t -> t reflectAbout p v = transform (reflectionAbout p v) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index bda157e8..6ddb4c32 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -17,7 +17,7 @@ module Diagrams.ThreeD.Types r3, unr3, mkR3 , p3, unp3, mkP3 , r3Iso, p3Iso, project - , V3 (..) + , V3 (..), P3 , R1 (..), R2 (..), R3 (..) -- * other coördinate systems diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 1d4a260e..99d50748 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Vector @@ -12,19 +9,22 @@ -- ----------------------------------------------------------------------------- module Diagrams.ThreeD.Vector - ( -- * Special 2D vectors - unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, unit, unit_ + ( -- * Special 3D vectors + unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, ) where +import Control.Lens ((&), (.~)) + import Diagrams.TwoD.Vector import Diagrams.ThreeD.Types -import Linear.Vector hiding (unit) +import Linear.Vector -- | The unit vector in the positive Y direction. unitZ :: (R3 v, Additive v, Num n) => v n -unitZ = unit _y +unitZ = zero & _z .~ 1 -- | The unit vector in the negative X direction. unit_Z :: (R3 v, Additive v, Num n) => v n -unit_Z = unit_ _z +unit_Z = zero & _z .~ (-1) + diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 0ad12c7a..8222af4c 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -61,7 +61,9 @@ ----------------------------------------------------------------------------- module Diagrams.TwoD ( -- * R^2 - r2, unr2, mkR2 + V2 (..), R1 (..), R2 (..) + , P2, T2 + , r2, unr2, mkR2 , p2, unp2, mkP2 , unitX, unitY, unit_X, unit_Y , xDir diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs index a8bb49b0..12bb1d74 100644 --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- @@ -27,6 +26,7 @@ import Diagrams.Tangent import Diagrams.TwoD.Types import Control.Lens (over) +import Control.Monad import Linear.Vector -- | Curvature measures how curved the segment is at a point. One intuition @@ -109,35 +109,24 @@ curvature :: RealFloat n -> PosInf n -- ^ Result is a @PosInf@ value where @PosInfty@ represents -- infinite curvature or zero radius of curvature. curvature s = toPosInf . over _y sqrt . curvaturePair s --- curvature s = toPosInf . second sqrt . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 -- | With @squaredCurvature@ we can compute values in spaces that do not support -- 'sqrt' and it is just as useful for relative ordering of curvatures or looking -- for zeros. squaredCurvature :: RealFloat n => Segment Closed V2 n -> n -> PosInf n --- squaredCurvature s = toPosInf . first (join (*)) . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 -squaredCurvature s = toPosInf . over _x sq . curvaturePair s -- TODO: Use the generalized unr2 - +squaredCurvature s = toPosInf . over _x (join (*)) . curvaturePair s -- | Reciprocal of @curvature@. radiusOfCurvature :: RealFloat n => Segment Closed V2 n -- ^ Segment to measure on. -> n -- ^ Parameter to measure at. -> PosInf n -- ^ Result is a @PosInf@ value where @PosInfty@ represents - -- infinite radius of curvature or zero curvature. --- radiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . second sqrt . curvaturePair (fmap unr2 s) + -- infinite radius of curvature or zero curvature. radiusOfCurvature s = toPosInf . (\(V2 p q) -> V2 (sqrt q) p) . curvaturePair s -- | Reciprocal of @squaredCurvature@ squaredRadiusOfCurvature :: RealFloat n => Segment Closed V2 n -> n -> PosInf n --- squaredRadiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . first (join (*)) . curvaturePair -squaredRadiusOfCurvature s = toPosInf . (\(V2 p q) -> (V2 q (sq p))) . curvaturePair s - -sq :: Num a => a -> a -sq x = x * x -{-# INLINE sq #-} - - +squaredRadiusOfCurvature s = toPosInf . (\(V2 p q) -> (V2 q (p * p))) . curvaturePair s -- Package up problematic values with the appropriate infinity. toPosInf :: RealFloat a => V2 a -> PosInf a @@ -150,10 +139,11 @@ toPosInf (V2 p q) -- Internal function that is not quite curvature or squaredCurvature but lets -- us get there by either taking the square root of the numerator or squaring -- the denominator respectively. -curvaturePair :: (Num n) +curvaturePair :: Num n => Segment Closed V2 n -> n -> V2 n -curvaturePair (Linear _) _ = V2 0 1 -- Linear segments always have zero curvature (infinite radius). -curvaturePair seg@(Cubic b c (OffsetClosed d)) t = V2 (x'*y'' - y'*x'') ((x'*x' + y'*y')^(3 :: Integer)) +curvaturePair (Linear _) _ = V2 0 1 -- Linear segments always have zero curvature (infinite radius). +curvaturePair seg@(Cubic b c (OffsetClosed d)) t + = V2 (x'*y'' - y'*x'') ((x'*x' + y'*y')^(3 :: Int)) where (V2 x' y' ) = seg `tangentAtParam` t (V2 x'' y'') = secondDerivative diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs index 7f51a9fa..4ef2d89b 100644 --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} @@ -33,20 +32,19 @@ module Diagrams.TwoD.Image ) where -import Codec.Picture -import Codec.Picture.Types (dynamicMap) +import Codec.Picture +import Codec.Picture.Types (dynamicMap) -import Data.Colour (AlphaColour) -import Data.Typeable (Typeable) +import Data.Colour (AlphaColour) +import Data.Semigroup +import Data.Typeable (Typeable) -import Diagrams.Core +import Diagrams.Core -import Diagrams.Attributes (colorToSRGBA) -import Diagrams.TwoD.Path (isInsideEvenOdd) -import Diagrams.TwoD.Shapes (rect) -import Diagrams.TwoD.Types - -import Data.Semigroup +import Diagrams.Attributes (colorToSRGBA) +import Diagrams.TwoD.Path (isInsideEvenOdd) +import Diagrams.TwoD.Shapes (rect) +import Diagrams.TwoD.Types import Linear.Affine @@ -65,7 +63,7 @@ data ImageData :: * -> * where ------------------------------------------------------------------------------- -- | An image primitive, the two ints are width followed by height. -- Will typically be created by @loadImageEmb@ or @loadImageExt@ which, --- will handle setting the width and heigh to the actual width and height +-- will handle setting the width and height to the actual width and height -- of the image. data DImage :: * -> * -> * where DImage :: ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t @@ -81,26 +79,29 @@ instance Fractional n => HasOrigin (DImage n a) where moveOriginTo p = translate (origin .-. p) -- | Make a 'DImage' into a 'Diagram'. -image :: (OrderedField n, RealFloat n, Typeable a, Renderable (DImage n a) b, Typeable n) +image :: (TypeableFloat n, Typeable a, Renderable (DImage n a) b) => DImage n a -> Diagram b V2 n -image img = mkQD (Prim img) (getEnvelope r) (getTrace r) mempty - (Query $ \p -> Any (isInsideEvenOdd p r)) +image img + = mkQD (Prim img) + (getEnvelope r) + (getTrace r) + mempty + (Query $ \p -> Any (isInsideEvenOdd p r)) where - -- r :: Path v r = rect (fromIntegral w) (fromIntegral h) DImage _ w h _ = img -- | Use JuicyPixels to read an image in any format and wrap it in a 'DImage'. -- The width and height of the image are set to their actual values. -loadImageEmb :: (Num n) => FilePath -> IO (Either String (DImage n Embedded)) +loadImageEmb :: Num n => FilePath -> IO (Either String (DImage n Embedded)) loadImageEmb path = do - dImg <- readImage path - return $ case dImg of - Left msg -> Left msg - Right img -> Right (DImage (ImageRaster img) w h mempty) - where - w = dynamicMap imageWidth img - h = dynamicMap imageHeight img + dImg <- readImage path + return $ case dImg of + Left msg -> Left msg + Right img -> Right (DImage (ImageRaster img) w h mempty) + where + w = dynamicMap imageWidth img + h = dynamicMap imageHeight img -- | Check that a file exists, and use JuicyPixels to figure out -- the right size, but save a reference to the image instead @@ -122,7 +123,7 @@ uncheckedImageRef :: Num n => FilePath -> Int -> Int -> DImage n External uncheckedImageRef path w h = DImage (ImageRef path) w h mempty -- | Crate a diagram from raw raster data. -rasterDia :: (OrderedField n, Typeable n, RealFloat n, Renderable (DImage n Embedded) b) +rasterDia :: (TypeableFloat n, Renderable (DImage n Embedded) b) => (Int -> Int -> AlphaColour Double) -> Int -> Int -> Diagram b V2 n rasterDia f w h = image $ raster f w h @@ -142,3 +143,4 @@ fromAlphaColour c = PixelRGBA8 r g b a instance Fractional n => (Renderable (DImage n a) NullBackend) where render _ _ = mempty + diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs index 5438ed4e..1ef7d800 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -63,13 +63,13 @@ instance Fractional n => Default (OriginOpts n) where def = OriginOpts red (1/50) 0.001 -- | Mark the origin of a diagram by placing a red dot 1/50th its size. -showOrigin :: (RealFloat n, OrderedField n, Renderable (Path V2 n) b, Data n, Monoid' m) +showOrigin :: (RealFloat n, Renderable (Path V2 n) b, Data n, Monoid' m) => QDiagram b V2 n m -> QDiagram b V2 n m showOrigin = showOrigin' def -- | Mark the origin of a diagram, with control over colour and scale -- of marker dot. -showOrigin' :: (RealFloat n, OrderedField n, Renderable (Path V2 n) b, Data n, Monoid' m) +showOrigin' :: (RealFloat n, Renderable (Path V2 n) b, Data n, Monoid' m) => OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m showOrigin' oo d = o <> d where o = stroke (circle sz) diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index bcc0873c..72fd1fec 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -65,6 +65,7 @@ import Diagrams.TwoD.Arc import Diagrams.TwoD.Curvature import Diagrams.TwoD.Path () import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector hiding (e) import Linear.Affine import Linear.Metric @@ -130,7 +131,7 @@ offsetEpsilon :: Lens' (OffsetOpts d) d -- | The default offset options use the default 'LineJoin' ('LineJoinMiter'), a -- miter limit of 10, and epsilon factor of 0.01. -instance (Fractional d) => Default (OffsetOpts d) where +instance Fractional d => Default (OffsetOpts d) where def = OffsetOpts def 10 0.01 -- | Options for specifying how a 'Trail' should be expanded. @@ -163,7 +164,7 @@ expandEpsilon :: Lens' (ExpandOpts d) d instance (Fractional d) => Default (ExpandOpts d) where def = ExpandOpts def 10 def 0.01 -offsetSegment :: (OrderedField n, RealFloat n) +offsetSegment :: RealFloat n => n -- ^ Epsilon factor that when multiplied to the -- absolute value of the radius gives a -- value that represents the maximum @@ -269,7 +270,7 @@ locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints t) -- -- <> -- -offsetTrail' :: (OrderedField n, RealFloat n) +offsetTrail' :: RealFloat n => OffsetOpts n -> n -- ^ Radius of offset. A negative value gives an offset on -- the left for a line and on the inside for a counter-clockwise @@ -287,17 +288,17 @@ offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r end isLoop = withTrail (const False) (const True) (unLoc t) -- | Offset a 'Trail' with the default options and a given radius. See 'offsetTrail''. -offsetTrail :: (OrderedField n, RealFloat n) => n -> Located (Trail V2 n) -> Located (Trail V2 n) +offsetTrail :: RealFloat n => n -> Located (Trail V2 n) -> Located (Trail V2 n) offsetTrail = offsetTrail' def -- | Offset a 'Path' by applying 'offsetTrail'' to each trail in the path. -offsetPath' :: (OrderedField n, RealFloat n) => OffsetOpts n -> n -> Path V2 n -> Path V2 n +offsetPath' :: RealFloat n => OffsetOpts n -> n -> Path V2 n -> Path V2 n offsetPath' opts r = mconcat . map (bindLoc (trailLike . offsetTrail' opts r) . (`at` origin)) . op Path -- | Offset a 'Path' with the default options and given radius. See 'offsetPath''. -offsetPath :: (OrderedField n, RealFloat n) => n -> Path V2 n -> Path V2 n +offsetPath :: RealFloat n => n -> Path V2 n -> Path V2 n offsetPath = offsetPath' def -- TODO: Include arrowheads on examples to indicate direction so the "left" and @@ -368,7 +369,7 @@ expandTrail' o r t -- TODO: consider just reversing the path instead of this error. | otherwise = withTrailL (pathFromLocTrail . expandLine o r) (expandLoop o r) t -expandLine :: (OrderedField n, RealFloat n) => ExpandOpts n -> n -> Located (Trail' Line V2 n) -> Located (Trail V2 n) +expandLine :: RealFloat n => ExpandOpts n -> n -> Located (Trail' Line V2 n) -> Located (Trail V2 n) expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) where eps = opts^.expandEpsilon @@ -380,7 +381,7 @@ expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) e = atEnd t cap = fromLineCap (opts^.expandCap) -expandLoop :: (OrderedField n, RealFloat n) => ExpandOpts n -> n -> Located (Trail' Loop V2 n) -> Path V2 n +expandLoop :: RealFloat n => ExpandOpts n -> n -> Located (Trail' Loop V2 n) -> Path V2 n expandLoop opts r (mapLoc wrapLoop -> t) = trailLike (f r) <> (trailLike . reverseDomain . f $ -r) where eps = opts^.expandEpsilon @@ -390,17 +391,17 @@ expandLoop opts r (mapLoc wrapLoop -> t) = trailLike (f r) <> (trailLike . rever ends = (\(a:as) -> as ++ [a]) . trailVertices $ t -- | Expand a 'Trail' with the given radius and default options. See 'expandTrail''. -expandTrail :: (OrderedField n, RealFloat n) => n -> Located (Trail V2 n) -> Path V2 n +expandTrail :: RealFloat n => n -> Located (Trail V2 n) -> Path V2 n expandTrail = expandTrail' def -- | Expand a 'Path' using 'expandTrail'' on each trail in the path. -expandPath' :: (OrderedField n, RealFloat n) => ExpandOpts n -> n -> Path V2 n -> Path V2 n +expandPath' :: RealFloat n => ExpandOpts n -> n -> Path V2 n -> Path V2 n expandPath' opts r = mconcat . map (bindLoc (expandTrail' opts r) . (`at` origin)) . op Path -- | Expand a 'Path' with the given radius and default options. See 'expandPath''. -expandPath :: (OrderedField n, RealFloat n) => n -> Path V2 n -> Path V2 n +expandPath :: RealFloat n => n -> Path V2 n -> Path V2 n expandPath = expandPath' def -- > import Diagrams.TwoD.Offset @@ -439,7 +440,7 @@ expandPath = expandPath' def -- caps takes the radius and the start and end points of the original line and -- the offset trails going out and coming back. The result is a new list of -- trails with the caps included. -caps :: (OrderedField n, RealFloat n) => (n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n) +caps :: RealFloat n => (n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n) -> n -> Point V2 n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Located (Trail V2 n) caps cap r s e fs bs = mapLoc glueTrail $ mconcat [ cap r s (atStart bs) (atStart fs) @@ -449,25 +450,25 @@ caps cap r s e fs bs = mapLoc glueTrail $ mconcat ] `at` atStart bs -- | Take a LineCap style and give a function for building the cap from -fromLineCap :: (OrderedField n, RealFloat n) => LineCap -> n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n +fromLineCap :: RealFloat n => LineCap -> n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n fromLineCap c = case c of LineCapButt -> capCut LineCapRound -> capArc LineCapSquare -> capSquare -- | Builds a cap that directly connects the ends. -capCut :: (OrderedField n, RealFloat n) => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n +capCut :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n capCut _r _c a b = fromSegments [straight (b .-. a)] -- | Builds a cap with a square centered on the end. -capSquare :: (OrderedField n, RealFloat n) => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n +capSquare :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n capSquare _r c a b = unLoc $ fromVertices [ a, a .+^ v, b .+^ v, b ] where v = perp (a .-. c) -- | Builds an arc to fit with a given radius, center, start, and end points. -- A Negative r means a counter-clockwise arc -capArc :: (OrderedField n, RealFloat n) => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n +capArc :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n capArc r c a b = trailLike . moveTo c $ fs where fs | r < 0 = scale (-r) $ arcVCW (a .-. c) (b .-. c) @@ -489,7 +490,7 @@ arcVCW u v = arc (direction u) (negated $ angleBetween v u) -- Note: this is not a general purpose join and assumes that we are joining an -- offset trail. For instance, a fixed radius arc will not fit between arbitrary -- trails without trimming or extending. -joinSegments :: (OrderedField n, RealFloat n) +joinSegments :: RealFloat n => n -> (n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n) -> Bool @@ -512,7 +513,7 @@ joinSegments epsilon j isLoop ml r es ts@(t:_) = t' -- | Take a join style and give the join function to be used by joinSegments. fromLineJoin - :: (OrderedField n, RealFloat n) => LineJoin -> n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n + :: RealFloat n => LineJoin -> n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n fromLineJoin j = case j of LineJoinMiter -> joinSegmentIntersect LineJoinRound -> joinSegmentArc @@ -532,18 +533,20 @@ joinSegmentCut _ _ e a b = fromSegments -- | Join by directly connecting the end points. On an inside corner this -- creates negative space for even-odd fill. Here is where we would want to -- use an arc or something else in the future. -joinSegmentClip :: (OrderedField n, RealFloat n) => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n +joinSegmentClip :: RealFloat n + => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentClip _ _ _ a b = fromSegments [straight $ atStart b .-. atEnd a] -- | Join with a radius arc. On an inside corner this will loop around the interior -- of the offset trail. With a winding fill this will not be visible. -joinSegmentArc :: (OrderedField n, RealFloat n) => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n +joinSegmentArc :: RealFloat n + => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentArc _ r e a b = capArc r e (atEnd a) (atStart b) -- | Join to the intersection of the incoming trails projected tangent to their ends. -- If the intersection is beyond the miter limit times the radius, stop at the limit. joinSegmentIntersect - :: (OrderedField n, RealFloat n) => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n + :: RealFloat n => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentIntersect miterLimit r e a b = if cross < 0.000001 then clip diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index d573ccdd..5ed75eb4 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -35,6 +35,7 @@ import Diagrams.Segment import Diagrams.Solve import Diagrams.TwoD.Transform import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector import Diagrams.Util import Linear.Affine diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index f8cadcd5..ebe004ed 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -20,8 +20,9 @@ module Diagrams.TwoD.Transform ( + T2 -- * Rotation - rotation, rotate, rotateBy + , rotation, rotate, rotateBy , rotationAbout, rotateAbout @@ -233,6 +234,7 @@ sh' f g k = swap . sh f g k . swap swap :: V2 n -> V2 n swap (V2 x y) = V2 y x +{-# INLINE swap #-} -- | @shearingX d@ is the linear transformation which is the identity on -- y coordinates and sends @(0,1)@ to @(d,1)@. diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 838f1ba1..d49e6410 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -15,34 +15,28 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space - V2 (..), R1 (..), R2 (..), P2, r2, unr2, mkR2, r2Iso - , p2, mkP2, unp2, p2Iso, project, perp + V2 (..), P2, R1 (..), R2 (..) + , r2, unr2, mkR2, r2Iso + , p2, mkP2, unp2, p2Iso, project , Polar(..) ) where -import Control.Lens (Iso', iso, _2) +import Control.Lens (Iso', iso, _2) -import Diagrams.Angle --- import Diagrams.Coordinates -import Diagrams.Points +import Diagrams.Angle +import Diagrams.Points -import Linear.Vector +import Diagrams.Core.Transform +import Diagrams.Core.V import Linear.Metric import Linear.V2 -import Diagrams.Core.V -import Diagrams.Core.Transform - +import Linear.Vector type P2 = Point V2 type instance V (V2 n) = V2 type instance N (V2 n) = n --- type ScalarR2Ish d = (RealFloat d, VectorSpace d, HasBasis d, Basis d ~ (), Transformable d, Scalar d ~ d, V d ~ d, Typeable d) --- type R2Ish v = (HasBasis v, Basis v ~ R2Basis, V v ~ v, Transformable v, InnerSpace v, Coordinates v, Decomposition v ~ (FinalCoord v :& FinalCoord v), PrevDim v ~ FinalCoord v, FinalCoord v ~ Scalar v, HasX v, HasY v, ScalarR2Ish (Scalar v), HasTheta v, Typeable v) - --- type R2D v = (R2Ish v, Data v, Data (Scalar v)) - -- | Construct a 2D vector from a pair of components. See also '&'. r2 :: (n, n) -> V2 n r2 = uncurry V2 @@ -85,8 +79,6 @@ project :: (Metric v, Fractional n) => v n -> v n -> v n project u v = ((v `dot` u) / quadrance u) *^ u -- find somewhere better for this --- TODO: coordinate instance for V2 - instance Transformable (V2 n) where transform = apply diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 473d4fac..ea008430 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -12,7 +12,6 @@ module Diagrams.TwoD.Vector ( -- * Special 2D vectors unitX, unitY, unit_X, unit_Y - , unit, unit_ -- * Converting between vectors and angles , e, xDir @@ -22,37 +21,30 @@ module Diagrams.TwoD.Vector -- * Synonym for R2 things ) where -import Control.Lens ((&), (.~), set', ASetter') +import Control.Lens (view, (&), (.~)) -import Diagrams.Angle -import Diagrams.Direction +import Diagrams.Angle +import Diagrams.Direction -import Linear.Vector hiding (unit) -import Diagrams.TwoD.Types import Linear.Metric - -unit :: (Additive v, Num n) => ASetter' (v n) n -> v n -unit l = set' l 1 zero - -unit_ :: (Additive v, Num n) => ASetter' (v n) n -> v n -unit_ l = set' l (-1) zero - +import Linear.Vector +import Linear.V2 -- | The unit vector in the positive X direction. unitX :: (R1 v, Additive v, Num n) => v n -unitX = unit _x - --- | The unit vector in the positive Y direction. -unitY :: (R2 v, Additive v, Num n) => v n -unitY = unit _y +unitX = zero & _x .~ 1 -- | The unit vector in the negative X direction. unit_X :: (R1 v, Additive v, Num n) => v n -unit_X = unit_ _x +unit_X = zero & _x .~ (-1) + +-- | The unit vector in the positive Y direction. +unitY :: (R2 v, Additive v, Num n) => v n +unitY = zero & _y .~ 1 -- | The unit vector in the negative Y direction. unit_Y :: (R2 v, Additive v, Num n) => v n -unit_Y = unit_ _y +unit_Y = zero & _y .~ (-1) -- | The origin of the direction AffineSpace. For all d, @d .-. xDir -- = d^._theta@. @@ -61,13 +53,8 @@ xDir = direction unitX -- | A unit vector at a specified angle counterclockwise from the -- positive X axis. -e :: (HasTheta v, R1 v, Additive v, RealFloat n) => Angle n -> v n -e a = unitX & _theta .~ a - --- -- | @perp v@ is perpendicular to and has the same magnitude as @v@. --- -- In particular @perp v == rotateBy (1/4) v@. --- perp :: Num n => V2 n -> V2 n --- perp (V2 x y) = V2 (-y) x +e :: Floating n => Angle n -> V2 n +e = angle . view rad -- | @leftTurn v1 v2@ tests whether the direction of @v2@ is a left -- turn from @v1@ (that is, if the direction of @v2@ can be obtained From 317c7ece6b471af0daa9cb4d89e6264e5c0ce457 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Fri, 29 Aug 2014 22:52:25 +0100 Subject: [PATCH 35/58] Merge Prelude.ThreeD with Prelude. To prevent name clashes, rotateAbout (2D) is now rotateAround and reflectAbout (3D) is now reflectAcross. --- diagrams-lib.cabal | 1 - src/Diagrams/Prelude/ThreeD.hs | 164 --------------------- src/Diagrams/ThreeD/Align.hs | 181 +++++++++--------------- src/Diagrams/ThreeD/Deform.hs | 58 +++----- src/Diagrams/ThreeD/Transform.hs | 25 ++-- src/Diagrams/TwoD.hs | 2 +- src/Diagrams/TwoD/Align.hs | 58 ++++---- src/Diagrams/TwoD/Deform.hs | 40 +++--- src/Diagrams/TwoD/Transform.hs | 10 +- src/Diagrams/TwoD/Transform/ScaleInv.hs | 20 +-- 10 files changed, 168 insertions(+), 391 deletions(-) delete mode 100644 src/Diagrams/Prelude/ThreeD.hs diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 7f4e2b72..c875432a 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -26,7 +26,6 @@ Source-repository head Library Exposed-modules: Diagrams.Prelude, - Diagrams.Prelude.ThreeD, Diagrams.Align, Diagrams.Angle, Diagrams.Combinators, diff --git a/src/Diagrams/Prelude/ThreeD.hs b/src/Diagrams/Prelude/ThreeD.hs deleted file mode 100644 index fdac6c85..00000000 --- a/src/Diagrams/Prelude/ThreeD.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} ------------------------------------------------------------------------------ --- | --- Module : Diagrams.Prelude.ThreeD --- Copyright : (c) 2014 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- A module to re-export most of the functionality of the diagrams --- core and standard library, including 3D types and functions. --- ------------------------------------------------------------------------------ - -module Diagrams.Prelude.ThreeD - ( - -- * Core library - -- | The core definitions of transformations, diagrams, - -- backends, and so on. - module Diagrams.Core - - -- * Standard library - - -- | Attributes (color, line style, etc.) and styles. - , module Diagrams.Attributes - - -- | Alignment of diagrams relative to their envelopes. - , module Diagrams.Align - - -- | Combining multiple diagrams into one. - , module Diagrams.Combinators - - -- | Giving concrete locations to translation-invariant things. - , module Diagrams.Located - - -- | Linear and cubic bezier segments. - , module Diagrams.Segment - - -- | Trails. - , module Diagrams.Trail - - -- | Parametrization of segments and trails. - , module Diagrams.Parametric - - -- | Adjusting the length of parameterized objects. - , module Diagrams.Parametric.Adjust - - -- | Computing tangent and normal vectors of segments and - -- trails. - , module Diagrams.Tangent - - -- | Trail-like things. - , module Diagrams.TrailLike - - -- | Paths. - , module Diagrams.Path - - -- | Cubic splines. - , module Diagrams.CubicSpline - - -- | Some additional transformation-related functions, like - -- conjugation of transformations. - , module Diagrams.Transform - - -- | Projective transformations and other deformations - -- lacking an inverse. - , module Diagrams.Deform - - -- | Giving names to subdiagrams and later retrieving - -- subdiagrams by name. - , module Diagrams.Names - - -- | Envelopes, aka functional bounding regions. - , module Diagrams.Envelope - - -- | Traces, aka embedded raytracers, for finding points on - -- the boundary of a diagram. - , module Diagrams.Trace - - -- | A query is a function that maps points in a vector space - -- to values in some monoid; they can be used to annotate - -- the points of a diagram with some values. - , module Diagrams.Query - - -- | Utilities for working with points. - , module Diagrams.Points - - -- | Angles - , module Diagrams.Angle - - -- | Convenience infix operators for working with coordinates. - , module Diagrams.Coordinates - - -- | Directions, distinguished from angles or vectors - , module Diagrams.Direction - - -- | things (shapes, transformations, combinators) specific - -- to creating three-dimensional diagrams. - , module Diagrams.ThreeD - - -- | Tools for making animations. - , module Diagrams.Animation - - -- | Various utility definitions. - , module Diagrams.Util - - -- * Convenience re-exports - -- | For representing and operating on colors. - , module Data.Colour - -- | A large list of color names. - , module Data.Colour.Names - -- | Semigroups and monoids show up all over the place, so things from - -- Data.Semigroup and Data.Monoid often come in handy. - , module Data.Semigroup - -- | For computing with vectors. - , module Linear.Vector - -- | For computing with points and vectors. - , module Linear.Affine - - -- | For working with 'Active' (i.e. animated) things. - , module Data.Active - - -- | Essential Lens Combinators - , (&), (.~), (%~) - - , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 - ) where - -import Diagrams.Core - -import Diagrams.Align -import Diagrams.Angle -import Diagrams.Animation -import Diagrams.Attributes -import Diagrams.Combinators -import Diagrams.Coordinates -import Diagrams.CubicSpline -import Diagrams.Deform -import Diagrams.Direction -import Diagrams.Envelope -import Diagrams.Located -import Diagrams.Names -import Diagrams.Parametric -import Diagrams.Parametric.Adjust -import Diagrams.Path -import Diagrams.Points -import Diagrams.Query -import Diagrams.Segment -import Diagrams.Tangent -import Diagrams.ThreeD -import Diagrams.Trace -import Diagrams.Trail hiding (trailPoints, loopPoints, linePoints) -import Diagrams.TrailLike -import Diagrams.Transform -import Diagrams.Util - -import Control.Applicative -import Control.Lens ((%~), (&), (.~)) -import Data.Active -import Data.Colour hiding (AffineSpace (..), atop, over) -import Data.Colour.Names hiding (tan) -import Data.Semigroup - -import Linear.Affine -import Linear.Vector hiding (unit) diff --git a/src/Diagrams/ThreeD/Align.hs b/src/Diagrams/ThreeD/Align.hs index ba7b5e21..adf2c372 100644 --- a/src/Diagrams/ThreeD/Align.hs +++ b/src/Diagrams/ThreeD/Align.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Align @@ -40,172 +39,124 @@ module Diagrams.ThreeD.Align ) where -import Diagrams.Core +import Diagrams.Core -import Diagrams.Align -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector +import Diagrams.Align +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector +import Diagrams.TwoD.Align import Linear.Vector -- | Translate the diagram along unitX so that all points have --- positive x-values. -alignXMin :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -alignXMin = align (negated unitX) +-- positive x-values. +alignXMin :: (Vn a ~ v n, Alignable a, HasOrigin a, + R1 v, Additive v, Fractional n) => a -> a +alignXMin = align unit_X -snugXMin :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -snugXMin = snug (negated unitX) +snugXMin :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R1 v, Additive v, Fractional n) => a -> a +snugXMin = snug unit_X -- | Translate the diagram along unitX so that all points have -- negative x-values. -alignXMax :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +alignXMax :: (Vn a ~ v n, Alignable a, HasOrigin a, + R1 v, Additive v, Fractional n) => a -> a alignXMax = align unitX -snugXMax :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +snugXMax :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R1 v, Additive v, Fractional n) => a -> a snugXMax = snug unitX +-- | Translate the diagram along unitY so that all points have +-- positive y-values. +alignYMin :: (Vn a ~ v n, Alignable a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a +alignYMin = align unit_Y + +snugYMin :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a +snugYMin = snug unit_Y + -- | Translate the diagram along unitY so that all points have -- negative y-values. -alignYMax :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +alignYMax :: (Vn a ~ v n, Alignable a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a alignYMax = align unitY --- | Move the origin along unitY until it touches the edge of the --- diagram. -snugYMax:: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +snugYMax :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a snugYMax = snug unitY --- | Translate the diagram along unitY so that all points have --- positive y-values. -alignYMin :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -alignYMin = align (negated unitY) -snugYMin :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -snugYMin = snug (negated unitY) +-- | Translate the diagram along unitZ so that all points have +-- positive z-values. +alignZMin :: (Vn a ~ v n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a +alignZMin = align unit_Z + +snugZMin :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a +snugZMin = snug unit_Z -- | Translate the diagram along unitZ so that all points have -- negative z-values. -alignZMax :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +alignZMax :: (Vn a ~ v n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a alignZMax = align unitZ --- | Move the origin along unitZ until it touches the edge of the --- diagram. -snugZMax:: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +snugZMax :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a snugZMax = snug unitZ --- | Translate the diagram along unitZ so that all points have --- positive z-values. -alignZMin :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -alignZMin = align (negated unitZ) - --- | Move the origin along unit_Z until it touches the edge of the --- diagram. -snugZMin :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -snugZMin = snug (negated unitZ) - --- | @alignX@ and @snugX@ move the local origin along unitX as follows: --- --- * @alignX (-1)@ moves the local origin to the low-x of the boundary; --- --- * @align 1@ moves the local origin to the high-x edge; --- --- * any other argument interpolates linearly between these. For --- example, @alignX 0@ centers, @alignX 2@ moves the origin one --- \"radius\" to the right of the right edge, and so on. --- --- * @snugX@ works the same way. - -alignX :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a -alignX = alignBy unitX - --- | See the documentation for 'alignX'. -snugX :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a -snugX = snugBy unitX - --- | Like 'alignX', but moving the local origin vertically, with an --- argument of @1@ corresponding to the top edge and @(-1)@ corresponding --- to the bottom edge. -alignY :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a -alignY = alignBy unitY - -snugY :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a -snugY = snugBy unitY - - -- | Like 'alignX', but moving the local origin in the Z direction, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignZ :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a +alignZ :: (Vn a ~ v n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => n -> a -> a alignZ = alignBy unitZ -snugZ :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => n -> a -> a +-- | See the documentation for 'alignZ'. +snugZ :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R3 v, Additive v, Fractional n) => n -> a -> a snugZ = snugBy unitZ --- | Center the local origin along the X-axis. -centerX :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -centerX = alignBy unitX 0 - -snugCenterX :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -snugCenterX = snugBy unitX 0 - --- | Center the local origin along the Y-axis. -centerY :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -centerY = alignBy unitY 0 - -snugCenterY :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -snugCenterY = snugBy unitY 0 -- | Center the local origin along the Z-axis. -centerZ :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -centerZ = alignBy unitZ 0 +centerZ :: (Vn a ~ v n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a +centerZ = alignBy unitZ 0 -snugCenterZ :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +snugCenterZ :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a snugCenterZ = snugBy unitZ 0 --- | Center along both the X- and Y-axes. -centerXY :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -centerXY = centerX . centerY - -snugCenterXY :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a -snugCenterXY = snugCenterX . snugCenterY - - -- | Center along both the X- and Z-axes. -centerXZ :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +centerXZ :: (Vn a ~ v n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a centerXZ = centerX . centerZ -snugCenterXZ :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +snugCenterXZ :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a snugCenterXZ = snugCenterX . snugCenterZ -- | Center along both the Y- and Z-axes. -centerYZ :: (Alignable a, HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +centerYZ :: (Vn a ~ v n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a centerYZ = centerZ . centerY -snugCenterYZ :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +snugCenterYZ :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a snugCenterYZ = snugCenterZ . snugCenterY -- | Center an object in three dimensions. -centerXYZ :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +centerXYZ :: (Vn a ~ v n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a centerXYZ = centerX . centerY . centerZ -snugCenterXYZ :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V3 n, Floating n) => a -> a +snugCenterXYZ :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a snugCenterXYZ = snugCenterX . snugCenterY . snugCenterZ diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs index 396e264b..06f5b603 100644 --- a/src/Diagrams/ThreeD/Deform.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -1,50 +1,28 @@ -module Diagrams.ThreeD.Deform where +module Diagrams.ThreeD.Deform + ( parallelX0, perspectiveX1, facingX + , parallelY0, perspectiveY1, facingY + , parallelZ0, perspectiveZ1, facingZ + ) where import Control.Lens import Diagrams.Deform -import Diagrams.ThreeD.Types +import Diagrams.TwoD.Deform --- | The parallel projection onto the plane x=0 -parallelX0 :: Floating n => Deformation V3 n -parallelX0 = Deformation (& _x .~ 0) - --- | The perspective division onto the plane x=1 along lines going --- through the origin. -perspectiveX1 :: Floating n => Deformation V3 n -perspectiveX1 = Deformation (\p -> let x = p^._x in - p & _x .~ 1 & _y //~ x & _z //~ x ) - --- | The parallel projection onto the plane y=0 -parallelY0 :: Floating n => Deformation V3 n -parallelY0 = Deformation (& _y .~ 0) - --- | The perspective division onto the plane y=1 along lines going --- through the origin. -perspectiveY1 :: Floating n => Deformation V3 n -perspectiveY1 = Deformation (\p -> let y = p^._y in - p & _x //~ y & _y .~ 1 & _z //~ y ) +import Linear.Vector +import Linear.V3 -- | The parallel projection onto the plane z=0 -parallelZ0 :: Floating n => Deformation V3 n -parallelZ0 = Deformation (& _z .~ 0) +parallelZ0 :: (R3 v, Num n) => Deformation v n +parallelZ0 = Deformation (_z .~ 0) -- | The perspective division onto the plane z=1 along lines going --- through the origin. -perspectiveZ1 :: Floating n => Deformation V3 n -perspectiveZ1 = Deformation (\p -> let z = p^._z in - p & _x //~ z & _y //~ z & _z .~ 1 ) - --- | The viewing transform for a viewer facing along the positive X --- axis. X coördinates stay fixed, while Y coördinates are compressed --- with increasing distance. @asDeformation (translation unitX) <> --- parallelX0 <> frustrumX = perspectiveX1@ -facingX :: Floating n => Deformation V3 n -facingX = Deformation (\v -> v & _y //~ (v^._x) & _z //~ (v^._x)) - -facingY :: Floating n => Deformation V3 n -facingY = Deformation (\v -> v & _x //~ (v^._y) & _z //~ (v^._y)) - -facingZ :: Floating n => Deformation V3 n -facingZ = Deformation (\v -> v & _x //~ (v^._z) & _y //~ (v^._z)) +-- through the origin. +perspectiveZ1 :: (R3 v, Functor v, Fractional n) => Deformation v n +perspectiveZ1 = Deformation $ \p -> p ^/ (p ^. _x) + +facingZ :: (R3 v, Functor v, Fractional n) => Deformation v n +facingZ = Deformation $ + \p -> let z = p ^. _z + in p ^/ z & _z .~ z diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index b354183d..4b295dfe 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -40,7 +40,7 @@ module Diagrams.ThreeD.Transform , reflectionX, reflectX , reflectionY, reflectY , reflectionZ, reflectZ - , reflectionAbout, reflectAbout + , reflectionAcross, reflectAcross -- * Utilities for Backends -- , onBasis @@ -56,8 +56,7 @@ import Diagrams.Transform import Control.Lens (view, (&), (*~), (.~), (//~)) import Data.Semigroup -import Diagrams.TwoD.Transform hiding (reflectAbout, reflectionAbout, - rotationAbout) +import Diagrams.TwoD.Transform import Linear.Affine import Linear.Metric @@ -106,7 +105,7 @@ aboutY (view rad -> a) = fromOrthogonal r where -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. rotationAbout - :: (Floating n) + :: Floating n => Point V3 n -- ^ origin of rotation -> Direction V3 n -- ^ direction of rotation axis -> Angle n -- ^ angle of rotation @@ -129,18 +128,18 @@ rotationAbout (P t) d (view rad -> a) -- without tilting, it will be, otherwise if only tilting is -- necessary, no panning will occur. The tilt will always be between -- ± 1/4 turn. -pointAt :: (Floating n) +pointAt :: Floating n => Direction V3 n -> Direction V3 n -> Direction V3 n -> Transformation V3 n pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) -- | pointAt' has the same behavior as 'pointAt', but takes vectors -- instead of directions. -pointAt' :: (Floating n) => V3 n -> V3 n -> V3 n -> Transformation V3 n +pointAt' :: Floating n => V3 n -> V3 n -> V3 n -> Transformation V3 n pointAt' about initial final = pointAtUnit (signorm about) (signorm initial) (signorm final) -- | pointAtUnit has the same behavior as @pointAt@, but takes unit vectors. -pointAtUnit :: (Floating n) => V3 n -> V3 n -> V3 n -> Transformation V3 n +pointAtUnit :: Floating n => V3 n -> V3 n -> V3 n -> Transformation V3 n pointAtUnit about initial final = tilt <> pan where -- rotating u by (signedAngle rel u v) about rel gives a vector in the direction of v signedAngle rel u v = signum (cross u v `dot` rel) *^ angleBetween u v @@ -189,22 +188,22 @@ reflectionZ = scalingZ (-1) reflectZ :: (Vn t ~ v n, R3 v, Transformable t, Additive v, Floating n) => t -> t reflectZ = transform reflectionZ --- | @reflectionAbout p v@ is a reflection across the plane through +-- | @reflectionAcross p v@ is a reflection across the plane through -- the point @p@ and normal to vector @v@. -reflectionAbout :: (R3 v, HasLinearMap v, Metric v, Fractional n) +reflectionAcross :: (R3 v, HasLinearMap v, Metric v, Fractional n) => Point v n -> v n -> Transformation v n -reflectionAbout p v = +reflectionAcross p v = conjugate (translation (origin .-. p)) reflect where reflect = fromLinear t (linv t) t = f v <-> f (negated v) f u w = w ^-^ 2 *^ project u w --- | @reflectAbout p v@ reflects a diagram in the line determined by +-- | @reflectAcross p v@ reflects a diagram across the plane though -- the point @p@ and the vector @v@. -reflectAbout :: (Vn t ~ v n, R3 v, HasLinearMap v, Metric v, Fractional n, Transformable t) +reflectAcross :: (Vn t ~ v n, R3 v, HasLinearMap v, Metric v, Fractional n, Transformable t) => Point v n -> v n -> t -> t -reflectAbout p v = transform (reflectionAbout p v) +reflectAcross p v = transform (reflectionAcross p v) -- Utilities ---------------------------------------- diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 8222af4c..5ed0433c 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -175,7 +175,7 @@ module Diagrams.TwoD -- * Transformations -- ** Rotation , rotation, rotate, rotateBy - , rotationAbout, rotateAbout + , rotationAround, rotateAround -- ** Scaling , scalingX, scaleX , scalingY, scaleY diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs index afd2fbff..73a9f600 100644 --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -41,11 +39,13 @@ module Diagrams.TwoD.Align ) where -import Diagrams.Core +import Diagrams.Core -import Diagrams.Align -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector +import Diagrams.Align +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector + +import Linear.Vector -- | Align along the left edge, i.e. translate the diagram in a -- horizontal direction so that the local origin is on the left edge @@ -108,45 +108,53 @@ snugBR = snugB . snugR -- -- * @snugX@ works the same way. -alignX :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => n -> a -> a +alignX :: (Vn a ~ v n, Alignable a, HasOrigin a, + R1 v, Additive v, Fractional n) => n -> a -> a alignX = alignBy unitX -- | See the documentation for 'alignX'. -snugX :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V2 n, Floating n) => n -> a -> a +snugX :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R1 v, Additive v, Fractional n) => n -> a -> a snugX = snugBy unitX -- | Like 'alignX', but moving the local origin vertically, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignY :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => n -> a -> a +alignY :: (Vn a ~ v n, Alignable a, HasOrigin a, + R2 v, Additive v, Fractional n) => n -> a -> a alignY = alignBy unitY -snugY :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V2 n, Floating n) => n -> a -> a +-- | See the documentation for 'alignY'. +snugY :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R2 v, Additive v, Fractional n) => n -> a -> a snugY = snugBy unitY + -- | Center the local origin along the X-axis. -centerX :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a -centerX = alignBy unitX 0 +centerX :: (Vn a ~ v n, Alignable a, HasOrigin a, + R1 v, Additive v, Fractional n) => a -> a +centerX = alignBy unitX 0 -snugCenterX :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +snugCenterX :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R1 v, Additive v, Fractional n) => a -> a snugCenterX = snugBy unitX 0 -- | Center the local origin along the Y-axis. -centerY :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a -centerY = alignBy unitY 0 +centerY :: (Vn a ~ v n, Alignable a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a +centerY = alignBy unitY 0 -snugCenterY :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +snugCenterY :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a snugCenterY = snugBy unitY 0 -- | Center along both the X- and Y-axes. -centerXY :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a -centerXY = center +centerXY :: (Vn a ~ v n, Alignable a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a +centerXY = centerX . centerY + +snugCenterXY :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a +snugCenterXY = snugCenterX . snugCenterY -snugCenterXY :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a -snugCenterXY = snugCenter diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs index 16b456f7..fbf0a429 100644 --- a/src/Diagrams/TwoD/Deform.hs +++ b/src/Diagrams/TwoD/Deform.hs @@ -3,33 +3,39 @@ module Diagrams.TwoD.Deform where import Control.Lens import Diagrams.Deform -import Diagrams.TwoD.Types --- | The parallel projection onto the line x=0 -parallelX0 :: Floating n => Deformation V2 n +import Linear.V2 +import Linear.Vector + +-- | The parallel projection onto the plane x=0 +parallelX0 :: (R1 v, Num n) => Deformation v n parallelX0 = Deformation (_x .~ 0) --- | The perspective division onto the line x=1 along lines going +-- | The perspective division onto the plane x=1 along lines going -- through the origin. -perspectiveX1 :: Floating n => Deformation V2 n -perspectiveX1 = Deformation (\p -> p & _y //~ (p^._x) & _x .~ 1) +perspectiveX1 :: (R1 v, Functor v, Fractional n) => Deformation v n +perspectiveX1 = Deformation $ \p -> p ^/ (p ^. _x) --- | The parallel projection onto the line y=0 -parallelY0 :: Floating n => Deformation V2 n -parallelY0 = Deformation (& _y .~ 0) +-- | The parallel projection onto the plane y=0 +parallelY0 :: (R2 v, Num n) => Deformation v n +parallelY0 = Deformation (_y .~ 0) --- | The perspective division onto the line y=1 along lines going +-- | The perspective division onto the plane y=1 along lines going -- through the origin. -perspectiveY1 :: Floating n => Deformation V2 n -perspectiveY1 = Deformation (\p -> p & _x //~ (p^._y) & _y .~ 1) +perspectiveY1 :: (R2 v, Functor v, Floating n) => Deformation v n +perspectiveY1 = Deformation $ \p -> p ^/ (p ^. _y) -- | The viewing transform for a viewer facing along the positive X -- axis. X coördinates stay fixed, while Y coördinates are compressed -- with increasing distance. @asDeformation (translation unitX) <> -- parallelX0 <> frustrumX = perspectiveX1@ -facingX :: Floating n => Deformation V2 n -facingX = Deformation (\v -> v & _y //~ (v^._x)) - -facingY :: Floating n => Deformation V2 n -facingY = Deformation (\v -> v & _x //~ (v^._y)) +facingX :: (R1 v, Functor v, Fractional n) => Deformation v n +facingX = Deformation $ + \p -> let x = p ^. _x + in p ^/ x & _x .~ x + +facingY :: (R2 v, Functor v, Fractional n) => Deformation v n +facingY = Deformation $ + \p -> let y = p ^. _y + in p ^/ y & _y .~ y diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index ebe004ed..83a601ba 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -24,7 +24,7 @@ module Diagrams.TwoD.Transform -- * Rotation , rotation, rotate, rotateBy - , rotationAbout, rotateAbout + , rotationAround, rotateAround -- * Scaling , scalingX, scaleX @@ -104,13 +104,13 @@ rotateBy = transform . rotation . review turn -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). -rotationAbout :: Floating n => P2 n -> Angle n -> T2 n -rotationAbout p angle = conjugate (translation (origin .-. p)) (rotation angle) +rotationAround :: Floating n => P2 n -> Angle n -> T2 n +rotationAround p angle = conjugate (translation (origin .-. p)) (rotation angle) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. -rotateAbout :: (Vn t ~ V2 n, Transformable t, Floating n) => P2 n -> Angle n -> t -> t -rotateAbout p angle = rotate angle `under` translation (origin .-. p) +rotateAround :: (Vn t ~ V2 n, Transformable t, Floating n) => P2 n -> Angle n -> t -> t +rotateAround p angle = rotate angle `under` translation (origin .-. p) -- Scaling ------------------------------------------------- diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index cd459453..8b0a975e 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -98,7 +98,7 @@ instance (Vn t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv angle = transform tr v ^. _theta rot :: (Vn k ~ Vn t, Transformable k) => k -> k - rot = rotateAbout l angle + rot = rotateAround l angle -- l' :: Point V2 n l' = transform tr l @@ -116,28 +116,28 @@ instance (Vn t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv = translate zeroV = id } - { rot = rotateAbout l angle - = rotateAbout l (direction (transform mempty v) - direction v) - = rotateAbout l (direction v - direction v) - = rotateAbout l 0 + { rot = rotateAround l angle + = rotateAround l (direction (transform mempty v) - direction v) + = rotateAround l (direction v - direction v) + = rotateAround l 0 = id } = ScaleInv t v l 2. transform t1 (transform t2 (ScaleInv t v l)) = let angle = direction (transform t2 v) - direction v - rot = rotateAbout l angle + rot = rotateAround l angle l' = transform t2 l trans = translate (l' .-. l) in transform t1 (ScaleInv (trans . rot $ t) (rot v) l') = let angle = direction (transform t2 v) - direction v - rot = rotateAbout l angle + rot = rotateAround l angle l' = transform t2 l trans = translate (l' .-. l) angle2 = direction (transform t1 (rot v)) - direction (rot v) - rot2 = rotateAbout l' angle2 + rot2 = rotateAround l' angle2 l'2 = transform t1 l' trans2 = translate (l'2 .-. l') in @@ -151,7 +151,7 @@ instance (Vn t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv = translate (transform (t1 <> t2) l .-. transform t2 l) = translate (transform t1 l .-. l) } - { rot v = rotateAbout l angle v + { rot v = rotateAround l angle v = rotate angle `under` translation (origin .-. l) $ v = rotate angle v } @@ -159,7 +159,7 @@ instance (Vn t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv = direction (transform t1 (rotate angle v)) - direction (rotate angle v) = direction (transform t1 (rotate angle v)) - direction v - angle } - { rot2 = rotateAbout l' angle2 + { rot2 = rotateAround l' angle2 = ??? } From d4a5fbd383b34241881e2009f767c3dc70939d98 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 31 Aug 2014 17:09:40 +0100 Subject: [PATCH 36/58] Added Prelude back. --- src/Diagrams/Prelude.hs | 168 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 168 insertions(+) create mode 100644 src/Diagrams/Prelude.hs diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs new file mode 100644 index 00000000..f87cca23 --- /dev/null +++ b/src/Diagrams/Prelude.hs @@ -0,0 +1,168 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Prelude +-- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- A module to re-export most of the functionality of the diagrams +-- core and standard library. +-- +----------------------------------------------------------------------------- + +module Diagrams.Prelude + ( + -- * Core library + -- | The core definitions of transformations, diagrams, + -- backends, and so on. + module Diagrams.Core + + -- * Standard library + + -- | Attributes (color, line style, etc.) and styles. + , module Diagrams.Attributes + + -- | Alignment of diagrams relative to their envelopes. + , module Diagrams.Align + + -- | Combining multiple diagrams into one. + , module Diagrams.Combinators + + -- | Giving concrete locations to translation-invariant things. + , module Diagrams.Located + + -- | Linear and cubic bezier segments. + , module Diagrams.Segment + + -- | Trails. + , module Diagrams.Trail + + -- | Parametrization of segments and trails. + , module Diagrams.Parametric + + -- | Adjusting the length of parameterized objects. + , module Diagrams.Parametric.Adjust + + -- | Computing tangent and normal vectors of segments and + -- trails. + , module Diagrams.Tangent + + -- | Trail-like things. + , module Diagrams.TrailLike + + -- | Paths. + , module Diagrams.Path + + -- | Cubic splines. + , module Diagrams.CubicSpline + + -- | Some additional transformation-related functions, like + -- conjugation of transformations. + , module Diagrams.Transform + + -- | Projective transformations and other deformations + -- lacking an inverse. + , module Diagrams.Deform + + -- | Giving names to subdiagrams and later retrieving + -- subdiagrams by name. + , module Diagrams.Names + + -- | Envelopes, aka functional bounding regions. + , module Diagrams.Envelope + + -- | Traces, aka embedded raytracers, for finding points on + -- the boundary of a diagram. + , module Diagrams.Trace + + -- | A query is a function that maps points in a vector space + -- to values in some monoid; they can be used to annotate + -- the points of a diagram with some values. + , module Diagrams.Query + + -- | Utilities for working with points. + , module Diagrams.Points + + -- | Angles + , module Diagrams.Angle + -- | Convenience infix operators for working with coordinates. + , module Diagrams.Coordinates + -- | Directions, distinguished from angles or vectors + , module Diagrams.Direction + + -- | A wide range of things (shapes, transformations, + -- combinators) specific to creating two-dimensional + -- diagrams. + , module Diagrams.TwoD + + -- | Tools for making animations. + , module Diagrams.Animation + + -- | Various utility definitions. + , module Diagrams.Util + + -- * Convenience re-exports + -- | For representing and operating on colors. + , module Data.Colour + -- | A large list of color names. + , module Data.Colour.Names + -- | Semigroups and monoids show up all over the place, so things from + -- Data.Semigroup and Data.Monoid often come in handy. + , module Data.Semigroup + -- | For computing with vectors. + , module Linear.Vector + -- | For computing with points and vectors. + , module Linear.Affine + -- | For computing with dot products and norm. + , module Linear.Metric + + -- | For working with 'Active' (i.e. animated) things. + , module Data.Active + + -- | Essential Lens Combinators + , (&), (.~), (%~) + + , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 + ) where + +import Diagrams.Core + +import Diagrams.Align +import Diagrams.Angle +import Diagrams.Animation +import Diagrams.Attributes +import Diagrams.Combinators +import Diagrams.Coordinates +import Diagrams.CubicSpline +import Diagrams.Deform +import Diagrams.Direction +import Diagrams.Envelope +import Diagrams.Located +import Diagrams.Names +import Diagrams.Parametric +import Diagrams.Parametric.Adjust +import Diagrams.Path +import Diagrams.Points +import Diagrams.Query +import Diagrams.Segment +import Diagrams.Tangent +import Diagrams.Trace +import Diagrams.Trail hiding (linePoints, loopPoints, + trailPoints) +import Diagrams.TrailLike +import Diagrams.Transform +import Diagrams.TwoD +import Diagrams.Util + +import Control.Applicative +import Control.Lens ((%~), (&), (.~)) +import Data.Active +import Data.Colour hiding (AffineSpace (..), atop, over) +import Data.Colour.Names hiding (tan) +import Data.Semigroup + +import Linear.Affine +import Linear.Vector +import Linear.Metric + From 5d68ad75ae33f0150eb8bfcac731c658f384ed56 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 31 Aug 2014 18:44:40 +0100 Subject: [PATCH 37/58] Added Polar, Cylindrical and Spherical coordinates. --- diagrams-lib.cabal | 55 +++++---- src/Diagrams/Angle.hs | 92 +++++++------- src/Diagrams/Coordinates.hs | 2 + src/Diagrams/Deform.hs | 9 +- src/Diagrams/Direction.hs | 9 +- src/Diagrams/ThreeD/Shapes.hs | 16 +-- src/Diagrams/ThreeD/Types.hs | 66 +++------- src/Diagrams/ThreeD/Types/Cylindrical.hs | 102 ++++++++++++++++ src/Diagrams/ThreeD/Types/Spherical.hs | 123 +++++++++++++++++++ src/Diagrams/TwoD/Types.hs | 35 ++++-- src/Diagrams/TwoD/Types/Polar.hs | 147 +++++++++++++++++++++++ 11 files changed, 506 insertions(+), 150 deletions(-) create mode 100644 src/Diagrams/ThreeD/Types/Cylindrical.hs create mode 100644 src/Diagrams/ThreeD/Types/Spherical.hs create mode 100644 src/Diagrams/TwoD/Types/Polar.hs diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index c875432a..eaef98d1 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -28,54 +28,56 @@ Library Exposed-modules: Diagrams.Prelude, Diagrams.Align, Diagrams.Angle, - Diagrams.Combinators, - Diagrams.Coordinates, Diagrams.Attributes, Diagrams.Attributes.Compile, - Diagrams.Points, + Diagrams.BoundingBox, + Diagrams.Combinators, + Diagrams.Coordinates, + Diagrams.CubicSpline, + Diagrams.CubicSpline.Internal, + Diagrams.Deform + Diagrams.Direction, + Diagrams.Envelope, Diagrams.Located, + Diagrams.Names, Diagrams.Parametric, Diagrams.Parametric.Adjust, - Diagrams.Segment, - Diagrams.Trail, - Diagrams.TrailLike, Diagrams.Path, - Diagrams.CubicSpline, - Diagrams.CubicSpline.Internal, - Diagrams.Direction, + Diagrams.Points, + Diagrams.Query, + Diagrams.Segment, Diagrams.Solve, Diagrams.Tangent, - Diagrams.Transform, - Diagrams.Deform - Diagrams.BoundingBox, - Diagrams.Names, - Diagrams.Envelope, Diagrams.Trace, - Diagrams.Query, + Diagrams.Trail, + Diagrams.TrailLike, + Diagrams.Transform, Diagrams.TwoD, - Diagrams.TwoD.Types, + Diagrams.TwoD.Adjust, Diagrams.TwoD.Align, + Diagrams.TwoD.Arc, Diagrams.TwoD.Arrow, Diagrams.TwoD.Arrowheads, Diagrams.TwoD.Attributes, Diagrams.TwoD.Combinators, + Diagrams.TwoD.Curvature, Diagrams.TwoD.Deform, - Diagrams.TwoD.Transform, - Diagrams.TwoD.Transform.ScaleInv, Diagrams.TwoD.Ellipse, - Diagrams.TwoD.Arc, - Diagrams.TwoD.Segment, - Diagrams.TwoD.Curvature, + Diagrams.TwoD.Image, + Diagrams.TwoD.Model, Diagrams.TwoD.Offset, Diagrams.TwoD.Path, Diagrams.TwoD.Polygons, + Diagrams.TwoD.Segment, Diagrams.TwoD.Shapes, - Diagrams.TwoD.Vector, Diagrams.TwoD.Size, - Diagrams.TwoD.Model, Diagrams.TwoD.Text, - Diagrams.TwoD.Image, - Diagrams.TwoD.Adjust, + Diagrams.TwoD.Transform, + Diagrams.TwoD.Transform.ScaleInv, + Diagrams.TwoD.Types, + Diagrams.TwoD.Types.Polar, + Diagrams.TwoD.Vector, + Diagrams.ThreeD, Diagrams.ThreeD.Align, Diagrams.ThreeD.Attributes, Diagrams.ThreeD.Camera, @@ -84,8 +86,9 @@ Library Diagrams.ThreeD.Shapes, Diagrams.ThreeD.Transform, Diagrams.ThreeD.Types, + Diagrams.ThreeD.Types.Cylindrical + Diagrams.ThreeD.Types.Spherical, Diagrams.ThreeD.Vector, - Diagrams.ThreeD, Diagrams.Animation, Diagrams.Animation.Active, Diagrams.Util, diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index ba808485..c692b000 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} --- {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Angle @@ -12,18 +8,28 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Type for representing angles, independent of vector-space +-- Type for representing angles. -- ----------------------------------------------------------------------------- module Diagrams.Angle - ( + ( -- * Angle type Angle - , rad, turn, deg - , fullTurn, halfTurn, quarterTurn, angleRatio - , sinA, cosA, tanA, asinA, acosA, atanA, atan2A - , (@@) - , angleBetween + + -- ** Using angles + , (@@), rad, turn, deg + + -- ** Common angles + , fullTurn, halfTurn, quarterTurn + + -- ** Trigonometric functions + , sinA, cosA, tanA + , asinA, acosA, atanA, atan2A + + -- ** Angle utilities + , angleBetween, angleRatio + + -- ** Classes , HasTheta(..) , HasPhi(..) ) where @@ -40,10 +46,12 @@ import Linear.Metric import Linear.Vector -- | Angles can be expressed in a variety of units. Internally, --- they are represented in radians. +-- they are represented in radians. newtype Angle n = Radians n deriving (Read, Show, Eq, Ord, Functor) +type instance N (Angle n) = n + instance Applicative Angle where pure = Radians {-# INLINE pure #-} @@ -56,29 +64,31 @@ instance Additive Angle where instance Num n => Semigroup (Angle n) where (<>) = (^+^) + {-# INLINE (<>) #-} instance Num n => Monoid (Angle n) where mappend = (<>) mempty = Radians 0 -type instance N (Angle n) = n - -- | The radian measure of an @Angle@ @a@ can be accessed as @a --- ^. rad@. A new @Angle@ can be defined in radians as @pi \@\@ rad@. +-- ^. rad@. A new @Angle@ can be defined in radians as @pi \@\@ rad@. rad :: Iso' (Angle n) n rad = iso (\(Radians r) -> r) Radians +{-# INLINE rad #-} -- | The measure of an @Angle@ @a@ in full circles can be accessed as --- @a ^. turn@. A new @Angle@ of one-half circle can be defined in as --- @1/2 \@\@ turn@. +-- @a ^. turn@. A new @Angle@ of one-half circle can be defined in as +-- @1/2 \@\@ turn@. turn :: Floating n => Iso' (Angle n) n turn = iso (\(Radians r) -> r / (2*pi)) (Radians . (*(2*pi))) +{-# INLINE turn #-} -- | The degree measure of an @Angle@ @a@ can be accessed as @a --- ^. deg@. A new @Angle@ can be defined in degrees as @180 \@\@ --- deg@. +-- ^. deg@. A new @Angle@ can be defined in degrees as @180 \@\@ +-- deg@. deg :: Floating n => Iso' (Angle n) n deg = iso (\(Radians r) -> r / (2*pi/360)) (Radians . ( * (2*pi/360))) +{-# INLINE deg #-} -- | An angle representing one full turn. fullTurn :: Floating v => Angle v @@ -94,7 +104,7 @@ quarterTurn = 0.25 @@ turn -- | Calculate ratio between two angles. angleRatio :: Floating n => Angle n -> Angle n -> n -angleRatio a b = abs (a ^. rad) / abs (b ^. rad) +angleRatio a b = (a ^. rad) / (b ^. rad) -- | The sine of the given @Angle@. sinA :: Floating n => Angle n -> n @@ -121,31 +131,15 @@ atanA :: Floating n => n -> Angle n atanA = Radians . atan -- | @atan2A n d@ is the @Angle with tangent @n/d@, unless d is 0, in --- which case it is ±π/2. +-- which case it is ±π/2. atan2A :: RealFloat n => n -> n -> Angle n atan2A y x = Radians $ atan2 y x --- Like atan2 but unable to differentiate between 0 and -0: --- atan2 0 (-0) = pi --- atan2' 0 (-0) = 0 --- --- have to decide if this technicality is worth a RealFloat instance. - --- atan2' :: (Floating n, Ord n) => n -> n -> n --- atan2' y x --- | x > 0 = atan (y/x) --- | x == 0 && y > 0 = pi/2 --- | x < 0 && y > 0 = pi + atan (y/x) --- | x <= 0 && y < 0 = -atan2' (-y) x --- | y == 0 && x < 0 = pi -- must be after the previous test on zero y --- | x == 0 && y == 0 = y -- must be after the other double zero tests --- | otherwise = x + y -- x or y is a NaN, return a NaN (via +) - -- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. -- --- More generally, @\@\@@ reverses the @Iso\'@ on its right, and --- applies the @Iso\'@ to the value on the left. @Angle@s are the --- motivating example where this order improves readability. +-- More generally, @\@\@@ reverses the @Iso\'@ on its right, and +-- applies the @Iso\'@ to the value on the left. @Angle@s are the +-- motivating example where this order improves readability. (@@) :: b -> Iso' a b -> a -- The signature above is slightly specialized, in favor of readability a @@ i = review i a @@ -166,17 +160,19 @@ angleBetween v1 v2 = acos (signorm v1 `dot` signorm v2) @@ rad -- | The class of types with at least one angle coordinate, called _theta. class HasTheta t where - _theta :: RealFloat n => Lens' (t n) (Angle n) + _theta :: RealFloat n => Lens' (t n) (Angle n) -- | The class of types with at least two angle coordinates, the --- second called _phi. +-- second called _phi. class HasTheta t => HasPhi t where - _phi :: RealFloat n => Lens' (t n) (Angle n) + _phi :: RealFloat n => Lens' (t n) (Angle n) -- Point instances instance HasTheta v => HasTheta (Point v) where - _theta = _pIso . _theta + _theta = lensP . _theta + {-# INLINE _theta #-} instance HasPhi v => HasPhi (Point v) where - _phi = _pIso . _phi + _phi = lensP . _phi + {-# INLINE _phi #-} diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index 41152b6d..3d67573b 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -22,6 +23,7 @@ module Diagrams.Coordinates where import Control.Lens (Lens') + import Diagrams.Points import Linear (V2 (..), V3 (..), V4 (..)) diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs index 6ca3ca84..c0a6accd 100644 --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -73,19 +73,22 @@ instance Deformable (Point v n) where -- precision by a series of @Segment@s. @deformSegment@ does this, -- which allows types built from lists of @Segment@s to themselves be -- @Deformable@. -deformSegment :: (Metric v, OrderedField n) => n -> Deformation v n -> FixedSegment v n -> [FixedSegment v n] +deformSegment :: (Metric v, OrderedField n) + => n -> Deformation v n -> FixedSegment v n -> [FixedSegment v n] deformSegment epsilon t s | goodEnough epsilon t s = [approx t s] | otherwise = concatMap (deformSegment epsilon t) [s1, s2] where (s1, s2) = splitAtParam s 0.5 -approx :: (Metric v, OrderedField n) => Deformation v n -> FixedSegment v n -> FixedSegment v n +approx :: (Metric v, OrderedField n) + => Deformation v n -> FixedSegment v n -> FixedSegment v n approx t (FLinear p0 p1) = FLinear (deform t p0) (deform t p1) approx t (FCubic p0 c1 c2 p1) = FCubic (f p0) (f c1) (f c2) (f p1) where f = deform t -goodEnough :: (Metric v, Ord n, Floating n) => n -> Deformation v n -> FixedSegment v n -> Bool +goodEnough :: (Metric v, Ord n, Floating n) + => n -> Deformation v n -> FixedSegment v n -> Bool goodEnough e t s = all (< e) [norm $ deform t (s `atParam` u) .-. approx t s `atParam` u | u <- [0.25, 0.5, 0.75]] diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index b2ae1156..2f7a2dd9 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -23,6 +23,7 @@ import Control.Lens (Iso', iso) import Diagrams.Angle import Diagrams.Core + import Linear.Metric -------------------------------------------------------------------------------- @@ -40,13 +41,13 @@ type instance N (Direction v n) = n -- instance (Transformable v, Vn (Direction v n) ~ v n) => Transformable (Direction v) where instance (Vn (v n) ~ v n, Transformable (v n)) => Transformable (Direction v n) where - transform t (Direction v) = Direction (transform t v) + transform t (Direction v) = Direction (transform t v) instance HasTheta v => HasTheta (Direction v) where - _theta = _Dir . _theta + _theta = _Dir . _theta instance HasPhi v => HasPhi (Direction v) where - _phi = _Dir . _phi + _phi = _Dir . _phi -- | _Dir is provided to allow efficient implementations of functions -- in particular vector-spaces, but should be used with care as it @@ -64,7 +65,7 @@ fromDirection :: (Metric v, Floating n) => Direction v n -> v n fromDirection (Direction v) = signorm v -- | compute the positive angle between the two directions in their common plane -angleBetweenDirs :: (Metric v, Floating n) +angleBetweenDirs :: (Metric v, Floating n) => Direction v n -> Direction v n -> Angle n angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index ec422048..f77b460e 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -51,14 +51,14 @@ instance Fractional n => Renderable (Ellipsoid n) NullBackend where render _ _ = mempty -- | A sphere of radius 1 with its center at the origin. -sphere :: (Typeable n, OrderedField n, Backend b V3 n, Renderable (Ellipsoid n) b) => Diagram b V3 n +sphere :: (Typeable n, OrderedField n, Renderable (Ellipsoid n) b) => Diagram b V3 n sphere = mkQD (Prim $ Ellipsoid mempty) (mkEnvelope sphereEnv) (mkTrace sphereTrace) mempty (Query sphereQuery) where - sphereEnv v = 1 / norm v + sphereEnv v = 1 / norm v sphereTrace (P p) v = mkSortedList $ quadForm a b c where a = v `dot` v @@ -80,7 +80,7 @@ instance Fractional n => Renderable (Box n) NullBackend where -- | A cube with side length 1, in the positive octant, with one -- vertex at the origin. -cube :: (Typeable n, OrderedField n, Backend b V3 n, Renderable (Box n) b) => Diagram b V3 n +cube :: (Typeable n, OrderedField n, Renderable (Box n) b) => Diagram b V3 n cube = mkQD (Prim $ Box mempty) (mkEnvelope boxEnv) (mkTrace boxTrace) @@ -118,7 +118,7 @@ instance Fractional n => Renderable (Frustum n) NullBackend where -- | A frustum of a right circular cone. It has height 1 oriented -- along the positive z axis, and radii r0 and r1 at Z=0 and Z=1. -- 'cone' and 'cylinder' are special cases. -frustum :: (Typeable n, OrderedField n, RealFloat n, Backend b V3 n, Renderable (Frustum n) b) => n -> n -> Diagram b V3 n +frustum :: (TypeableFloat n, Renderable (Frustum n) b) => n -> n -> Diagram b V3 n frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) (mkEnvelope frEnv) (mkTrace frTrace) @@ -133,7 +133,7 @@ frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) a = norm $ projectXY v -- The plane containing v and the z axis intersects the frustum in a trapezoid -- Test the four corners of this trapezoid; one must determine the Envelope - frEnv v = maximum . map (norm . project v . review cylindrical) $ corners + frEnv v = maximum . map (norm . project v . review r3CylindricalIso) $ corners where θ = v ^. _theta corners = [(r1,θ,1), (-r1,θ,1), (r0,θ,0), (-r0,θ,0)] @@ -154,17 +154,17 @@ frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) zbounds t = ray t ^. _z >= 0 && ray t ^. _z <= 1 ends = concatMap cap [0,1] - cap z = [ t | ray t ^. cylindrical . _1 < r0 + z * dr ] + cap z = [ t | ray t ^. lensP . r3CylindricalIso . _1 < r0 + z * dr ] where t = (z - pz) / vz -- | A cone with its base centered on the origin, with radius 1 at the -- base, height 1, and it's apex on the positive Z axis. -cone :: (Typeable n, OrderedField n, RealFloat n, Backend b V3 n, Renderable (Frustum n) b) => Diagram b V3 n +cone :: (TypeableFloat n, Renderable (Frustum n) b) => Diagram b V3 n cone = frustum 1 0 -- | A circular cylinder of radius 1 with one end cap centered on the -- origin, and extending to Z=1. -cylinder :: (Typeable n, OrderedField n, RealFloat n, Backend b V3 n, Renderable (Frustum n) b) => Diagram b V3 n +cylinder :: (TypeableFloat n, Renderable (Frustum n) b) => Diagram b V3 n cylinder = frustum 1 1 diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 6ddb4c32..39eaddb8 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -17,29 +17,27 @@ module Diagrams.ThreeD.Types r3, unr3, mkR3 , p3, unp3, mkP3 , r3Iso, p3Iso, project + , r3SphericalIso, r3CylindricalIso , V3 (..), P3 , R1 (..), R2 (..), R3 (..) - -- * other coördinate systems - , Spherical(..), Cylindrical(..), HasPhi(..) ) where -import Control.Lens (Iso', iso, _2) +import Control.Lens (Iso', iso, _1, _2, _3) import Diagrams.Angle import Diagrams.Core import Diagrams.Points +import Diagrams.TwoD.Types import Linear.V3 as V import Linear.Metric -import Linear.Vector ------------------------------------------------------------ -- 3D Euclidean space -- Basic R3 types --- type R3 = V3 type P3 = Point V3 r3Iso :: Iso' (V3 n) (n, n, n) @@ -72,56 +70,28 @@ p3Iso = iso unp3 p3 mkP3 :: n -> n -> n -> P3 n mkP3 x y z = p3 (x, y, z) - --- | @project u v@ computes the projection of @v@ onto @u@. -project :: (Metric v, Fractional n) => v n -> v n -> v n -project u v = ((v `dot` u) / quadrance u) *^ u - --- | Types which can be expressed in spherical 3D coordinates, as a --- triple (r,θ,φ), where θ is rotation about the Z axis, and φ is the --- angle from the Z axis. -class Spherical v where - spherical :: RealFloat n => Iso' (v n) (n, Angle n, Angle n) - --- | Types which can be expressed in cylindrical 3D coordinates. -class Cylindrical v where - cylindrical :: Floating n => Iso' (v n) (n, Angle n, n) -- r, θ, z - -instance Cylindrical v => Cylindrical (Point v) where - cylindrical = _pIso . cylindrical - -instance Spherical v => Spherical (Point v) where - spherical = _pIso . spherical - type instance V (V3 n) = V3 type instance N (V3 n) = n instance Transformable (V3 n) where - transform = apply - -instance Cylindrical V3 where - cylindrical = iso - (\(V3 x y z) -> (sqrt (sq x + sq y), atanA (y/x), z)) - (\(r,θ,z) -> V3 (r*cosA θ) (r*sinA θ) z) - where sq x = x * x + transform = apply -instance Spherical V3 where - spherical = iso - (\v@(V3 x y z) -> (norm v, atan2A y x, acosA (z / norm v))) - (\(r,θ,φ) -> V3 (r * cosA θ * sinA φ) (r * sinA θ * sinA φ) (r * cosA φ)) +r3SphericalIso :: RealFloat n => Iso' (V3 n) (n, Angle n, Angle n) +r3SphericalIso = iso + (\v@(V3 x y z) -> (norm v, atan2A y x, acosA (z / norm v))) + (\(r,θ,φ) -> V3 (r * cosA θ * sinA φ) (r * sinA θ * sinA φ) (r * cosA φ)) - -- spherical = iso - -- (\v@(R3 x y z) -> (magnitude v, atanA (y/x), atanA (v^._r/z))) - -- (\(r,θ,φ) -> R3 (r*cosA θ*sinA φ) (r*sinA θ*sinA φ) (r*cosA φ)) +r3CylindricalIso :: RealFloat n => Iso' (V3 n) (n, Angle n, n) +r3CylindricalIso = iso + (\(V3 x y z) -> (sqrt $ x*x + y*y, atan2A y x, z)) + (\(r,θ,z) -> V3 (r*cosA θ) (r*sinA θ) z) --- We'd like to write: instance Spherical t => HasR t --- But GHC can't work out that the instance won't overlap. Just write them explicitly: - --- instance HasR V3 where --- _r = spherical . _1 +instance HasR V3 where + _r = r3SphericalIso . _1 instance HasTheta V3 where - _theta = cylindrical . _2 + _theta = r3CylindricalIso . _2 + +instance HasPhi V3 where + _phi = r3SphericalIso . _3 --- instance HasPhi V3 where --- _phi = spherical . _3 diff --git a/src/Diagrams/ThreeD/Types/Cylindrical.hs b/src/Diagrams/ThreeD/Types/Cylindrical.hs new file mode 100644 index 00000000..f4f0da92 --- /dev/null +++ b/src/Diagrams/ThreeD/Types/Cylindrical.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Diagrams.ThreeD.Types.Cylindrical + ( -- * Data type + Cylindrical + , mkCylindrical, cylindrical, uncylindrical + , cylindricalV3, cylindricalIso + + -- * Classes + , Radial (..), Circle (..), Cylinder (..) + , HasX (..), HasY (..), HasZ (..) + + -- * Basis elements + , er, eθ, etheta, eh + + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Distributive +import Data.Foldable +import Data.Functor.Rep +import Data.Typeable +import GHC.Generics (Generic1) + +import Diagrams.Angle +import Diagrams.TwoD.Types.Polar +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Types.Spherical + +import Linear.Vector + + +-- | Space which has a radial, angular and height basis. +class Circle t => Cylinder t where + _longitude :: Lens' (t a) a + _cylindrical :: Lens' (t a) (Cylindrical a) + +eh :: Cylinder v => E v +eh = E (_cylindrical . cylindricalWrapper . _z) + +newtype Cylindrical a = Cylindrical (V3 a) + deriving (Monad, Functor, Typeable, MonadFix, Applicative, Traversable, + Generic1, MonadZip, Foldable) + +cylindricalWrapper :: Iso' (Cylindrical a) (V3 a) +cylindricalWrapper = iso (\(Cylindrical v) -> v) Cylindrical + +mkCylindrical :: n -> Angle n -> n -> Cylindrical n +mkCylindrical r θ z = Cylindrical $ V3 r (θ ^. rad) z + +cylindrical :: (n, Angle n, n) -> Cylindrical n +cylindrical (r,θ,z) = mkCylindrical r θ z + +uncylindrical :: Cylindrical n -> (n, Angle n, n) +uncylindrical (Cylindrical (V3 r θ z)) = (r, θ @@ rad, z) + +cylindricalIso :: Iso' (Cylindrical n) (n, Angle n, n) +cylindricalIso = iso uncylindrical cylindrical + +instance Distributive Cylindrical where + distribute f = Cylindrical $ V3 (fmap (\(Cylindrical (V3 x _ _)) -> x) f) + (fmap (\(Cylindrical (V3 _ y _)) -> y) f) + (fmap (\(Cylindrical (V3 _ _ z)) -> z) f) + +instance Representable Cylindrical where + type Rep Cylindrical = E Cylindrical + tabulate f = Cylindrical $ V3 (f er) (f eθ) (f eh) + index xs (E l) = view l xs + +instance Radial Cylindrical where + _radial = cylindricalWrapper . _x + +instance Circle Cylindrical where + _azimuth = cylindricalWrapper . _y . from rad + _polar = cylindricalWrapper . _xy . _Unwrapped' + +instance Cylinder Cylindrical where + _longitude = cylindricalWrapper . _z + _cylindrical = id + +cylindricalV3 :: RealFloat n => Iso' (Cylindrical n) (V3 n) +cylindricalV3 = iso + (\(Cylindrical (V3 r θ z)) -> V3 (r*cos θ) (r*sin θ) z) + (\(V3 x y z) -> Cylindrical $ V3 (sqrt $ x*x + y*y) (atan2 y x) z) + +instance HasX Cylindrical where x_ = cylindricalV3 . _x +instance HasY Cylindrical where xy_ = cylindricalV3 . _xy +instance HasZ Cylindrical where xyz_ = cylindricalV3 + +instance HasR Cylindrical where _r = cylindricalV3 . _r +instance HasTheta Cylindrical where _theta = _azimuth +instance HasPhi Cylindrical where _phi = cylindricalV3 . _phi + diff --git a/src/Diagrams/ThreeD/Types/Spherical.hs b/src/Diagrams/ThreeD/Types/Spherical.hs new file mode 100644 index 00000000..b8d93ca9 --- /dev/null +++ b/src/Diagrams/ThreeD/Types/Spherical.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Diagrams.ThreeD.Types.Spherical + ( -- * Data type + Spherical + , mkSpherical, spherical, unspherical, sphericalIso, sphericalV3 + + -- ** Spherical functions + , interpSpherical + + -- * Classes + , Radial (..), Circle (..), Sphere (..) + , HasX (..), HasY (..), HasZ (..), HasR (..) + + -- * Basis elements + , er, eθ, etheta, eφ, ephi + + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Distributive +import Data.Foldable +import Data.Functor.Rep +import Data.Typeable +import GHC.Generics (Generic1) + +import Diagrams.Angle +import Diagrams.TwoD.Types.Polar + +import Linear.Affine +import Linear.Metric +import Linear.V1 +import Linear.V2 +import Linear.V3 +import Linear.Vector + +-- | Space which has a radial and two angular basis. The inclination is the +-- positive angles from the z-axis. +class Circle t => Sphere t where + _inclination :: Lens' (t a) (Angle a) + _spherical :: Lens' (t a) (Spherical a) + +eφ, ephi :: Sphere v => E v +eφ = E (_spherical . sphericalV3 . _z) +ephi = eφ + +newtype Spherical a = Spherical (V3 a) + deriving (Monad, Functor, Typeable, MonadFix, Applicative, Traversable, + Generic1, MonadZip, Foldable) + +sphericalV3 :: Iso' (Spherical a) (V3 a) +sphericalV3 = iso (\(Spherical v) -> v) Spherical + +mkSpherical :: n -> Angle n -> Angle n -> Spherical n +mkSpherical r θ φ = Spherical $ V3 r (θ ^. rad) (φ ^. rad) + +spherical :: (n, Angle n, Angle n) -> Spherical n +spherical (n, θ, φ) = mkSpherical n θ φ + +unspherical :: Spherical n -> (n, Angle n, Angle n) +unspherical (Spherical (V3 r θ φ)) = (r, θ @@ rad, φ @@ rad) + +-- | Linear interpolation between spherical coordinates. +interpSpherical :: Num n => n -> Spherical n -> Spherical n -> Spherical n +interpSpherical t (Spherical a) (Spherical b) = Spherical $ lerp t a b + +instance Distributive Spherical where + distribute f = Spherical $ V3 (fmap (\(Spherical (V3 x _ _)) -> x) f) + (fmap (\(Spherical (V3 _ y _)) -> y) f) + (fmap (\(Spherical (V3 _ _ z)) -> z) f) + +instance Representable Spherical where + type Rep Spherical = E Spherical + tabulate f = Spherical $ V3 (f er) (f eθ) (f eφ) + index xs (E l) = view l xs + +instance Radial Spherical where + _radial = sphericalV3 . _x + +instance Circle Spherical where + _azimuth = sphericalV3 . _y . from rad + _polar = sphericalV3 . _xy . _Unwrapped' + +instance Sphere Spherical where + _inclination = sphericalV3 . _z . from rad + _spherical = id + +sphericalIso :: RealFloat n => Iso' (Spherical n) (V3 n) +sphericalIso = iso + (\(Spherical (V3 r θ φ)) -> V3 (r * cos θ * sin φ) (r * sin θ * sin φ) (r * cos φ)) + (\v@(V3 x y z) -> let r = norm v + in Spherical $ V3 r (atan2 y x) (acos (z / r))) + +-- | Coordinate with at least three dimensions where the x, y and z coordinate can be +-- retreived numerically. +class HasY t => HasZ t where + z_ :: RealFloat n => Lens' (t n) n + z_ = xyz_ . _z + + xyz_ :: RealFloat n => Lens' (t n) (V3 n) + +instance HasZ v => HasZ (Point v) where + xyz_ = lensP . xyz_ + +instance HasZ V3 where xyz_ = id + +instance HasX Spherical where x_ = sphericalIso . _x +instance HasY Spherical where xy_ = sphericalIso . _xy +instance HasZ Spherical where xyz_ = sphericalIso + +instance HasR Spherical where _r = _radial +instance HasTheta Spherical where _theta = _azimuth +instance HasPhi Spherical where _phi = _inclination + diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index d49e6410..052e52aa 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -17,11 +17,13 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space V2 (..), P2, R1 (..), R2 (..) , r2, unr2, mkR2, r2Iso - , p2, mkP2, unp2, p2Iso, project - , Polar(..) + , p2, mkP2, unp2, p2Iso + , r2polarIso + , project + , HasR (..) ) where -import Control.Lens (Iso', iso, _2) +import Control.Lens (Lens', Iso', iso, _1, _2) import Diagrams.Angle import Diagrams.Points @@ -67,13 +69,6 @@ mkP2 x = P . V2 x p2Iso :: Iso' (Point V2 n) (n, n) p2Iso = iso unp2 p2 --- | Types which can be expressed in polar 2D coordinates, as a magnitude and an angle. -class Polar t where - polar :: RealFloat n => Iso' (t n) (n, Angle n) - -instance Polar v => Polar (Point v) where - polar = _pIso . polar - -- | @project u v@ computes the projection of @v@ onto @u@. project :: (Metric v, Fractional n) => v n -> v n -> v n project u v = ((v `dot` u) / quadrance u) *^ u @@ -82,10 +77,24 @@ project u v = ((v `dot` u) / quadrance u) *^ u instance Transformable (V2 n) where transform = apply -instance Polar V2 where - polar = iso (\v@(V2 x y) -> (norm v, atan2A y x)) +r2polarIso :: RealFloat n => Iso' (V2 n) (n, Angle n) +r2polarIso = iso (\v@(V2 x y) -> (norm v, atan2A y x)) (\(r,θ) -> V2 (r * cosA θ) (r * sinA θ)) +{-# INLINE r2polarIso #-} + +-- | A space which has magnitude '_r' that can be calculated numerically. +class HasR t where + _r :: RealFloat n => Lens' (t n) n + +instance HasR v => HasR (Point v) where + _r = lensP . _r + {-# INLINE _r #-} + +instance HasR V2 where + _r = r2polarIso . _1 + {-# INLINE _r #-} instance HasTheta V2 where - _theta = polar . _2 + _theta = r2polarIso . _2 + {-# INLINE _theta #-} diff --git a/src/Diagrams/TwoD/Types/Polar.hs b/src/Diagrams/TwoD/Types/Polar.hs new file mode 100644 index 00000000..fdc2e0e3 --- /dev/null +++ b/src/Diagrams/TwoD/Types/Polar.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Diagrams.TwoD.Types.Polar + ( -- * Polar type + Polar + , mkPolar, polar, unpolar, polarIso, polarV2 + + -- * Polar functions + , interpPolar + + -- * Classes + , Radial (..), Circle (..) + , HasX (..), HasY (..), HasR (..) + + -- * Basis elements + , er, eθ, etheta, + + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Distributive +import Data.Foldable +import Data.Functor.Rep +import Data.Typeable +import GHC.Generics (Generic1) + +import Diagrams.Angle +import Diagrams.TwoD.Types + +import Linear.Affine +import Linear.Metric +import Linear.V3 +import Linear.Vector + + +newtype Polar a = Polar (V2 a) + deriving (Monad, Functor, Typeable, MonadFix, Applicative, Traversable, + Generic1, MonadZip, Foldable) + +makeWrapped ''Polar + +-- can't make reasonable Additive instance + +instance Distributive Polar where + distribute f = Polar $ V2 (fmap (\(Polar (V2 x _)) -> x) f) + (fmap (\(Polar (V2 _ y)) -> y) f) + +instance Representable Polar where + type Rep Polar = E Polar + tabulate f = Polar $ V2 (f er) (f eθ) + index xs (E l) = view l xs + +instance Circle Polar where + _azimuth = polarWrapper . _y . from rad + _polar = id + +-- | Construct a 'Polar' from a magnitude and an 'Angle'. +mkPolar :: n -> Angle n -> Polar n +mkPolar r θ = Polar $ V2 r (θ^.rad) + +-- | Construct a 'Polar' from a magnitude and 'Angle' tuple. +polar :: (n, Angle n) -> Polar n +polar = uncurry mkPolar + +-- | Turn a 'Polar' back into a magnitude and 'Angle' tuple. +unpolar :: Polar n -> (n, Angle n) +unpolar (Polar (V2 r θ)) = (r, θ @@ rad) + +-- | 'Iso'' between 'Polar' and its tuple form. +polarIso :: Iso' (Polar n) (n, Angle n) +polarIso = iso unpolar polar + +-- | Numerical 'Iso'' between 'Polar' and 'R2'. +polarV2 :: RealFloat n => Iso' (Polar n) (V2 n) +polarV2 = iso (\(Polar (V2 r θ)) -> V2 (r * cos θ) (r * sin θ)) + (\v@(V2 x y) -> Polar $ V2 (norm v) (atan2 y x)) + +-- internal iso for instances +polarWrapper :: Iso' (Polar a) (V2 a) +polarWrapper = iso (\(Polar v) -> v) Polar + +-- | Polar interpolation between two polar coordinates. +interpPolar :: Num n => n -> Polar n -> Polar n -> Polar n +interpPolar t (Polar a) (Polar b) = Polar (lerp t a b) + + +-- | Space which has a radial length basis. For Polar and Cylindrical this is +-- the radius of the circle in the xy-plane. For Spherical this is the +-- distance from the origin. +class Radial t where + _radial :: Lens' (t a) a + +instance Radial Polar where + _radial = polarWrapper . _x + +-- | Space which has a radial and angular basis. +class Radial t => Circle t where + _azimuth :: Lens' (t a) (Angle a) + _polar :: Lens' (t a) (Polar a) + +er :: Circle v => E v +er = E _radial + +eθ, etheta :: Circle v => E v +eθ = E (_polar . polarWrapper . _y) +etheta = eθ + +-- | Coordinate with at least one dimension where the x coordinate can be +-- retreived numerically. Note this differs slightly from 'R1' which requires +-- a lens for all values. This allows instances for different coordinates +-- such as 'Polar', where the x coordinate can only be retreived numerically. +class HasX t where + x_ :: RealFloat n => Lens' (t n) n + +instance HasX v => HasX (Point v) where + x_ = lensP . x_ + +instance HasX V2 where x_ = _x +instance HasX V3 where x_ = _x +instance HasX Polar where x_ = polarV2 . _x + +-- | Coordinate with at least two dimensions where the x and y coordinates can be +-- retreived numerically. +class HasX t => HasY t where + y_ :: RealFloat n => Lens' (t n) n + y_ = xy_ . _y + + xy_ :: RealFloat n => Lens' (t n) (V2 n) + +instance HasY v => HasY (Point v) where + xy_ = lensP . xy_ + +instance HasY V2 where xy_ = id +instance HasY V3 where xy_ = _xy +instance HasY Polar where xy_ = polarV2 + From 7e5ca2b463172a39ed6736c5c32ff25e13d4ab3d Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 31 Aug 2014 19:28:53 +0100 Subject: [PATCH 38/58] Use stylish-haskell config. --- src/Diagrams/Align.hs | 21 ++++--- src/Diagrams/Angle.hs | 20 +++--- src/Diagrams/Animation.hs | 24 ++++---- src/Diagrams/Attributes.hs | 16 ++--- src/Diagrams/BoundingBox.hs | 40 ++++++------ src/Diagrams/Combinators.hs | 10 +-- src/Diagrams/Coordinates.hs | 20 ++---- src/Diagrams/CubicSpline.hs | 7 ++- src/Diagrams/Deform.hs | 36 ++++++----- src/Diagrams/Direction.hs | 8 +-- src/Diagrams/Located.hs | 16 ++--- src/Diagrams/Names.hs | 2 +- src/Diagrams/Parametric/Adjust.hs | 12 ++-- src/Diagrams/Path.hs | 41 ++++++------- src/Diagrams/Points.hs | 12 ++-- src/Diagrams/Prelude.hs | 77 ++++++++++++------------ src/Diagrams/Query.hs | 2 +- src/Diagrams/Segment.hs | 21 +++---- src/Diagrams/Tangent.hs | 8 +-- src/Diagrams/ThreeD.hs | 18 +++--- src/Diagrams/ThreeD/Align.hs | 14 ++--- src/Diagrams/ThreeD/Deform.hs | 10 +-- src/Diagrams/ThreeD/Shapes.hs | 28 ++++----- src/Diagrams/ThreeD/Transform.hs | 32 +++++----- src/Diagrams/ThreeD/Types.hs | 6 +- src/Diagrams/ThreeD/Types/Cylindrical.hs | 31 +++++----- src/Diagrams/ThreeD/Types/Spherical.hs | 38 ++++++------ src/Diagrams/ThreeD/Vector.hs | 8 +-- src/Diagrams/Trace.hs | 4 +- src/Diagrams/Trail.hs | 24 ++++---- src/Diagrams/TrailLike.hs | 8 +-- src/Diagrams/TwoD/Align.hs | 12 ++-- src/Diagrams/TwoD/Arc.hs | 11 ++-- src/Diagrams/TwoD/Arrow.hs | 66 ++++++++++---------- src/Diagrams/TwoD/Arrowheads.hs | 6 +- src/Diagrams/TwoD/Combinators.hs | 7 +-- src/Diagrams/TwoD/Curvature.hs | 14 ++--- src/Diagrams/TwoD/Deform.hs | 8 +-- src/Diagrams/TwoD/Image.hs | 23 ++++--- src/Diagrams/TwoD/Model.hs | 22 +++---- src/Diagrams/TwoD/Offset.hs | 59 +++++++++--------- src/Diagrams/TwoD/Path.hs | 49 +++++++-------- src/Diagrams/TwoD/Polygons.hs | 54 ++++++++--------- src/Diagrams/TwoD/Segment.hs | 31 +++++----- src/Diagrams/TwoD/Shapes.hs | 9 ++- src/Diagrams/TwoD/Size.hs | 13 ++-- src/Diagrams/TwoD/Text.hs | 3 +- src/Diagrams/TwoD/Transform.hs | 11 ++-- src/Diagrams/TwoD/Transform/ScaleInv.hs | 4 +- src/Diagrams/TwoD/Types.hs | 16 ++--- src/Diagrams/TwoD/Types/Polar.hs | 38 ++++++------ src/Diagrams/TwoD/Vector.hs | 12 ++-- 52 files changed, 524 insertions(+), 558 deletions(-) diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs index b42de8e2..83e85ad7 100644 --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -36,18 +36,18 @@ module Diagrams.Align ) where import Diagrams.Core -import Diagrams.Util (applyAll) +import Diagrams.Util (applyAll) -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) -import qualified Data.Foldable as F -import qualified Data.Map as M -import qualified Data.Set as S +import qualified Data.Foldable as F +import qualified Data.Map as M +import qualified Data.Set as S -import Linear.Affine -import Linear.Vector -import Linear.Metric +import Linear.Affine +import Linear.Metric +import Linear.Vector -- | Class of things which can be aligned. class Alignable a where @@ -76,6 +76,7 @@ alignBy'Default boundary v d a = moveOriginTo (lerp ((d + 1) / 2) (boundary v a) (boundary (negated v) a) ) a + -- | Some standard functions which can be used as the `boundary` argument to -- `alignBy'`. @@ -163,3 +164,5 @@ snugCenter = applyAll fs where fs = map snugCenterV basis +{-# ANN module "HLint: ignore Use camelCase" #-} + diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index c692b000..77cc75d9 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -34,16 +34,16 @@ module Diagrams.Angle , HasPhi(..) ) where -import Control.Applicative -import Control.Lens (Iso', Lens', iso, review, (^.)) -import Data.Monoid hiding ((<>)) -import Data.Semigroup +import Control.Applicative +import Control.Lens (Iso', Lens', iso, review, (^.)) +import Data.Monoid hiding ((<>)) +import Data.Semigroup -import Diagrams.Core.V -import Diagrams.Points +import Diagrams.Core.V +import Diagrams.Points -import Linear.Metric -import Linear.Vector +import Linear.Metric +import Linear.Vector -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. @@ -162,8 +162,8 @@ angleBetween v1 v2 = acos (signorm v1 `dot` signorm v2) @@ rad class HasTheta t where _theta :: RealFloat n => Lens' (t n) (Angle n) --- | The class of types with at least two angle coordinates, the --- second called _phi. +-- | The class of types with at least two angle coordinates, the second called +-- _phi. _phi is the positive angle measured from the z axis. class HasTheta t => HasPhi t where _phi :: RealFloat n => Lens' (t n) (Angle n) diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs index fc217bee..38711b2b 100644 --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -29,22 +29,22 @@ module Diagrams.Animation ) where -import Diagrams.Core +import Control.Applicative ((<$>)) +import Data.Active +import Data.Foldable (foldMap) +import Data.Semigroup -import Diagrams.Animation.Active () -import Diagrams.BoundingBox -import Diagrams.Combinators -import Diagrams.TrailLike -import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Types +import Diagrams.Core -import Data.Active -import Data.Semigroup +import Diagrams.Animation.Active () +import Diagrams.BoundingBox +import Diagrams.Combinators +import Diagrams.TrailLike +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Types -import Control.Applicative ((<$>)) -import Data.Foldable (foldMap) -import Linear.Metric +import Linear.Metric -- | A value of type @QAnimation b v m@ is an animation (a -- time-varying diagram with start and end times) that can be diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 444267c9..fa843c0a 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -47,15 +47,15 @@ module Diagrams.Attributes ( ) where -import Data.Colour -import Data.Colour.RGBSpace (RGB (..)) -import Data.Colour.SRGB (toSRGB) -import Data.Default.Class +import Data.Colour +import Data.Colour.RGBSpace (RGB (..)) +import Data.Colour.SRGB (toSRGB) +import Data.Default.Class -import Data.Semigroup -import Data.Typeable +import Data.Semigroup +import Data.Typeable -import Diagrams.Core +import Diagrams.Core ------------------------------------------------------------ -- Color ------------------------------------------------- @@ -99,7 +99,7 @@ instance (Floating a, Real a) => Color (AlphaColour a) where instance Color SomeColor where toAlphaColour (SomeColor c) = toAlphaColour c - fromAlphaColour c = SomeColor c + fromAlphaColour = SomeColor -- | Convert to sRGBA. colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index 3d383769..dbc15885 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -1,11 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -42,25 +42,25 @@ module Diagrams.BoundingBox , union, intersection ) where -import Data.Data (Data, Typeable) -import Data.Foldable as F -import Data.Maybe (fromMaybe) -import Data.Semigroup - -import Diagrams.Core.Transform -import Diagrams.Core -import Diagrams.TwoD.Types -import Diagrams.TwoD.Path () -import Diagrams.TwoD.Shapes -import Diagrams.ThreeD.Shapes -import Diagrams.ThreeD.Types -import Diagrams.Path - -import Control.Applicative -import Data.Traversable as T -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Data.Data (Data, Typeable) +import Data.Foldable as F +import Data.Maybe (fromMaybe) +import Data.Semigroup + +import Diagrams.Core +import Diagrams.Core.Transform +import Diagrams.Path +import Diagrams.ThreeD.Shapes +import Diagrams.ThreeD.Types +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Types + +import Control.Applicative +import Data.Traversable as T +import Linear.Affine +import Linear.Metric +import Linear.Vector -- Unexported utility newtype diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index d3952b8f..8a8ac181 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -41,8 +41,8 @@ module Diagrams.Combinators import Data.Typeable -import Control.Lens (Lens', generateSignatures, lensRules, - makeLensesWith, (%~), (&), (.~), (^.), _Wrapping) +import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, (%~), + (&), (.~), (^.), _Wrapping) import Data.Default.Class import Data.Monoid.Deletable (toDeletable) import Data.Monoid.MList (inj) @@ -58,9 +58,9 @@ import Diagrams.Direction import Diagrams.Segment (straight) import Diagrams.Util -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Linear.Affine +import Linear.Metric +import Linear.Vector ------------------------------------------------------------ -- Working with envelopes diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index 3d67573b..b5af4775 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -16,17 +16,12 @@ module Diagrams.Coordinates ( (:&)(..), Coordinates(..) - - -- * Lenses for particular axes - , HasR(..) ) where -import Control.Lens (Lens') +import Diagrams.Points -import Diagrams.Points - -import Linear (V2 (..), V3 (..), V4 (..)) +import Linear (V2 (..), V3 (..), V4 (..)) -- | Types which are instances of the @Coordinates@ class can be -- constructed using '^&' (for example, a three-dimensional vector @@ -111,7 +106,7 @@ instance Coordinates (a,b,c,d) where type PrevDim (a,b,c,d) = (a,b,c) type Decomposition (a,b,c,d) = Decomposition (a,b,c) :& d - (w,x,y) ^& z = (w,x,y,z) + (w,x,y) ^& z = (w,x,y,z) coords (w,x,y,z) = coords (w,x,y) :& z instance Coordinates (v n) => Coordinates (Point v n) where @@ -119,7 +114,7 @@ instance Coordinates (v n) => Coordinates (Point v n) where type PrevDim (Point v n) = PrevDim (v n) type Decomposition (Point v n) = Decomposition (v n) - x ^& y = P (x ^& y) + x ^& y = P (x ^& y) coords (P v) = coords v -- instances for linear @@ -148,8 +143,3 @@ instance Coordinates (V4 n) where V3 x y z ^& w = V4 x y z w coords (V4 x y z w) = x :& y :& z :& w --- | The class of types with a single length coordinate _r. _r is --- magnitude of a vector, or the distance from the origin of a point. -class HasR t where - _r :: Lens' (t n) n - diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs index 0dabe130..14bb56fa 100644 --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -23,6 +23,8 @@ module Diagrams.CubicSpline cubicSpline ) where +import Control.Lens (view) + import Diagrams.Core import Diagrams.CubicSpline.Internal import Diagrams.Located (Located, at, mapLoc) @@ -30,9 +32,8 @@ import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike (TrailLike (..)) -import Linear.Affine -import Control.Lens (view) -import Linear.Metric +import Linear.Affine +import Linear.Metric -- | Construct a spline path-like thing of cubic segments from a list of -- vertices, with the first vertex as the starting point. The first diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs index c0a6accd..74fe210b 100644 --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -5,22 +5,26 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Diagrams.Deform (Deformation(..), Deformable(..), asDeformation) where - -import Control.Lens (under, _Unwrapped) -import Data.Monoid hiding ((<>)) -import Data.Semigroup - -import Diagrams.Core -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Trail - -import Linear.Affine -import Linear.Metric -import Linear.Vector +module Diagrams.Deform + ( Deformation(..) + , Deformable(..) + , asDeformation + ) where + +import Control.Lens (under, _Unwrapped) +import Data.Monoid hiding ((<>)) +import Data.Semigroup + +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail + +import Linear.Affine +import Linear.Metric +import Linear.Vector ------------------------------------------------------------ -- Deformations diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index 2f7a2dd9..91091ba9 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -19,12 +19,12 @@ module Diagrams.Direction , angleBetweenDirs ) where -import Control.Lens (Iso', iso) +import Control.Lens (Iso', iso) -import Diagrams.Angle -import Diagrams.Core +import Diagrams.Angle +import Diagrams.Core -import Linear.Metric +import Linear.Metric -------------------------------------------------------------------------------- -- Direction diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs index 9ea28ef5..c979186b 100644 --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -23,16 +23,16 @@ module Diagrams.Located ) where -import Control.Lens (Iso', Lens, Lens', iso, lens) -import Data.Functor ((<$>)) +import Control.Lens (Iso', Lens, Lens', iso, lens) +import Data.Functor ((<$>)) -import Linear.Affine -import Linear.Vector +import Linear.Affine +import Linear.Vector -import Diagrams.Core -import Diagrams.Core.Points () -import Diagrams.Core.Transform -import Diagrams.Parametric +import Diagrams.Core +import Diagrams.Core.Points () +import Diagrams.Core.Transform +import Diagrams.Parametric -- for GHC 7.4 type family bug -- | \"Located\" things, /i.e./ things with a concrete location: diff --git a/src/Diagrams/Names.hs b/src/Diagrams/Names.hs index 98181a84..b79380ed 100644 --- a/src/Diagrams/Names.hs +++ b/src/Diagrams/Names.hs @@ -44,7 +44,7 @@ import Diagrams.Core (HasLinearMap, OrderedField, Point) import Diagrams.Core.Names import Diagrams.Core.Types -import Linear.Metric +import Linear.Metric -- | Attach an atomic name to a diagram. named :: (IsName nm, HasLinearMap v, Metric v, OrderedField n, Semigroup m) diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs index bf5a4ac8..11254064 100644 --- a/src/Diagrams/Parametric/Adjust.hs +++ b/src/Diagrams/Parametric/Adjust.hs @@ -21,14 +21,14 @@ module Diagrams.Parametric.Adjust ) where -import Control.Lens (Lens', generateSignatures, lensRules, - makeLensesWith, (&), (.~), (^.)) -import Data.Proxy +import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, (&), + (.~), (^.)) +import Data.Proxy -import Data.Default.Class +import Data.Default.Class -import Diagrams.Core.V -import Diagrams.Parametric +import Diagrams.Core.V +import Diagrams.Parametric -- | What method should be used for adjusting a segment, trail, or -- path? diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 7157d949..e8f2c901 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -56,29 +56,28 @@ module Diagrams.Path ) where -import Data.Typeable - -import Diagrams.Align -import Diagrams.Core -import Diagrams.Core.Points () -import Diagrams.Located -import Diagrams.Points -import Diagrams.Segment -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.Transform - -import Control.Arrow ((***)) -import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, - op, over, view, (%~), _Unwrapped', - _Wrapped) -import qualified Data.Foldable as F -import Data.List (partition) +import Data.Typeable + +import Diagrams.Align +import Diagrams.Core +import Diagrams.Core.Points () +import Diagrams.Located +import Diagrams.Points +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.Transform + +import Control.Arrow ((***)) +import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, over, view, (%~), + _Unwrapped', _Wrapped) +import qualified Data.Foldable as F +import Data.List (partition) import Data.Semigroup -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Linear.Affine +import Linear.Metric +import Linear.Vector ------------------------------------------------------------ -- Paths ------------------------------------------------- diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs index f03fa132..99c6309f 100644 --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -20,14 +20,14 @@ module Diagrams.Points , _pIso, lensP ) where -import Diagrams.Core (pointDiagram) -import Diagrams.Core.Points +import Diagrams.Core (pointDiagram) +import Diagrams.Core.Points -import Control.Lens (Iso', iso) +import Control.Lens (Iso', iso) -import Data.Foldable as F -import Linear.Affine -import Linear.Vector +import Data.Foldable as F +import Linear.Affine +import Linear.Vector -- Point v <-> v _pIso :: Iso' (Point v n) (v n) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index f87cca23..eefa0483 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -126,43 +126,42 @@ module Diagrams.Prelude , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 ) where -import Diagrams.Core - -import Diagrams.Align -import Diagrams.Angle -import Diagrams.Animation -import Diagrams.Attributes -import Diagrams.Combinators -import Diagrams.Coordinates -import Diagrams.CubicSpline -import Diagrams.Deform -import Diagrams.Direction -import Diagrams.Envelope -import Diagrams.Located -import Diagrams.Names -import Diagrams.Parametric -import Diagrams.Parametric.Adjust -import Diagrams.Path -import Diagrams.Points -import Diagrams.Query -import Diagrams.Segment -import Diagrams.Tangent -import Diagrams.Trace -import Diagrams.Trail hiding (linePoints, loopPoints, - trailPoints) -import Diagrams.TrailLike -import Diagrams.Transform -import Diagrams.TwoD -import Diagrams.Util - -import Control.Applicative -import Control.Lens ((%~), (&), (.~)) -import Data.Active -import Data.Colour hiding (AffineSpace (..), atop, over) -import Data.Colour.Names hiding (tan) -import Data.Semigroup - -import Linear.Affine -import Linear.Vector -import Linear.Metric +import Diagrams.Core + +import Diagrams.Align +import Diagrams.Angle +import Diagrams.Animation +import Diagrams.Attributes +import Diagrams.Combinators +import Diagrams.Coordinates +import Diagrams.CubicSpline +import Diagrams.Deform +import Diagrams.Direction +import Diagrams.Envelope +import Diagrams.Located +import Diagrams.Names +import Diagrams.Parametric +import Diagrams.Parametric.Adjust +import Diagrams.Path +import Diagrams.Points +import Diagrams.Query +import Diagrams.Segment +import Diagrams.Tangent +import Diagrams.Trace +import Diagrams.Trail hiding (linePoints, loopPoints, trailPoints) +import Diagrams.TrailLike +import Diagrams.Transform +import Diagrams.TwoD +import Diagrams.Util + +import Control.Applicative +import Control.Lens ((%~), (&), (.~)) +import Data.Active +import Data.Colour hiding (AffineSpace (..), atop, over) +import Data.Colour.Names hiding (tan) +import Data.Semigroup + +import Linear.Affine +import Linear.Metric +import Linear.Vector diff --git a/src/Diagrams/Query.hs b/src/Diagrams/Query.hs index dc976a0a..a0490b34 100644 --- a/src/Diagrams/Query.hs +++ b/src/Diagrams/Query.hs @@ -16,5 +16,5 @@ module Diagrams.Query ) where -import Diagrams.Core +import Diagrams.Core diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index 442d033d..c6663566 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -63,24 +63,23 @@ module Diagrams.Segment ) where -import Control.Lens (Rewrapped, Traversal, - Wrapped (..), iso, - makeLenses, op, over) +import Control.Lens (Rewrapped, Traversal, Wrapped (..), iso, makeLenses, op, + over) import Data.FingerTree import Data.Monoid.MList import Data.Semigroup import Numeric.Interval.Kaucher (Interval (..)) import qualified Numeric.Interval.Kaucher as I -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Linear.Affine +import Linear.Metric +import Linear.Vector -import Control.Applicative -import Diagrams.Core -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Solve +import Control.Applicative +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Solve ------------------------------------------------------------ diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs index 9835475d..e032d042 100644 --- a/src/Diagrams/Tangent.hs +++ b/src/Diagrams/Tangent.hs @@ -31,7 +31,7 @@ import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment -import Linear.Vector +import Linear.Vector ------------------------------------------------------------ -- Tangent @@ -119,19 +119,19 @@ instance (Additive v, Num n) -- :: (R2Ish (Codomain (Tangent t)), Parametric (Tangent t)) -- => t -> Scalar (V t) -> Codomain (Tangent t) -- normalAtParam t p = normize (t `tangentAtParam` p) --- +-- -- -- | Compute the normal vector at the start of a segment or trail. -- normalAtStart -- :: (R2Ish (Codomain (Tangent t)), EndValues (Tangent t)) -- => t -> Codomain (Tangent t) -- normalAtStart = normize . tangentAtStart --- +-- -- -- | Compute the normal vector at the end of a segment or trail. -- normalAtEnd -- :: (R2Ish (Codomain (Tangent t)), EndValues (Tangent t)) -- => t -> Codomain (Tangent t) -- normalAtEnd = normize . tangentAtEnd --- +-- -- | Construct a normal vector from a tangent. -- normize :: (Additive v, Num n) => v n -> v n -- normize = negated . perp . normalize diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs index 83c3521a..a799a31b 100644 --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -43,13 +43,13 @@ module Diagrams.ThreeD , module Diagrams.ThreeD.Vector ) where -import Diagrams.ThreeD.Align -import Diagrams.ThreeD.Attributes -import Diagrams.ThreeD.Camera -import Diagrams.ThreeD.Deform -import Diagrams.ThreeD.Light -import Diagrams.ThreeD.Shapes -import Diagrams.ThreeD.Transform -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector +import Diagrams.ThreeD.Align +import Diagrams.ThreeD.Attributes +import Diagrams.ThreeD.Camera +import Diagrams.ThreeD.Deform +import Diagrams.ThreeD.Light +import Diagrams.ThreeD.Shapes +import Diagrams.ThreeD.Transform +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector diff --git a/src/Diagrams/ThreeD/Align.hs b/src/Diagrams/ThreeD/Align.hs index adf2c372..96abf718 100644 --- a/src/Diagrams/ThreeD/Align.hs +++ b/src/Diagrams/ThreeD/Align.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -39,14 +39,14 @@ module Diagrams.ThreeD.Align ) where -import Diagrams.Core +import Diagrams.Core -import Diagrams.Align -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector -import Diagrams.TwoD.Align +import Diagrams.Align +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector +import Diagrams.TwoD.Align -import Linear.Vector +import Linear.Vector -- | Translate the diagram along unitX so that all points have -- positive x-values. diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs index 06f5b603..dd02e06a 100644 --- a/src/Diagrams/ThreeD/Deform.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -4,13 +4,13 @@ module Diagrams.ThreeD.Deform , parallelZ0, perspectiveZ1, facingZ ) where -import Control.Lens +import Control.Lens -import Diagrams.Deform -import Diagrams.TwoD.Deform +import Diagrams.Deform +import Diagrams.TwoD.Deform -import Linear.Vector -import Linear.V3 +import Linear.V3 +import Linear.Vector -- | The parallel projection onto the plane z=0 parallelZ0 :: (R3 v, Num n) => Deformation v n diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index f77b460e..a9ce0445 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -23,20 +23,20 @@ module Diagrams.ThreeD.Shapes , Frustum(..) , frustum, cone, cylinder ) where -import Control.Applicative -import Control.Lens (review, (^.), _1) -import Data.Typeable - -import Data.Semigroup -import Diagrams.Angle -import Diagrams.Core -import Diagrams.Solve -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector - -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Control.Applicative +import Control.Lens (review, (^.), _1) +import Data.Typeable + +import Data.Semigroup +import Diagrams.Angle +import Diagrams.Core +import Diagrams.Solve +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector + +import Linear.Affine +import Linear.Metric +import Linear.Vector data Ellipsoid n = Ellipsoid (Transformation V3 n) deriving Typeable diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 4b295dfe..c8ebc0a3 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -46,22 +46,22 @@ module Diagrams.ThreeD.Transform -- , onBasis ) where -import Diagrams.Core -import Diagrams.Core.Transform - -import Diagrams.Angle -import Diagrams.Direction -import Diagrams.ThreeD.Types -import Diagrams.Transform - -import Control.Lens (view, (&), (*~), (.~), (//~)) -import Data.Semigroup -import Diagrams.TwoD.Transform - -import Linear.Affine -import Linear.Metric -import Linear.V3 (cross) -import Linear.Vector +import Diagrams.Core +import Diagrams.Core.Transform + +import Diagrams.Angle +import Diagrams.Direction +import Diagrams.ThreeD.Types +import Diagrams.Transform + +import Control.Lens (view, (&), (*~), (.~), (//~)) +import Data.Semigroup +import Diagrams.TwoD.Transform + +import Linear.Affine +import Linear.Metric +import Linear.V3 (cross) +import Linear.Vector -- | Create a transformation which rotates by the given angle about -- a line parallel the Z axis passing through the local origin. diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 39eaddb8..dc65bee5 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -23,15 +23,15 @@ module Diagrams.ThreeD.Types ) where -import Control.Lens (Iso', iso, _1, _2, _3) +import Control.Lens (Iso', iso, _1, _2, _3) import Diagrams.Angle import Diagrams.Core import Diagrams.Points import Diagrams.TwoD.Types -import Linear.V3 as V -import Linear.Metric +import Linear.Metric +import Linear.V3 as V ------------------------------------------------------------ -- 3D Euclidean space diff --git a/src/Diagrams/ThreeD/Types/Cylindrical.hs b/src/Diagrams/ThreeD/Types/Cylindrical.hs index f4f0da92..74f5f4ba 100644 --- a/src/Diagrams/ThreeD/Types/Cylindrical.hs +++ b/src/Diagrams/ThreeD/Types/Cylindrical.hs @@ -21,22 +21,21 @@ module Diagrams.ThreeD.Types.Cylindrical ) where -import Control.Applicative -import Control.Lens -import Control.Monad.Fix -import Control.Monad.Zip -import Data.Distributive -import Data.Foldable -import Data.Functor.Rep -import Data.Typeable -import GHC.Generics (Generic1) - -import Diagrams.Angle -import Diagrams.TwoD.Types.Polar -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Types.Spherical - -import Linear.Vector +import Control.Applicative +import Control.Lens +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Distributive +import Data.Foldable +import Data.Functor.Rep +import Data.Typeable +import GHC.Generics (Generic1) + +import Diagrams.Angle +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Types.Spherical + +import Linear.Vector -- | Space which has a radial, angular and height basis. diff --git a/src/Diagrams/ThreeD/Types/Spherical.hs b/src/Diagrams/ThreeD/Types/Spherical.hs index b8d93ca9..9fa6c35c 100644 --- a/src/Diagrams/ThreeD/Types/Spherical.hs +++ b/src/Diagrams/ThreeD/Types/Spherical.hs @@ -23,25 +23,25 @@ module Diagrams.ThreeD.Types.Spherical ) where -import Control.Applicative -import Control.Lens -import Control.Monad.Fix -import Control.Monad.Zip -import Data.Distributive -import Data.Foldable -import Data.Functor.Rep -import Data.Typeable -import GHC.Generics (Generic1) - -import Diagrams.Angle -import Diagrams.TwoD.Types.Polar - -import Linear.Affine -import Linear.Metric -import Linear.V1 -import Linear.V2 -import Linear.V3 -import Linear.Vector +import Control.Applicative +import Control.Lens +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Distributive +import Data.Foldable +import Data.Functor.Rep +import Data.Typeable +import GHC.Generics (Generic1) + +import Diagrams.Angle +import Diagrams.TwoD.Types.Polar + +import Linear.Affine +import Linear.Metric +import Linear.V1 +import Linear.V2 +import Linear.V3 +import Linear.Vector -- | Space which has a radial and two angular basis. The inclination is the -- positive angles from the z-axis. diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 99d50748..9a5fa6ce 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -13,12 +13,12 @@ module Diagrams.ThreeD.Vector unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, ) where -import Control.Lens ((&), (.~)) +import Control.Lens ((&), (.~)) -import Diagrams.TwoD.Vector -import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Types +import Diagrams.TwoD.Vector -import Linear.Vector +import Linear.Vector -- | The unit vector in the positive Y direction. unitZ :: (R3 v, Additive v, Num n) => v n diff --git a/src/Diagrams/Trace.hs b/src/Diagrams/Trace.hs index 42648dc4..9ef8d955 100644 --- a/src/Diagrams/Trace.hs +++ b/src/Diagrams/Trace.hs @@ -35,8 +35,8 @@ import Data.Maybe import Data.Semigroup import Diagrams.Combinators (withTrace) -import Linear.Vector -import Linear.Metric +import Linear.Metric +import Linear.Vector -- | Compute the furthest point on the boundary of a subdiagram, -- beginning from the location (local origin) of the subdiagram and diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index c8eb08ec..e2ff8f80 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -103,11 +103,9 @@ module Diagrams.Trail ) where import Control.Arrow ((***)) -import Control.Lens (AnIso', Rewrapped, - Wrapped (..), cloneIso, iso, - op, view, (^.)) -import Data.FingerTree (FingerTree, ViewL (..), - ViewR (..), (<|), (|>)) +import Control.Lens (AnIso', Rewrapped, Wrapped (..), cloneIso, iso, op, view, + (^.)) +import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), (|>)) import qualified Data.FingerTree as FT import Data.Fixed import qualified Data.Foldable as F @@ -115,15 +113,15 @@ import Data.Monoid.MList import Data.Semigroup import qualified Numeric.Interval.Kaucher as I -import Diagrams.Core hiding ((|>)) -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Segment -import Diagrams.Tangent +import Diagrams.Core hiding ((|>)) +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment +import Diagrams.Tangent -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Linear.Affine +import Linear.Metric +import Linear.Vector -- $internals -- diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs index 468cf1d2..778faa22 100644 --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -29,17 +29,15 @@ module Diagrams.TrailLike ) where import Control.Lens (view, _Unwrapped') --- import Data.AffineSpace ((.-.)) --- import Data.VectorSpace import Diagrams.Core import Diagrams.Located import Diagrams.Segment import Diagrams.Trail -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Linear.Affine +import Linear.Metric +import Linear.Vector ------------------------------------------------------------ -- TrailLike class diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs index 73a9f600..5aeef771 100644 --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -39,13 +39,13 @@ module Diagrams.TwoD.Align ) where -import Diagrams.Core +import Diagrams.Core -import Diagrams.Align -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector +import Diagrams.Align +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector -import Linear.Vector +import Linear.Vector -- | Align along the left edge, i.e. translate the diagram in a -- horizontal direction so that the local origin is on the left edge diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index 0069143f..df9c42d4 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arc @@ -39,9 +38,9 @@ import Diagrams.Util (( # )) import Control.Lens ((&), (<>~), (^.)) import Data.Semigroup ((<>)) -import Linear.Vector -import Linear.Metric -import Linear.Affine +import Linear.Affine +import Linear.Metric +import Linear.Vector -- For details of this approximation see: -- http://www.tinaja.com/glib/bezcirc2.pdf @@ -105,7 +104,7 @@ arcT start sweep = trailFromSegments bs -- @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. arc :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => Direction V2 n -> Angle n -> t -arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ p2 (1,0)) +arc start sweep = trailLike $ arcT start sweep `at` rotate (start ^. _theta) (p2 (1,0)) -- | Given a radus @r@, a start direction @d@ and an angle @s@, -- @'arc'' r d s@ is the path of a radius @(abs r)@ arc starting at @@ -117,7 +116,7 @@ arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ -- > arc'Ex = mconcat [ arc' r (0 @@ turn) (1/4 @@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 arc' :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> Direction V2 n -> Angle n -> t -arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) $ p2 (abs r,0)) +arc' r start sweep = trailLike $ scale (abs r) ts `at` rotate (start ^. _theta) (p2 (abs r,0)) where ts = arcT start sweep -- | Create a circular wedge of the given radius, beginning at the diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index deee10a3..fa837ade 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -101,40 +101,38 @@ module Diagrams.TwoD.Arrow , module Diagrams.TwoD.Arrowheads ) where -import Control.Applicative ((<*>)) -import Control.Lens (Lens', Setter', Traversal', - generateSignatures, lensRules, - makeLensesWith, view, (%~), (&), (.~), - (^.)) -import Data.Default.Class -import Data.Functor ((<$>)) -import Data.Maybe (fromMaybe) -import Data.Monoid.Coproduct (untangle) -import Data.Semigroup - -import Data.Colour hiding (atop) -import Diagrams.Core -import Diagrams.Core.Types (QDiaLeaf (..), mkQD') - -import Diagrams.Angle -import Diagrams.Attributes -import Diagrams.Direction -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Solve (quadForm) -import Diagrams.Tangent (tangentAtEnd, tangentAtStart) -import Diagrams.Trail -import Diagrams.TwoD.Arrowheads -import Diagrams.TwoD.Attributes -import Diagrams.TwoD.Path (stroke, strokeT) -import Diagrams.TwoD.Transform (rotate, translateX) -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unit_X) -import Diagrams.Util (( # )) - -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Control.Applicative ((<*>)) +import Control.Lens (Lens', Setter', Traversal', generateSignatures, + lensRules, makeLensesWith, view, (%~), (&), (.~), (^.)) +import Data.Default.Class +import Data.Functor ((<$>)) +import Data.Maybe (fromMaybe) +import Data.Monoid.Coproduct (untangle) +import Data.Semigroup + +import Data.Colour hiding (atop) +import Diagrams.Core +import Diagrams.Core.Types (QDiaLeaf (..), mkQD') + +import Diagrams.Angle +import Diagrams.Attributes +import Diagrams.Direction +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Solve (quadForm) +import Diagrams.Tangent (tangentAtEnd, tangentAtStart) +import Diagrams.Trail +import Diagrams.TwoD.Arrowheads +import Diagrams.TwoD.Attributes +import Diagrams.TwoD.Path (stroke, strokeT) +import Diagrams.TwoD.Transform (rotate, translateX) +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (unitX, unit_X) +import Diagrams.Util (( # )) + +import Linear.Affine +import Linear.Metric +import Linear.Vector data ArrowOpts n diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 2d24daaf..ea265b8c 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -77,9 +77,9 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unit_X, xDir) import Diagrams.Util (( # )) -import Linear.Affine -import Linear.Vector -import Linear.Metric +import Linear.Affine +import Linear.Metric +import Linear.Vector ----------------------------------------------------------------------------- diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index f9089a7a..6347dc32 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -59,10 +58,8 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Diagrams.Util (( # )) --- import Data.Typeable --- import Data.Data -import Linear.Affine -import Linear.Vector +import Linear.Affine +import Linear.Vector infixl 6 === infixl 6 ||| diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs index 12bb1d74..88180e6d 100644 --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -19,15 +19,15 @@ module Diagrams.TwoD.Curvature , squaredRadiusOfCurvature ) where -import Data.Monoid.Inf +import Control.Lens (over) +import Control.Monad +import Data.Monoid.Inf -import Diagrams.Segment -import Diagrams.Tangent -import Diagrams.TwoD.Types +import Diagrams.Segment +import Diagrams.Tangent +import Diagrams.TwoD.Types -import Control.Lens (over) -import Control.Monad -import Linear.Vector +import Linear.Vector -- | Curvature measures how curved the segment is at a point. One intuition -- for the concept is how much you would turn the wheel when driving a car diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs index fbf0a429..1acfe937 100644 --- a/src/Diagrams/TwoD/Deform.hs +++ b/src/Diagrams/TwoD/Deform.hs @@ -1,11 +1,11 @@ module Diagrams.TwoD.Deform where -import Control.Lens +import Control.Lens -import Diagrams.Deform +import Diagrams.Deform -import Linear.V2 -import Linear.Vector +import Linear.V2 +import Linear.Vector -- | The parallel projection onto the plane x=0 parallelX0 :: (R1 v, Num n) => Deformation v n diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs index 4ef2d89b..e7cd2b40 100644 --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -31,22 +31,21 @@ module Diagrams.TwoD.Image , rasterDia ) where +import Codec.Picture +import Codec.Picture.Types (dynamicMap) -import Codec.Picture -import Codec.Picture.Types (dynamicMap) +import Data.Colour (AlphaColour) +import Data.Semigroup +import Data.Typeable (Typeable) -import Data.Colour (AlphaColour) -import Data.Semigroup -import Data.Typeable (Typeable) +import Diagrams.Core -import Diagrams.Core +import Diagrams.Attributes (colorToSRGBA) +import Diagrams.TwoD.Path (isInsideEvenOdd) +import Diagrams.TwoD.Shapes (rect) +import Diagrams.TwoD.Types -import Diagrams.Attributes (colorToSRGBA) -import Diagrams.TwoD.Path (isInsideEvenOdd) -import Diagrams.TwoD.Shapes (rect) -import Diagrams.TwoD.Types - -import Linear.Affine +import Linear.Affine data Embedded deriving Typeable data External deriving Typeable diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs index 1ef7d800..e239e9bc 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} @@ -22,7 +21,14 @@ module Diagrams.TwoD.Model , showLabels ) where +import Control.Arrow (second) import Control.Lens (makeLenses, (^.)) +import Data.Colour (Colour) +import Data.Colour.Names +import Data.Data +import Data.Default.Class +import qualified Data.Map as M +import Data.Semigroup import Diagrams.Core import Diagrams.Path @@ -34,18 +40,8 @@ import Diagrams.TwoD.Text import Diagrams.TwoD.Types import Diagrams.Util -import Control.Arrow (second) -import Data.Default.Class -import Data.Semigroup - -import qualified Data.Map as M - -import Data.Colour (Colour) -import Data.Colour.Names - -import Linear.Affine -import Linear.Vector -import Data.Data +import Linear.Affine +import Linear.Vector ------------------------------------------------------------ -- Marking the origin diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index 72fd1fec..f757960f 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} @@ -41,35 +40,35 @@ module Diagrams.TwoD.Offset ) where -import Control.Applicative -import Control.Lens hiding (at) - -import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Monoid.Inf - -import Data.Default.Class - -import Diagrams.Core - -import Diagrams.Angle -import Diagrams.Attributes -import Diagrams.Direction (direction) -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Trail hiding (isLoop, offset) -import Diagrams.TrailLike -import Diagrams.TwoD.Arc -import Diagrams.TwoD.Curvature -import Diagrams.TwoD.Path () -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector hiding (e) - -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Control.Applicative +import Control.Lens hiding (at) + +import Data.Maybe (catMaybes) +import Data.Monoid +import Data.Monoid.Inf + +import Data.Default.Class + +import Diagrams.Core + +import Diagrams.Angle +import Diagrams.Attributes +import Diagrams.Direction (direction) +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail hiding (isLoop, offset) +import Diagrams.TrailLike +import Diagrams.TwoD.Arc +import Diagrams.TwoD.Curvature +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector hiding (e) + +import Linear.Affine +import Linear.Metric +import Linear.Vector unitPerp :: OrderedField n => V2 n -> V2 n unitPerp = signorm . perp diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 439254ed..8e496d37 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -47,34 +46,32 @@ module Diagrams.TwoD.Path , Clip(..), clipBy, clipTo, clipped ) where -import Control.Applicative (liftA2) -import Control.Lens (Lens, Lens', generateSignatures, - lensRules, makeLensesWith, - makeWrapped, op, (.~), (^.), - _Wrapped') -import qualified Data.Foldable as F +import Control.Applicative (liftA2) +import Control.Lens (Lens, Lens', generateSignatures, lensRules, makeLensesWith, + makeWrapped, op, (.~), (^.), _Wrapped') +import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable -import Data.Default.Class - -import Diagrams.Angle -import Diagrams.Combinators (withEnvelope, withTrace) -import Diagrams.Core -import Diagrams.Core.Trace -import Diagrams.Located (Located, mapLoc, unLoc) -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Solve -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.TwoD.Segment () -import Diagrams.TwoD.Types -import Diagrams.Util (tau) - -import Linear.Affine -import Linear.Vector +import Data.Default.Class + +import Diagrams.Angle +import Diagrams.Combinators (withEnvelope, withTrace) +import Diagrams.Core +import Diagrams.Core.Trace +import Diagrams.Located (Located, mapLoc, unLoc) +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Solve +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Segment () +import Diagrams.TwoD.Types +import Diagrams.Util (tau) + +import Linear.Affine +import Linear.Vector ------------------------------------------------------------ -- Trail and path traces --------------------------------- diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index b640d9a0..f0756729 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -46,33 +45,32 @@ module Diagrams.TwoD.Polygons( ) where -import Control.Lens (Lens', generateSignatures, lensRules, - makeLensesWith, view, (.~), (^.)) -import Control.Monad (forM, liftM) -import Control.Monad.ST (ST, runST) -import Data.Array.ST (STUArray, newArray, readArray, writeArray) -import Data.List (maximumBy, minimumBy) -import Data.Maybe (catMaybes) -import Data.Monoid (mconcat, mempty) -import Data.Ord (comparing) - -import Data.Default.Class - -import Diagrams.Angle -import Diagrams.Core -import Diagrams.Located -import Diagrams.Path -import Diagrams.Points (centroid) -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) -import Diagrams.Util (tau, ( # )) - -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, + view, (.~), (^.)) +import Control.Monad (forM, liftM) +import Control.Monad.ST (ST, runST) +import Data.Array.ST (STUArray, newArray, readArray, writeArray) +import Data.Default.Class +import Data.List (maximumBy, minimumBy) +import Data.Maybe (catMaybes) +import Data.Monoid (mconcat, mempty) +import Data.Ord (comparing) + +import Diagrams.Angle +import Diagrams.Core +import Diagrams.Located +import Diagrams.Path +import Diagrams.Points (centroid) +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) +import Diagrams.Util (tau, ( # )) + +import Linear.Affine +import Linear.Metric +import Linear.Vector -- | Method used to determine the vertices of a polygon. data PolyType n = PolyPolar [Angle n] [n] diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index 5ed75eb4..7530bfb9 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} @@ -23,24 +22,24 @@ module Diagrams.TwoD.Segment where -import Control.Applicative (liftA2) -import Control.Lens ((^.)) +import Control.Applicative (liftA2) +import Control.Lens ((^.)) -import Diagrams.Core +import Diagrams.Core -import Diagrams.Angle -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Segment -import Diagrams.Solve -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector -import Diagrams.Util +import Diagrams.Angle +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment +import Diagrams.Solve +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector +import Diagrams.Util -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Linear.Affine +import Linear.Metric +import Linear.Vector {- All instances of Traced should maintain the invariant that the list of traces is sorted in increasing order. diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index 4acc34ba..d0ebe5bd 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -46,6 +45,10 @@ module Diagrams.TwoD.Shapes , roundedRect' ) where +import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.)) +import Data.Default.Class +import Data.Semigroup + import Diagrams.Core import Diagrams.Angle @@ -59,12 +62,8 @@ import Diagrams.TwoD.Polygons import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector - import Diagrams.Util -import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.)) -import Data.Default.Class -import Data.Semigroup -- | Create a centered horizontal (L-R) line of the given length. -- diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index 8a13bb2b..c5f1b542 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -32,17 +31,17 @@ module Diagrams.TwoD.Size , sized, sizedAs, sizePair ) where -import Diagrams.Core -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector - import Control.Applicative import Control.Arrow ((&&&), (***)) import Data.Hashable (Hashable) import GHC.Generics (Generic) -import Linear.Vector -import Control.Lens (Iso', iso) +import Diagrams.Core +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector + +import Control.Lens (Iso', iso) +import Linear.Vector ------------------------------------------------------------ -- Computing diagram sizes diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 5ab33247..80aca4d6 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -45,7 +44,7 @@ import Data.Data import Data.Default.Class import Data.Semigroup -import Linear.Affine +import Linear.Affine ------------------------------------------------------------ -- Text diagrams diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 83a601ba..c313cd25 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -56,16 +55,14 @@ import Diagrams.Core import Diagrams.Angle import Diagrams.Transform -import Diagrams.TwoD.Size (height, width) +import Diagrams.TwoD.Size (height, width) import Diagrams.TwoD.Types -import Control.Lens (review, (^.), (*~), (//~), (&), (.~)) +import Control.Lens (review, (&), (*~), (.~), (//~), (^.)) import Data.Semigroup -import Linear.Affine -import Linear.Vector - - +import Linear.Affine +import Linear.Vector type T2 = Transformation V2 diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 8b0a975e..3986728e 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -34,8 +34,8 @@ import Diagrams.Core import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Linear.Vector -import Linear.Affine +import Linear.Affine +import Linear.Vector -- | The @ScaleInv@ wrapper creates two-dimensional /scale-invariant/ -- objects. Intuitively, a scale-invariant object is affected by diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 052e52aa..c0f980e3 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -23,16 +23,16 @@ module Diagrams.TwoD.Types , HasR (..) ) where -import Control.Lens (Lens', Iso', iso, _1, _2) +import Control.Lens (Iso', Lens', iso, _1, _2) -import Diagrams.Angle -import Diagrams.Points +import Diagrams.Angle +import Diagrams.Points -import Diagrams.Core.Transform -import Diagrams.Core.V -import Linear.Metric -import Linear.V2 -import Linear.Vector +import Diagrams.Core.Transform +import Diagrams.Core.V +import Linear.Metric +import Linear.V2 +import Linear.Vector type P2 = Point V2 diff --git a/src/Diagrams/TwoD/Types/Polar.hs b/src/Diagrams/TwoD/Types/Polar.hs index fdc2e0e3..1707d718 100644 --- a/src/Diagrams/TwoD/Types/Polar.hs +++ b/src/Diagrams/TwoD/Types/Polar.hs @@ -3,9 +3,9 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Diagrams.TwoD.Types.Polar @@ -25,23 +25,23 @@ module Diagrams.TwoD.Types.Polar ) where -import Control.Applicative -import Control.Lens -import Control.Monad.Fix -import Control.Monad.Zip -import Data.Distributive -import Data.Foldable -import Data.Functor.Rep -import Data.Typeable -import GHC.Generics (Generic1) +import Control.Applicative +import Control.Lens +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Distributive +import Data.Foldable +import Data.Functor.Rep +import Data.Typeable +import GHC.Generics (Generic1) -import Diagrams.Angle -import Diagrams.TwoD.Types +import Diagrams.Angle +import Diagrams.TwoD.Types -import Linear.Affine -import Linear.Metric -import Linear.V3 -import Linear.Vector +import Linear.Affine +import Linear.Metric +import Linear.V3 +import Linear.Vector newtype Polar a = Polar (V2 a) @@ -95,8 +95,8 @@ interpPolar :: Num n => n -> Polar n -> Polar n -> Polar n interpPolar t (Polar a) (Polar b) = Polar (lerp t a b) --- | Space which has a radial length basis. For Polar and Cylindrical this is --- the radius of the circle in the xy-plane. For Spherical this is the +-- | Space which has a radial length basis. For Polar and Cylindrical this is +-- the radius of the circle in the xy-plane. For Spherical this is the -- distance from the origin. class Radial t where _radial :: Lens' (t a) a diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index ea008430..20123802 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -21,14 +21,14 @@ module Diagrams.TwoD.Vector -- * Synonym for R2 things ) where -import Control.Lens (view, (&), (.~)) +import Control.Lens (view, (&), (.~)) -import Diagrams.Angle -import Diagrams.Direction +import Diagrams.Angle +import Diagrams.Direction -import Linear.Metric -import Linear.Vector -import Linear.V2 +import Linear.Metric +import Linear.V2 +import Linear.Vector -- | The unit vector in the positive X direction. unitX :: (R1 v, Additive v, Num n) => v n From e24baefae199f3f48ec81b7625654a91e8ebc0cf Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Tue, 2 Sep 2014 17:24:13 +0100 Subject: [PATCH 39/58] Fixed scaling measures. --- src/Diagrams/BoundingBox.hs | 4 ++-- src/Diagrams/TwoD/Arrow.hs | 36 +++++++++++++-------------------- src/Diagrams/TwoD/Attributes.hs | 16 ++++++++------- src/Diagrams/TwoD/Model.hs | 6 +++--- src/Diagrams/TwoD/Size.hs | 7 ++++++- 5 files changed, 34 insertions(+), 35 deletions(-) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index dbc15885..4bbc1763 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -164,8 +164,8 @@ isEmptyBox _ = False -- | Gets the lower and upper corners that define the bounding box. getCorners :: BoundingBox v n -> Maybe (Point v n, Point v n) getCorners (BoundingBox p) = nonEmptyCorners <$> getOption p --- --- -- | Computes all of the corners of the bounding box. + +-- | Computes all of the corners of the bounding box. getAllCorners :: (Additive v, Traversable v, Num n) => BoundingBox v n -> [Point v n] getAllCorners (BoundingBox (Option Nothing)) = [] getAllCorners (BoundingBox (Option (Just (NonEmptyBoundingBox (l, u))))) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index fa837ade..e6a2cb97 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -253,13 +253,9 @@ headSty opts = fc black (opts^.headStyle) tailSty :: TypeableFloat n => ArrowOpts n -> Style V2 n tailSty opts = fc black (opts^.tailStyle) -fromMeasure :: TypeableFloat n => n -> n -> Measure n -> n -fromMeasure g n m = u - where Output u = toOutput g n m - -- | Calculate the length of the portion of the horizontal line that passes -- through the origin and is inside of p. -xWidth :: (Floating n) => (Traced t, Vn t ~ V2 n) => t -> n +xWidth :: Floating n => (Traced t, Vn t ~ V2 n) => t -> n xWidth p = a + b where a = fromMaybe 0 (norm <$> traceV origin unitX p) @@ -269,19 +265,19 @@ xWidth p = a + b -- And set the opacity of the shaft to the current opacity. colorJoint :: TypeableFloat n => Style V2 n -> Style V2 n colorJoint sStyle = - let c = fmap getLineTexture . getAttr $ sStyle - o = fmap getOpacity . getAttr $ sStyle - in - case (c, o) of - (Nothing, Nothing) -> fillColor (black :: Colour Double) mempty - (Just t, Nothing) -> fillTexture t mempty - (Nothing, Just o') -> opacity o' . fillColor (black :: Colour Double) $ mempty - (Just t, Just o') -> opacity o' . fillTexture t $ mempty + let c = fmap getLineTexture . getAttr $ sStyle + o = fmap getOpacity . getAttr $ sStyle + in + case (c, o) of + (Nothing, Nothing) -> fillColor (black :: Colour Double) mempty + (Just t, Nothing) -> fillTexture t mempty + (Nothing, Just o') -> opacity o' . fillColor (black :: Colour Double) $ mempty + (Just t, Just o') -> opacity o' . fillTexture t $ mempty -- | Get line width from a style. -widthOfJoint :: forall n. TypeableFloat n => Style V2 n -> n -> n -> n +widthOfJoint :: forall n. TypeableFloat n => Style V2 n -> n -> n -> n widthOfJoint sStyle gToO nToO = - maybe (fromMeasure gToO nToO (Output 1 :: Measure n)) -- Should be same as default line width + maybe (fromMeasure gToO nToO medium) -- should be same as default line width (fromMeasure gToO nToO) (fmap getLineWidth . getAttr $ sStyle :: Maybe (Measure n)) @@ -290,8 +286,8 @@ widthOfJoint sStyle gToO nToO = -- and its width. mkHead :: (DataFloat n, Renderable (Path V2 n) b) => n -> ArrowOpts n -> n -> n -> (Diagram b V2 n, n) -mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 - , hWidth + jWidth) +mkHead size opts gToO nToO = ( (j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 + , hWidth + jWidth) where (h', j') = (opts^.arrowHead) size (widthOfJoint (shaftSty opts) gToO nToO) @@ -417,15 +413,11 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- The head size, tail size, head gap, and tail gap are obtained -- from the style and converted to output units. - scaleFromMeasure = fromMeasure gToO nToO . scaleFromTransform tr + scaleFromMeasure = fromMeasure gToO nToO . scaleLocal (avgScale tr) hSize = scaleFromMeasure $ opts ^. headLength tSize = scaleFromMeasure $ opts ^. tailLength hGap = scaleFromMeasure $ opts ^. headGap tGap = scaleFromMeasure $ opts ^. tailGap - -- hSize = fromMeasure gToO nToO . transform tr $ opts ^. headLength - -- tSize = fromMeasure gToO nToO . transform tr $ opts ^. tailLength - -- hGap = fromMeasure gToO nToO . transform tr $ opts ^. headGap - -- tGap = fromMeasure gToO nToO . transform tr $ opts ^. tailGap -- Make the head and tail and save their widths. (h, hWidth') = mkHead hSize opts' gToO nToO diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index c5bbeb4e..a7eb1e97 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -131,7 +131,7 @@ type instance V (LineWidth n) = V2 type instance N (LineWidth n) = n instance Floating n => Transformable (LineWidth n) where - transform = scaleFromTransform + transform t (LineWidth (Last m)) = LineWidth (Last $ scaleLocal (avgScale t) m) instance Floating n => Default (LineWidth n) where def = LineWidth (Last medium) @@ -190,18 +190,20 @@ type instance V (DashingA n) = V2 type instance N (DashingA n) = n instance Floating n => Transformable (DashingA n) where - transform = scaleFromTransform + transform t (DashingA (Last (Dashing ms m))) + = DashingA (Last $ Dashing (map f ms) (f m)) + where f = scaleLocal (avgScale t) getDashing :: DashingA n -> Dashing n getDashing (DashingA (Last d)) = d -- | Set the line dashing style. -dashing :: (Floating n, Data n, HasStyle a, Vn a ~ V2 n) => - [Measure n] -- ^ A list specifying alternate lengths of on - -- and off portions of the stroke. The empty - -- list indicates no dashing. +dashing :: (Floating n, Data n, HasStyle a, Vn a ~ V2 n) + => [Measure n] -- ^ A list specifying alternate lengths of on + -- and off portions of the stroke. The empty + -- list indicates no dashing. -> Measure n -- ^ An offset into the dash pattern at which the - -- stroke should start. + -- stroke should start. -> a -> a dashing ds offs = applyGTAttr (DashingA (Last (Dashing ds offs))) diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs index e239e9bc..99eef3c3 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -69,9 +69,9 @@ showOrigin' :: (RealFloat n, Renderable (Path V2 n) b, Data n, Monoid' m) => OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m showOrigin' oo d = o <> d where o = stroke (circle sz) - # fc (oo^.oColor) - # lineWidth (Output 0) - # fmap (const mempty) + # fc (oo^.oColor) + # lw none + # fmap (const mempty) (w,h) = size2D d ^* oo^.oScale sz = maximum [w, h, oo^.oMinSize] diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index c5f1b542..56e497d6 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -33,6 +33,7 @@ module Diagrams.TwoD.Size import Control.Applicative import Control.Arrow ((&&&), (***)) +import Control.Lens (Iso', iso) import Data.Hashable (Hashable) import GHC.Generics (Generic) @@ -40,7 +41,6 @@ import Diagrams.Core import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -import Control.Lens (Iso', iso) import Linear.Vector ------------------------------------------------------------ @@ -59,6 +59,11 @@ height = maybe 0 (negate . uncurry (-)) . extentY size2D :: (Vn a ~ V2 n, Enveloped a) => a -> (n, n) size2D = width &&& height +-- | Compute the vector that goes from the lower left to the upper right of an +-- enveloped object. +envelopeRange :: (Vn a ~ V2 n, Enveloped a) => a -> V2 n +envelopeRange = liftA2 V2 width height + -- | Compute the size of an enveloped object as a 'SizeSpec2D' value. sizeSpec2D :: (Vn a ~ V2 n, Enveloped a) => a -> SizeSpec2D n sizeSpec2D = uncurry Dims . size2D From a11a0f3b03276f56c5b1cc922778e5c4f2267c12 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Thu, 4 Sep 2014 00:09:48 +0100 Subject: [PATCH 40/58] Fix bug with showOrigin. --- src/Diagrams/Align.hs | 2 +- src/Diagrams/BoundingBox.hs | 16 ++++++++++------ src/Diagrams/TwoD/Adjust.hs | 8 ++++---- src/Diagrams/TwoD/Arrow.hs | 12 ++++++------ src/Diagrams/TwoD/Arrowheads.hs | 16 ++++++++-------- src/Diagrams/TwoD/Model.hs | 5 ++--- src/Diagrams/TwoD/Size.hs | 7 +------ 7 files changed, 32 insertions(+), 34 deletions(-) diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs index 83e85ad7..65814f90 100644 --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -164,5 +164,5 @@ snugCenter = applyAll fs where fs = map snugCenterV basis -{-# ANN module "HLint: ignore Use camelCase" #-} +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index 4bbc1763..5d668620 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -171,6 +171,10 @@ getAllCorners (BoundingBox (Option Nothing)) = [] getAllCorners (BoundingBox (Option (Just (NonEmptyBoundingBox (l, u))))) = T.sequence (liftI2 (\a b -> [a,b]) l u) +-- +-- allCorners :: (Additive v, Traversable v, Num n) => BoundingBox v n -> Maybe [Point v n] +-- allCorners = fmap (\(l,u) -> T.sequence (liftI2 (\a b -> [a,b]) l u)) . getCorners + -- | Get the size of the bounding box - the vector from the (component-wise) -- lesser point to the greater point. boxExtents :: (Additive v, Num n) => BoundingBox v n -> v n @@ -181,12 +185,12 @@ boxTransform :: (Additive v, Fractional n) => BoundingBox v n -> BoundingBox v n -> Maybe (Transformation v n) boxTransform u v = do - (P ul, _) <- getCorners u - (P vl, _) <- getCorners v - let i = s (v, u) <-> s (u, v) - s = liftU2 (*) . uncurry (liftU2 (/)) . mapT boxExtents - return $ Transformation i i (vl ^-^ s (v, u) ul) - -- NOTE: Need to check this one + (P ul, _) <- getCorners u + (P vl, _) <- getCorners v + let i = s (v, u) <-> s (u, v) + s = liftU2 (*) . uncurry (liftU2 (/)) . mapT boxExtents + return $ Transformation i i (vl ^-^ s (v, u) ul) + -- NOTE: Need to check this one -- | Transforms an enveloped thing to fit within a @BoundingBox@. If it's -- empty, then the result is also @mempty@. diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs index 0f9d0eff..e7769781 100644 --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -69,16 +69,16 @@ adjustDiaSize2D :: (TypeableFloat n, Monoid' m) adjustDiaSize2D szL _ opts d = ( case spec of Dims _ _ -> opts - _ -> opts & szL .~ (uncurry Dims . over both (*s) $ size) + _ -> opts & szL .~ (uncurry Dims . over both (*s) $ sz) , adjustT , d # transform adjustT ) where spec = opts ^. szL - size = size2D d - s = requiredScale spec size + sz = size2D d + s = requiredScale spec sz finalSz = case spec of Dims w h -> (w,h) - _ -> over both (*s) size + _ -> over both (*s) sz tr = (0.5 *. p2 finalSz) .-. (s *. center2D d) adjustT = translation tr <> scaling s diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index e6a2cb97..f819aeb3 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -242,7 +242,7 @@ shaftTexture = shaftStyle . styleLineTexture -- default style after all other styles have been applied. -- The semigroup stucture of the lw attribute will insure that the default -- is only used if it has not been set in @opts@. -shaftSty :: (Fractional n) => ArrowOpts n -> Style V2 n +shaftSty :: Fractional n => ArrowOpts n -> Style V2 n shaftSty opts = opts^.shaftStyle -- Set the default head style. See `shaftSty`. @@ -286,10 +286,10 @@ widthOfJoint sStyle gToO nToO = -- and its width. mkHead :: (DataFloat n, Renderable (Path V2 n) b) => n -> ArrowOpts n -> n -> n -> (Diagram b V2 n, n) -mkHead size opts gToO nToO = ( (j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 +mkHead sz opts gToO nToO = ( (j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 , hWidth + jWidth) where - (h', j') = (opts^.arrowHead) size + (h', j') = (opts^.arrowHead) sz (widthOfJoint (shaftSty opts) gToO nToO) hWidth = xWidth h' jWidth = xWidth j' @@ -299,10 +299,10 @@ mkHead size opts gToO nToO = ( (j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO -- | Just like mkHead only the attachment point is on the right. mkTail :: (DataFloat n, Renderable (Path V2 n) b) => n -> ArrowOpts n -> n -> n -> (Diagram b V2 n, n) -mkTail size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 +mkTail sz opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 , tWidth + jWidth) where - (t', j') = (opts^.arrowTail) size + (t', j') = (opts^.arrowTail) sz (widthOfJoint (shaftSty opts) gToO nToO) tWidth = xWidth t' jWidth = xWidth j' @@ -313,7 +313,7 @@ mkTail size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 -- tw, head width hw and shaft of tr, such that the magnituted of the shaft -- offset is size. Used for calculating the offset of an arrow. spine :: TypeableFloat n => Trail V2 n -> n -> n -> n -> Trail V2 n -spine tr tw hw size = tS <> tr # scale size <> hS +spine tr tw hw sz = tS <> tr # scale sz <> hS where tSpine = trailFromOffsets [signorm . tangentAtStart $ tr] # scale tw hSpine = trailFromOffsets [signorm . tangentAtEnd $ tr] # scale hw diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index ea265b8c..39f0d9d7 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -113,7 +113,7 @@ arrowheadTriangle theta = aHead -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. arrowheadDart :: RealFloat n => Angle n -> ArrowHT n -arrowheadDart theta len shaftWidth = (hd # scale size, jt) +arrowheadDart theta len shaftWidth = (hd # scale sz, jt) where hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] jt = pathFromTrail . glueTrail $ j <> reflectY j @@ -125,7 +125,7 @@ arrowheadDart theta len shaftWidth = (hd # scale size, jt) jLength = shaftWidth / (2 * tan psi) -- If the shaft if too wide, set the size to a default value of 1. - size = max 1 ((len - jLength) / 1.5) + sz = max 1 ((len - jLength) / 1.5) -- | Isoceles triangle with curved concave base. Inkscape type 2. arrowheadSpike :: RealFloat n => Angle n -> ArrowHT n @@ -157,7 +157,7 @@ arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) -- | Curved sides, linear concave base. Illustrator CS5 #3 arrowheadThorn :: RealFloat n => Angle n -> ArrowHT n -arrowheadThorn theta len shaftWidth = (hd # scale size, jt) +arrowheadThorn theta len shaftWidth = (hd # scale sz, jt) where hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop hTop = closeTrail . trailFromSegments $ [c, l] @@ -171,7 +171,7 @@ arrowheadThorn theta len shaftWidth = (hd # scale size, jt) jLength = shaftWidth / (2 * tanA psi) -- If the shaft if too wide, set the size to a default value of 1. - size = max 1 ((len - jLength) / 1.5) + sz = max 1 ((len - jLength) / 1.5) -- | Make a side for the thorn head. curvedSide :: (Floating n, Ord n) => Angle n -> Segment Closed V2 n @@ -225,9 +225,9 @@ dart = arrowheadDart (2/5 @@ turn) headToTail :: (OrderedField n) => ArrowHT n -> ArrowHT n headToTail hd = tl where - tl size shaftWidth = (t, j) + tl sz shaftWidth = (t, j) where - (t', j') = hd size shaftWidth + (t', j') = hd sz shaftWidth t = reflectX t' j = reflectX j' @@ -249,8 +249,8 @@ arrowtailQuill theta = aTail aTail len shaftWidth = (t, j) where t = closedPath (trailFromVertices [v0, v1, v2, v3, v4, v5, v0]) - # scale size # alignR - size = len / 0.6 + # scale sz # alignR + sz = len / 0.6 v0 = p2 (0.5, 0) v2 = origin .+^ (rotate theta unitX # scale 0.5) v1 = v2 # translateX (5/8) diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs index 99eef3c3..513ad8a1 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -35,7 +35,6 @@ import Diagrams.Path import Diagrams.TwoD.Attributes import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Path -import Diagrams.TwoD.Size (size2D) import Diagrams.TwoD.Text import Diagrams.TwoD.Types import Diagrams.Util @@ -72,8 +71,8 @@ showOrigin' oo d = o <> d # fc (oo^.oColor) # lw none # fmap (const mempty) - (w,h) = size2D d ^* oo^.oScale - sz = maximum [w, h, oo^.oMinSize] + V2 w h = oo^.oScale *^ size d + sz = maximum [w, h, oo^.oMinSize] ------------------------------------------------------------ -- Labeling named points diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index 56e497d6..7a6c7c7b 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -59,11 +59,6 @@ height = maybe 0 (negate . uncurry (-)) . extentY size2D :: (Vn a ~ V2 n, Enveloped a) => a -> (n, n) size2D = width &&& height --- | Compute the vector that goes from the lower left to the upper right of an --- enveloped object. -envelopeRange :: (Vn a ~ V2 n, Enveloped a) => a -> V2 n -envelopeRange = liftA2 V2 width height - -- | Compute the size of an enveloped object as a 'SizeSpec2D' value. sizeSpec2D :: (Vn a ~ V2 n, Enveloped a) => a -> SizeSpec2D n sizeSpec2D = uncurry Dims . size2D @@ -131,7 +126,7 @@ spec2D = iso getter (uncurry mkSizeSpec) requiredScaleT :: (Additive v, RealFloat n) => SizeSpec2D n -> (n, n) -> Transformation v n -requiredScaleT spec size = scaling (requiredScale spec size) +requiredScaleT spec sz = scaling (requiredScale spec sz) -- is requiredScaling a more consistent name? -- | @requiredScale spec sz@ returns a scaling factor necessary to From 84570553054354896bd7071152f8b18cc4098089 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 7 Sep 2014 02:09:10 +0100 Subject: [PATCH 41/58] Postpone new polar coordinate and general cleanup. --- diagrams-lib.cabal | 9 +- src/Diagrams/Animation/Active.hs | 5 +- src/Diagrams/Direction.hs | 1 - src/Diagrams/Located.hs | 10 +- src/Diagrams/Parametric/Adjust.hs | 6 +- src/Diagrams/ThreeD/Camera.hs | 6 +- src/Diagrams/ThreeD/Shapes.hs | 6 +- src/Diagrams/ThreeD/Types/Cylindrical.hs | 101 ---------------- src/Diagrams/ThreeD/Types/Spherical.hs | 123 ------------------- src/Diagrams/Trail.hs | 14 +-- src/Diagrams/TwoD/Arrowheads.hs | 8 +- src/Diagrams/TwoD/Attributes.hs | 10 +- src/Diagrams/TwoD/Transform/ScaleInv.hs | 3 - src/Diagrams/TwoD/Types/Polar.hs | 147 ----------------------- 14 files changed, 31 insertions(+), 418 deletions(-) delete mode 100644 src/Diagrams/ThreeD/Types/Cylindrical.hs delete mode 100644 src/Diagrams/ThreeD/Types/Spherical.hs delete mode 100644 src/Diagrams/TwoD/Types/Polar.hs diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index eaef98d1..90302168 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -75,7 +75,6 @@ Library Diagrams.TwoD.Transform, Diagrams.TwoD.Transform.ScaleInv, Diagrams.TwoD.Types, - Diagrams.TwoD.Types.Polar, Diagrams.TwoD.Vector, Diagrams.ThreeD, Diagrams.ThreeD.Align, @@ -86,8 +85,6 @@ Library Diagrams.ThreeD.Shapes, Diagrams.ThreeD.Transform, Diagrams.ThreeD.Types, - Diagrams.ThreeD.Types.Cylindrical - Diagrams.ThreeD.Types.Spherical, Diagrams.ThreeD.Vector, Diagrams.Animation, Diagrams.Animation.Active, @@ -112,9 +109,9 @@ Library safe >= 0.2 && < 0.4, JuicyPixels >= 3.1.5 && < 3.2, hashable >= 1.1 && < 1.3, - linear, - adjunctions, - distributive + linear >= 1.10 && < 2.0, + adjunctions >= 4.0 && < 5.0, + distributive >=0.2.2 && < 1.0 if impl(ghc < 7.6) Build-depends: ghc-prim diff --git a/src/Diagrams/Animation/Active.hs b/src/Diagrams/Animation/Active.hs index bef589e3..949884e2 100644 --- a/src/Diagrams/Animation/Active.hs +++ b/src/Diagrams/Animation/Active.hs @@ -96,5 +96,6 @@ instance Juxtaposable a => Juxtaposable (Active a) where ) a1 ---instance Alignable a => Alignable (Active a) where --- alignBy v d a = alignBy v d <$> a +-- instance Alignable a => Alignable (Active a) where +-- alignBy v d a = alignBy v d <$> a + diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index 91091ba9..e5180b60 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -39,7 +39,6 @@ newtype Direction v n = Direction (v n) type instance V (Direction v n) = v type instance N (Direction v n) = n --- instance (Transformable v, Vn (Direction v n) ~ v n) => Transformable (Direction v) where instance (Vn (v n) ~ v n, Transformable (v n)) => Transformable (Direction v n) where transform t (Direction v) = Direction (transform t v) diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs index c979186b..6976e4fd 100644 --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -19,11 +19,11 @@ module Diagrams.Located ( Located - , at, viewLoc, unLoc, loc, mapLoc, located, _location, _Loc + , at, viewLoc, unLoc, loc, mapLoc, located, ) where -import Control.Lens (Iso', Lens, Lens', iso, lens) +import Control.Lens (Lens) import Data.Functor ((<$>)) import Linear.Affine @@ -91,12 +91,6 @@ mapLoc f (Loc p a) = Loc p (f a) located :: (Vn a ~ Vn a') => Lens (Located a) (Located a') a a' located f (Loc p a) = Loc p <$> f a -_location :: (Vn a ~ v n) => Lens' (Located a) (Point v n) -_location = lens (\(Loc l _) -> l) (\(Loc _ a) l -> Loc l a) - -_Loc :: (Vn a ~ v n) => Iso' (Located a) (Point v n, a) -_Loc = iso viewLoc (uncurry Loc) - deriving instance (Eq (V a (N a)), Eq a ) => Eq (Located a) deriving instance (Ord (V a (N a)), Ord a ) => Ord (Located a) deriving instance (Show (V a (N a)), Show a) => Show (Located a) diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs index 11254064..2708992e 100644 --- a/src/Diagrams/Parametric/Adjust.hs +++ b/src/Diagrams/Parametric/Adjust.hs @@ -33,11 +33,11 @@ import Diagrams.Parametric -- | What method should be used for adjusting a segment, trail, or -- path? data AdjustMethod n = ByParam n -- ^ Extend by the given parameter value - -- (use a negative parameter to shrink) + -- (use a negative parameter to shrink) | ByAbsolute n -- ^ Extend by the given arc length - -- (use a negative length to shrink) + -- (use a negative length to shrink) | ToAbsolute n -- ^ Extend or shrink to the given - -- arc length + -- arc length -- | Which side of a segment, trail, or path should be adjusted? data AdjustSide = Start -- ^ Adjust only the beginning diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index e784fcaf..078b0216 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -57,8 +57,8 @@ type instance V (Camera l n) = V3 type instance N (Camera l n) = n class Typeable l => CameraLens l where - -- | The natural aspect ratio of the projection. - aspect :: Floating n => l n -> n + -- | The natural aspect ratio of the projection. + aspect :: Floating n => l n -> n -- | A perspective projection data PerspectiveLens n = PerspectiveLens @@ -98,7 +98,7 @@ instance Num n => Transformable (Camera l n) where l instance Num n => Renderable (Camera l n) NullBackend where - render _ _ = mempty + render _ _ = mempty -- | A camera at the origin facing along the negative Z axis, with its -- up-axis coincident with the positive Y axis. The field of view is diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index a9ce0445..7312d645 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -104,16 +104,16 @@ cube = mkQD (Prim $ Box mempty) boxQuery = Any . range data Frustum n = Frustum n n (Transformation V3 n) - deriving Typeable + deriving Typeable type instance V (Frustum n) = V3 type instance N (Frustum n) = n instance Fractional n => Transformable (Frustum n) where - transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) + transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) instance Fractional n => Renderable (Frustum n) NullBackend where - render _ _ = mempty + render _ _ = mempty -- | A frustum of a right circular cone. It has height 1 oriented -- along the positive z axis, and radii r0 and r1 at Z=0 and Z=1. diff --git a/src/Diagrams/ThreeD/Types/Cylindrical.hs b/src/Diagrams/ThreeD/Types/Cylindrical.hs deleted file mode 100644 index 74f5f4ba..00000000 --- a/src/Diagrams/ThreeD/Types/Cylindrical.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module Diagrams.ThreeD.Types.Cylindrical - ( -- * Data type - Cylindrical - , mkCylindrical, cylindrical, uncylindrical - , cylindricalV3, cylindricalIso - - -- * Classes - , Radial (..), Circle (..), Cylinder (..) - , HasX (..), HasY (..), HasZ (..) - - -- * Basis elements - , er, eθ, etheta, eh - - ) where - -import Control.Applicative -import Control.Lens -import Control.Monad.Fix -import Control.Monad.Zip -import Data.Distributive -import Data.Foldable -import Data.Functor.Rep -import Data.Typeable -import GHC.Generics (Generic1) - -import Diagrams.Angle -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Types.Spherical - -import Linear.Vector - - --- | Space which has a radial, angular and height basis. -class Circle t => Cylinder t where - _longitude :: Lens' (t a) a - _cylindrical :: Lens' (t a) (Cylindrical a) - -eh :: Cylinder v => E v -eh = E (_cylindrical . cylindricalWrapper . _z) - -newtype Cylindrical a = Cylindrical (V3 a) - deriving (Monad, Functor, Typeable, MonadFix, Applicative, Traversable, - Generic1, MonadZip, Foldable) - -cylindricalWrapper :: Iso' (Cylindrical a) (V3 a) -cylindricalWrapper = iso (\(Cylindrical v) -> v) Cylindrical - -mkCylindrical :: n -> Angle n -> n -> Cylindrical n -mkCylindrical r θ z = Cylindrical $ V3 r (θ ^. rad) z - -cylindrical :: (n, Angle n, n) -> Cylindrical n -cylindrical (r,θ,z) = mkCylindrical r θ z - -uncylindrical :: Cylindrical n -> (n, Angle n, n) -uncylindrical (Cylindrical (V3 r θ z)) = (r, θ @@ rad, z) - -cylindricalIso :: Iso' (Cylindrical n) (n, Angle n, n) -cylindricalIso = iso uncylindrical cylindrical - -instance Distributive Cylindrical where - distribute f = Cylindrical $ V3 (fmap (\(Cylindrical (V3 x _ _)) -> x) f) - (fmap (\(Cylindrical (V3 _ y _)) -> y) f) - (fmap (\(Cylindrical (V3 _ _ z)) -> z) f) - -instance Representable Cylindrical where - type Rep Cylindrical = E Cylindrical - tabulate f = Cylindrical $ V3 (f er) (f eθ) (f eh) - index xs (E l) = view l xs - -instance Radial Cylindrical where - _radial = cylindricalWrapper . _x - -instance Circle Cylindrical where - _azimuth = cylindricalWrapper . _y . from rad - _polar = cylindricalWrapper . _xy . _Unwrapped' - -instance Cylinder Cylindrical where - _longitude = cylindricalWrapper . _z - _cylindrical = id - -cylindricalV3 :: RealFloat n => Iso' (Cylindrical n) (V3 n) -cylindricalV3 = iso - (\(Cylindrical (V3 r θ z)) -> V3 (r*cos θ) (r*sin θ) z) - (\(V3 x y z) -> Cylindrical $ V3 (sqrt $ x*x + y*y) (atan2 y x) z) - -instance HasX Cylindrical where x_ = cylindricalV3 . _x -instance HasY Cylindrical where xy_ = cylindricalV3 . _xy -instance HasZ Cylindrical where xyz_ = cylindricalV3 - -instance HasR Cylindrical where _r = cylindricalV3 . _r -instance HasTheta Cylindrical where _theta = _azimuth -instance HasPhi Cylindrical where _phi = cylindricalV3 . _phi - diff --git a/src/Diagrams/ThreeD/Types/Spherical.hs b/src/Diagrams/ThreeD/Types/Spherical.hs deleted file mode 100644 index 9fa6c35c..00000000 --- a/src/Diagrams/ThreeD/Types/Spherical.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module Diagrams.ThreeD.Types.Spherical - ( -- * Data type - Spherical - , mkSpherical, spherical, unspherical, sphericalIso, sphericalV3 - - -- ** Spherical functions - , interpSpherical - - -- * Classes - , Radial (..), Circle (..), Sphere (..) - , HasX (..), HasY (..), HasZ (..), HasR (..) - - -- * Basis elements - , er, eθ, etheta, eφ, ephi - - ) where - -import Control.Applicative -import Control.Lens -import Control.Monad.Fix -import Control.Monad.Zip -import Data.Distributive -import Data.Foldable -import Data.Functor.Rep -import Data.Typeable -import GHC.Generics (Generic1) - -import Diagrams.Angle -import Diagrams.TwoD.Types.Polar - -import Linear.Affine -import Linear.Metric -import Linear.V1 -import Linear.V2 -import Linear.V3 -import Linear.Vector - --- | Space which has a radial and two angular basis. The inclination is the --- positive angles from the z-axis. -class Circle t => Sphere t where - _inclination :: Lens' (t a) (Angle a) - _spherical :: Lens' (t a) (Spherical a) - -eφ, ephi :: Sphere v => E v -eφ = E (_spherical . sphericalV3 . _z) -ephi = eφ - -newtype Spherical a = Spherical (V3 a) - deriving (Monad, Functor, Typeable, MonadFix, Applicative, Traversable, - Generic1, MonadZip, Foldable) - -sphericalV3 :: Iso' (Spherical a) (V3 a) -sphericalV3 = iso (\(Spherical v) -> v) Spherical - -mkSpherical :: n -> Angle n -> Angle n -> Spherical n -mkSpherical r θ φ = Spherical $ V3 r (θ ^. rad) (φ ^. rad) - -spherical :: (n, Angle n, Angle n) -> Spherical n -spherical (n, θ, φ) = mkSpherical n θ φ - -unspherical :: Spherical n -> (n, Angle n, Angle n) -unspherical (Spherical (V3 r θ φ)) = (r, θ @@ rad, φ @@ rad) - --- | Linear interpolation between spherical coordinates. -interpSpherical :: Num n => n -> Spherical n -> Spherical n -> Spherical n -interpSpherical t (Spherical a) (Spherical b) = Spherical $ lerp t a b - -instance Distributive Spherical where - distribute f = Spherical $ V3 (fmap (\(Spherical (V3 x _ _)) -> x) f) - (fmap (\(Spherical (V3 _ y _)) -> y) f) - (fmap (\(Spherical (V3 _ _ z)) -> z) f) - -instance Representable Spherical where - type Rep Spherical = E Spherical - tabulate f = Spherical $ V3 (f er) (f eθ) (f eφ) - index xs (E l) = view l xs - -instance Radial Spherical where - _radial = sphericalV3 . _x - -instance Circle Spherical where - _azimuth = sphericalV3 . _y . from rad - _polar = sphericalV3 . _xy . _Unwrapped' - -instance Sphere Spherical where - _inclination = sphericalV3 . _z . from rad - _spherical = id - -sphericalIso :: RealFloat n => Iso' (Spherical n) (V3 n) -sphericalIso = iso - (\(Spherical (V3 r θ φ)) -> V3 (r * cos θ * sin φ) (r * sin θ * sin φ) (r * cos φ)) - (\v@(V3 x y z) -> let r = norm v - in Spherical $ V3 r (atan2 y x) (acos (z / r))) - --- | Coordinate with at least three dimensions where the x, y and z coordinate can be --- retreived numerically. -class HasY t => HasZ t where - z_ :: RealFloat n => Lens' (t n) n - z_ = xyz_ . _z - - xyz_ :: RealFloat n => Lens' (t n) (V3 n) - -instance HasZ v => HasZ (Point v) where - xyz_ = lensP . xyz_ - -instance HasZ V3 where xyz_ = id - -instance HasX Spherical where x_ = sphericalIso . _x -instance HasY Spherical where xy_ = sphericalIso . _xy -instance HasZ Spherical where xyz_ = sphericalIso - -instance HasR Spherical where _r = _radial -instance HasTheta Spherical where _theta = _azimuth -instance HasPhi Spherical where _phi = _inclination - diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index e2ff8f80..ac9643fd 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -673,8 +673,7 @@ instance (Metric v, OrderedField n, Real n) instance Num n => DomainBounds (Trail v n) -instance (Metric v, OrderedField n, Real n) - => EndValues (Trail v n) +instance (Metric v, OrderedField n, Real n) => EndValues (Trail v n) -- | Note that there is no @Sectionable@ instance for @Trail' Loop@, -- because it does not make sense (splitting a loop at a parameter @@ -685,8 +684,7 @@ instance (Metric v, OrderedField n, Real n) -- semantically a bit silly, so please don't rely on it. (*E.g.* if -- this is really the behavior you want, consider first calling -- 'cutLoop' yourself.) -instance (Metric v, OrderedField n, Real n) - => Sectionable (Trail v n) where +instance (Metric v, OrderedField n, Real n) => Sectionable (Trail v n) where splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t reverseDomain = reverseTrail @@ -735,7 +733,7 @@ withLine f = withTrail f (f . cutLoop) -- there is no nice way in general to convert a line into a loop, -- operate on it, and then convert back. onLine :: (Metric v, OrderedField n) - => (Trail' Line v n -> Trail' Line v n) -> Trail v n -> Trail v n + => (Trail' Line v n -> Trail' Line v n) -> Trail v n -> Trail v n onLine f = onTrail f (glueLine . f . cutLoop) -- | Convert a 'Trail'' into a 'Trail', hiding the type-level @@ -786,14 +784,12 @@ trailFromSegments = wrapTrail . lineFromSegments -- -- > import Diagrams.Coordinates -- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 ^& 1, 2 ^& (-1), 2 ^& 0.5 ] -lineFromOffsets :: (Metric v, OrderedField n) - => [v n] -> Trail' Line v n +lineFromOffsets :: (Metric v, OrderedField n) => [v n] -> Trail' Line v n lineFromOffsets = lineFromSegments . map straight -- | @trailFromOffsets === 'wrapTrail' . 'lineFromOffsets'@, for -- conveniently constructing a @Trail@ instead of a @Trail' Line@. -trailFromOffsets :: (Metric v, OrderedField n) - => [v n] -> Trail v n +trailFromOffsets :: (Metric v, OrderedField n) => [v n] -> Trail v n trailFromOffsets = wrapTrail . lineFromOffsets -- | Construct a line containing only linear segments from a list of diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 39f0d9d7..be12c0a2 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -222,7 +222,7 @@ dart = arrowheadDart (2/5 @@ turn) -- | Utility function to convert any arrowhead to an arrowtail, i.e. -- attached at the start of the trail. -headToTail :: (OrderedField n) => ArrowHT n -> ArrowHT n +headToTail :: OrderedField n => ArrowHT n -> ArrowHT n headToTail hd = tl where tl sz shaftWidth = (t, j) @@ -243,7 +243,7 @@ arrowtailBlock theta = aTail x = norm a -- | The angle is where the top left corner intersects the circle. -arrowtailQuill :: (Floating n, Ord n) => Angle n -> ArrowHT n +arrowtailQuill :: OrderedField n => Angle n -> ArrowHT n arrowtailQuill theta = aTail where aTail len shaftWidth = (t, j) @@ -266,10 +266,10 @@ arrowtailQuill theta = aTail -- Standard tails --------------------------------------------------------- -- | A line the same width as the shaft. -lineTail :: (RealFloat n) => ArrowHT n +lineTail :: RealFloat n => ArrowHT n lineTail s w = (square 1 # scaleY w # scaleX s # alignR, mempty) -noTail :: (Floating n, Ord n) => ArrowHT n +noTail :: OrderedField n => ArrowHT n noTail _ _ = (mempty, mempty) -- | <> diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index a7eb1e97..8e695bd2 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -122,7 +122,7 @@ huge = Normalized 0.10 -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. newtype LineWidth n = LineWidth (Last (Measure n)) - deriving (Typeable, Semigroup, Functor) + deriving (Typeable, Semigroup, Functor) deriving instance (Data n) => Data (LineWidth n) instance (Typeable n) => AttributeClass (LineWidth n) @@ -134,7 +134,7 @@ instance Floating n => Transformable (LineWidth n) where transform t (LineWidth (Last m)) = LineWidth (Last $ scaleLocal (avgScale t) m) instance Floating n => Default (LineWidth n) where - def = LineWidth (Last medium) + def = LineWidth (Last medium) getLineWidth :: LineWidth n -> Measure n getLineWidth (LineWidth (Last w)) = w @@ -405,7 +405,7 @@ instance Floating n => Transformable (LineTexture n) where transform t (LineTexture (Last tx)) = LineTexture (Last $ transform t tx) instance Default (LineTexture n) where - def = LineTexture (Last (SC (SomeColor (black :: Colour Double)))) + def = LineTexture (Last (SC (SomeColor (black :: Colour Double)))) getLineTexture :: LineTexture n -> Texture n getLineTexture (LineTexture (Last t)) = t @@ -475,8 +475,8 @@ instance Floating n => Transformable (FillTexture n) where transform t (FillTexture (Commit (Last tx))) = FillTexture (Commit (Last $ transform t tx)) instance Default (FillTexture n) where - def = FillTexture (Recommend (Last (SC - (SomeColor (transparent :: AlphaColour Double))))) + def = FillTexture (Recommend (Last (SC + (SomeColor (transparent :: AlphaColour Double))))) getFillTexture :: FillTexture n -> Texture n getFillTexture (FillTexture tx) = getLast . getRecommend $ tx diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 3986728e..78671d09 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -94,16 +94,13 @@ instance (Vn t ~ v n, Additive v, Num n, HasOrigin t) => HasOrigin (ScaleInv t) instance (Vn t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv t) where transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where - -- angle :: Angle n angle = transform tr v ^. _theta rot :: (Vn k ~ Vn t, Transformable k) => k -> k rot = rotateAround l angle - -- l' :: Point V2 n l' = transform tr l - -- trans :: (Vn k ~ Vn t, Transformable k) => k -> k trans = translate (l' .-. l) {- Proof that the above satisfies the monoid action laws. diff --git a/src/Diagrams/TwoD/Types/Polar.hs b/src/Diagrams/TwoD/Types/Polar.hs deleted file mode 100644 index 1707d718..00000000 --- a/src/Diagrams/TwoD/Types/Polar.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Diagrams.TwoD.Types.Polar - ( -- * Polar type - Polar - , mkPolar, polar, unpolar, polarIso, polarV2 - - -- * Polar functions - , interpPolar - - -- * Classes - , Radial (..), Circle (..) - , HasX (..), HasY (..), HasR (..) - - -- * Basis elements - , er, eθ, etheta, - - ) where - -import Control.Applicative -import Control.Lens -import Control.Monad.Fix -import Control.Monad.Zip -import Data.Distributive -import Data.Foldable -import Data.Functor.Rep -import Data.Typeable -import GHC.Generics (Generic1) - -import Diagrams.Angle -import Diagrams.TwoD.Types - -import Linear.Affine -import Linear.Metric -import Linear.V3 -import Linear.Vector - - -newtype Polar a = Polar (V2 a) - deriving (Monad, Functor, Typeable, MonadFix, Applicative, Traversable, - Generic1, MonadZip, Foldable) - -makeWrapped ''Polar - --- can't make reasonable Additive instance - -instance Distributive Polar where - distribute f = Polar $ V2 (fmap (\(Polar (V2 x _)) -> x) f) - (fmap (\(Polar (V2 _ y)) -> y) f) - -instance Representable Polar where - type Rep Polar = E Polar - tabulate f = Polar $ V2 (f er) (f eθ) - index xs (E l) = view l xs - -instance Circle Polar where - _azimuth = polarWrapper . _y . from rad - _polar = id - --- | Construct a 'Polar' from a magnitude and an 'Angle'. -mkPolar :: n -> Angle n -> Polar n -mkPolar r θ = Polar $ V2 r (θ^.rad) - --- | Construct a 'Polar' from a magnitude and 'Angle' tuple. -polar :: (n, Angle n) -> Polar n -polar = uncurry mkPolar - --- | Turn a 'Polar' back into a magnitude and 'Angle' tuple. -unpolar :: Polar n -> (n, Angle n) -unpolar (Polar (V2 r θ)) = (r, θ @@ rad) - --- | 'Iso'' between 'Polar' and its tuple form. -polarIso :: Iso' (Polar n) (n, Angle n) -polarIso = iso unpolar polar - --- | Numerical 'Iso'' between 'Polar' and 'R2'. -polarV2 :: RealFloat n => Iso' (Polar n) (V2 n) -polarV2 = iso (\(Polar (V2 r θ)) -> V2 (r * cos θ) (r * sin θ)) - (\v@(V2 x y) -> Polar $ V2 (norm v) (atan2 y x)) - --- internal iso for instances -polarWrapper :: Iso' (Polar a) (V2 a) -polarWrapper = iso (\(Polar v) -> v) Polar - --- | Polar interpolation between two polar coordinates. -interpPolar :: Num n => n -> Polar n -> Polar n -> Polar n -interpPolar t (Polar a) (Polar b) = Polar (lerp t a b) - - --- | Space which has a radial length basis. For Polar and Cylindrical this is --- the radius of the circle in the xy-plane. For Spherical this is the --- distance from the origin. -class Radial t where - _radial :: Lens' (t a) a - -instance Radial Polar where - _radial = polarWrapper . _x - --- | Space which has a radial and angular basis. -class Radial t => Circle t where - _azimuth :: Lens' (t a) (Angle a) - _polar :: Lens' (t a) (Polar a) - -er :: Circle v => E v -er = E _radial - -eθ, etheta :: Circle v => E v -eθ = E (_polar . polarWrapper . _y) -etheta = eθ - --- | Coordinate with at least one dimension where the x coordinate can be --- retreived numerically. Note this differs slightly from 'R1' which requires --- a lens for all values. This allows instances for different coordinates --- such as 'Polar', where the x coordinate can only be retreived numerically. -class HasX t where - x_ :: RealFloat n => Lens' (t n) n - -instance HasX v => HasX (Point v) where - x_ = lensP . x_ - -instance HasX V2 where x_ = _x -instance HasX V3 where x_ = _x -instance HasX Polar where x_ = polarV2 . _x - --- | Coordinate with at least two dimensions where the x and y coordinates can be --- retreived numerically. -class HasX t => HasY t where - y_ :: RealFloat n => Lens' (t n) n - y_ = xy_ . _y - - xy_ :: RealFloat n => Lens' (t n) (V2 n) - -instance HasY v => HasY (Point v) where - xy_ = lensP . xy_ - -instance HasY V2 where xy_ = id -instance HasY V3 where xy_ = _xy -instance HasY Polar where xy_ = polarV2 - From b53a17154eac6640906044f202d393201ec83a4e Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Thu, 11 Sep 2014 22:02:09 +0000 Subject: [PATCH 42/58] add missing comma in .cabal --- diagrams-lib.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 39d2e3c5..0f90f264 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -111,7 +111,7 @@ Library hashable >= 1.1 && < 1.3, linear >= 1.10 && < 2.0, adjunctions >= 4.0 && < 5.0, - distributive >=0.2.2 && < 1.0 + distributive >=0.2.2 && < 1.0, process >= 1.1 && < 1.3, fsnotify >= 0.1 && < 0.2, directory >= 1.2 && < 1.3, From 3437160a3fc56308ee9fd45498b1e39864e79d11 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Thu, 11 Sep 2014 22:43:54 +0000 Subject: [PATCH 43/58] linear updates for more recent code in master --- src/Diagrams/Backend/CmdLine.hs | 2 +- src/Diagrams/Combinators.hs | 2 -- src/Diagrams/TwoD/Arrow.hs | 20 ++++++++++---------- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index 11e81cae..6ddf075e 100644 --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -548,7 +548,7 @@ defaultAnimMainRender :: (opts -> Diagram b v n -> IO ()) -> (Lens' opts FilePath) -- ^ A lens into the output path. -> (opts ,DiagramAnimOpts) - -> Animation b v + -> Animation b v n -> IO () defaultAnimMainRender renderF out (opts,animOpts) anim = do let diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index a8dc3981..2cdaa47c 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -44,8 +44,6 @@ import Data.Typeable import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, (%~), (&), (.~), (^.), _Wrapping) -import Data.AdditiveGroup --- import Data.AffineSpace ((.+^)) import Data.Default.Class import Data.Monoid.Deletable (toDeletable) import Data.Monoid.MList (inj) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 9529b93d..bea4621b 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -75,7 +75,7 @@ module Diagrams.TwoD.Arrow , arrow , arrow' - + , arrowFromLocatedTrail , arrowFromLocatedTrail' @@ -112,6 +112,7 @@ import Data.Functor ((<$>)) import Data.Maybe (fromMaybe) import Data.Monoid.Coproduct (untangle) import Data.Semigroup +import Data.Data import Data.Colour hiding (atop) import Diagrams.Core @@ -502,19 +503,19 @@ arrowV' => ArrowOpts n -> V2 n -> Diagram b V2 n arrowV' opts = arrowAt' opts origin --- | Turn a located trail into a default arrow by putting an +-- | Turn a located trail into a default arrow by putting an -- arrowhead at the end of the trail. -arrowFromLocatedTrail - :: Renderable (Path R2) b - => Located (Trail R2) -> Diagram b R2 +arrowFromLocatedTrail + :: (Renderable (Path V2 n) b, RealFloat n, Data n) + => Located (Trail V2 n) -> Diagram b V2 n arrowFromLocatedTrail = arrowFromLocatedTrail' def -- | Turn a located trail into an arrow using the given options. -arrowFromLocatedTrail' - :: Renderable (Path R2) b - => ArrowOpts -> Located (Trail R2) -> Diagram b R2 +arrowFromLocatedTrail' + :: (Renderable (Path V2 n) b, RealFloat n, Data n) + => ArrowOpts n -> Located (Trail V2 n) -> Diagram b V2 n arrowFromLocatedTrail' opts trail = arrowBetween' opts' start end - where + where opts' = opts & arrowShaft .~ unLoc trail start = atStart trail end = atEnd trail @@ -576,4 +577,3 @@ connectOutside' opts n1 n2 = e' = fromMaybe (location b2) $ traceP midpoint v b2 in atop (arrowBetween' opts s' e') - From fe6f37226bf53e09fc9f57d9c8c2df4cdd7f9eb7 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 14 Sep 2014 19:24:27 +0100 Subject: [PATCH 44/58] Fixes to changes to HasLinearMap and Measure from core. --- src/Diagrams/Animation.hs | 5 ++--- src/Diagrams/Attributes.hs | 2 +- src/Diagrams/BoundingBox.hs | 4 ++-- src/Diagrams/TwoD/Attributes.hs | 17 ++++------------- 4 files changed, 9 insertions(+), 19 deletions(-) diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs index 38711b2b..886020b6 100644 --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -43,7 +43,6 @@ import Diagrams.TrailLike import Diagrams.TwoD.Shapes import Diagrams.TwoD.Types - import Linear.Metric -- | A value of type @QAnimation b v m@ is an animation (a @@ -91,7 +90,7 @@ type Animation b v n = QAnimation b v n Any -- -- See also 'animRect' for help constructing a background to go -- behind an animation. -animEnvelope :: (Backend b v n, OrderedField n, Metric v, Monoid' m) +animEnvelope :: (Backend b v n, OrderedField n, Metric v, HasLinearMap v, Monoid' m) => QAnimation b v n m -> QAnimation b v n m animEnvelope = animEnvelope' 30 @@ -99,7 +98,7 @@ animEnvelope = animEnvelope' 30 -- parameter is the number of samples per time unit to use. Lower -- rates will be faster but less accurate; higher rates are more -- accurate but slower. -animEnvelope' :: (Backend b v n, OrderedField n, Metric v, Monoid' m) +animEnvelope' :: (Backend b v n, OrderedField n, Metric v, HasLinearMap v, Monoid' m) => Rational -> QAnimation b v n m -> QAnimation b v n m animEnvelope' r a = withEnvelope (simulate r a) <$> a diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index fa843c0a..c5ed4a7f 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -158,7 +158,7 @@ newtype LineCapA = LineCapA (Last LineCap) instance AttributeClass LineCapA instance Default LineCap where - def = LineCapButt + def = LineCapButt getLineCap :: LineCapA -> LineCap getLineCap (LineCapA (Last c)) = c diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index 5d668620..5d9fda51 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -148,7 +148,7 @@ fromPoints :: (Additive v, Ord n) => [Point v n] -> BoundingBox v n fromPoints = mconcat . map fromPoint -- | Create a bounding box for any enveloped object (such as a diagram or path). -boundingBox :: (Vn a ~ v n, Enveloped a, HasLinearMap v, Num n) +boundingBox :: (Vn a ~ v n, Enveloped a, HasLinearMap v, HasBasis v, Num n) => a -> BoundingBox v n boundingBox a = fromMaybeEmpty $ do env <- (appEnvelope . getEnvelope) a @@ -195,7 +195,7 @@ boxTransform u v = do -- | Transforms an enveloped thing to fit within a @BoundingBox@. If it's -- empty, then the result is also @mempty@. boxFit - :: (Vn a ~ v n, Enveloped a, Transformable a, Monoid a, HasLinearMap v, Num n) + :: (Vn a ~ v n, Enveloped a, Transformable a, Monoid a, HasLinearMap v, HasBasis v, Num n) => BoundingBox (V a) (N a) -> a -> a boxFit b x = maybe mempty (`transform` x) $ boxTransform (boundingBox x) b diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 8e695bd2..fc010e8d 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -122,10 +121,9 @@ huge = Normalized 0.10 -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. newtype LineWidth n = LineWidth (Last (Measure n)) - deriving (Typeable, Semigroup, Functor) + deriving (Data, Typeable, Semigroup) -deriving instance (Data n) => Data (LineWidth n) -instance (Typeable n) => AttributeClass (LineWidth n) +instance (Typeable n) => AttributeClass (LineWidth n) type instance V (LineWidth n) = V2 type instance N (LineWidth n) = n @@ -173,16 +171,10 @@ lwL w = lineWidth (Local w) -- | Create lines that are dashing... er, dashed. data Dashing n = Dashing [Measure n] (Measure n) - deriving (Typeable, Functor) - -deriving instance Data n => Data (Dashing n) -deriving instance Eq n => Eq (Dashing n) + deriving (Data, Typeable) newtype DashingA n = DashingA (Last (Dashing n)) - deriving (Typeable, Semigroup, Functor) - -deriving instance Data n => Data (DashingA n) -deriving instance Eq n => Eq (DashingA n) + deriving (Data, Typeable, Semigroup) instance Typeable n => AttributeClass (DashingA n) @@ -227,7 +219,6 @@ dashingL w v = dashing (map Local w) (Local v) data GradientStop d = GradientStop { _stopColor :: SomeColor , _stopFraction :: d} - deriving Functor makeLensesWith (lensRules & generateSignatures .~ False) ''GradientStop From 0e3afee3635e33624d0be81ee43527a808016afd Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 14 Sep 2014 19:34:47 +0100 Subject: [PATCH 45/58] Some fixes to Angle and BoundingBox. --- src/Diagrams/Align.hs | 1 + src/Diagrams/Angle.hs | 12 ++++++------ src/Diagrams/BoundingBox.hs | 7 +------ 3 files changed, 8 insertions(+), 12 deletions(-) diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs index 65814f90..eb734ce8 100644 --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -76,6 +76,7 @@ alignBy'Default boundary v d a = moveOriginTo (lerp ((d + 1) / 2) (boundary v a) (boundary (negated v) a) ) a +{-# ANN alignBy'Default ("HLint: ignore Use camelCase" :: String) #-} -- | Some standard functions which can be used as the `boundary` argument to diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 77cc75d9..fa3fb42f 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -94,7 +94,7 @@ deg = iso (\(Radians r) -> r / (2*pi/360)) (Radians . ( * (2*pi/360))) fullTurn :: Floating v => Angle v fullTurn = 1 @@ turn --- | An angle representing a half. +-- | An angle representing a half turn. halfTurn :: Floating v => Angle v halfTurn = 0.5 @@ turn @@ -130,8 +130,8 @@ acosA = Radians . acos atanA :: Floating n => n -> Angle n atanA = Radians . atan --- | @atan2A n d@ is the @Angle with tangent @n/d@, unless d is 0, in --- which case it is ±π/2. +-- | @atan2A y x@ is the angle between the positive x-axis and the vector given +-- by the coordinates (x, y). The 'Angle' returned is in the [-pi,pi] range. atan2A :: RealFloat n => n -> n -> Angle n atan2A y x = Radians $ atan2 y x @@ -146,12 +146,12 @@ a @@ i = review i a infixl 5 @@ --- | compute the positive angle between the two vectors in their common plane --- | N.B.: currently discards the common plane information +-- | Compute the positive angle between the two vectors in their common plane. angleBetween :: (Metric v, Floating n) => v n -> v n -> Angle n angleBetween v1 v2 = acos (signorm v1 `dot` signorm v2) @@ rad +-- N.B.: Currently discards the common plane information. --- | Normalize an angle so that is lies in the [0,tau) range. +-- | Normalize an angle so that it lies in the [0,tau) range. -- normalizeAngle :: (Floating n, Real n) => Angle n -> Angle n -- normalizeAngle = over rad (`mod'` (2 * pi)) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index 5d9fda51..d3e9a71b 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -171,10 +171,6 @@ getAllCorners (BoundingBox (Option Nothing)) = [] getAllCorners (BoundingBox (Option (Just (NonEmptyBoundingBox (l, u))))) = T.sequence (liftI2 (\a b -> [a,b]) l u) --- --- allCorners :: (Additive v, Traversable v, Num n) => BoundingBox v n -> Maybe [Point v n] --- allCorners = fmap (\(l,u) -> T.sequence (liftI2 (\a b -> [a,b]) l u)) . getCorners - -- | Get the size of the bounding box - the vector from the (component-wise) -- lesser point to the greater point. boxExtents :: (Additive v, Num n) => BoundingBox v n -> v n @@ -190,13 +186,12 @@ boxTransform u v = do let i = s (v, u) <-> s (u, v) s = liftU2 (*) . uncurry (liftU2 (/)) . mapT boxExtents return $ Transformation i i (vl ^-^ s (v, u) ul) - -- NOTE: Need to check this one -- | Transforms an enveloped thing to fit within a @BoundingBox@. If it's -- empty, then the result is also @mempty@. boxFit :: (Vn a ~ v n, Enveloped a, Transformable a, Monoid a, HasLinearMap v, HasBasis v, Num n) - => BoundingBox (V a) (N a) -> a -> a + => BoundingBox v n -> a -> a boxFit b x = maybe mempty (`transform` x) $ boxTransform (boundingBox x) b -- | Check whether a point is contained in a bounding box (including its edges). From 5a3aacedb5ca46c0eb15de88c9876c42f17cfcc0 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 14 Sep 2014 19:56:27 +0100 Subject: [PATCH 46/58] Remove Data instance for BoundingBox. --- src/Diagrams/BoundingBox.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index d3e9a71b..c3ea4090 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -65,7 +65,7 @@ import Linear.Vector -- Unexported utility newtype newtype NonEmptyBoundingBox v n = NonEmptyBoundingBox (Point v n, Point v n) - deriving (Eq, Data, Typeable, Functor) + deriving (Eq, Typeable, Functor) type instance V (NonEmptyBoundingBox v n) = v type instance N (NonEmptyBoundingBox v n) = n @@ -87,7 +87,7 @@ instance (Additive v, Ord n) => Semigroup (NonEmptyBoundingBox v n) where -- indicating its \"lower\" and \"upper\" corners. It can also represent -- an empty bounding box - the points are wrapped in @Maybe@. newtype BoundingBox v n = BoundingBox (Option (NonEmptyBoundingBox v n)) - deriving (Eq, Data, Typeable, Functor) + deriving (Eq, Typeable, Functor) deriving instance (Additive v, Ord n) => Semigroup (BoundingBox v n) deriving instance (Additive v, Ord n) => Monoid (BoundingBox v n) From df659a45fa7ebd1b9b2b01534d17795d73febfd5 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 14 Sep 2014 20:33:49 +0100 Subject: [PATCH 47/58] Remove redundent import. --- src/Diagrams/BoundingBox.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index c3ea4090..2ae2481e 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -42,10 +42,10 @@ module Diagrams.BoundingBox , union, intersection ) where -import Data.Data (Data, Typeable) import Data.Foldable as F import Data.Maybe (fromMaybe) import Data.Semigroup +import Data.Typeable (Typeable) import Diagrams.Core import Diagrams.Core.Transform From db94ac4e7a6fc224bb40311de70199371e244cba Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 15 Sep 2014 16:41:21 +0100 Subject: [PATCH 48/58] First attempt at fixes for 7.6. --- src/Diagrams/Align.hs | 36 +++++++++---------- src/Diagrams/Animation.hs | 4 +-- src/Diagrams/Attributes.hs | 2 +- src/Diagrams/BoundingBox.hs | 9 +++-- src/Diagrams/Combinators.hs | 16 ++++----- src/Diagrams/CubicSpline.hs | 2 +- src/Diagrams/Deform.hs | 2 +- src/Diagrams/Path.hs | 18 ++++++++-- src/Diagrams/ThreeD/Transform.hs | 8 ++--- src/Diagrams/TrailLike.hs | 6 ++-- src/Diagrams/Transform.hs | 2 +- src/Diagrams/TwoD/Align.hs | 40 ++++++++++----------- src/Diagrams/TwoD/Arc.hs | 10 +++--- src/Diagrams/TwoD/Arrow.hs | 2 +- src/Diagrams/TwoD/Attributes.hs | 48 ++++++++++++------------- src/Diagrams/TwoD/Combinators.hs | 20 +++++------ src/Diagrams/TwoD/Ellipse.hs | 8 ++--- src/Diagrams/TwoD/Offset.hs | 6 ++-- src/Diagrams/TwoD/Path.hs | 2 +- src/Diagrams/TwoD/Polygons.hs | 2 +- src/Diagrams/TwoD/Shapes.hs | 38 ++++++++++---------- src/Diagrams/TwoD/Size.hs | 18 +++++----- src/Diagrams/TwoD/Text.hs | 12 +++---- src/Diagrams/TwoD/Transform.hs | 32 ++++++++--------- src/Diagrams/TwoD/Transform/ScaleInv.hs | 10 +++--- 25 files changed, 183 insertions(+), 170 deletions(-) diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs index eb734ce8..98d842f9 100644 --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -58,19 +58,19 @@ class Alignable a where -- edge of the boundary in the direction of the negation of @v@. -- Other values of @d@ interpolate linearly (so for example, @d = -- 0@ centers the origin along the direction of @v@). - alignBy' :: (Vn a ~ v n, HasOrigin a, Additive v, Fractional n) + alignBy' :: (V a ~ v, N a ~ n, HasOrigin a, Additive v, Fractional n) => (v n -> a -> Point v n) -> v n -> n -> a -> a alignBy' = alignBy'Default - defaultBoundary :: Vn a ~ v n => v n -> a -> Point v n + defaultBoundary :: (V a ~ v, N a ~ n) => v n -> a -> Point v n - alignBy :: (Vn a ~ v n, Additive v, HasOrigin a, Fractional n) + alignBy :: (V a ~ v, N a ~ n, Additive v, HasOrigin a, Fractional n) => v n -> n -> a -> a alignBy = alignBy' defaultBoundary -- | Default implementation of 'alignBy' for types with 'HasOrigin' -- and 'AdditiveGroup' instances. -alignBy'Default :: (Vn a ~ v n, HasOrigin a, Additive v, Fractional n) +alignBy'Default :: (V a ~ v, N a ~ n, HasOrigin a, Additive v, Fractional n) => (v n -> a -> Point v n) -> v n -> n -> a -> a alignBy'Default boundary v d a = moveOriginTo (lerp ((d + 1) / 2) (boundary v a) @@ -81,14 +81,14 @@ alignBy'Default boundary v d a = moveOriginTo (lerp ((d + 1) / 2) -- | Some standard functions which can be used as the `boundary` argument to -- `alignBy'`. -envelopeBoundary :: (Vn a ~ v n, Enveloped a) => v n -> a -> Point v n +envelopeBoundary :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Point v n envelopeBoundary = envelopeP -traceBoundary :: (Vn a ~ v n, Num n, Traced a) => v n -> a -> Point v n +traceBoundary :: (V a ~ v, N a ~ n, Num n, Traced a) => v n -> a -> Point v n traceBoundary v a = fromMaybe origin (maxTraceP origin v a) combineBoundaries - :: (Vn a ~ v n, F.Foldable f, Metric v, Ord n, Num n) + :: (V a ~ v, N a ~ n, F.Foldable f, Metric v, Ord n, Num n) => (v n -> a -> Point v n) -> v n -> f a -> Point v n combineBoundaries b v fa = b v $ F.maximumBy (comparing (quadrance . (.-. origin) . b v)) fa @@ -99,14 +99,14 @@ instance (Metric v, OrderedField n) => Alignable (Envelope v n) where instance (Metric v, OrderedField n) => Alignable (Trace v n) where defaultBoundary = traceBoundary -instance (Vn b ~ v n, Metric v, OrderedField n, Alignable b) => Alignable [b] where +instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) => Alignable [b] where defaultBoundary = combineBoundaries defaultBoundary -instance (Vn b ~ v n, Metric v, OrderedField n, Alignable b) +instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) => Alignable (S.Set b) where defaultBoundary = combineBoundaries defaultBoundary -instance (Vn b ~ v n, Metric v, OrderedField n, Alignable b) +instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) => Alignable (M.Map k b) where defaultBoundary = combineBoundaries defaultBoundary @@ -119,7 +119,7 @@ instance (HasLinearMap v, Metric v, OrderedField n, Monoid' m) -- 'defaultBoundary'. Instead, we provide a total method, but one that -- is not sensible. This should not present a serious problem as long -- as your use of 'Alignable' happens through 'alignBy'. -instance (Vn a ~ v n, Additive v, Num n, HasOrigin a, Alignable a) => Alignable (b -> a) where +instance (V a ~ v, N a ~ n, Additive v, Num n, HasOrigin a, Alignable a) => Alignable (b -> a) where alignBy v d f b = alignBy v d (f b) defaultBoundary _ _ = origin @@ -128,38 +128,38 @@ instance (Vn a ~ v n, Additive v, Num n, HasOrigin a, Alignable a) => Alignable -- direction of @v@ until it is on the edge of the envelope. (Note -- that if the local origin is outside the envelope to begin with, -- it may have to move \"backwards\".) -align :: (Vn a ~ v n, Additive v, Alignable a, HasOrigin a, Fractional n) => v n -> a -> a +align :: (V a ~ v, N a ~ n, Additive v, Alignable a, HasOrigin a, Fractional n) => v n -> a -> a align v = alignBy v 1 -- | Version of @alignBy@ specialized to use @traceBoundary@ -snugBy :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, Fractional n) +snugBy :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, Fractional n) => v n -> n -> a -> a snugBy = alignBy' traceBoundary -- | Like align but uses trace. -snug :: (Vn a ~ v n, Fractional n, Alignable a, Traced a, HasOrigin a) +snug :: (V a ~ v, N a ~ n, Fractional n, Alignable a, Traced a, HasOrigin a) => v n -> a -> a snug v = snugBy v 1 -- | @centerV v@ centers an enveloped object along the direction of -- @v@. -centerV :: (Vn a ~ v n, Additive v, Alignable a, HasOrigin a, Fractional n) => v n -> a -> a +centerV :: (V a ~ v, N a ~ n, Additive v, Alignable a, HasOrigin a, Fractional n) => v n -> a -> a centerV v = alignBy v 0 -- | @center@ centers an enveloped object along all of its basis vectors. -center :: (Vn a ~ v n, HasLinearMap v, Alignable a, HasOrigin a, Fractional n) => a -> a +center :: (V a ~ v, N a ~ n, HasLinearMap v, Alignable a, HasOrigin a, Fractional n) => a -> a center = applyAll fs where fs = map centerV basis -- | Like @centerV@ using trace. snugCenterV - :: (Vn a ~ v n, Fractional n, Alignable a, Traced a, HasOrigin a) + :: (V a ~ v, N a ~ n, Fractional n, Alignable a, Traced a, HasOrigin a) => v n -> a -> a snugCenterV v = alignBy' traceBoundary v 0 -- | Like @center@ using trace. -snugCenter :: (Vn a ~ v n, HasLinearMap v, Alignable a, HasOrigin a, Fractional n, Traced a) +snugCenter :: (V a ~ v, N a ~ n, HasLinearMap v, Alignable a, HasOrigin a, Fractional n, Traced a) => a -> a snugCenter = applyAll fs where diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs index 886020b6..6bd1d54c 100644 --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -109,7 +109,7 @@ animEnvelope' r a = withEnvelope (simulate r a) <$> a -- -- Uses 30 samples per time unit by default; to adjust this number -- see 'animRect''. -animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, Vn t ~ V2 n, RealFloat n, Monoid' m) +animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ V2, N t ~ n, RealFloat n, Monoid' m) => QAnimation b V2 n m -> t animRect = animRect' 30 @@ -117,7 +117,7 @@ animRect = animRect' 30 -- parameter is the number of samples per time unit to use. Lower -- rates will be faster but less accurate; higher rates are more -- accurate but slower. -animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, Vn t ~ V2 n, RealFloat n, Monoid' m) +animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ V2, N t ~ n, RealFloat n, Monoid' m) => Rational -> QAnimation b V2 n m -> t animRect' r anim | null results = rect 1 1 diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index c5ed4a7f..46ae840f 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -173,7 +173,7 @@ data LineJoin = LineJoinMiter -- ^ Use a \"miter\" shape (whatever that is). | LineJoinBevel -- ^ Use a \"bevel\" shape (whatever -- that is). Are these... -- carpentry terms? - deriving (Eq,Show,Typeable) + deriving (Eq, Show, Typeable) newtype LineJoinA = LineJoinA (Last LineJoin) deriving (Typeable, Semigroup, Eq) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index 2ae2481e..c5fa54cf 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -45,7 +45,6 @@ module Diagrams.BoundingBox import Data.Foldable as F import Data.Maybe (fromMaybe) import Data.Semigroup -import Data.Typeable (Typeable) import Diagrams.Core import Diagrams.Core.Transform @@ -65,7 +64,7 @@ import Linear.Vector -- Unexported utility newtype newtype NonEmptyBoundingBox v n = NonEmptyBoundingBox (Point v n, Point v n) - deriving (Eq, Typeable, Functor) + deriving (Eq, Functor) type instance V (NonEmptyBoundingBox v n) = v type instance N (NonEmptyBoundingBox v n) = n @@ -87,7 +86,7 @@ instance (Additive v, Ord n) => Semigroup (NonEmptyBoundingBox v n) where -- indicating its \"lower\" and \"upper\" corners. It can also represent -- an empty bounding box - the points are wrapped in @Maybe@. newtype BoundingBox v n = BoundingBox (Option (NonEmptyBoundingBox v n)) - deriving (Eq, Typeable, Functor) + deriving (Eq, Functor) deriving instance (Additive v, Ord n) => Semigroup (BoundingBox v n) deriving instance (Additive v, Ord n) => Monoid (BoundingBox v n) @@ -148,7 +147,7 @@ fromPoints :: (Additive v, Ord n) => [Point v n] -> BoundingBox v n fromPoints = mconcat . map fromPoint -- | Create a bounding box for any enveloped object (such as a diagram or path). -boundingBox :: (Vn a ~ v n, Enveloped a, HasLinearMap v, HasBasis v, Num n) +boundingBox :: (V a ~ v, N a ~ n, Enveloped a, HasLinearMap v, HasBasis v, Num n) => a -> BoundingBox v n boundingBox a = fromMaybeEmpty $ do env <- (appEnvelope . getEnvelope) a @@ -190,7 +189,7 @@ boxTransform u v = do -- | Transforms an enveloped thing to fit within a @BoundingBox@. If it's -- empty, then the result is also @mempty@. boxFit - :: (Vn a ~ v n, Enveloped a, Transformable a, Monoid a, HasLinearMap v, HasBasis v, Num n) + :: (V a ~ v, N a ~ n, Enveloped a, Transformable a, Monoid a, HasLinearMap v, HasBasis v, Num n) => BoundingBox v n -> a -> a boxFit b x = maybe mempty (`transform` x) $ boxTransform (boundingBox x) b diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 2cdaa47c..5988573c 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -80,19 +80,19 @@ import Linear.Vector -- > ) -- > c = circle 0.8 -- > withEnvelopeEx = sqNewEnv # centerXY # pad 1.5 -withEnvelope :: (Vn a ~ v n, HasLinearMap v, Enveloped a, Monoid' m) +withEnvelope :: (V a ~ v, N a ~ n, HasLinearMap v, Enveloped a, Monoid' m) => a -> QDiagram b v n m -> QDiagram b v n m withEnvelope = setEnvelope . getEnvelope -- | Use the trace from some object as the trace for a diagram, in -- place of the diagram's default trace. -withTrace :: (Vn a ~ v n, HasLinearMap v, Traced a, OrderedField n, Metric v, Monoid' m) +withTrace :: (V a ~ v, N a ~ n, HasLinearMap v, Traced a, OrderedField n, Metric v, Monoid' m) => a -> QDiagram b v n m -> QDiagram b v n m withTrace = setTrace . getTrace -- | @phantom x@ produces a \"phantom\" diagram, which has the same -- envelope and trace as @x@ but produces no output. -phantom :: (Enveloped a, Traced a, Vn a ~ v n, Monoid' m) => a -> QDiagram b v n m +phantom :: (Enveloped a, Traced a, V a ~ v, N a ~ n, Monoid' m) => a -> QDiagram b v n m phantom a = QD $ D.leafU ((inj . toDeletable . getEnvelope $ a) <> (inj . toDeletable . getTrace $ a)) -- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of @@ -233,7 +233,7 @@ beside v d1 d2 = d1 <> juxtapose v d1 d2 -- from the first. The local origin of the resulting combined -- diagram is the same as the local origin of the first. See the -- documentation of 'beside' for more information. -atDirection :: (Juxtaposable a, Semigroup a, Vn a ~ v n, Metric v, Floating n) +atDirection :: (Juxtaposable a, Semigroup a, V a ~ v, N a ~ n, Metric v, Floating n) => Direction v n -> a -> a -> a atDirection = beside . fromDirection @@ -263,12 +263,12 @@ appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps) -- > positionEx = position (zip (map mkPoint [-3, -2.8 .. 3]) (repeat dot)) -- > where dot = circle 0.2 # fc black -- > mkPoint x = p2 (x,x^2) -position :: (Vn a ~ v n, Additive v, Num n, HasOrigin a, Monoid' a) => [(Point v n, a)] -> a +position :: (V a ~ v, N a ~ n, Additive v, Num n, HasOrigin a, Monoid' a) => [(Point v n, a)] -> a position = mconcat . map (uncurry moveTo) -- | Curried version of @position@, takes a list of points and a list of -- objects. -atPoints :: (Vn a ~ v n, Additive v, Num n, HasOrigin a, Monoid' a) => [Point v n] -> [a] -> a +atPoints :: (V a ~ v, N a ~ n, Additive v, Num n, HasOrigin a, Monoid' a) => [Point v n] -> [a] -> a atPoints ps as = position $ zip ps as -- | Methods for concatenating diagrams. @@ -330,7 +330,7 @@ instance Num n => Default (CatOpts n) where -- -- See also 'cat'', which takes an extra options record allowing -- certain aspects of the operation to be tweaked. -cat :: (Juxtaposable a, Monoid' a, HasOrigin a , Vn a ~ v n, Metric v, OrderedField n) +cat :: (Juxtaposable a, Monoid' a, HasOrigin a , V a ~ v, N a ~ n, Metric v, OrderedField n) => v n -> [a] -> a cat v = cat' v def @@ -351,7 +351,7 @@ cat v = cat' v def -- Note that @cat' v (with & catMethod .~ Distrib) === mconcat@ -- (distributing with a separation of 0 is the same as -- superimposing). -cat' :: ( Juxtaposable a, Monoid' a, HasOrigin a, Vn a ~ v n, Metric v, OrderedField n) +cat' :: ( Juxtaposable a, Monoid' a, HasOrigin a, V a ~ v, N a ~ n, Metric v, OrderedField n) => v n -> CatOpts n -> [a] -> a cat' v (CatOpts { _catMethod = Cat, _sep = s }) = foldB comb mempty where comb d1 d2 = d1 <> (juxtapose v d1 d2 # moveOriginBy vs) diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs index 14bb56fa..ddbe506d 100644 --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -49,7 +49,7 @@ import Linear.Metric -- > # centerXY # pad 1.1 -- -- For more information, see . -cubicSpline :: (Vn t ~ v n, TrailLike t, Fractional (v n)) => Bool -> [Point v n] -> t +cubicSpline :: (V t ~ v, N t ~ n, TrailLike t, Fractional (v n)) => Bool -> [Point v n] -> t cubicSpline closed [] = trailLike . closeIf closed $ emptyLine `at` origin cubicSpline closed ps = flattenBeziers . map f . solveCubicSplineCoefficients closed . map (view lensP) $ ps where diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs index 74fe210b..446eceb7 100644 --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -47,7 +47,7 @@ class Deformable a where -- | @deform' epsilon d a@ transforms @a@ by the deformation @d@. -- If the type of @a@ is not closed under projection, approximate -- to accuracy @epsilon@. - deform' :: Vn a ~ v n => n -> Deformation v n -> a -> a + deform' :: (V a ~ v, N a ~ n) => n -> Deformation v n -> a -> a -- | @deform d a@ transforms @a@ by the deformation @d@. -- If the type of @a@ is not closed under projection, @deform@ diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index e8f2c901..7654fb70 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -88,7 +89,20 @@ import Linear.Vector -- and they form a monoid under /superposition/ (placing one path on -- top of another) rather than concatenation. newtype Path v n = Path [Located (Trail v n)] - deriving (Semigroup, Monoid, Typeable) + deriving (Semigroup, Monoid +#if __GLASGOW_HASKELL__ >= 707 + , Typeable +#endif + ) + +#if __GLASGOW_HASKELL__ < 707 +instance Typeable2 Path where + typeOf2 _ = mkTyConApp pathTyCon [] + +pathTyCon :: TyCon +pathTyCon = mkTyCon3 "diagrams-lib" "Diagrams.Path" "Path" +#endif + instance Wrapped (Path v n) where type Unwrapped (Path v n) = [Located (Trail v n)] @@ -187,7 +201,7 @@ fixPath = map fixTrail . op Path -- | \"Explode\" a path by exploding every component trail (see -- 'explodeTrail'). -explodePath :: (Vn t ~ v n, Additive v, TrailLike t) => Path v n -> [[t]] +explodePath :: (V t ~ v, N t ~ n, Additive v, TrailLike t) => Path v n -> [[t]] explodePath = map explodeTrail . op Path -- | Partition a path into two paths based on a predicate on trails: diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index c8ebc0a3..ebc04c9e 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -161,7 +161,7 @@ scalingZ c = fromSymmetric s -- | Scale a diagram by the given factor in the z direction. To scale -- uniformly, use 'scale'. -scaleZ :: (Vn t ~ v n, R3 v, Additive v, Transformable t, Floating n) => n -> t -> t +scaleZ :: (V t ~ v, N t ~ n, R3 v, Additive v, Transformable t, Floating n) => n -> t -> t scaleZ = transform . scalingZ -- Translation ---------------------------------------- @@ -173,7 +173,7 @@ translationZ z = translation (zero & _z .~ z) -- | Translate a diagram by the given distance in the y -- direction. -translateZ :: (Vn t ~ v n, R3 v, Transformable t, Additive v, Floating n) => n -> t -> t +translateZ :: (V t ~ v, N t ~ n, R3 v, Transformable t, Additive v, Floating n) => n -> t -> t translateZ = transform . translationZ -- Reflection ---------------------------------------------- @@ -185,7 +185,7 @@ reflectionZ = scalingZ (-1) -- | Flip a diagram across z=0, i.e. send the point (x,y,z) to -- (x,y,-z). -reflectZ :: (Vn t ~ v n, R3 v, Transformable t, Additive v, Floating n) => t -> t +reflectZ :: (V t ~ v, N t ~ n, R3 v, Transformable t, Additive v, Floating n) => t -> t reflectZ = transform reflectionZ -- | @reflectionAcross p v@ is a reflection across the plane through @@ -201,7 +201,7 @@ reflectionAcross p v = -- | @reflectAcross p v@ reflects a diagram across the plane though -- the point @p@ and the vector @v@. -reflectAcross :: (Vn t ~ v n, R3 v, HasLinearMap v, Metric v, Fractional n, Transformable t) +reflectAcross :: (V t ~ v, N t ~ n, R3 v, HasLinearMap v, Metric v, Fractional n, Transformable t) => Point v n -> v n -> t -> t reflectAcross p v = transform (reflectionAcross p v) diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs index 778faa22..abcc92df 100644 --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -145,7 +145,7 @@ fromOffsets = trailLike . (`at` origin) . trailFromOffsets -- | Construct a trail-like thing of linear segments from a located -- list of offsets. -fromLocOffsets :: (Vn (Vn t) ~ Vn t, TrailLike t) => Located [Vn t] -> t +fromLocOffsets :: (V t ~ v, N t ~ n, V (v n) ~ v, N (v n) ~ n, TrailLike t) => Located [v n] -> t fromLocOffsets = trailLike . mapLoc trailFromOffsets -- | Construct a trail-like thing connecting the given vertices with @@ -183,7 +183,7 @@ segmentsFromVertices vvs@(_:vs) = map straight (zipWith (flip (.-.)) vvs vs) -- > twiddleEx -- > = mconcat ((~~) <$> hexagon 1 <*> hexagon 1) -- > # centerXY # pad 1.1 -(~~) :: (Vn t ~ v n, TrailLike t) => Point v n -> Point v n -> t +(~~) :: (V t ~ v, N t ~ n, TrailLike t) => Point v n -> Point v n -> t p1 ~~ p2 = fromVertices [p1, p2] -- | Given a concretely located trail, \"explode\" it by turning each @@ -197,7 +197,7 @@ p1 ~~ p2 = fromVertices [p1, p2] -- > # explodeTrail -- generate a list of diagrams -- > # zipWith lc [orange, green, yellow, red, blue] -- > # mconcat # centerXY # pad 1.1 -explodeTrail :: (Vn t ~ v n, Additive v, TrailLike t) => Located (Trail v n) -> [t] +explodeTrail :: (V t ~ v, N t ~ n, Additive v, TrailLike t) => Located (Trail v n) -> [t] explodeTrail = map (mkTrail . fromFixedSeg) . fixTrail where mkTrail = trailLike . mapLoc (trailFromSegments . (:[])) diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs index 206e477c..d538514e 100644 --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -55,6 +55,6 @@ conjugate t1 t2 = inv t1 <> t2 <> t1 -- @ -- -- for all transformations @t1@ and @t2@. -under :: (Transformable a, Transformable b, Vn a ~ Vn b, Vn a ~ v n, Num n, Functor v) +under :: (Transformable a, Transformable b, V a ~ V b, N a ~ N b, V a ~ v, N a ~ n, Num n, Functor v) => (a -> b) -> Transformation v n -> a -> b f `under` t = transform (inv t) . f . transform t diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs index 5aeef771..76205c71 100644 --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -50,46 +50,46 @@ import Linear.Vector -- | Align along the left edge, i.e. translate the diagram in a -- horizontal direction so that the local origin is on the left edge -- of the envelope. -alignL :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +alignL :: (Alignable a, HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a alignL = align unit_X snugL :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a + HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a snugL = snug unit_X -- | Align along the right edge. -alignR :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +alignR :: (Alignable a, HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a alignR = align unitX snugR :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a + HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a snugR = snug unitX -- | Align along the top edge. -alignT :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +alignT :: (Alignable a, HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a alignT = align unitY snugT:: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a + HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a snugT = snug unitY -- | Align along the bottom edge. -alignB :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +alignB :: (Alignable a, HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a alignB = align unit_Y snugB :: (Fractional n, Alignable a, Traced a, - HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a + HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a snugB = snug unit_Y -alignTL, alignTR, alignBL, alignBR :: (Alignable a, HasOrigin a, Vn a ~ V2 n, Floating n) => a -> a +alignTL, alignTR, alignBL, alignBR :: (Alignable a, HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a alignTL = alignT . alignL alignTR = alignT . alignR alignBL = alignB . alignL alignBR = alignB . alignR snugTL, snugTR, snugBL, snugBR - :: (Fractional n, Alignable a, Traced a, HasOrigin a, Vn a ~ V2 n, Floating n) + :: (Fractional n, Alignable a, Traced a, HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a snugTL = snugT . snugL snugTR = snugT . snugR @@ -108,52 +108,52 @@ snugBR = snugB . snugR -- -- * @snugX@ works the same way. -alignX :: (Vn a ~ v n, Alignable a, HasOrigin a, +alignX :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R1 v, Additive v, Fractional n) => n -> a -> a alignX = alignBy unitX -- | See the documentation for 'alignX'. -snugX :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugX :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R1 v, Additive v, Fractional n) => n -> a -> a snugX = snugBy unitX -- | Like 'alignX', but moving the local origin vertically, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignY :: (Vn a ~ v n, Alignable a, HasOrigin a, +alignY :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R2 v, Additive v, Fractional n) => n -> a -> a alignY = alignBy unitY -- | See the documentation for 'alignY'. -snugY :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugY :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R2 v, Additive v, Fractional n) => n -> a -> a snugY = snugBy unitY -- | Center the local origin along the X-axis. -centerX :: (Vn a ~ v n, Alignable a, HasOrigin a, +centerX :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R1 v, Additive v, Fractional n) => a -> a centerX = alignBy unitX 0 -snugCenterX :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugCenterX :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R1 v, Additive v, Fractional n) => a -> a snugCenterX = snugBy unitX 0 -- | Center the local origin along the Y-axis. -centerY :: (Vn a ~ v n, Alignable a, HasOrigin a, +centerY :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R2 v, Additive v, Fractional n) => a -> a centerY = alignBy unitY 0 -snugCenterY :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugCenterY :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R2 v, Additive v, Fractional n) => a -> a snugCenterY = snugBy unitY 0 -- | Center along both the X- and Y-axes. -centerXY :: (Vn a ~ v n, Alignable a, HasOrigin a, +centerXY :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R2 v, Additive v, Fractional n) => a -> a centerXY = centerX . centerY -snugCenterXY :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugCenterXY :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R2 v, Additive v, Fractional n) => a -> a snugCenterXY = snugCenterX . snugCenterY diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index df9c42d4..8210734b 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -103,7 +103,7 @@ arcT start sweep = trailFromSegments bs -- path of a radius one arc starting at @d@ and sweeping out the angle -- @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. -arc :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => Direction V2 n -> Angle n -> t +arc :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => Direction V2 n -> Angle n -> t arc start sweep = trailLike $ arcT start sweep `at` rotate (start ^. _theta) (p2 (1,0)) -- | Given a radus @r@, a start direction @d@ and an angle @s@, @@ -115,7 +115,7 @@ arc start sweep = trailLike $ arcT start sweep `at` rotate (start ^. _theta) (p2 -- -- > arc'Ex = mconcat [ arc' r (0 @@ turn) (1/4 @@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 -arc' :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> Direction V2 n -> Angle n -> t +arc' :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> Direction V2 n -> Angle n -> t arc' r start sweep = trailLike $ scale (abs r) ts `at` rotate (start ^. _theta) (p2 (abs r,0)) where ts = arcT start sweep @@ -131,7 +131,7 @@ arc' r start sweep = trailLike $ scale (abs r) ts `at` rotate (start ^. _theta) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -wedge :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> Direction V2 n -> Angle n -> t +wedge :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> Direction V2 n -> Angle n -> t wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine $ fromOffsets [r *^ fromDirection d] <> arc d s # scale r @@ -148,7 +148,7 @@ wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine -- > arcBetweenEx = mconcat -- > [ arcBetween origin (p2 (2,1)) ht | ht <- [-0.2, -0.1 .. 0.2] ] -- > # centerXY # pad 1.1 -arcBetween :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => Point V2 n -> Point V2 n -> n -> t +arcBetween :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => Point V2 n -> Point V2 n -> n -> t arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) where h = abs ht @@ -182,7 +182,7 @@ arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -annularWedge :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => +annularWedge :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> n -> Direction V2 n -> Angle n -> t annularWedge r1' r2' d1 s = trailLike . (`at` o) . glueTrail . wrapLine $ fromOffsets [(r1' - r2') *^ fromDirection d1] diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index bea4621b..b806de99 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -260,7 +260,7 @@ tailSty opts = fc black (opts^.tailStyle) -- | Calculate the length of the portion of the horizontal line that passes -- through the origin and is inside of p. -xWidth :: Floating n => (Traced t, Vn t ~ V2 n) => t -> n +xWidth :: Floating n => (Traced t, V t ~ V2, N t ~ n) => t -> n xWidth p = a + b where a = fromMaybe 0 (norm <$> traceV origin unitX p) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index fc010e8d..64ef6791 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -138,31 +138,31 @@ getLineWidth :: LineWidth n -> Measure n getLineWidth (LineWidth (Last w)) = w -- | Set the line (stroke) width. -lineWidth :: (Data n, HasStyle a, Vn a ~ V2 n, Floating n) => Measure n -> a -> a +lineWidth :: (Data n, HasStyle a, V a ~ V2, N a ~ n, Floating n) => Measure n -> a -> a lineWidth = applyGTAttr . LineWidth . Last -- | Apply a 'LineWidth' attribute. -lineWidthA :: (Data n, HasStyle a, Vn a ~ V2 n, Floating n) => LineWidth n -> a -> a +lineWidthA :: (Data n, HasStyle a, V a ~ V2, N a ~ n, Floating n) => LineWidth n -> a -> a lineWidthA = applyGTAttr -- | Default for 'lineWidth'. -lw :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => Measure n -> a -> a +lw :: (Data n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => Measure n -> a -> a lw = lineWidth -- | A convenient synonym for 'lineWidth (Global w)'. -lwG :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => n -> a -> a +lwG :: (Data n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => n -> a -> a lwG w = lineWidth (Global w) -- | A convenient synonym for 'lineWidth (Normalized w)'. -lwN :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => n -> a -> a +lwN :: (Data n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => n -> a -> a lwN w = lineWidth (Normalized w) -- | A convenient synonym for 'lineWidth (Output w)'. -lwO :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => n -> a -> a +lwO :: (Data n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => n -> a -> a lwO w = lineWidth (Output w) -- | A convenient sysnonym for 'lineWidth (Local w)'. -lwL :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => n -> a -> a +lwL :: (Data n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => n -> a -> a lwL w = lineWidth (Local w) ----------------------------------------------------------------- @@ -190,7 +190,7 @@ getDashing :: DashingA n -> Dashing n getDashing (DashingA (Last d)) = d -- | Set the line dashing style. -dashing :: (Floating n, Data n, HasStyle a, Vn a ~ V2 n) +dashing :: (Floating n, Data n, HasStyle a, V a ~ V2, N a ~ n) => [Measure n] -- ^ A list specifying alternate lengths of on -- and off portions of the stroke. The empty -- list indicates no dashing. @@ -200,19 +200,19 @@ dashing :: (Floating n, Data n, HasStyle a, Vn a ~ V2 n) dashing ds offs = applyGTAttr (DashingA (Last (Dashing ds offs))) -- | A convenient synonym for 'dashing (Global w)'. -dashingG :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => [n] -> n -> a -> a +dashingG :: (Data n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => [n] -> n -> a -> a dashingG w v = dashing (map Global w) (Global v) -- | A convenient synonym for 'dashing (Normalized w)'. -dashingN :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => [n] -> n -> a -> a +dashingN :: (Data n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => [n] -> n -> a -> a dashingN w v = dashing (map Normalized w) (Normalized v) -- | A convenient synonym for 'dashing (Output w)'. -dashingO :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => [n] -> n -> a -> a +dashingO :: (Data n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => [n] -> n -> a -> a dashingO w v = dashing (map Output w) (Output v) -- | A convenient sysnonym for 'dashing (Local w)'. -dashingL :: (Data n, Floating n, HasStyle a, Vn a ~ V2 n) => [n] -> n -> a -> a +dashingL :: (Data n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => [n] -> n -> a -> a dashingL w v = dashing (map Local w) (Local v) -- | A gradient stop contains a color and fraction (usually between 0 and 1) @@ -401,10 +401,10 @@ instance Default (LineTexture n) where getLineTexture :: LineTexture n -> Texture n getLineTexture (LineTexture (Last t)) = t -lineTexture :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => Texture n -> a -> a +lineTexture :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => Texture n -> a -> a lineTexture = applyTAttr . LineTexture . Last -lineTextureA :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => LineTexture n -> a -> a +lineTextureA :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => LineTexture n -> a -> a lineTextureA = applyTAttr mkLineTexture :: Texture v -> LineTexture v @@ -426,26 +426,26 @@ styleLineTexture = sets modifyLineTexture -- 'AlphaColour'), but this can sometimes create problems for type -- inference, so the 'lc' and 'lcA' variants are provided with more -- concrete types. -lineColor :: (Typeable n, Floating n, Color c, HasStyle a, Vn a ~ V2 n) => c -> a -> a +lineColor :: (Typeable n, Floating n, Color c, HasStyle a, V a ~ V2, N a ~ n) => c -> a -> a lineColor = lineTexture . SC . SomeColor -- | A synonym for 'lineColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). See comment in 'lineColor' about backends. -lc :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => Colour Double -> a -> a +lc :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => Colour Double -> a -> a lc = lineColor -- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). See comment in 'lineColor' -- about backends. -lcA :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => AlphaColour Double -> a -> a +lcA :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => AlphaColour Double -> a -> a lcA = lineColor -- | Apply a linear gradient. -lineLGradient :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => LGradient n -> a -> a +lineLGradient :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => LGradient n -> a -> a lineLGradient g = lineTexture (LG g) -- | Apply a radial gradient. -lineRGradient :: (Typeable n, Floating n, HasStyle a, Vn a ~ V2 n) => RGradient n -> a -> a +lineRGradient :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => RGradient n -> a -> a lineRGradient g = lineTexture (RG g) -- | The texture with which objects are filled. @@ -472,7 +472,7 @@ instance Default (FillTexture n) where getFillTexture :: FillTexture n -> Texture n getFillTexture (FillTexture tx) = getLast . getRecommend $ tx -fillTexture :: (HasStyle a, Vn a ~ V2 n, Typeable n, Floating n) => Texture n -> a -> a +fillTexture :: (HasStyle a, V a ~ V2, N a ~ n, Typeable n, Floating n) => Texture n -> a -> a fillTexture = applyTAttr . FillTexture . Commit . Last mkFillTexture :: Texture n -> FillTexture n @@ -493,24 +493,24 @@ styleFillTexture = sets modifyFillTexture -- type (so it can be used with either 'Colour' or 'AlphaColour'), -- but this can sometimes create problems for type inference, so the -- 'fc' and 'fcA' variants are provided with more concrete types. -fillColor :: (Color c, HasStyle a, Vn a ~ V2 n, Typeable n, Floating n) => c -> a -> a +fillColor :: (Color c, HasStyle a, V a ~ V2, N a ~ n, Typeable n, Floating n) => c -> a -> a fillColor = fillTexture . SC . SomeColor -- | Set a \"recommended\" fill color, to be used only if no explicit -- calls to 'fillColor' (or 'fc', or 'fcA') are used. -- See comment after 'fillColor' about backends. -recommendFillColor :: (Color c, HasStyle a, Vn a ~ V2 n, Typeable n, Floating n) => c -> a -> a +recommendFillColor :: (Color c, HasStyle a, V a ~ V2, N a ~ n, Typeable n, Floating n) => c -> a -> a recommendFillColor = applyTAttr . FillTexture . Recommend . Last . SC . SomeColor -- | A synonym for 'fillColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). See comment after 'fillColor' about backends. -fc :: (HasStyle a, Vn a ~ V2 n, Floating n, Typeable n) => Colour Double -> a -> a +fc :: (HasStyle a, V a ~ V2, N a ~ n, Floating n, Typeable n) => Colour Double -> a -> a fc = fillColor -- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). See comment after 'fillColor' about backends. -fcA :: (HasStyle a, Vn a ~ V2 n, Floating n, Typeable n) => AlphaColour Double -> a -> a +fcA :: (HasStyle a, V a ~ V2, N a ~ n, Floating n, Typeable n) => AlphaColour Double -> a -> a fcA = fillColor ------------------------------------------------------------ diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 6347dc32..0b3c6428 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -78,7 +78,7 @@ infixl 6 ||| -- combined diagram is the same as the local origin of the first. -- @(===)@ is associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. -(===) :: (Juxtaposable a, Vn a ~ V2 n, TypeableFloat n, Semigroup a) => a -> a -> a +(===) :: (Juxtaposable a, V a ~ V2, N a ~ n, TypeableFloat n, Semigroup a) => a -> a -> a (===) = beside unit_Y -- | Place two diagrams (or other juxtaposable objects) horizontally @@ -87,7 +87,7 @@ infixl 6 ||| -- is the same as the local origin of the first. @(|||)@ is -- associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. -(|||) :: (Juxtaposable a, Vn a ~ V2 n, TypeableFloat n, Semigroup a) => a -> a -> a +(|||) :: (Juxtaposable a, V a ~ V2, N a ~ n, TypeableFloat n, Semigroup a) => a -> a -> a (|||) = beside unitX -- | Lay out a list of juxtaposable objects in a row from left to right, @@ -101,7 +101,7 @@ infixl 6 ||| -- "Diagrams.TwoD.Align" before applying 'hcat'. -- -- * For non-axis-aligned layout, see 'cat'. -hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) +hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ V2, N a ~ n, TypeableFloat n) => [a] -> a hcat = hcat' def @@ -109,13 +109,13 @@ hcat = hcat' def -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. For the common case of setting just a -- separation amount, see 'hsep'. -hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) +hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ V2, N a ~ n, TypeableFloat n) => CatOpts n -> [a] -> a hcat' = cat' unitX -- | A convenient synonym for horizontal concatenation with -- separation: @hsep s === hcat' (with & sep .~ s)@. -hsep :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) +hsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ V2, N a ~ n, TypeableFloat n) => n -> [a] -> a hsep s = hcat' (def & sep .~ s) @@ -130,7 +130,7 @@ hsep s = hcat' (def & sep .~ s) -- "Diagrams.TwoD.Align" before applying 'vcat'. -- -- * For non-axis-aligned layout, see 'cat'. -vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) +vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ V2, N a ~ n, TypeableFloat n) => [a] -> a vcat = vcat' def @@ -138,13 +138,13 @@ vcat = vcat' def -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. For the common case of setting just a -- separation amount, see 'vsep'. -vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) +vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ V2, N a ~ n, TypeableFloat n) => CatOpts n -> [a] -> a vcat' = cat' unit_Y -- | A convenient synonym for vertical concatenation with -- separation: @vsep s === vcat' (with & sep .~ s)@. -vsep :: (Juxtaposable a, HasOrigin a, Monoid' a, Vn a ~ V2 n, TypeableFloat n) +vsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ V2, N a ~ n, TypeableFloat n) => n -> [a] -> a vsep s = vcat' (def & sep .~ s) @@ -244,8 +244,8 @@ view p (V2 w h) = withEnvelope (rect w h # alignBL # moveTo p :: D V2 n) -- | Construct a bounding rectangle for an enveloped object, that is, -- the smallest axis-aligned rectangle which encloses the object. -boundingRect :: ( Enveloped t, Transformable t, TrailLike t, Monoid t, Vn a ~ Vn t - , Enveloped a, Vn a ~ V2 n, TypeableFloat n +boundingRect :: ( Enveloped t, Transformable t, TrailLike t, Monoid t, V a ~ V t, N a ~ N t + , Enveloped a, V a ~ V2, N a ~ n, TypeableFloat n ) => a -> t boundingRect = (`boxFit` rect 1 1) . boundingBox diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index 5816f372..b5c44c0d 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -36,18 +36,18 @@ import Diagrams.TwoD.Vector (xDir) import Diagrams.Util -- | A circle of radius 1, with center at the origin. -unitCircle :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => t +unitCircle :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => t unitCircle = trailLike $ glueTrail (arcT xDir fullTurn) `at` p2 (1,0) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). -circle :: (TrailLike t, Vn t ~ V2 n, RealFloat n, Transformable t) => n -> t +circle :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n, Transformable t) => n -> t circle d = unitCircle # scale d -- | @ellipse e@ constructs an ellipse with eccentricity @e@ by -- scaling the unit circle in the X direction. The eccentricity must -- be within the interval [0,1). -ellipse :: (TrailLike t, Vn t ~ V2 n, RealFloat n, Transformable t) => n -> t +ellipse :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n, Transformable t) => n -> t ellipse e | e >= 0 && e < 1 = scaleX (sqrt (1 - e*e)) unitCircle | otherwise = error "Eccentricity of ellipse must be >= 0 and < 1." @@ -55,5 +55,5 @@ ellipse e -- | @ellipseXY x y@ creates an axis-aligned ellipse, centered at the -- origin, with radius @x@ along the x-axis and radius @y@ along the -- y-axis. -ellipseXY :: (TrailLike t, Vn t ~ V2 n, RealFloat n, Transformable t) => n -> n -> t +ellipseXY :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n, Transformable t) => n -> n -> t ellipseXY x y = unitCircle # scaleX x # scaleY y diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index f757960f..b93d2e88 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -240,7 +240,7 @@ offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va -- collapse the Located into the result. This assumes that Located has the -- meaning of merely taking something that cannot be translated and lifting -- it into a space with translation. -bindLoc :: (Transformable b, Vn a ~ Vn b, Vn a ~ V2 n, Num n) => (a -> b) -> Located a -> b +bindLoc :: (Transformable b, V a ~ V b, N a ~ N b, V a ~ V2, N a ~ n, Num n) => (a -> b) -> Located a -> b bindLoc f = join' . mapLoc f where join' (viewLoc -> (p,a)) = translate (p .-. origin) a @@ -475,10 +475,10 @@ capArc r c a b = trailLike . moveTo c $ fs -- Arc helpers -- always picks the shorter arc (< τ/2) -arcV :: (OrderedField n, RealFloat n, TrailLike t, Vn t ~ V2 n) => V2 n -> V2 n -> t +arcV :: (OrderedField n, RealFloat n, TrailLike t, V t ~ V2, N t ~ n) => V2 n -> V2 n -> t arcV u v = arc (direction u) (angleBetween v u) -arcVCW :: (OrderedField n, RealFloat n, TrailLike t, Vn t ~ V2 n) => V2 n -> V2 n -> t +arcVCW :: (OrderedField n, RealFloat n, TrailLike t, V t ~ V2, N t ~ n) => V2 n -> V2 n -> t arcVCW u v = arc (direction u) (negated $ angleBetween v u) -- | Join together a list of located trails with the given join style. The diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 8e496d37..9c598c4f 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -376,7 +376,7 @@ instance (OrderedField n) => Transformable (Clip n) where -- path will be drawn. -- -- * The envelope of the diagram is unaffected. -clipBy :: (HasStyle a, Vn a ~ V2 n, TypeableFloat n) => Path V2 n -> a -> a +clipBy :: (HasStyle a, V a ~ V2, N a ~ n, TypeableFloat n) => Path V2 n -> a -> a clipBy = applyTAttr . Clip . (:[]) -- | Clip a diagram to the given path setting its envelope to the diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index d0ead891..148c8ca1 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -177,7 +177,7 @@ polyTrail po = transform ori tr NoOrient -> mempty -- | Generate the polygon described by the given options. -polygon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => PolygonOpts n -> t +polygon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => PolygonOpts n -> t polygon = trailLike . polyTrail -- | Generate the located trail of a polygon specified by polar data diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index d0ebe5bd..7cb75471 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -71,7 +71,7 @@ import Diagrams.Util -- -- > hruleEx = vcat' (with & sep .~ 0.2) (map hrule [1..5]) -- > # centerXY # pad 1.1 -hrule :: (TrailLike t, Vn t ~ V2 n) => n -> t +hrule :: (TrailLike t, V t ~ V2, N t ~ n) => n -> t hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` p2 (-d/2,0) -- | Create a centered vertical (T-B) line of the given length. @@ -80,14 +80,14 @@ hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` p2 (-d/2,0) -- -- > vruleEx = hcat' (with & sep .~ 0.2) (map vrule [1, 1.2 .. 2]) -- > # centerXY # pad 1.1 -vrule :: (TrailLike t, Vn t ~ V2 n) => n -> t +vrule :: (TrailLike t, V t ~ V2, N t ~ n) => n -> t vrule d = trailLike $ trailFromSegments [straight $ r2 (0, -d)] `at` p2 (0,d/2) -- | A square with its center at the origin and sides of length 1, -- oriented parallel to the axes. -- -- <> -unitSquare :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => t +unitSquare :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => t unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2) & polyOrient .~ OrientH) @@ -97,7 +97,7 @@ unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2) -- length, oriented parallel to the axes. -- -- <> -square :: (TrailLike t, Transformable t, Vn t ~ V2 n, RealFloat n) => n -> t +square :: (TrailLike t, Transformable t, V t ~ V2, N t ~ n, RealFloat n) => n -> t square d = rect d d -- > squareEx = hcat' (with & sep .~ 0.5) [square 1, square 2, square 3] @@ -107,7 +107,7 @@ square d = rect d d -- @h@, centered at the origin. -- -- <> -rect :: (TrailLike t, Transformable t, Vn t ~ V2 n, RealFloat n) => n -> n -> t +rect :: (TrailLike t, Transformable t, V t ~ V2, N t ~ n, RealFloat n) => n -> n -> t rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h -- > rectEx = rect 1 0.7 # pad 1.1 @@ -139,7 +139,7 @@ rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h -- polygons of a given /radius/). -- -- The polygon will be oriented with one edge parallel to the x-axis. -regPoly :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => Int -> n -> t +regPoly :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => Int -> n -> t regPoly n l = polygon (def & polyType .~ PolySides (repeat (1/fromIntegral n @@ turn)) @@ -159,76 +159,76 @@ regPoly n l = polygon (def & polyType .~ -- > dodecagonEx = shapeEx dodecagon -- | A synonym for 'triangle', provided for backwards compatibility. -eqTriangle :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +eqTriangle :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t eqTriangle = triangle -- | An equilateral triangle, with sides of the given length and base -- parallel to the x-axis. -- -- <> -triangle :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +triangle :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t triangle = regPoly 3 -- | A regular pentagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -pentagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +pentagon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t pentagon = regPoly 5 -- | A regular hexagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -hexagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +hexagon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t hexagon = regPoly 6 -- | A regular heptagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -heptagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +heptagon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t heptagon = regPoly 7 -- | A synonym for 'heptagon'. It is, however, completely inferior, -- being a base admixture of the Latin /septum/ (seven) and the -- Greek γωνία (angle). -septagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +septagon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t septagon = heptagon -- | A regular octagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -octagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +octagon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t octagon = regPoly 8 -- | A regular nonagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -nonagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +nonagon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t nonagon = regPoly 9 -- | A regular decagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -decagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +decagon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t decagon = regPoly 10 -- | A regular hendecagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -hendecagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +hendecagon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t hendecagon = regPoly 11 -- | A regular dodecagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> -dodecagon :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> t +dodecagon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> t dodecagon = regPoly 12 ------------------------------------------------------------ @@ -266,7 +266,7 @@ instance (Num d) => Default (RoundedRectOpts d) where -- > & radiusBR .~ 0.1) -- > ] -roundedRect :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> n -> n -> t +roundedRect :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> n -> n -> t roundedRect w h r = roundedRect' w h (def & radiusTL .~ r & radiusBR .~ r & radiusTR .~ r @@ -276,7 +276,7 @@ roundedRect w h r = roundedRect' w h (def & radiusTL .~ r -- each corner indivually, using @RoundedRectOpts@. The default corner radius is 0. -- Each radius can also be negative, which results in the curves being reversed -- to be inward instead of outward. -roundedRect' :: (TrailLike t, Vn t ~ V2 n, RealFloat n) => n -> n -> RoundedRectOpts n -> t +roundedRect' :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> n -> RoundedRectOpts n -> t roundedRect' w h opts = trailLike . (`at` p2 (w/2, abs rBR - h/2)) diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index 7a6c7c7b..081efa99 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -48,36 +48,36 @@ import Linear.Vector ------------------------------------------------------------ -- | Compute the width of an enveloped object. -width :: (Vn a ~ V2 n, Enveloped a) => a -> n +width :: (V a ~ V2, N a ~ n, Enveloped a) => a -> n width = maybe 0 (negate . uncurry (-)) . extentX -- | Compute the height of an enveloped object. -height :: (Vn a ~ V2 n, Enveloped a) => a -> n +height :: (V a ~ V2, N a ~ n, Enveloped a) => a -> n height = maybe 0 (negate . uncurry (-)) . extentY -- | Compute the width and height of an enveloped object. -size2D :: (Vn a ~ V2 n, Enveloped a) => a -> (n, n) +size2D :: (V a ~ V2, N a ~ n, Enveloped a) => a -> (n, n) size2D = width &&& height -- | Compute the size of an enveloped object as a 'SizeSpec2D' value. -sizeSpec2D :: (Vn a ~ V2 n, Enveloped a) => a -> SizeSpec2D n +sizeSpec2D :: (V a ~ V2, N a ~ n, Enveloped a) => a -> SizeSpec2D n sizeSpec2D = uncurry Dims . size2D -- | Compute the absolute x-coordinate range of an enveloped object in -- R2, in the form (lo,hi). Return @Nothing@ for objects with an -- empty envelope. -extentX :: (Vn a ~ V2 n, Enveloped a) => a -> Maybe (n, n) +extentX :: (V a ~ V2, N a ~ n, Enveloped a) => a -> Maybe (n, n) extentX d = (\f -> (-f unit_X, f unitX)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the absolute y-coordinate range of an enveloped object in -- R2, in the form (lo,hi). -extentY :: (Vn a ~ V2 n, Enveloped a) => a -> Maybe (n, n) +extentY :: (V a ~ V2, N a ~ n, Enveloped a) => a -> Maybe (n, n) extentY d = (\f -> (-f unit_Y, f unitY)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the point at the center (in the x- and y-directions) of a -- enveloped object. Return the origin for objects with an empty -- envelope. -center2D :: (Vn a ~ V2 n, Enveloped a) => a -> Point V2 n +center2D :: (V a ~ V2, N a ~ n, Enveloped a) => a -> Point V2 n center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) where mm = uncurry (liftA2 (,)) mid = (/2) . uncurry (+) @@ -152,14 +152,14 @@ requiredScale (Dims wSpec hSpec) (w,h) = s -- | Uniformly scale any enveloped object so that it fits within the -- given size. -sized :: (Vn a ~ V2 n, Transformable a, Enveloped a, RealFloat n) +sized :: (V a ~ V2, N a ~ n, Transformable a, Enveloped a, RealFloat n) => SizeSpec2D n -> a -> a sized spec a = transform (requiredScaleT spec (size2D a)) a -- | Uniformly scale an enveloped object so that it \"has the same -- size as\" (fits within the width and height of) some other -- object. -sizedAs :: (Vn a ~ V2 n, Vn a ~ Vn b, Transformable a, +sizedAs :: (V a ~ V2, N a ~ n, V a ~ V b, N a ~ N b, Transformable a, Enveloped a, Enveloped b, RealFloat n) => b -> a -> a sizedAs other = sized (sizeSpec2D other) diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 80aca4d6..4d778afc 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -214,28 +214,28 @@ getFontSizeIsLocal (FontSize (Last (_,b))) = b -- | Set the font size, that is, the size of the font's em-square as -- measured within the current local vector space. The default size -- is @1@. -fontSize :: (Data n, HasStyle a, Vn a ~ V2 n) => Measure n -> a -> a +fontSize :: (Data n, HasStyle a, V a ~ V2, N a ~ n) => Measure n -> a -> a fontSize m@(Local {}) = applyGTAttr . FontSize . Last $ (m,True) fontSize m = applyGTAttr . FontSize . Last $ (m,False) -- | A convenient synonym for 'fontSize (Global w)'. -fontSizeG :: (Data n, HasStyle a, Vn a ~ V2 n) => n -> a -> a +fontSizeG :: (Data n, HasStyle a, V a ~ V2, N a ~ n) => n -> a -> a fontSizeG w = fontSize (Global w) -- | A convenient synonym for 'fontSize (Normalized w)'. -fontSizeN :: (Data n, HasStyle a, Vn a ~ V2 n) => n -> a -> a +fontSizeN :: (Data n, HasStyle a, V a ~ V2, N a ~ n) => n -> a -> a fontSizeN w = fontSize (Normalized w) -- | A convenient synonym for 'fontSize (Output w)'. -fontSizeO :: (Data n, HasStyle a, Vn a ~ V2 n) => n -> a -> a +fontSizeO :: (Data n, HasStyle a, V a ~ V2, N a ~ n) => n -> a -> a fontSizeO w = fontSize (Output w) -- | A convenient sysnonym for 'fontSize (Local w)'. -fontSizeL :: (Data n, HasStyle a, Vn a ~ V2 n) => n -> a -> a +fontSizeL :: (Data n, HasStyle a, V a ~ V2, N a ~ n) => n -> a -> a fontSizeL w = fontSize (Local w) -- | Apply a 'FontSize' attribute. -fontSizeA :: (Data n, HasStyle a, Vn a ~ V2 n) => FontSize n -> a -> a +fontSizeA :: (Data n, HasStyle a, V a ~ V2, N a ~ n) => FontSize n -> a -> a fontSizeA = applyGTAttr -------------------------------------------------- diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index c313cd25..f5e11f25 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -90,13 +90,13 @@ rotation ang = fromLinear r (linv r) -- will yield an error since GHC cannot figure out which sort of -- angle you want to use. In this common situation you can use -- 'rotateBy', which interprets its argument as a number of turns. -rotate :: (Vn t ~ V2 n, Transformable t, Floating n) => Angle n -> t -> t +rotate :: (V t ~ V2, N t ~ n, Transformable t, Floating n) => Angle n -> t -> t rotate = transform . rotation -- | A synonym for 'rotate', interpreting its argument in units of -- turns; it can be more convenient to write @rotateBy (1\/4)@ than -- @'rotate' (1\/4 \@\@ 'turn')@. -rotateBy :: (Vn t ~ V2 n, Transformable t, Floating n) => n -> t -> t +rotateBy :: (V t ~ V2, N t ~ n, Transformable t, Floating n) => n -> t -> t rotateBy = transform . rotation . review turn -- | @rotationAbout p@ is a rotation about the point @p@ (instead of @@ -106,7 +106,7 @@ rotationAround p angle = conjugate (translation (origin .-. p)) (rotation angle) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. -rotateAround :: (Vn t ~ V2 n, Transformable t, Floating n) => P2 n -> Angle n -> t -> t +rotateAround :: (V t ~ V2, N t ~ n, Transformable t, Floating n) => P2 n -> Angle n -> t -> t rotateAround p angle = rotate angle `under` translation (origin .-. p) -- Scaling ------------------------------------------------- @@ -119,7 +119,7 @@ scalingX c = fromLinear s s -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. -scaleX :: (Vn t ~ v n, Transformable t, R1 v, Additive v, Floating n) +scaleX :: (V t ~ v, N t ~ n, Transformable t, R1 v, Additive v, Floating n) => n -> t -> t scaleX = transform . scalingX @@ -131,7 +131,7 @@ scalingY c = fromLinear s s -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. -scaleY :: (Vn t ~ v n, Transformable t, R2 v, Additive v, Floating n) +scaleY :: (V t ~ v, N t ~ n, Transformable t, R2 v, Additive v, Floating n) => n -> t -> t scaleY = transform . scalingY @@ -139,26 +139,26 @@ scaleY = transform . scalingY -- whatever factor required to make its width @w@. @scaleToX@ -- should not be applied to diagrams with a width of 0, such as -- 'vrule'. -scaleToX :: (Vn t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t +scaleToX :: (V t ~ V2, N t ~ n, Enveloped t, Transformable t) => n -> t -> t scaleToX w d = scaleX (w / width d) d -- | @scaleToY h@ scales a diagram in the y (vertical) direction by -- whatever factor required to make its height @h@. @scaleToY@ -- should not be applied to diagrams with a height of 0, such as -- 'hrule'. -scaleToY :: (Vn t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t +scaleToY :: (V t ~ V2, N t ~ n, Enveloped t, Transformable t) => n -> t -> t scaleToY h d = scaleY (h / height d) d -- | @scaleUToX w@ scales a diagram /uniformly/ by whatever factor -- required to make its width @w@. @scaleUToX@ should not be -- applied to diagrams with a width of 0, such as 'vrule'. -scaleUToX :: (Vn t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t +scaleUToX :: (V t ~ V2, N t ~ n, Enveloped t, Transformable t) => n -> t -> t scaleUToX w d = scale (w / width d) d -- | @scaleUToY h@ scales a diagram /uniformly/ by whatever factor -- required to make its height @h@. @scaleUToY@ should not be applied -- to diagrams with a height of 0, such as 'hrule'. -scaleUToY :: (Vn t ~ V2 n, Enveloped t, Transformable t) => n -> t -> t +scaleUToY :: (V t ~ V2, N t ~ n, Enveloped t, Transformable t) => n -> t -> t scaleUToY h d = scale (h / height d) d -- Translation --------------------------------------------- @@ -170,7 +170,7 @@ translationX x = translation (zero & _x .~ x) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. -translateX :: (Vn t ~ v n, Transformable t, R1 v, Additive v, Floating n) +translateX :: (V t ~ v, N t ~ n, Transformable t, R1 v, Additive v, Floating n) => n -> t -> t translateX = transform . translationX @@ -181,7 +181,7 @@ translationY y = translation (zero & _y .~ y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. -translateY :: (Vn t ~ v n, Transformable t, R2 v, Additive v, Floating n) +translateY :: (V t ~ v, N t ~ n, Transformable t, R2 v, Additive v, Floating n) => n -> t -> t translateY = transform . translationY @@ -194,7 +194,7 @@ reflectionX = scalingX (-1) -- | Flip a diagram from left to right, i.e. send the point (x,y) to -- (-x,y). -reflectX :: (Vn t ~ v n, Transformable t, R1 v, Additive v, Floating n) => t -> t +reflectX :: (V t ~ v, N t ~ n, Transformable t, R1 v, Additive v, Floating n) => t -> t reflectX = transform reflectionX -- | Construct a transformation which flips a diagram from top to @@ -204,7 +204,7 @@ reflectionY = scalingY (-1) -- | Flip a diagram from top to bottom, i.e. send the point (x,y) to -- (x,-y). -reflectY :: (Vn t ~ v n, Transformable t, R2 v, Additive v, Floating n) +reflectY :: (V t ~ v, N t ~ n, Transformable t, R2 v, Additive v, Floating n) => t -> t reflectY = transform reflectionY @@ -217,7 +217,7 @@ reflectionAbout p v = -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. -reflectAbout :: (Vn t ~ V2 n, Transformable t, RealFloat n) => P2 n -> V2 n -> t -> t +reflectAbout :: (V t ~ V2, N t ~ n, Transformable t, RealFloat n) => P2 n -> V2 n -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Shears -------------------------------------------------- @@ -244,7 +244,7 @@ shearingX d = fromLinear (sh f g d <-> sh f g (-d)) -- | @shearX d@ performs a shear in the x-direction which sends -- @(0,1)@ to @(d,1)@. -shearX :: (Vn t ~ V2 n, Transformable t, Num n) => n -> t -> t +shearX :: (V t ~ V2, N t ~ n, Transformable t, Num n) => n -> t -> t shearX = transform . shearingX -- | @shearingY d@ is the linear transformation which is the identity on @@ -258,7 +258,7 @@ shearingY d = fromLinear (sh f g d <-> sh f g (-d)) -- | @shearY d@ performs a shear in the y-direction which sends -- @(1,0)@ to @(1,d)@. -shearY :: (Vn t ~ V2 n, Transformable t, Num n) => n -> t -> t +shearY :: (V t ~ V2, N t ~ n, Transformable t, Num n) => n -> t -> t shearY = transform . shearingY -- | Get the matrix equivalent of the linear transform, diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 78671d09..572165f8 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -82,16 +82,16 @@ makeLenses ''ScaleInv -- | Create a scale-invariant object pointing in the given direction, -- located at the origin. -scaleInv :: (Vn t ~ v n, Additive v, Num n) => t -> v n -> ScaleInv t +scaleInv :: (V t ~ v, N t ~ n, Additive v, Num n) => t -> v n -> ScaleInv t scaleInv t d = ScaleInv t d origin type instance V (ScaleInv t) = V t type instance N (ScaleInv t) = N t -instance (Vn t ~ v n, Additive v, Num n, HasOrigin t) => HasOrigin (ScaleInv t) where +instance (V t ~ v, N t ~ n, Additive v, Num n, HasOrigin t) => HasOrigin (ScaleInv t) where moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) -instance (Vn t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv t) where +instance (V t ~ V2, N t ~ n, RealFloat n, Transformable t) => Transformable (ScaleInv t) where transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where angle = transform tr v ^. _theta @@ -162,7 +162,7 @@ instance (Vn t ~ V2 n, RealFloat n, Transformable t) => Transformable (ScaleInv -} -instance (Vn t ~ V2 n, RealFloat n, Renderable t b) => Renderable (ScaleInv t) b where +instance (V t ~ V2, N t ~ n, RealFloat n, Renderable t b) => Renderable (ScaleInv t) b where render b = render b . view scaleInvObj -- | Create a diagram from a single scale-invariant primitive. The @@ -180,6 +180,6 @@ instance (Vn t ~ V2 n, RealFloat n, Renderable t b) => Renderable (ScaleInv t) b -- scale-invariant things will be used only as \"decorations\" (/e.g./ -- arrowheads) which should not affect the envelope, trace, and -- query. -scaleInvPrim :: (Vn t ~ V2 n, RealFloat n, Transformable t, Typeable t, Renderable t b, Monoid m) +scaleInvPrim :: (V t ~ V2, N t ~ n, RealFloat n, Transformable t, Typeable t, Renderable t b, Monoid m) => t -> V2 n -> QDiagram b (V t) (N t) m scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty From 4dee63c32eafa563c0050585f5e481d787817c4e Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 15 Sep 2014 14:49:01 +0000 Subject: [PATCH 49/58] move `project` to Diagrams.Points It's not actually about points, but it's a utility function for vector spaces, like the rest of that module, and it doesn't belong under 2D. --- src/Diagrams/Points.hs | 5 +++++ src/Diagrams/ThreeD/Shapes.hs | 2 +- src/Diagrams/ThreeD/Transform.hs | 1 + src/Diagrams/TwoD/Polygons.hs | 2 +- src/Diagrams/TwoD/Types.hs | 8 -------- 5 files changed, 8 insertions(+), 10 deletions(-) diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs index 99c6309f..e8b15469 100644 --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -18,6 +18,7 @@ module Diagrams.Points , centroid , pointDiagram , _pIso, lensP + , project ) where import Diagrams.Core (pointDiagram) @@ -27,6 +28,7 @@ import Control.Lens (Iso', iso) import Data.Foldable as F import Linear.Affine +import Linear.Metric import Linear.Vector -- Point v <-> v @@ -41,3 +43,6 @@ meanV :: (Foldable f, Additive v, Fractional a) => f (v a) -> v a meanV = uncurry (^/) . F.foldl' (\(s,c) e -> (e ^+^ s,c+1)) (zero,0) {-# INLINE meanV #-} +-- | @project u v@ computes the projection of @v@ onto @u@. +project :: (Metric v, Fractional n) => v n -> v n -> v n +project u v = ((v `dot` u) / quadrance u) *^ u diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index 7312d645..c0b997cb 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -33,6 +33,7 @@ import Diagrams.Core import Diagrams.Solve import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector +import Diagrams.Points import Linear.Affine import Linear.Metric @@ -167,4 +168,3 @@ cone = frustum 1 0 -- origin, and extending to Z=1. cylinder :: (TypeableFloat n, Renderable (Frustum n) b) => Diagram b V3 n cylinder = frustum 1 1 - diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index ebc04c9e..ad220cfe 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -53,6 +53,7 @@ import Diagrams.Angle import Diagrams.Direction import Diagrams.ThreeD.Types import Diagrams.Transform +import Diagrams.Points import Control.Lens (view, (&), (*~), (.~), (//~)) import Data.Semigroup diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index 148c8ca1..9ba4bf93 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -61,7 +61,7 @@ import Diagrams.Angle import Diagrams.Core import Diagrams.Located import Diagrams.Path -import Diagrams.Points (centroid) +import Diagrams.Points (centroid, project) import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Transform diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index c0f980e3..a20018e8 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -19,7 +19,6 @@ module Diagrams.TwoD.Types , r2, unr2, mkR2, r2Iso , p2, mkP2, unp2, p2Iso , r2polarIso - , project , HasR (..) ) where @@ -32,7 +31,6 @@ import Diagrams.Core.Transform import Diagrams.Core.V import Linear.Metric import Linear.V2 -import Linear.Vector type P2 = Point V2 @@ -69,11 +67,6 @@ mkP2 x = P . V2 x p2Iso :: Iso' (Point V2 n) (n, n) p2Iso = iso unp2 p2 --- | @project u v@ computes the projection of @v@ onto @u@. -project :: (Metric v, Fractional n) => v n -> v n -> v n -project u v = ((v `dot` u) / quadrance u) *^ u --- find somewhere better for this - instance Transformable (V2 n) where transform = apply @@ -97,4 +90,3 @@ instance HasR V2 where instance HasTheta V2 where _theta = r2polarIso . _2 {-# INLINE _theta #-} - From 2b59c1f77b9ca630a3b1e845f777ebdb4cfdf639 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 15 Sep 2014 17:09:15 +0100 Subject: [PATCH 50/58] Some changes I missed. --- src/Diagrams/Direction.hs | 2 +- src/Diagrams/Located.hs | 10 +++--- src/Diagrams/Parametric/Adjust.hs | 3 +- src/Diagrams/ThreeD/Align.hs | 44 ++++++++++++------------- src/Diagrams/TwoD/Transform/ScaleInv.hs | 2 +- 5 files changed, 30 insertions(+), 31 deletions(-) diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index e5180b60..ed1fff05 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -39,7 +39,7 @@ newtype Direction v n = Direction (v n) type instance V (Direction v n) = v type instance N (Direction v n) = n -instance (Vn (v n) ~ v n, Transformable (v n)) => Transformable (Direction v n) where +instance (V (v n) ~ v, N (v n) ~ n, Transformable (v n)) => Transformable (Direction v n) where transform t (Direction v) = Direction (transform t v) instance HasTheta v => HasTheta (Direction v) where diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs index 6976e4fd..e767fc5e 100644 --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -88,7 +88,7 @@ mapLoc :: (V a ~ V b, N a ~ N b) => (a -> b) -> Located a -> Located b mapLoc f (Loc p a) = Loc p (f a) -- | A lens giving access to the object within a 'Located' wrapper. -located :: (Vn a ~ Vn a') => Lens (Located a) (Located a') a a' +located :: (V a ~ V a', N a ~ N a') => Lens (Located a) (Located a') a a' located f (Loc p a) = Loc p <$> f a deriving instance (Eq (V a (N a)), Eq a ) => Eq (Located a) @@ -130,7 +130,7 @@ instance Qualifiable a => Qualifiable (Located a) where type instance Codomain (Located a) = Point (Codomain a) -instance (Vn a ~ v n, Codomain a ~ v, Additive v, Num n, Parametric a) +instance (V a ~ v, N a ~ n, Codomain a ~ v, Additive v, Num n, Parametric a) => Parametric (Located a) where (Loc x a) `atParam` p = x .+^ (a `atParam` p) @@ -138,10 +138,10 @@ instance DomainBounds a => DomainBounds (Located a) where domainLower (Loc _ a) = domainLower a domainUpper (Loc _ a) = domainUpper a -instance (Vn a ~ v n, Codomain a ~ v, Additive v, Num n, EndValues a) +instance (V a ~ v, N a ~ n, Codomain a ~ v, Additive v, Num n, EndValues a) => EndValues (Located a) -instance (Vn a ~ v n, Codomain a ~ v, Fractional n, Additive v, Sectionable a, Parametric a) +instance (V a ~ v, N a ~ n, Codomain a ~ v, Fractional n, Additive v, Sectionable a, Parametric a) => Sectionable (Located a) where splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2) where (a1,a2) = splitAtParam a p @@ -149,7 +149,7 @@ instance (Vn a ~ v n, Codomain a ~ v, Fractional n, Additive v, Sectionable a, P reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a) where y = a `atParam` domainUpper a -instance (Vn a ~ v n, Codomain a ~ v, Additive v, Fractional n, HasArcLength a) +instance (V a ~ v, N a ~ n, Codomain a ~ v, Additive v, Fractional n, HasArcLength a) => HasArcLength (Located a) where arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a arcLengthToParam eps (Loc _ a) = arcLengthToParam eps a diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs index bfeba613..e809af92 100644 --- a/src/Diagrams/Parametric/Adjust.hs +++ b/src/Diagrams/Parametric/Adjust.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -80,7 +79,7 @@ instance Fractional n => Default (AdjustOpts v n) where -- | Adjust the length of a parametric object such as a segment or -- trail. The second parameter is an option record which controls how -- the adjustment should be performed; see 'AdjustOpts'. -adjust :: (Vn a ~ v n, DomainBounds a, Sectionable a, HasArcLength a, Fractional n) +adjust :: (V a ~ v, N a ~ n, DomainBounds a, Sectionable a, HasArcLength a, Fractional n) => a -> AdjustOpts v n -> a adjust s opts = section s (if opts^.adjSide == End then domainLower s else getParam s) diff --git a/src/Diagrams/ThreeD/Align.hs b/src/Diagrams/ThreeD/Align.hs index 96abf718..eae538d9 100644 --- a/src/Diagrams/ThreeD/Align.hs +++ b/src/Diagrams/ThreeD/Align.hs @@ -50,113 +50,113 @@ import Linear.Vector -- | Translate the diagram along unitX so that all points have -- positive x-values. -alignXMin :: (Vn a ~ v n, Alignable a, HasOrigin a, +alignXMin :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R1 v, Additive v, Fractional n) => a -> a alignXMin = align unit_X -snugXMin :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugXMin :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R1 v, Additive v, Fractional n) => a -> a snugXMin = snug unit_X -- | Translate the diagram along unitX so that all points have -- negative x-values. -alignXMax :: (Vn a ~ v n, Alignable a, HasOrigin a, +alignXMax :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R1 v, Additive v, Fractional n) => a -> a alignXMax = align unitX -snugXMax :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugXMax :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R1 v, Additive v, Fractional n) => a -> a snugXMax = snug unitX -- | Translate the diagram along unitY so that all points have -- positive y-values. -alignYMin :: (Vn a ~ v n, Alignable a, HasOrigin a, +alignYMin :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R2 v, Additive v, Fractional n) => a -> a alignYMin = align unit_Y -snugYMin :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugYMin :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R2 v, Additive v, Fractional n) => a -> a snugYMin = snug unit_Y -- | Translate the diagram along unitY so that all points have -- negative y-values. -alignYMax :: (Vn a ~ v n, Alignable a, HasOrigin a, +alignYMax :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R2 v, Additive v, Fractional n) => a -> a alignYMax = align unitY -snugYMax :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugYMax :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R2 v, Additive v, Fractional n) => a -> a snugYMax = snug unitY -- | Translate the diagram along unitZ so that all points have -- positive z-values. -alignZMin :: (Vn a ~ v n, Alignable a, HasOrigin a, +alignZMin :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a alignZMin = align unit_Z -snugZMin :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugZMin :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a snugZMin = snug unit_Z -- | Translate the diagram along unitZ so that all points have -- negative z-values. -alignZMax :: (Vn a ~ v n, Alignable a, HasOrigin a, +alignZMax :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a alignZMax = align unitZ -snugZMax :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugZMax :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a snugZMax = snug unitZ -- | Like 'alignX', but moving the local origin in the Z direction, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignZ :: (Vn a ~ v n, Alignable a, HasOrigin a, +alignZ :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R3 v, Additive v, Fractional n) => n -> a -> a alignZ = alignBy unitZ -- | See the documentation for 'alignZ'. -snugZ :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugZ :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R3 v, Additive v, Fractional n) => n -> a -> a snugZ = snugBy unitZ -- | Center the local origin along the Z-axis. -centerZ :: (Vn a ~ v n, Alignable a, HasOrigin a, +centerZ :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a centerZ = alignBy unitZ 0 -snugCenterZ :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugCenterZ :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a snugCenterZ = snugBy unitZ 0 -- | Center along both the X- and Z-axes. -centerXZ :: (Vn a ~ v n, Alignable a, HasOrigin a, +centerXZ :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a centerXZ = centerX . centerZ -snugCenterXZ :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugCenterXZ :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a snugCenterXZ = snugCenterX . snugCenterZ -- | Center along both the Y- and Z-axes. -centerYZ :: (Vn a ~ v n, Alignable a, HasOrigin a, +centerYZ :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a centerYZ = centerZ . centerY -snugCenterYZ :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugCenterYZ :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a snugCenterYZ = snugCenterZ . snugCenterY -- | Center an object in three dimensions. -centerXYZ :: (Vn a ~ v n, Alignable a, HasOrigin a, +centerXYZ :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a centerXYZ = centerX . centerY . centerZ -snugCenterXYZ :: (Vn a ~ v n, Alignable a, Traced a, HasOrigin a, +snugCenterXYZ :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R3 v, Additive v, Fractional n) => a -> a snugCenterXYZ = snugCenterX . snugCenterY . snugCenterZ diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 572165f8..7d2c0e5c 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -96,7 +96,7 @@ instance (V t ~ V2, N t ~ n, RealFloat n, Transformable t) => Transformable (Sca where angle = transform tr v ^. _theta - rot :: (Vn k ~ Vn t, Transformable k) => k -> k + rot :: (V k ~ V t, N k ~ N t, Transformable k) => k -> k rot = rotateAround l angle l' = transform tr l From c20fb8cc4511c81e5762430ac2c4db6e3b79c4ed Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Tue, 16 Sep 2014 00:07:35 +0100 Subject: [PATCH 51/58] Make Typeable1 instances for Path v and CameraLens l. --- src/Diagrams/BoundingBox.hs | 1 - src/Diagrams/Path.hs | 24 ++++++++++++++++-------- src/Diagrams/ThreeD/Attributes.hs | 13 +++++++++---- src/Diagrams/ThreeD/Camera.hs | 16 +++++++++++++++- src/Diagrams/TwoD/Attributes.hs | 12 ++++++++++-- 5 files changed, 50 insertions(+), 16 deletions(-) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index c5fa54cf..4763b2fd 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 7654fb70..e622ad2f 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} +#endif {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -57,6 +59,12 @@ module Diagrams.Path ) where +import Control.Arrow ((***)) +import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, over, view, (%~), + _Unwrapped', _Wrapped) +import qualified Data.Foldable as F +import Data.List (partition) +import Data.Semigroup import Data.Typeable import Diagrams.Align @@ -69,12 +77,6 @@ import Diagrams.Trail import Diagrams.TrailLike import Diagrams.Transform -import Control.Arrow ((***)) -import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, over, view, (%~), - _Unwrapped', _Wrapped) -import qualified Data.Foldable as F -import Data.List (partition) -import Data.Semigroup import Linear.Affine import Linear.Metric @@ -96,8 +98,14 @@ newtype Path v n = Path [Located (Trail v n)] ) #if __GLASGOW_HASKELL__ < 707 -instance Typeable2 Path where - typeOf2 _ = mkTyConApp pathTyCon [] +-- This should really be Typeable2 Path but since Path has kind +-- (* -> *) -> * -> * +-- not +-- * -> * -> * +-- we can only do Typeable1 (Path v). This is why the instance cannot be +-- derived. +instance Typeable1 (Path v) where + typeOf1 _ = mkTyConApp pathTyCon [] pathTyCon :: TyCon pathTyCon = mkTyCon3 "diagrams-lib" "Diagrams.Path" "Path" diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs index db05639f..8e53e3df 100644 --- a/src/Diagrams/ThreeD/Attributes.hs +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -39,7 +39,8 @@ import Diagrams.Core -- | @SurfaceColor@ is the inherent pigment of an object, assumed to -- be opaque. newtype SurfaceColor = SurfaceColor (Last (Colour Double)) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup) + instance AttributeClass SurfaceColor surfaceColor :: Iso' SurfaceColor (Colour Double) @@ -55,7 +56,8 @@ sc = applyAttr . review surfaceColor -- Attribute. For physical reasonableness, @Diffuse@ should have a -- value between 0 and 1; this is not checked. newtype Diffuse = Diffuse (Last Double) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup) + instance AttributeClass Diffuse _Diffuse :: Iso' Diffuse Double @@ -72,7 +74,8 @@ diffuse = applyAttr . review _Diffuse -- indirect lighting incident on that object and the diffuse -- reflectance. newtype Ambient = Ambient (Last Double) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup) + instance AttributeClass Ambient _Ambient :: Iso' Ambient Double @@ -96,7 +99,8 @@ data Specular = Specular { _specularIntensity :: Double makeLenses ''Specular newtype Highlight = Highlight (Last Specular) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup) + instance AttributeClass Highlight _Highlight :: Iso' Highlight Specular @@ -105,3 +109,4 @@ _Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last) -- | Set the specular highlight. highlight :: HasStyle d => Specular -> d -> d highlight = applyAttr . review _Highlight + diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index 078b0216..47054e3c 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -51,12 +52,25 @@ data Camera l n = Camera , up :: V3 n , lens :: l n } +#if __GLASGOW_HASKELL__ >= 707 deriving Typeable +#else + +instance Typeable1 (Camera l) where + typeOf1 _ = mkTyConApp cameraTyCon [] + +cameraTyCon :: TyCon +cameraTyCon = mkTyCon3 "diagrams-lib" "Diagrams.ThreeD.Camera" "Camera" +#endif type instance V (Camera l n) = V3 type instance N (Camera l n) = n +#if __GLASGOW_HASKELL__ > 707 class Typeable l => CameraLens l where +#else +class Typeable1 l => CameraLens l where +#endif -- | The natural aspect ratio of the projection. aspect :: Floating n => l n -> n @@ -115,6 +129,7 @@ facing_ZCamera :: (Floating n, Ord n, Typeable n, CameraLens l, Renderable (Came l n -> Diagram b V3 n facing_ZCamera l = mkQD (Prim $ Camera origin unit_Z unitY l) mempty mempty mempty (Query . const . Any $ False) +{-# ANN facing_ZCamera ("HLint: ignore Use camelCase" :: String) #-} mm50, mm50Wide, mm50Narrow :: Floating n => PerspectiveLens n @@ -146,4 +161,3 @@ camLens = lens camAspect :: (Floating n, CameraLens l) => Camera l n -> n camAspect = aspect . camLens -{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 64ef6791..0ac1e85a 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -528,6 +528,14 @@ instance Typeable n => SplitAttribute (FillTextureLoops n) where -- applied to lines/non-closed paths as well as loops/closed paths, -- whereas in the semantics of diagrams, fill attributes only apply -- to loops. -splitTextureFills :: forall b v n a. (Typeable v, Typeable n) => RTree b v n a -> RTree b v n a +splitTextureFills + :: forall b v n a. ( +#if __GLASGOW_HASKELL__ > 707 + Typeable v +#else + Typeable1 v +#endif + + , Typeable n) => RTree b v n a -> RTree b v n a splitTextureFills = splitAttr (FillTextureLoops :: FillTextureLoops n) From ced8456e854cd78dac3097b233d6f7333fc58b87 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Tue, 16 Sep 2014 00:31:52 +0100 Subject: [PATCH 52/58] Remove redundent Data.Typeable from Diagrams.Combinators. --- src/Diagrams/Combinators.hs | 5 ----- src/Diagrams/ThreeD/Camera.hs | 3 +-- 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 5988573c..bc12da27 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} @@ -39,17 +38,13 @@ module Diagrams.Combinators ) where -import Data.Typeable - import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, (%~), (&), (.~), (^.), _Wrapping) import Data.Default.Class import Data.Monoid.Deletable (toDeletable) import Data.Monoid.MList (inj) -#if __GLASGOW_HASKELL__ < 707 import Data.Proxy -#endif import Data.Semigroup import qualified Data.Tree.DUAL as D diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index 47054e3c..2c0f25b2 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -39,10 +39,9 @@ import Data.Typeable import Diagrams.Angle import Diagrams.Core import Diagrams.Direction -import Diagrams.ThreeD.Types () import Diagrams.ThreeD.Vector -import Linear.V3 +import Linear.V3 -- Parameterize Camera on the lens type, so that Backends can express which -- lenses they handle. From cc232a61080e2e65ee18ed2216b76dde0b6f720a Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Tue, 16 Sep 2014 19:14:30 +0100 Subject: [PATCH 53/58] Fix Typeable1 instances. --- src/Diagrams/Path.hs | 11 +++-------- src/Diagrams/ThreeD/Camera.hs | 11 +++++------ 2 files changed, 8 insertions(+), 14 deletions(-) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index e622ad2f..8740cf99 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -69,7 +69,6 @@ import Data.Typeable import Diagrams.Align import Diagrams.Core -import Diagrams.Core.Points () import Diagrams.Located import Diagrams.Points import Diagrams.Segment @@ -77,7 +76,6 @@ import Diagrams.Trail import Diagrams.TrailLike import Diagrams.Transform - import Linear.Affine import Linear.Metric import Linear.Vector @@ -104,14 +102,11 @@ newtype Path v n = Path [Located (Trail v n)] -- * -> * -> * -- we can only do Typeable1 (Path v). This is why the instance cannot be -- derived. -instance Typeable1 (Path v) where - typeOf1 _ = mkTyConApp pathTyCon [] - -pathTyCon :: TyCon -pathTyCon = mkTyCon3 "diagrams-lib" "Diagrams.Path" "Path" +instance forall v. Typeable1 v => Typeable1 (Trail v) where + typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.Path" "Path") [] `mkAppTy` + typeOf1 (undefined :: v n) #endif - instance Wrapped (Path v n) where type Unwrapped (Path v n) = [Located (Trail v n)] _Wrapped' = iso (\(Path x) -> x) Path diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index 2c0f25b2..f6620b2a 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -55,11 +56,9 @@ data Camera l n = Camera deriving Typeable #else -instance Typeable1 (Camera l) where - typeOf1 _ = mkTyConApp cameraTyCon [] - -cameraTyCon :: TyCon -cameraTyCon = mkTyCon3 "diagrams-lib" "Diagrams.ThreeD.Camera" "Camera" +instance forall l. Typeable1 l => Typeable1 (Camera l) where + typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.ThreeD.Camera" "Camera") [] `mkAppTy` + typeOf1 (undefined :: l n) #endif type instance V (Camera l n) = V3 @@ -101,7 +100,7 @@ type instance V (OrthoLens n) = V3 type instance N (OrthoLens n) = n instance CameraLens OrthoLens where - aspect (OrthoLens h v) = h / v + aspect (OrthoLens h v) = h / v instance Num n => Transformable (Camera l n) where transform t (Camera p f u l) = From dde9d027bdd48b500419120330b0fd2fc0296563 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Tue, 16 Sep 2014 20:12:09 +0100 Subject: [PATCH 54/58] Call it Path. --- src/Diagrams/Path.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 8740cf99..ec5e4835 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -102,7 +102,7 @@ newtype Path v n = Path [Located (Trail v n)] -- * -> * -> * -- we can only do Typeable1 (Path v). This is why the instance cannot be -- derived. -instance forall v. Typeable1 v => Typeable1 (Trail v) where +instance forall v. Typeable1 v => Typeable1 (Path v) where typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.Path" "Path") [] `mkAppTy` typeOf1 (undefined :: v n) #endif From 63e92b155665e072b1b8a9380b1ac32488dfca40 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Sat, 20 Sep 2014 15:07:26 -0400 Subject: [PATCH 55/58] add Enum instance for Angle --- src/Diagrams/Angle.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index fa3fb42f..b345c852 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Angle @@ -48,7 +49,7 @@ import Linear.Vector -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. newtype Angle n = Radians n - deriving (Read, Show, Eq, Ord, Functor) + deriving (Read, Show, Eq, Ord, Enum, Functor) type instance N (Angle n) = n From 0268582f47f99171af84a1c48a0fd52a9603f232 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sun, 5 Oct 2014 01:49:38 +0000 Subject: [PATCH 56/58] document semantics of Lights fix change of semantics made during linear migration --- src/Diagrams/ThreeD/Light.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs index 56e76022..cdc63258 100644 --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -26,15 +26,17 @@ import Diagrams.Core import Diagrams.Direction import Diagrams.ThreeD.Types -import Linear.Affine - +-- | A @PointLight@ radiates uniformly in all directions from a given +-- point. data PointLight n = PointLight (Point V3 n) (Colour Double) deriving Typeable type instance V (PointLight n) = V3 type instance N (PointLight n) = n -data ParallelLight n = ParallelLight (Point V3 n) (Colour Double) +-- | A @ParallelLight@ casts parallel rays in the specified direction, +-- from some distant location outside the scene. +data ParallelLight n = ParallelLight (V3 n) (Colour Double) deriving Typeable type instance V (ParallelLight n) = V3 @@ -59,5 +61,5 @@ parallelLight :: (Typeable n, OrderedField n, Renderable (ParallelLight n) b) => Direction V3 n -- ^ The direction in which the light travels. -> Colour Double -- ^ The color of the light. -> Diagram b V3 n -parallelLight d c = mkQD (Prim $ ParallelLight (P $ fromDirection d) c) +parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c) mempty mempty mempty (Query . const . Any $ False) From 65cfee70bd52ba2aa23498b38f2565824ec45d43 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 6 Oct 2014 13:38:57 +0100 Subject: [PATCH 57/58] Add Diagrams.ThreeD to prelude. --- src/Diagrams/Prelude.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index eefa0483..dfce8da3 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -96,6 +96,9 @@ module Diagrams.Prelude -- diagrams. , module Diagrams.TwoD + -- | Extra things for three-dimensional diagrams. + , module Diagrams.ThreeD + -- | Tools for making animations. , module Diagrams.Animation @@ -152,6 +155,7 @@ import Diagrams.Trail hiding (linePoints, loopPoints, trai import Diagrams.TrailLike import Diagrams.Transform import Diagrams.TwoD +import Diagrams.ThreeD import Diagrams.Util import Control.Applicative From d92afe25ccbf18eb8ea6830ed949ef42a649ca17 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 6 Oct 2014 12:54:52 +0000 Subject: [PATCH 58/58] cabal: conservative upper bound on linear --- diagrams-lib.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 0f90f264..7755fb9c 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -109,7 +109,7 @@ Library safe >= 0.2 && < 0.4, JuicyPixels >= 3.1.5 && < 3.2, hashable >= 1.1 && < 1.3, - linear >= 1.10 && < 2.0, + linear >= 1.10 && < 1.11, adjunctions >= 4.0 && < 5.0, distributive >=0.2.2 && < 1.0, process >= 1.1 && < 1.3,