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/diagrams-lib.cabal b/diagrams-lib.cabal index 75fc88b9..7755fb9c 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -26,57 +26,57 @@ Source-repository head Library Exposed-modules: Diagrams.Prelude, - Diagrams.Prelude.ThreeD, 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.Vector, + Diagrams.ThreeD, Diagrams.ThreeD.Align, Diagrams.ThreeD.Attributes, Diagrams.ThreeD.Camera, @@ -86,7 +86,6 @@ Library Diagrams.ThreeD.Transform, Diagrams.ThreeD.Types, Diagrams.ThreeD.Vector, - Diagrams.ThreeD, Diagrams.Animation, Diagrams.Animation.Active, Diagrams.Util, @@ -99,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, @@ -113,6 +109,9 @@ Library safe >= 0.2 && < 0.4, JuicyPixels >= 3.1.5 && < 3.2, hashable >= 1.1 && < 1.3, + linear >= 1.10 && < 1.11, + adjunctions >= 4.0 && < 5.0, + distributive >=0.2.2 && < 1.0, process >= 1.1 && < 1.3, fsnotify >= 0.1 && < 0.2, directory >= 1.2 && < 1.3, @@ -123,3 +122,8 @@ Library Hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 + other-extensions: BangPatterns, CPP, DefaultSignatures, DeriveDataTypeable, + DeriveFunctor, DeriveGeneric, EmptyDataDecls, ExistentialQuantification, + GADTs, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, Rank2Types, + RankNTypes, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, + TypeOperators, TypeSynonymInstances, UndecidableInstances, ViewPatterns 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 (( (V a -> a -> Point (V a)) -> V a -> Scalar (V a) -> a -> a + 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 :: V a -> a -> Point (V a) + defaultBoundary :: (V a ~ v, N a ~ 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 :: (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 :: ( 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 :: (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) + (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 -- `alignBy'`. -envelopeBoundary :: Enveloped a => V a -> a -> Point (V a) +envelopeBoundary :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Point v n envelopeBoundary = envelopeP -traceBoundary :: Traced a => V a -> a -> Point (V a) +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 - :: (F.Foldable f, InnerSpace (V a), Ord (Scalar (V a))) - => (V a -> a -> Point (V a)) -> (V a -> f a -> Point (V a)) + :: (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 (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 (V b ~ v, N b ~ 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 (V b ~ v, N b ~ 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 (V b ~ v, N b ~ 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 +119,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 (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 -- | @align v@ aligns an enveloped object along the edge in the @@ -127,42 +128,42 @@ 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 :: (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 :: (Alignable a, Traced a, HasOrigin a, Num (Scalar (V a)), Fractional (Scalar (V a))) - => V a -> Scalar (V a) -> a -> a +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 :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a) - => V a -> a -> a -snug v = snugBy v 1 +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 :: ( Alignable a, HasOrigin a, Num (Scalar (V a)) - , Fractional (Scalar (V a))) => V a -> 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 :: ( HasLinearMap (V a), Alignable a, HasOrigin a, Num (Scalar (V a)), - Fractional (Scalar (V a))) => a -> a -center d = applyAll fs d +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 - :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a) - => V a -> a -> a -snugCenterV v = (alignBy' traceBoundary) v 0 + :: (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 :: ( 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 :: (V a ~ v, N a ~ n, HasLinearMap v, Alignable a, HasOrigin a, Fractional n, Traced a) + => a -> a +snugCenter = applyAll fs where - fs = map snugCenterV basis \ No newline at end of file + fs = map snugCenterV basis + +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} + diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 5fba3f72..b345c852 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Angle @@ -8,119 +9,171 @@ -- 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, fullCircle, 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 -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.Metric +import Linear.Vector -- | 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) +-- they are represented in radians. +newtype Angle n = Radians n + deriving (Read, Show, Eq, Ord, Enum, Functor) -instance Semigroup Angle where - (<>) = (^+^) +type instance N (Angle n) = n -instance Monoid Angle where - mappend = (<>) - mempty = Radians 0 +instance Applicative Angle where + pure = Radians + {-# INLINE pure #-} + Radians f <*> Radians x = Radians (f x) + {-# INLINE (<*>) #-} -instance VectorSpace Angle where - type Scalar Angle = Double - s *^ Radians t = Radians (s*t) +instance Additive Angle where + zero = pure 0 + {-# INLINE zero #-} + +instance Num n => Semigroup (Angle n) where + (<>) = (^+^) + {-# INLINE (<>) #-} + +instance Num n => Monoid (Angle n) where + mappend = (<>) + mempty = Radians 0 -- | 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@. 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@. -turn :: Iso' Angle Double -turn = iso (\(Radians r) -> r/2/pi) (Radians . (*(2*pi))) +-- @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 :: Iso' Angle Double -deg = iso (\(Radians r) -> r/2/pi*360) (Radians . (*(2*pi/360))) +-- ^. 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 :: Angle +fullTurn :: Floating v => Angle v fullTurn = 1 @@ turn --- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. -fullCircle :: Angle -fullCircle = fullTurn +-- | An angle representing a half turn. +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 :: Angle -> Angle -> Double -angleRatio a b = (a^.rad) / (b^.rad) +angleRatio :: Floating n => Angle n -> Angle n -> n +angleRatio a b = (a ^. rad) / (b ^. rad) -- | The sine of the given @Angle@. -sinA :: Angle -> Double +sinA :: Floating n => Angle n -> n sinA (Radians r) = sin r -- | The cosine of the given @Angle@. -cosA :: Angle -> Double +cosA :: Floating n => Angle n -> n cosA (Radians r) = cos r -- | The tangent function of the given @Angle@. -tanA :: Angle -> Double +tanA :: Floating n => Angle n -> n tanA (Radians r) = tan r -- | The @Angle@ with the given sine. -asinA :: Double -> Angle +asinA :: Floating n => n -> Angle n asinA = Radians . asin -- | The @Angle@ with the given cosine. -acosA :: Double -> Angle +acosA :: Floating n => n -> Angle n acosA = Radians . acos -- | The @Angle@ with the given tangent. -atanA :: Double -> Angle +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 :: Double -> Double -> Angle -atan2A n d = Radians $ atan2 n d +-- | @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 -- | @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 infixl 5 @@ --- | compute the positive angle between the two vectors in their common plane -angleBetween :: (InnerSpace v, Scalar v ~ Double) => v -> v -> Angle -angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad +-- | 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 it 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 :: Lens' t Angle + _theta :: RealFloat n => Lens' (t n) (Angle n) + +-- | 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) + +-- Point instances +instance HasTheta v => HasTheta (Point v) where + _theta = lensP . _theta + {-# INLINE _theta #-} + +instance HasPhi v => HasPhi (Point v) where + _phi = lensP . _phi + {-# INLINE _phi #-} + diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs index a1cac8ce..6bd1d54c 100644 --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -29,6 +29,11 @@ module Diagrams.Animation ) where +import Control.Applicative ((<$>)) +import Data.Active +import Data.Foldable (foldMap) +import Data.Semigroup + import Diagrams.Core import Diagrams.Animation.Active () @@ -38,18 +43,13 @@ import Diagrams.TrailLike import Diagrams.TwoD.Shapes import Diagrams.TwoD.Types -import Data.Active -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 @@ -58,7 +58,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 @@ -90,16 +90,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, HasLinearMap 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, HasLinearMap 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 @@ -109,18 +109,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 ~ R2 - , Monoid' m) - => QAnimation b R2 m -> t +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 -- | 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 - , Monoid' m) - => Rational -> QAnimation b R2 m -> t +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 | otherwise = boxFit (foldMap boundingBox results) (rect 1 1) diff --git a/src/Diagrams/Animation/Active.hs b/src/Diagrams/Animation/Active.hs index 16017150..949884e2 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 @@ -95,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/Attributes.hs b/src/Diagrams/Attributes.hs index f08ae854..46ae840f 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 @@ -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) @@ -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 @@ -167,14 +167,13 @@ 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. | 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) @@ -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) @@ -209,4 +207,5 @@ 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/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/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index cb94a0f1..6ddf075e 100644 --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -358,30 +358,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 @@ -487,11 +487,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 -- @ -- @@ -511,7 +511,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 @@ -529,7 +529,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@. @@ -543,11 +543,12 @@ 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 :: - (opts -> Diagram b v -> IO ()) + (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 @@ -558,7 +559,7 @@ defaultAnimMainRender renderF 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 diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index de0ce1f2..4763b2fd 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# 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 @@ -34,299 +34,231 @@ module Diagrams.BoundingBox , isEmptyBox , getCorners, getAllCorners , boxExtents, boxTransform, boxFit - , contains, contains' + , contains, contains', boundingBoxQuery , inside, inside', outside, outside' -- * Operations on bounding boxes , union, intersection ) where -import Control.Applicative ((<$>)) -import qualified Data.Foldable as F -import Data.Map (Map, fromDistinctAscList, fromList, - toAscList, toList) - +import Data.Foldable as F 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) -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.V (V) +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 -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, Functor) + +type instance V (NonEmptyBoundingBox v n) = v +type instance N (NonEmptyBoundingBox v n) = n -fromNonEmpty :: NonEmptyBoundingBox v -> BoundingBox v +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, 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) +-- 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) -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 +-- 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) . 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 :: (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 - 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] +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) -- | 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 + :: (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 -- | 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) + +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 - :: (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 diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index babd14c1..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,22 +38,15 @@ module Diagrams.Combinators ) where -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) -#if __GLASGOW_HASKELL__ < 707 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)) @@ -62,6 +54,10 @@ import Diagrams.Direction import Diagrams.Segment (straight) import Diagrams.Util +import Linear.Affine +import Linear.Metric +import Linear.Vector + ------------------------------------------------------------ -- Working with envelopes ------------------------------------------------------------ @@ -79,19 +75,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 :: (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 :: (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 :: (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 :: (Backend b (V a), Typeable (V a), Enveloped a, Traced a, Monoid' m) => a -> QDiagram b (V a) 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 @@ -100,21 +96,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 @@ -127,12 +121,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 @@ -153,9 +143,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, 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 @@ -166,24 +155,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, 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, 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 @@ -192,8 +179,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` @@ -233,7 +220,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 @@ -241,8 +228,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, V a ~ v, N a ~ n, Metric v, Floating n) + => Direction v n -> a -> a -> a atDirection = beside . fromDirection ------------------------------------------------------------ @@ -259,7 +246,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 @@ -271,12 +258,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 :: (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 :: (HasOrigin a, Monoid' a) => [Point (V a)] -> [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. @@ -296,9 +283,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, @@ -312,24 +299,22 @@ data CatOpts v = CatOpts { _catMethod :: CatMethod -- this is not a problem when using the 'sep' lens, as its type is -- more restricted. -makeLensesWith - ( lensRules & generateSignatures .~ False) - ''CatOpts +makeLensesWith (lensRules & generateSignatures .~ False) ''CatOpts -- | 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 - def = CatOpts { _catMethod = Cat - , _sep = 0 - , catOptsvProxy__ = Proxy +instance Num n => Default (CatOpts n) where + def = CatOpts { _catMethod = Cat + , _sep = 0 + , catOptsvProxy = Proxy } -- | @cat v@ positions a list of objects so that their local origins @@ -340,10 +325,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 , V a ~ v, N a ~ n, Metric v, OrderedField n) + => v n -> [a] -> a cat v = cat' v def -- | Like 'cat', but taking an extra 'CatOpts' arguments allowing the @@ -363,13 +346,11 @@ 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, 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) - 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/Coordinates.hs b/src/Diagrams/Coordinates.hs index 11065a61..b5af4775 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Coordinates @@ -14,23 +16,12 @@ module Diagrams.Coordinates ( (:&)(..), Coordinates(..) - - -- * Lenses for particular axes - , HasX(..), HasY(..), HasZ(..), HasR(..) ) where -import Control.Lens (Lens') - -import Diagrams.Core.Points - --- | A pair of values, with a convenient infix (left-associative) --- data constructor. -data a :& b = a :& b - deriving (Eq, Ord, Show) - -infixl 7 :& +import Diagrams.Points +import Linear (V2 (..), V3 (..), V4 (..)) -- | Types which are instances of the @Coordinates@ class can be -- constructed using '^&' (for example, a three-dimensional vector @@ -60,7 +51,7 @@ class Coordinates c where -- -- @ -- 2 ^& 3 :: P2 - -- 3 ^& 5 ^& 6 :: R3 + -- 3 ^& 5 ^& 6 :: V3 -- @ -- -- Note that @^&@ is left-associative. @@ -76,6 +67,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 @@ -83,7 +90,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 @@ -99,30 +106,40 @@ 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 => 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) + 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 Double +-- 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 --- | The class of types with at least two coordinates, the second called _y. -class HasY t where - _y :: Lens' t Double +instance Coordinates (V4 n) where + type FinalCoord (V4 n) = n + type PrevDim (V4 n) = V3 n + type Decomposition (V4 n) = n :& n :& n :& n --- | The class of types with at least three coordinates, the third called _z. -class HasZ t where - _z :: Lens' t Double + 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 Double diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs index 651b4f9a..ddbe506d 100644 --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -23,16 +23,17 @@ module Diagrams.CubicSpline cubicSpline ) where +import Control.Lens (view) + 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 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 +49,15 @@ import Data.VectorSpace -- > # centerXY # pad 1.1 -- -- For more information, see . -cubicSpline :: (TrailLike t, Fractional (V t)) => Bool -> [Point (V t)] -> 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 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/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/Deform.hs b/src/Diagrams/Deform.hs index c5b9049e..446eceb7 100644 --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -5,15 +5,15 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Diagrams.Deform (Deformation(..), Deformable(..), asDeformation) where +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 +22,10 @@ import Diagrams.Path import Diagrams.Segment import Diagrams.Trail +import Linear.Affine +import Linear.Metric +import Linear.Vector + ------------------------------------------------------------ -- Deformations @@ -30,41 +34,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' :: (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@ - -- 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 +77,46 @@ 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, 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] + | 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, 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 :: (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) + => 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, OrderedField 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, 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 effb9cab..ed1fff05 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,12 @@ module Diagrams.Direction , angleBetweenDirs ) where -import Control.Lens (Iso', iso) -import Data.VectorSpace +import Control.Lens (Iso', iso) -import Diagrams.Angle -import Diagrams.Core +import Diagrams.Angle +import Diagrams.Core + +import Linear.Metric -------------------------------------------------------------------------------- -- Direction @@ -32,29 +33,38 @@ 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 +newtype Direction v n = Direction (v n) + deriving (Read, Show, Eq, Ord) -- todo: special instances + +type instance V (Direction v n) = v +type instance N (Direction v n) = n -type instance V (Direction v) = v +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 (Transformable v, V (Direction v) ~ V v) => Transformable (Direction v) where - transform t (Direction v) = Direction (transform t v) +instance HasTheta v => HasTheta (Direction v) where + _theta = _Dir . _theta + +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) => Direction v n -> v n +fromDirection (Direction v) = signorm 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 :: (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 6410c0e1..e767fc5e 100644 --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -19,14 +19,15 @@ module Diagrams.Located ( Located - , at, viewLoc, unLoc, loc, mapLoc, located + , at, viewLoc, unLoc, loc, mapLoc, located, ) where import Control.Lens (Lens) -import Data.AffineSpace import Data.Functor ((<$>)) -import Data.VectorSpace + +import Linear.Affine +import Linear.Vector import Diagrams.Core import Diagrams.Core.Points () @@ -49,27 +50,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 +84,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 +122,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 +130,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 (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) @@ -135,22 +138,19 @@ 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 (V a ~ v, N a ~ n, Codomain a ~ v, Additive v, Num n, EndValues a) => EndValues (Located a) -instance ( Codomain a ~ V a, Fractional (Scalar (V a)), AdditiveGroup (V a) - , 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 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)) - , 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) l = arcLengthToParam eps a l + arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a + arcLengthToParam eps (Loc _ a) = arcLengthToParam eps a + diff --git a/src/Diagrams/Names.hs b/src/Diagrams/Names.hs index 9e617645..b79380ed 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.hs b/src/Diagrams/Parametric.hs index 05ae5782..709e70d3 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 qualified Numeric.Interval.Kaucher as I +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,16 +46,16 @@ 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) + 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 -> Scalar (V p) + domainUpper :: p -> N p - default domainUpper :: Num (Scalar (V p)) => p -> Scalar (V p) + default domainUpper :: Num n => p -> n domainUpper = const 1 -- | Type class for querying the values of a parametric object at the @@ -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,8 +127,8 @@ 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 :: 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. @@ -148,18 +146,18 @@ 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 :: N p -> p -> N p + 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 -> Scalar (V p) - default stdArcLength :: Fractional (Scalar (V p)) => p -> Scalar (V p) + stdArcLength :: p -> N p + default stdArcLength :: Fractional (N p) => p -> N p stdArcLength = arcLength stdTolerance -- | @'arcLengthToParam' eps s l@ converts the absolute arc length @@ -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 :: p -> N p -> N p + default stdArcLengthToParam :: Fractional (N p) => p -> N p -> N p stdArcLengthToParam = arcLengthToParam stdTolerance + diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs index 10b90437..e809af92 100644 --- a/src/Diagrams/Parametric/Adjust.hs +++ b/src/Diagrams/Parametric/Adjust.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -21,23 +21,23 @@ module Diagrams.Parametric.Adjust ) where -import Control.Lens (makeLensesWith, lensRules, generateSignatures, (^.), (&), (.~), Lens') +import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, (&), + (.~), (^.)) 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 - -- (use a negative parameter to shrink) - | ByAbsolute (Scalar v) -- ^ Extend by the given arc length - -- (use a negative length to shrink) - | ToAbsolute (Scalar v) -- ^ Extend or shrink to the given - -- arc length +data AdjustMethod n = ByParam n -- ^ Extend by the given parameter value + -- (use a negative parameter to shrink) + | ByAbsolute n -- ^ Extend by the given arc length + -- (use a negative length to shrink) + | ToAbsolute n -- ^ Extend or shrink to the given + -- arc length -- | Which side of a segment, trail, or path should be adjusted? data AdjustSide = Start -- ^ Adjust only the beginning @@ -46,43 +46,41 @@ 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 & generateSignatures .~ False) - ''AdjustOpts +makeLensesWith (lensRules & generateSignatures .~ False) ''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 - def = AO { _adjMethod = def - , _adjSide = def - , _adjEps = stdTolerance - , adjOptsvProxy__ = Proxy +instance Fractional n => Default (AdjustOpts v n) where + 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 -- the adjustment should be performed; see 'AdjustOpts'. -adjust :: (DomainBounds a, Sectionable a, HasArcLength a, Fractional (Scalar (V a))) - => a -> AdjustOpts (V a) -> a +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) (if opts^.adjSide == Start then domainUpper s else domainUpper s - getParam (reverseDomain s)) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index fd5a1b57..ec5e4835 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -1,12 +1,13 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} +#endif {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -58,11 +59,16 @@ 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 import Diagrams.Core -import Diagrams.Core.Points () import Diagrams.Located import Diagrams.Points import Diagrams.Segment @@ -70,14 +76,9 @@ 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 Data.AffineSpace -import qualified Data.Foldable as F -import Data.List (partition) -import Data.Semigroup -import Data.VectorSpace +import Linear.Affine +import Linear.Metric +import Linear.Vector ------------------------------------------------------------ -- Paths ------------------------------------------------- @@ -87,63 +88,69 @@ 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)] - deriving (Semigroup, Monoid, Typeable) - -instance Wrapped (Path v) where - type Unwrapped (Path v) = [Located (Trail v)] - _Wrapped' = iso (\(Path x) -> x) Path - -instance Rewrapped (Path v) (Path v') +newtype Path v n = Path [Located (Trail v n)] + deriving (Semigroup, Monoid +#if __GLASGOW_HASKELL__ >= 707 + , Typeable +#endif + ) + +#if __GLASGOW_HASKELL__ < 707 +-- 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 forall v. Typeable1 v => Typeable1 (Path 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 + +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] - -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 (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 +163,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 +182,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 :: (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: -- 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,10 +219,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/Points.hs b/src/Diagrams/Points.hs index 7bf3ff7b..e8b15469 100644 --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Points @@ -9,28 +6,43 @@ -- 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". -- ----------------------------------------------------------------------------- module Diagrams.Points ( -- * Points - Point, origin, (*.) + Point (..), origin, (*.) -- * Point-related utilities , centroid , pointDiagram - + , _pIso, lensP + , project ) where -import Diagrams.Core (pointDiagram) +import Diagrams.Core (pointDiagram) import Diagrams.Core.Points -import Control.Arrow ((&&&)) +import Control.Lens (Iso', iso) + +import Data.Foldable as F +import Linear.Affine +import Linear.Metric +import Linear.Vector -import Data.AffineSpace.Point -import Data.VectorSpace +-- Point v <-> v +_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 #-} + +-- | @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/Prelude.hs b/src/Diagrams/Prelude.hs index ca39ffb9..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 @@ -111,9 +114,11 @@ module Diagrams.Prelude -- 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 computing with dot products and norm. + , module Linear.Metric -- | For working with 'Active' (i.e. animated) things. , module Data.Active @@ -146,17 +151,21 @@ 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.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 ((&), (.~), (%~)) + +import Linear.Affine +import Linear.Metric +import Linear.Vector + diff --git a/src/Diagrams/Prelude/ThreeD.hs b/src/Diagrams/Prelude/ThreeD.hs deleted file mode 100644 index 9bce4ca0..00000000 --- a/src/Diagrams/Prelude/ThreeD.hs +++ /dev/null @@ -1,163 +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 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 (trailPoints, loopPoints, linePoints) -import Diagrams.TrailLike -import Diagrams.Transform -import Diagrams.ThreeD -import Diagrams.Util - -import Control.Applicative -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/Query.hs b/src/Diagrams/Query.hs index 3f670d4c..a0490b34 100644 --- a/src/Diagrams/Query.hs +++ b/src/Diagrams/Query.hs @@ -17,3 +17,4 @@ module Diagrams.Query ) where import Diagrams.Core + diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index d9284cc8..c6663566 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -11,7 +11,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -42,11 +41,11 @@ module Diagrams.Segment -- * Segment offsets - , Offset(..), segOffset + , Offset(..) , segOffset -- * Constructing and modifying segments - , Segment(..), straight, bezier3, bézier3, reverseSegment + , Segment(..), straight, bezier3, bézier3, reverseSegment, mapSegmentVectors -- * Fixed (absolutely located) segments , FixedSegment(..) @@ -64,16 +63,19 @@ module Diagrams.Segment ) where -import Control.Lens (makeLenses, Wrapped(..), Rewrapped, iso, op) -import Control.Applicative (liftA2) -import Data.AffineSpace +import Control.Lens (Rewrapped, Traversal, Wrapped (..), iso, makeLenses, op, + over) 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 Numeric.Interval.Kaucher (Interval (..)) +import qualified Numeric.Interval.Kaucher as I +import Linear.Affine +import Linear.Metric +import Linear.Vector + +import Control.Applicative import Diagrams.Core import Diagrams.Located import Diagrams.Parametric @@ -102,22 +104,29 @@ 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) + +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) = 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 --------------------------------- @@ -130,11 +139,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, @@ -143,21 +152,38 @@ data Segment c v 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. (?) -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 = mapSegmentVectors . apply -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 @@ -169,37 +195,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 @@ -230,61 +256,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 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 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 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 -- | 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 @@ -308,13 +334,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) @@ -327,7 +354,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) @@ -340,7 +367,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 @@ -350,56 +377,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 p2 p1 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 c1 x1 + p12 = lerp t c2 c1 + p13 = lerp t x2 c2 - p21 = alerp p11 p12 t - p22 = alerp p12 p13 t + p21 = lerp t p12 p11 + p22 = lerp t p13 p12 - p3 = alerp p21 p22 t + p3 = lerp t p22 p21 -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 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 = alerp p0 c1 t - p = alerp c1 c2 t - d = alerp c2 p1 t + a = lerp t c1 p0 + p = lerp t c2 c1 + d = lerp t p1 c2 -- second round - b = alerp a p t - c = alerp p d t + b = lerp t p a + c = lerp t d p -- final round - cut = alerp b c t + cut = lerp t c b reverseDomain (FLinear p0 p1) = FLinear p1 p0 reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0 @@ -428,70 +455,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 @@ -500,32 +526,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/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 5d0df5c3..e032d042 100644 --- a/src/Diagrams/Tangent.hs +++ b/src/Diagrams/Tangent.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -18,20 +19,19 @@ module Diagrams.Tangent ( tangentAtParam , tangentAtStart , tangentAtEnd - , normalAtParam - , normalAtStart - , normalAtEnd + -- , normalAtParam + -- , normalAtStart + -- , normalAtEnd , Tangent(..) ) where -import Data.VectorSpace import Diagrams.Core import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment -import Diagrams.TwoD.Types (R2) -import Diagrams.TwoD.Vector (perp) + +import Linear.Vector ------------------------------------------------------------ -- Tangent @@ -42,6 +42,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 @@ -69,30 +70,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 @@ -114,23 +115,23 @@ instance (VectorSpace v, Num (Scalar v)) -- * @Located (Trail R2) -> Double -> P2@ -- -- See the instances listed for the 'Tangent' newtype for more. -normalAtParam - :: (Codomain (Tangent t) ~ R2, Parametric (Tangent t)) - => t -> Scalar (V t) -> R2 -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 -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 -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 :: R2 -> R2 -normize = negateV . perp . normalized +-- 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 7e338ade..a799a31b 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/Align.hs b/src/Diagrams/ThreeD/Align.hs index 67b1ddf0..eae538d9 100644 --- a/src/Diagrams/ThreeD/Align.hs +++ b/src/Diagrams/ThreeD/Align.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Align @@ -44,166 +44,119 @@ import Diagrams.Core import Diagrams.Align import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector +import Diagrams.TwoD.Align -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 ~ R3) => a -> a -alignXMin = align (negateV unitX) +-- positive x-values. +alignXMin :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R1 v, Additive v, Fractional n) => a -> a +alignXMin = align unit_X -snugXMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a -snugXMin = snug (negateV unitX) +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 :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignXMax :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R1 v, Additive v, Fractional n) => a -> a alignXMax = align unitX -snugXMax :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> 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 :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a +alignYMin = align unit_Y + +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 :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignYMax :: (V a ~ v, N a ~ 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 (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> 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 unitY so that all points have --- positive y-values. -alignYMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a -alignYMin = align (negateV unitY) -snugYMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a -snugYMin = snug (negateV unitY) +-- | Translate the diagram along unitZ so that all points have +-- positive z-values. +alignZMin :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a +alignZMin = align unit_Z + +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 :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignZMax :: (V a ~ v, N a ~ 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 (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> 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 --- | Translate the diagram along unitZ so that all points have --- positive z-values. -alignZMin :: (Alignable a, HasOrigin a, V a ~ R3) => 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 -snugZMin = snug (negateV 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, V a ~ R3) => Double -> 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 -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 = alignBy unitY - -snugY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => Double -> 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 :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => n -> a -> a alignZ = alignBy unitZ -snugZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => Double -> a -> a +-- | See the documentation for 'alignZ'. +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 X-axis. -centerX :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a -centerX = alignBy unitX 0 - -snugCenterX :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => 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 = alignBy unitY 0 - -snugCenterY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => 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 = alignBy unitZ 0 +centerZ :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a +centerZ = alignBy unitZ 0 -snugCenterZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> 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 Y-axes. -centerXY :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a -centerXY = centerX . centerY - -snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> a -snugCenterXY = snugCenterX . snugCenterY - - -- | Center along both the X- and Z-axes. -centerXZ :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerXZ :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a centerXZ = centerX . centerZ -snugCenterXZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> 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 :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerYZ :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R3 v, Additive v, Fractional n) => a -> a centerYZ = centerZ . centerY -snugCenterYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> 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 :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> 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 :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R3) => a -> 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/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs index 52c013ef..8e53e3df 100644 --- a/src/Diagrams/ThreeD/Attributes.hs +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Attributes @@ -25,18 +28,19 @@ 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. newtype SurfaceColor = SurfaceColor (Last (Colour Double)) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup) + instance AttributeClass SurfaceColor surfaceColor :: Iso' SurfaceColor (Colour Double) @@ -52,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 @@ -69,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 @@ -87,13 +93,14 @@ 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 newtype Highlight = Highlight (Last Specular) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup) + instance AttributeClass Highlight _Highlight :: Iso' Highlight Specular @@ -102,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 75b55cc6..f6620b2a 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -30,82 +34,102 @@ module Diagrams.ThreeD.Camera where import Control.Lens (makeLenses) -import Data.Cross import Data.Monoid import Data.Typeable import Diagrams.Angle import Diagrams.Core import Diagrams.Direction -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 :: P3 - , forward :: R3 - , up :: R3 - , lens :: l +data Camera l n = Camera + { camLoc :: Point V3 n + , forward :: V3 n + , up :: V3 n + , lens :: l n } +#if __GLASGOW_HASKELL__ >= 707 deriving Typeable +#else + +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 +type instance N (Camera l n) = n + +#if __GLASGOW_HASKELL__ > 707 class Typeable l => CameraLens l where - -- | The natural aspect ratio of the projection. - aspect :: l -> Double +#else +class Typeable1 l => CameraLens l where +#endif + -- | The natural aspect ratio of the projection. + aspect :: Floating n => l n -> n -- | A perspective projection -data PerspectiveLens = PerspectiveLens - { _horizontalFieldOfView :: Angle -- ^ Horizontal field of view. - , _verticalFieldOfView :: Angle -- ^ 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 n) = V3 +type instance N (PerspectiveLens n) = n + instance CameraLens PerspectiveLens where - aspect (PerspectiveLens h v) = angleRatio h v + aspect (PerspectiveLens h v) = angleRatio h v -- | An orthographic projection -data OrthoLens = OrthoLens - { _orthoWidth :: Double -- ^ Width - , _orthoHeight :: Double -- ^ Height +data OrthoLens n = OrthoLens + { _orthoWidth :: n -- ^ Width + , _orthoHeight :: n -- ^ Height } deriving Typeable makeLenses ''OrthoLens -instance CameraLens OrthoLens where - aspect (OrthoLens h v) = h / v +type instance V (OrthoLens n) = V3 +type instance N (OrthoLens n) = n -type instance V (Camera l) = R3 +instance CameraLens OrthoLens where + aspect (OrthoLens h v) = h / v -instance 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 Renderable (Camera l) NullBackend where - render _ _ = mempty +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 :: (Backend b R3, Renderable (Camera PerspectiveLens) b) => Diagram b R3 +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 :: (CameraLens l, Backend b R3, Renderable (Camera l) b) => - l -> Diagram b R3 +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) +{-# ANN facing_ZCamera ("HLint: ignore Use camelCase" :: String) #-} -mm50, mm50Wide, mm50Narrow :: PerspectiveLens +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. @@ -116,21 +140,22 @@ 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 :: Camera l -> Direction R3 +camForward :: Fractional n => Camera l n -> Direction V3 n camForward = direction . forward -camUp :: Camera l -> Direction R3 +camUp :: Fractional n => Camera l n -> Direction V3 n camUp = direction . up -camRight :: Camera l -> Direction R3 +camRight :: Fractional n => Camera l n -> Direction V3 n camRight c = direction right where - right = cross3 (forward c) (up c) + right = cross (forward c) (up c) -camLens :: Camera l -> l +camLens :: Camera l n -> l n camLens = lens -camAspect :: CameraLens l => Camera l -> Double +camAspect :: (Floating n, CameraLens l) => Camera l n -> n camAspect = aspect . camLens + diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs index 3fb13d30..dd02e06a 100644 --- a/src/Diagrams/ThreeD/Deform.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -1,51 +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 Control.Lens -import Diagrams.Deform +import Diagrams.Deform +import Diagrams.TwoD.Deform -import Diagrams.Coordinates -import Diagrams.ThreeD.Types - --- | The parallel projection onto the plane x=0 -parallelX0 :: Deformation R3 -parallelX0 = Deformation (& _x .~ 0) - --- | The perspective division onto the plane x=1 along lines going --- through the origin. -perspectiveX1 :: Deformation R3 -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 = Deformation (& _y .~ 0) - --- | The perspective division onto the plane y=1 along lines going --- through the origin. -perspectiveY1 :: Deformation R3 -perspectiveY1 = Deformation (\p -> let y = p^._y in - p & _x //~ y & _y .~ 1 & _z //~ y ) +import Linear.V3 +import Linear.Vector -- | The parallel projection onto the plane z=0 -parallelZ0 :: Deformation R3 -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 :: Deformation R3 -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 :: Deformation R3 -facingX = Deformation (\v -> v & _y //~ (v^._x) & _z //~ (v^._x)) +-- through the origin. +perspectiveZ1 :: (R3 v, Functor v, Fractional n) => Deformation v n +perspectiveZ1 = Deformation $ \p -> p ^/ (p ^. _x) -facingY :: Deformation R3 -facingY = Deformation (\v -> v & _x //~ (v^._y) & _z //~ (v^._y)) +facingZ :: (R3 v, Functor v, Fractional n) => Deformation v n +facingZ = Deformation $ + \p -> let z = p ^. _z + in p ^/ z & _z .~ z -facingZ :: Deformation R3 -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..cdc63258 100644 --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -24,33 +26,40 @@ import Diagrams.Core import Diagrams.Direction import Diagrams.ThreeD.Types -data PointLight = PointLight P3 (Colour Double) +-- | A @PointLight@ radiates uniformly in all directions from a given +-- point. +data PointLight n = PointLight (Point V3 n) (Colour Double) deriving Typeable -data ParallelLight = ParallelLight R3 (Colour Double) +type instance V (PointLight n) = V3 +type instance N (PointLight n) = n + +-- | 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 PointLight = R3 -type instance V ParallelLight = R3 +type instance V (ParallelLight n) = V3 +type instance N (ParallelLight n) = n -instance Transformable PointLight 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 Transformable ParallelLight 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 R3, Renderable PointLight b) +pointLight :: (Typeable n, Num n, Ord n, Renderable (PointLight n) b) => Colour Double -- ^ The color of the light - -> Diagram b R3 + -> 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 R3, Renderable ParallelLight b) - => Direction R3 -- ^ The direction in which the light travels. - -> Colour Double -- ^ The color of the light. - -> Diagram b R3 +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 (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..c0b997cb 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Shapes @@ -24,56 +27,61 @@ 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 import Diagrams.Solve import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector +import Diagrams.Points -data Ellipsoid = Ellipsoid T3 +import Linear.Affine +import Linear.Metric +import Linear.Vector + +data Ellipsoid n = Ellipsoid (Transformation V3 n) deriving Typeable -type instance V Ellipsoid = R3 +type instance V (Ellipsoid n) = V3 +type instance N (Ellipsoid n) = n -instance Transformable Ellipsoid where +instance Fractional n => Transformable (Ellipsoid n) where transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) -instance Renderable Ellipsoid NullBackend where +instance Fractional n => Renderable (Ellipsoid n) 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 :: (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 / 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 + 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 = Box T3 - deriving (Typeable) +data Box n = Box (Transformation V3 n) + deriving Typeable -type instance V Box = R3 +type instance V (Box n) = V3 +type instance N (Box n) = n -instance Transformable Box where +instance Fractional n => Transformable (Box n) where transform t1 (Box t2) = Box (t1 <> t2) -instance Renderable Box 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 :: (Backend b R3, Renderable Box b) => Diagram b R3 +cube :: (Typeable n, OrderedField n, Renderable (Box n) b) => Diagram b V3 n cube = mkQD (Prim $ Box mempty) (mkEnvelope boxEnv) (mkTrace boxTrace) @@ -81,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 @@ -96,21 +104,22 @@ cube = mkQD (Prim $ Box mempty) (x, y, z) = unp3 u boxQuery = Any . range -data Frustum = Frustum Double Double T3 - deriving (Typeable) +data Frustum n = Frustum n n (Transformation V3 n) + deriving Typeable -type instance V Frustum = R3 +type instance V (Frustum n) = V3 +type instance N (Frustum n) = n -instance Transformable Frustum where - transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) +instance Fractional n => Transformable (Frustum n) where + transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) -instance Renderable Frustum NullBackend where - render _ _ = mempty +instance Fractional n => Renderable (Frustum n) 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 :: (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) @@ -120,14 +129,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 r3CylindricalIso) $ 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 @@ -138,25 +147,24 @@ 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 ^. 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 :: (Backend b R3, Renderable Frustum b) => Diagram b R3 +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 :: (Backend b R3, Renderable Frustum b) => Diagram b R3 +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 b3c86ede..ad220cfe 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -37,27 +40,29 @@ module Diagrams.ThreeD.Transform , reflectionX, reflectX , reflectionY, reflectY , reflectionZ, reflectZ - , reflectionAbout, reflectAbout + , reflectionAcross, reflectAcross -- * 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.Direction -import Diagrams.Transform import Diagrams.ThreeD.Types -import Diagrams.Coordinates +import Diagrams.Transform +import Diagrams.Points -import Control.Lens (view, (*~), (//~)) +import Control.Lens (view, (&), (*~), (.~), (//~)) import Data.Semigroup +import Diagrams.TwoD.Transform -import Data.AffineSpace -import Data.Cross -import Data.VectorSpace +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. @@ -73,53 +78,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 :: Angle -> T3 -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 :: Angle -> T3 -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 :: Angle -> T3 -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 :: - P3 -- ^ origin of rotation - -> Direction R3 -- ^ direction of rotation axis - -> Angle -- ^ angle of rotation - -> T3 -rotationAbout p d a - = mconcat [translation (negateV t), - fromLinear r (linv r), +rotationAbout + :: Floating 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 :: Double -> R3 -> R3 - 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 @@ -128,144 +129,88 @@ 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 :: 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' :: R3 -> R3 -> R3 -> T3 -pointAt' about initial final = pointAtUnit (normalized about) (normalized initial) (normalized final) +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 :: R3 -> R3 -> R3 -> T3 +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 (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 :: Double -> T3 -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 = transform . scalingX - --- | Construct a transformation which scales by the given factor in --- the y direction. -scalingY :: Double -> T3 -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 = transform . scalingY - -- | Construct a transformation which scales by the given factor in -- the z direction. -scalingZ :: Double -> T3 -scalingZ c = fromLinear s s +scalingZ :: (R3 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 :: (Transformable t, V t ~ R3) => Double -> t -> t +scaleZ :: (V t ~ v, N t ~ n, R3 v, Additive v, Transformable t, Floating n) => n -> t -> t scaleZ = transform . scalingZ -- Translation ---------------------------------------- --- | Construct a transformation which translates by the given distance --- in the x direction. -translationX :: Double -> T3 -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 = transform . translationX - --- | Construct a transformation which translates by the given distance --- in the y direction. -translationY :: Double -> T3 -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 = transform . translationY - -- | Construct a transformation which translates by the given distance -- in the z direction. -translationZ :: Double -> T3 -translationZ z = translation (0 ^& 0 ^& z) +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 :: (Transformable t, V t ~ R3) => Double -> t -> t +translateZ :: (V t ~ v, N t ~ n, R3 v, Transformable t, 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 :: T3 -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 = 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 = 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 = 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 :: (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 :: (Transformable t, V t ~ R3) => t -> t +reflectZ :: (V t ~ v, N t ~ 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 :: P3 -> R3 -> T3 -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 - --- | @reflectAbout p v@ reflects a diagram in the line determined by +reflectionAcross :: (R3 v, HasLinearMap v, Metric v, Fractional n) + => Point v n -> v n -> Transformation v n +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 + +-- | @reflectAcross p v@ reflects a diagram across the plane though -- the point @p@ and the vector @v@. -reflectAbout :: (Transformable t, V t ~ R3) => P3 -> R3 -> t -> t -reflectAbout p v = transform (reflectionAbout p v) +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) -- 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 :: T3 -> ((R3, R3, R3), R3) -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 db6136ee..dc65bee5 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,11 +1,5 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -20,177 +14,84 @@ module Diagrams.ThreeD.Types ( -- * 3D Euclidean space - R3(..), r3, unr3, mkR3 - , P3, p3, unp3, mkP3 - , T3 - , r3Iso, p3Iso + 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', Lens', iso, over - , _1, _2, _3, (^.)) +import Control.Lens (Iso', iso, _1, _2, _3) -import Diagrams.Core import Diagrams.Angle -import Diagrams.Direction -import Diagrams.TwoD.Types (R2) -import Diagrams.Coordinates +import Diagrams.Core +import Diagrams.Points +import Diagrams.TwoD.Types -import Data.AffineSpace.Point -import Data.Basis -import Data.Cross -import Data.VectorSpace +import Linear.Metric +import Linear.V3 as V ------------------------------------------------------------ -- 3D Euclidean space --- | The three-dimensional Euclidean vector space R^3. -data R3 = R3 !Double !Double !Double - deriving (Eq, Ord, Show, Read) +-- Basic R3 types -r3Iso :: Iso' R3 (Double, Double, Double) +type P3 = Point V3 + +r3Iso :: Iso' (V3 n) (n, n, n) 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 :: (n, n, n) -> V3 n +r3 (x,y,z) = V3 x y z -- | Curried version of `r3`. -mkR3 :: Double -> Double -> Double -> R3 -mkR3 = R3 +mkR3 :: n -> n -> n -> V3 n +mkR3 = V3 -- | 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 :: V3 n -> (n, n, n) +unr3 (V3 x y z) = (x,y,z) -- | Construct a 3D point from a triple of coordinates. -p3 :: (Double, Double, Double) -> P3 +p3 :: (n, n, n) -> P3 n p3 = P . r3 -- | Convert a 3D point back into a triple of coordinates. -unp3 :: P3 -> (Double, Double, Double) -unp3 = unr3 . unPoint +unp3 :: P3 n -> (n, n, n) +unp3 (P (V3 x y z)) = (x,y,z) -p3Iso :: Iso' P3 (Double, Double, Double) +p3Iso :: Iso' (P3 n) (n, n, n) p3Iso = iso unp3 p3 -- | Curried version of `r3`. -mkP3 :: Double -> Double -> Double -> P3 +mkP3 :: n -> n -> n -> P3 n mkP3 x y z = p3 (x, y, z) --- | Transformations in R^3. -type T3 = Transformation R3 +type instance V (V3 n) = V3 +type instance N (V3 n) = n -instance Transformable R3 where +instance Transformable (V3 n) 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. -class Spherical t where - spherical :: Iso' t (Double, Angle, Angle) - --- | Types which can be expressed in cylindrical 3D coordinates. -class Cylindrical t where - cylindrical :: Iso' t (Double, Angle, Double) -- 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 - --- | The class of types with at least two angle coordinates, the --- second called _phi. -class HasPhi t where - _phi :: Lens' t Angle - -instance HasPhi R3 where - _phi = spherical . _3 +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 φ)) -instance HasPhi P3 where - _phi = spherical . _3 +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) -instance Cylindrical P3 where - cylindrical = _relative origin . cylindrical +instance HasR V3 where + _r = r3SphericalIso . _1 -instance Spherical P3 where - spherical = _relative origin . spherical +instance HasTheta V3 where + _theta = r3CylindricalIso . _2 -instance HasTheta (Direction R3) where - _theta = _Dir . _theta +instance HasPhi V3 where + _phi = r3SphericalIso . _3 -instance HasPhi (Direction R3) where - _phi = _Dir . _phi diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 975188b5..9a5fa6ce 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts - , TypeFamilies - , ViewPatterns - #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Vector @@ -13,34 +9,22 @@ -- ----------------------------------------------------------------------------- module Diagrams.ThreeD.Vector - ( -- * Special 2D vectors + ( -- * Special 3D vectors unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, ) where -import Diagrams.Coordinates -import Diagrams.ThreeD.Types +import Control.Lens ((&), (.~)) +import Diagrams.ThreeD.Types +import Diagrams.TwoD.Vector --- | The unit vector in the positive X direction. -unitX :: R3 -unitX = 1 ^& 0 ^& 0 +import Linear.Vector -- | The unit vector in the positive Y direction. -unitY :: R3 -unitY = 0 ^& 1 ^& 0 - --- | The unit vector in the positive Z direction. -unitZ :: R3 -unitZ = 0 ^& 0 ^& 1 +unitZ :: (R3 v, Additive v, Num n) => v n +unitZ = zero & _z .~ 1 -- | The unit vector in the negative X direction. -unit_X :: R3 -unit_X = (-1) ^& 0 ^& 0 - --- | The unit vector in the negative Y direction. -unit_Y :: R3 -unit_Y = 0 ^& (-1) ^& 0 +unit_Z :: (R3 v, Additive v, Num n) => v n +unit_Z = zero & _z .~ (-1) --- | The unit vector in the negative Z direction. -unit_Z :: R3 -unit_Z = 0 ^& 0 ^& (-1) diff --git a/src/Diagrams/Trace.hs b/src/Diagrams/Trace.hs index a1a3a6dd..9ef8d955 100644 --- a/src/Diagrams/Trace.hs +++ b/src/Diagrams/Trace.hs @@ -27,28 +27,30 @@ 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 Diagrams.Combinators (withTrace) +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 -- 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 ad85fce2..ac9643fd 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 #-} @@ -104,25 +102,27 @@ module Diagrams.Trail ) where -import Control.Arrow ((***)) -import Control.Lens (AnIso', iso, view, op, Wrapped(..), Rewrapped - , cloneIso, (^.)) -import Data.AffineSpace -import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), - (|>)) -import qualified Data.FingerTree as FT -import qualified Data.Foldable as F +import Control.Arrow ((***)) +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.VectorSpace hiding (Sum (..)) -import qualified Numeric.Interval.Kaucher as I +import qualified Numeric.Interval.Kaucher as I -import Diagrams.Core hiding ((|>)) +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 + -- $internals -- -- Most users of diagrams should not need to use anything in this @@ -134,8 +134,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 (N a) , FT.Measured m a, Transformable a ) => Transformable (FingerTree m a) where @@ -152,37 +153,37 @@ 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, Real 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, Real n) + => EndValues (SegTree v n) -instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) - => Sectionable (SegTree v) 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 @@ -199,9 +200,9 @@ instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) , SegTree $ FT.singleton seg2 ) | otherwise = case FT.viewl after of - EmptyL -> emptySplit + 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' ) @@ -216,8 +217,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, Real 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 @@ -225,10 +226,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 t fun = trailMeasure (const 0) - (getArcLengthFun :: ArcLength v -> Scalar v -> I.Interval (Scalar v)) + getArcLengthFun t arcLengthToParam eps st@(SegTree t) l @@ -250,16 +251,21 @@ instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) 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 (Scalar v)))) t + before, after :: FingerTree (SegMeasure v n) (Segment Closed v n) + (before, after) = + FT.split ((>= l) + . trailMeasure + 0 + (I.midpoint . getArcLengthBounded eps)) + 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 n :>: m, FT.Measured (SegMeasure v n) t ) => a -> (m -> a) -> t -> a trailMeasure d f = option d f . get . FT.measure @@ -267,18 +273,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 :: ( 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 (Scalar v), Ord (Scalar v), InnerSpace v, - FT.Measured (SegMeasure v) t +offset :: ( OrderedField n, Metric v, + FT.Measured (SegMeasure v n) t ) - => t -> v -offset = trailMeasure zeroV (op TotalOffset . view oeOffset) + => t -> v n +offset = trailMeasure zero (op TotalOffset . view oeOffset) ------------------------------------------------------------ -- Trails ------------------------------------------------ @@ -346,133 +352,117 @@ 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. -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 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 (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 (Metric v, OrderedField n) => Monoid (Trail' Line v n) 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 + ftEnv :: Trail' Line v n -> Envelope v n + 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, Real 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)) - , VectorSpace v - , Num (Scalar v) - ) - => Parametric (Tangent (Trail' c v)) where +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 -> zeroV - 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)) - , EndValues (GetSegment (Trail' c v)) - , VectorSpace v - , Num (Scalar v) +instance ( Parametric (GetSegment (Trail' c v n)) + , EndValues (GetSegment (Trail' c v n)) + , Additive 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 - Just (_, seg, _) -> atStart (Tangent seg) + GetSegmentCodomain Nothing -> zero + GetSegmentCodomain (Just (_, seg, _)) -> atStart (Tangent seg) atEnd (Tangent tr) = case atEnd (GetSegment tr) of - Nothing -> zeroV - Just (_, seg, _) -> atEnd (Tangent seg) + GetSegmentCodomain Nothing -> zero + GetSegmentCodomain (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) - ) - => Parametric (Tangent (Trail v)) where +instance (Metric v , OrderedField n, Real n) + => 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) - ) - => EndValues (Tangent (Trail v)) where +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 (Scalar v) => DomainBounds (Trail' l v) +instance Num n => DomainBounds (Trail' l v n) -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => EndValues (Trail' l v) +instance (Metric v, OrderedField n, Real n) + => EndValues (Trail' l v n) -instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) - => Sectionable (Trail' Line v) where +instance (Metric v, OrderedField n, Real 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, Real n) + => HasArcLength (Trail' l v n) where arcLengthBounded eps = withTrail' (\(Line t) -> arcLengthBounded eps t) @@ -506,7 +496,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 @@ -521,41 +511,42 @@ instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) -- 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 getSegment = GetSegment type instance V (GetSegment t) = V 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 - ) +type instance N (GetSegment t) = N t + +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 (InnerSpace v, OrderedField (Scalar v)) - => Parametric (GetSegment (Trail' Line v)) 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 (zeroV, 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 + = 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)) @@ -563,12 +554,11 @@ 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, Real 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, Real n) + => Parametric (GetSegment (Trail v n)) where atParam (GetSegment t) p = withTrail ((`atParam` p) . GetSegment) @@ -579,40 +569,41 @@ instance DomainBounds t => DomainBounds (GetSegment t) where domainLower (GetSegment t) = domainLower t domainUpper (GetSegment t) = domainUpper t -instance (InnerSpace v, OrderedField (Scalar v)) - => EndValues (GetSegment (Trail' Line v)) where +instance (Metric v, OrderedField n, Real 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 (zeroV, 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 (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => EndValues (GetSegment (Trail' Loop v)) where +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 (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => EndValues (GetSegment (Trail v)) where +instance (Metric v, OrderedField n, Real 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 -------------------------------------------------- @@ -621,23 +612,23 @@ 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 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 @@ -645,7 +636,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 -> @@ -660,29 +651,29 @@ 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, Real 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, 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 @@ -693,14 +684,13 @@ 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, OrderedField n, Real 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, Real n) + => HasArcLength (Trail v n) where arcLengthBounded = withLine . arcLengthBounded arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr @@ -709,13 +699,13 @@ 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) - -> (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 @@ -725,8 +715,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 @@ -742,25 +732,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 ------------------------------------------------------------ @@ -768,22 +758,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 @@ -794,14 +784,12 @@ 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 @@ -823,8 +811,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 @@ -832,8 +820,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 ------------------------------------------------------------ @@ -860,16 +848,16 @@ 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) - 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. -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 @@ -895,12 +883,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 @@ -912,22 +900,22 @@ 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 (_ , Linear OffsetOpen) -> Line (SegTree (t |> Linear off)) (_ , Cubic c1 c2 OffsetOpen) -> Line (SegTree (t |> Cubic c1 c2 off)) where - offV :: v - offV = negateV . trailMeasure zeroV (op TotalOffset .view oeOffset) $ t + offV :: v n + 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 ------------------------------------------------------------ @@ -935,45 +923,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 @@ -989,22 +977,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 @@ -1018,27 +1006,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, Num n) => Point v n -> [Segment Closed v n] -> [Point v n] segmentPoints p = scanl (.+^) p . map segOffset tolerance :: OrderedField a => a @@ -1055,46 +1043,46 @@ 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' toler (viewLoc -> (p,t)) +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 l = trailVertices' tolerance l +trailVertices :: (Metric v, OrderedField n) + => Located (Trail v n) -> [Point v n] +trailVertices = trailVertices' tolerance -- | 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' toler (viewLoc -> (p,t)) +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 l = lineVertices' tolerance l +lineVertices :: (Metric v, OrderedField n) + => Located (Trail' Line v n) -> [Point v n] +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 -- more information. -loopVertices' :: (InnerSpace v, OrderedField (Scalar v)) - => Scalar v -> Located (Trail' Loop v) -> [Point v] -loopVertices' toler (viewLoc -> (p,t)) - | length segs > 1 = if far > toler then init ps else init . (drop 1) $ ps +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 | otherwise = ps where - far = magnitudeSq ((normalized . tangentAtStart . head $ segs) ^-^ - (normalized . tangentAtEnd . last $ segs)) + far = quadrance ((signorm . tangentAtStart . head $ segs) ^-^ + (signorm . 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 l = loopVertices' tolerance l +loopVertices :: (Metric v, OrderedField n) + => Located (Trail' Loop v n) -> [Point v n] +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. @@ -1102,30 +1090,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 n -> [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 = [(signorm . tangentAtStart $ s + ,signorm . 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) ------------------------------------------------------------ @@ -1139,7 +1127,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 @@ -1150,27 +1138,28 @@ 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 + diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs index 5a6b03b1..abcc92df 100644 --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -28,15 +28,17 @@ module Diagrams.TrailLike ) where -import Data.AffineSpace ((.-.)) -import Data.VectorSpace -import Control.Lens (view, _Unwrapped') +import Control.Lens (view, _Unwrapped') import Diagrams.Core import Diagrams.Located import Diagrams.Segment import Diagrams.Trail +import Linear.Affine +import Linear.Metric +import Linear.Vector + ------------------------------------------------------------ -- TrailLike class ------------------------------------------------------------ @@ -61,13 +63,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 +77,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 +121,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 +140,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 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 @@ -166,11 +168,11 @@ 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) -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 +183,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 +(~~) :: (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 @@ -195,7 +197,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 :: (VectorSpace (V t), TrailLike t) => Located (Trail (V t)) -> [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 b3c379d9..d538514e 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, 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.hs b/src/Diagrams/TwoD.hs index b35ff2fc..5ed0433c 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -61,9 +61,10 @@ ----------------------------------------------------------------------------- module Diagrams.TwoD ( -- * R^2 - R2, r2, unr2, mkR2 - , P2, p2, unp2, mkP2 - , T2 + V2 (..), R1 (..), R2 (..) + , P2, T2 + , r2, unr2, mkR2 + , p2, unp2, mkP2 , unitX, unitY, unit_X, unit_Y , xDir @@ -174,7 +175,7 @@ module Diagrams.TwoD -- * Transformations -- ** Rotation , rotation, rotate, rotateBy - , rotationAbout, rotateAbout + , rotationAround, rotateAround -- ** Scaling , scalingX, scaleX , scalingY, scaleY @@ -239,7 +240,7 @@ module Diagrams.TwoD , sized, sizedAs -- * Textures - , Texture(..), solid + , Texture(..), solid , SpreadMethod(..), GradientStop(..), mkStops, getFillTexture , fillTexture, getLineTexture, lineTexture, lineTextureA , stopFraction, stopColor @@ -292,4 +293,4 @@ import Diagrams.TwoD.Transform import Diagrams.TwoD.Types 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 aa73d552..e7769781 100644 --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -19,21 +22,20 @@ 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 (R2, T2, 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 Linear.Affine + -- | 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 :: (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 @@ -60,23 +62,23 @@ 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 :: (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) $ 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) - _ -> scale s size + _ -> over both (*s) sz tr = (0.5 *. p2 finalSz) .-. (s *. center2D d) adjustT = translation tr <> scaling s @@ -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 :: (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) 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..76205c71 100644 --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Align @@ -45,51 +45,51 @@ import Diagrams.Align import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -import Data.VectorSpace +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, V a ~ R2) => a -> a -alignL = align (negateV unitX) +alignL :: (Alignable a, HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a +alignL = align unit_X -snugL :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a -snugL = snug (negateV unitX) +snugL :: (Fractional n, Alignable a, Traced 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, V a ~ R2) => a -> a +alignR :: (Alignable a, HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a alignR = align unitX -snugR :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a +snugR :: (Fractional n, Alignable a, Traced 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, V a ~ R2) => a -> a +alignT :: (Alignable a, HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a alignT = align unitY -snugT:: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a +snugT:: (Fractional n, Alignable a, Traced 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, V a ~ R2) => a -> a -alignB = align (negateV unitY) +alignB :: (Alignable a, HasOrigin a, V a ~ V2, N a ~ n, Floating n) => a -> a +alignB = align unit_Y -snugB :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a -snugB = snug (negateV unitY) +snugB :: (Fractional n, Alignable a, Traced 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, V a ~ R2) => 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 (Scalar (V a)), Alignable a, Traced a, HasOrigin a, V a ~ R2) + :: (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,44 +108,53 @@ snugBR = snugB . snugR -- -- * @snugX@ works the same way. -alignX :: (Alignable a, HasOrigin a, V a ~ R2) => Double -> a -> 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 :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => Double -> a -> 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 :: (Alignable a, HasOrigin a, V a ~ R2) => Double -> a -> a +alignY :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R2 v, Additive v, Fractional n) => n -> a -> a alignY = alignBy unitY -snugY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => Double -> a -> a +-- | See the documentation for 'alignY'. +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 :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a -centerX = alignBy unitX 0 +centerX :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R1 v, Additive v, Fractional n) => a -> a +centerX = alignBy unitX 0 -snugCenterX :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> 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 :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a -centerY = alignBy unitY 0 +centerY :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a +centerY = alignBy unitY 0 -snugCenterY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> 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 :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a -centerXY = center +centerXY :: (V a ~ v, N a ~ n, Alignable a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a +centerXY = centerX . centerY + +snugCenterXY :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, + R2 v, Additive v, Fractional n) => a -> a +snugCenterXY = snugCenterX . snugCenterY + -snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a, - HasOrigin a, V a ~ R2) => a -> a -snugCenterXY = snugCenter diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index b2b11005..8210734b 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arc @@ -23,8 +24,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,11 +35,12 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unitY, unit_Y) import Diagrams.Util (( # )) -import Control.Lens ((^.), (&), (<>~)) -import Data.AffineSpace +import Control.Lens ((&), (<>~), (^.)) import Data.Semigroup ((<>)) -import Data.VectorSpace -import Diagrams.Coordinates + +import Linear.Affine +import Linear.Metric +import Linear.Vector -- For details of this approximation see: -- http://www.tinaja.com/glib/bezcirc2.pdf @@ -47,12 +49,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 :: Angle -> 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)) - 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 @@ -60,13 +62,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 :: Angle -> [Segment Closed R2] +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] @@ -92,17 +94,17 @@ 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 :: RealFloat 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 :: (TrailLike t, V t ~ R2) => Direction R2 -> Angle -> t -arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ p2 (1,0)) +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@, -- @'arc'' r d s@ is the path of a radius @(abs r)@ arc starting at @@ -113,8 +115,8 @@ 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 p, V p ~ R2) => Double -> Direction R2 -> Angle -> p -arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) $ p2 (abs r,0)) +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 -- | Create a circular wedge of the given radius, beginning at the @@ -129,11 +131,11 @@ 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 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 - <> 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@ @@ -146,24 +148,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 :: (TrailLike t, V t ~ R2) => P2 -> P2 -> Double -> 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 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) @@ -180,12 +182,13 @@ 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 +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] + $ 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 07b246a1..b806de99 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -72,7 +75,7 @@ module Diagrams.TwoD.Arrow , arrow , arrow' - + , arrowFromLocatedTrail , arrowFromLocatedTrail' @@ -102,17 +105,14 @@ module Diagrams.TwoD.Arrow ) where import Control.Applicative ((<*>)) -import Control.Lens (Lens', Setter', Traversal', - generateSignatures, lensRules, - makeLensesWith, view, (%~), (&), - (.~), (^.)) -import Data.AffineSpace +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.VectorSpace +import Data.Data import Data.Colour hiding (atop) import Diagrams.Core @@ -135,25 +135,30 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unit_X) import Diagrams.Util (( # )) -data ArrowOpts +import Linear.Affine +import Linear.Metric +import Linear.Vector + + +data ArrowOpts n = 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 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 :: Trail R2 +straightShaft :: OrderedField n => Trail V2 n straightShaft = trailFromOffsets [unitX] -instance Default ArrowOpts where +instance RealFloat n => Default (ArrowOpts n) where def = ArrowOpts { _arrowHead = dart , _arrowTail = noTail @@ -163,59 +168,59 @@ instance Default ArrowOpts 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 ArrowHT +arrowHead :: Lens' (ArrowOpts n) (ArrowHT n) -- | A shape to place at the tail of the arrow. -arrowTail :: Lens' ArrowOpts ArrowHT +arrowTail :: Lens' (ArrowOpts n) (ArrowHT n) -- | The trail to use for the arrow shaft. -arrowShaft :: Lens' ArrowOpts (Trail R2) +arrowShaft :: Lens' (ArrowOpts n) (Trail V2 n) -- | Distance to leave between the head and the target point. -headGap :: Lens' ArrowOpts (Measure R2) +headGap :: Lens' (ArrowOpts n) (Measure n) -- | Distance to leave between the starting point and the tail. -tailGap :: Lens' ArrowOpts (Measure R2) +tailGap :: Lens' (ArrowOpts n) (Measure n) -- | Set both the @headGap@ and @tailGap@ simultaneously. -gaps :: Traversal' ArrowOpts (Measure R2) +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 (Measure R2) +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 (Style R2) +headStyle :: Lens' (ArrowOpts n) (Style V2 n) -- | Style to apply to the tail. See `headStyle`. -tailStyle :: Lens' ArrowOpts (Style R2) +tailStyle :: Lens' (ArrowOpts n) (Style V2 n) -- | Style to apply to the shaft. See `headStyle`. -shaftStyle :: Lens' ArrowOpts (Style R2) +shaftStyle :: Lens' (ArrowOpts n) (Style V2 n) -- | The length from the start of the joint to the tip of the head. -headLength :: Lens' ArrowOpts (Measure R2) +headLength :: Lens' (ArrowOpts n) (Measure n) --- | The length of the tail plus its joint. -tailLength :: Lens' ArrowOpts (Measure R2) +-- | The length of the tail plus its joint. +tailLength :: Lens' (ArrowOpts n) (Measure n) -- | Set both the @headLength@ and @tailLength@ simultaneously. -lengths :: Traversal' ArrowOpts (Measure R2) +lengths :: Traversal' (ArrowOpts n) (Measure n) lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts ^. headLength) <*> f (opts ^. tailLength) @@ -225,75 +230,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 :: Setter' ArrowOpts Texture +headTexture :: TypeableFloat n => Setter' (ArrowOpts n) (Texture n) headTexture = headStyle . styleFillTexture -- | A lens for setting or modifying the texture of an arrow -- tail. -tailTexture :: Setter' ArrowOpts Texture +tailTexture :: TypeableFloat n => Setter' (ArrowOpts n) (Texture n) tailTexture = tailStyle . styleFillTexture -- | A lens for setting or modifying the texture of an arrow -- shaft. -shaftTexture :: Setter' ArrowOpts Texture +shaftTexture :: TypeableFloat 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 :: ArrowOpts -> Style R2 +shaftSty :: Fractional n => ArrowOpts n -> Style V2 n shaftSty opts = opts^.shaftStyle -- Set the default head style. See `shaftSty`. -headSty :: ArrowOpts -> Style R2 +headSty :: TypeableFloat n => ArrowOpts n -> Style V2 n headSty opts = fc black (opts^.headStyle) -- Set the default tail style. See `shaftSty`. -tailSty :: ArrowOpts -> Style R2 +tailSty :: TypeableFloat n => ArrowOpts n -> Style V2 n tailSty opts = fc black (opts^.tailStyle) -fromMeasure :: Double -> Double -> Measure R2 -> Double -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 :: Floating n => (Traced t, V t ~ V2, N t ~ 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 :: Style R2 -> Style R2 +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 :: Style v -> Double -> Double -> Double +widthOfJoint :: forall n. TypeableFloat n => Style V2 n -> n -> n -> n widthOfJoint sStyle gToO nToO = - maybe (fromMeasure gToO nToO (Output 1)) -- 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) + (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 :: Renderable (Path R2) b => - Double -> ArrowOpts -> Double -> Double -> (Diagram b R2, Double) -mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 - , hWidth + jWidth) +mkHead :: (DataFloat n, Renderable (Path V2 n) b) => + n -> ArrowOpts n -> n -> n -> (Diagram b V2 n, n) +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' @@ -301,12 +302,12 @@ 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 size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 +mkTail :: (DataFloat n, Renderable (Path V2 n) b) => + n -> ArrowOpts n -> n -> n -> (Diagram b V2 n, n) +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' @@ -316,17 +317,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 :: Trail R2 -> Double -> Double -> Double -> Trail R2 -spine tr tw hw size = tS <> tr # scale size <> hS +spine :: TypeableFloat n => Trail V2 n -> n -> n -> n -> Trail V2 n +spine tr tw hw sz = tS <> tr # scale sz <> hS where - tSpine = trailFromOffsets [(normalized . tangentAtStart) $ tr] # scale tw - hSpine = trailFromOffsets [(normalized . 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 :: Trail R2 -> Double -> Double -> Double -> Double +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 @@ -341,9 +342,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 @@ -351,31 +352,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 # 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 :: ArrowOpts -> Double -> Envelope R2 +arrowEnv :: TypeableFloat 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 :: Renderable (Path R2) b => Double -> Diagram b R2 -arrow len = arrow' def len +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' :: Renderable (Path R2) b => ArrowOpts -> Double -> Diagram b R2 +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. @@ -417,10 +418,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. - 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 . scaleLocal (avgScale tr) + hSize = scaleFromMeasure $ opts ^. headLength + tSize = scaleFromMeasure $ opts ^. tailLength + hGap = scaleFromMeasure $ opts ^. headGap + tGap = scaleFromMeasure $ opts ^. tailGap -- Make the head and tail and save their widths. (h, hWidth') = mkHead hSize opts' gToO nToO @@ -430,7 +432,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) @@ -447,7 +449,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) @@ -462,7 +464,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 :: (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 @@ -470,64 +472,64 @@ 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 + :: (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 :: Renderable (Path R2) b => P2 -> R2 -> Diagram b R2 -arrowAt s v = arrowAt' def s v +arrowAt :: (DataFloat n, Renderable (Path V2 n) b) => Point V2 n -> V2 n -> Diagram b V2 n +arrowAt = arrowAt' def arrowAt' - :: Renderable (Path R2) b => - ArrowOpts -> P2 -> R2 -> Diagram b R2 + :: (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 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 :: Renderable (Path R2) b => R2 -> Diagram b R2 +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 magnitude of +-- | @arrowV' v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin). arrowV' - :: Renderable (Path R2) b - => ArrowOpts -> R2 -> Diagram b R2 + :: (DataFloat n, Renderable (Path V2 n) b) + => 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 -- | Connect two diagrams with a straight arrow. connect - :: (Renderable (Path R2) b, IsName n1, IsName n2) - => n1 -> n2 -> (Diagram b R2 -> Diagram b R2) + :: (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' - :: (Renderable (Path R2) b, IsName n1, IsName n2) - => ArrowOpts -> n1 -> n2 -> (Diagram b R2 -> Diagram b R2) + :: (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 -> withName n2 $ \sub2 -> @@ -537,15 +539,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 -> Angle - -> (Diagram b R2 -> Diagram b R2) + :: (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' - :: (Renderable (Path R2) b, IsName n1, IsName n2) - => ArrowOpts -> n1 -> n2 -> Angle -> Angle - -> (Diagram b R2 -> Diagram b R2) + :: (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 = withName n1 $ \sub1 -> withName n2 $ \sub2 -> @@ -559,19 +561,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) + :: (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' - :: (Renderable (Path R2) b, IsName n1, IsName n2) - => ArrowOpts -> n1 -> n2 -> (Diagram b R2 -> Diagram b R2) + :: (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 -> 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 (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 fdc2588f..be12c0a2 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -54,16 +56,13 @@ module Diagrams.TwoD.Arrowheads , ArrowHT ) where -import Control.Lens ((&), (.~), (^.), (<>~)) -import Data.AffineSpace +import Control.Lens ((&), (.~), (<>~), (^.)) 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 @@ -78,11 +77,15 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unit_X, xDir) import Diagrams.Util (( # )) +import Linear.Affine +import Linear.Metric +import Linear.Vector + ----------------------------------------------------------------------------- -type ArrowHT = Double -> Double -> (Path R2, Path R2) +type ArrowHT n = n -> n -> (Path V2 n, Path V2 n) -closedPath :: (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 ------------------------------------------------------------------ @@ -97,42 +100,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 :: Angle -> ArrowHT +arrowheadTriangle :: 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 :: Angle -> ArrowHT -arrowheadDart theta len shaftWidth = (hd # scale size, jt) +arrowheadDart :: RealFloat n => Angle n -> ArrowHT n +arrowheadDart theta len shaftWidth = (hd # scale sz, 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)) + sz = max 1 ((len - jLength) / 1.5) -- | Isoceles triangle with curved concave base. Inkscape type 2. -arrowheadSpike :: Angle -> ArrowHT +arrowheadSpike :: RealFloat 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 @@ -153,25 +156,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 :: Angle -> ArrowHT -arrowheadThorn theta len shaftWidth = (hd # scale size, jt) +arrowheadThorn :: RealFloat n => Angle n -> ArrowHT n +arrowheadThorn theta len shaftWidth = (hd # scale sz, 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)) + sz = max 1 ((len - jLength) / 1.5) -- | Make a side for the thorn head. -curvedSide :: Angle -> Segment Closed R2 +curvedSide :: (Floating n, Ord n) => Angle n -> Segment Closed V2 n curvedSide theta = bezier3 ctrl1 ctrl2 end where v0 = unit_X @@ -182,34 +185,34 @@ curvedSide theta = bezier3 ctrl1 ctrl2 end -- Standard heads --------------------------------------------------------- -- | A line the same width as the shaft. -lineHead :: ArrowHT +lineHead :: RealFloat n => ArrowHT n lineHead s w = (square 1 # scaleX s # scaleY w # alignL, mempty) -noHead :: ArrowHT +noHead :: (Floating n, Ord n) => ArrowHT n noHead _ _ = (mempty, mempty) -- | <> -- > triEx = drawHead tri -tri :: ArrowHT +tri :: RealFloat n => ArrowHT n tri = arrowheadTriangle (1/3 @@ turn) -- | <> -- > spikeEx = drawHead spike -spike :: ArrowHT +spike :: RealFloat n => ArrowHT n spike = arrowheadSpike (3/8 @@ turn) -- | <> -- > thornEx = drawHead thorn -thorn :: ArrowHT -thorn = arrowheadThorn (3/8 @@ turn) +thorn :: RealFloat n => ArrowHT n +thorn = arrowheadThorn (3/8 @@ turn) -- | <> -- > dartEx = drawHead dart -dart :: ArrowHT +dart :: RealFloat n => ArrowHT n dart = arrowheadDart (2/5 @@ turn) -- Tails ------------------------------------------------------------------ @@ -219,88 +222,89 @@ 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 :: 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' -arrowtailBlock :: Angle -> ArrowHT +arrowtailBlock :: forall n. (RealFloat n) => Angle n -> ArrowHT n arrowtailBlock theta = aTail where aTail len _ = (t, mempty) where - t = rect len (len * x) # alignR - 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 :: Angle -> ArrowHT +arrowtailQuill :: OrderedField 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 - size = len / 0.6 + t = closedPath (trailFromVertices [v0, v1, v2, v3, v4, v5, v0]) + # 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) 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 :: ArrowHT +lineTail :: RealFloat n => ArrowHT n lineTail s w = (square 1 # scaleY w # scaleX s # alignR, mempty) -noTail :: ArrowHT +noTail :: OrderedField n => ArrowHT n noTail _ _ = (mempty, mempty) -- | <> -- > tri'Ex = drawTail tri' -tri' :: ArrowHT +tri' :: RealFloat n => ArrowHT n tri' = headToTail tri -- | <> -- > spike'Ex = drawTail spike' -spike' :: ArrowHT +spike' :: RealFloat n => ArrowHT n spike' = headToTail spike -- | <> -- > thorn'Ex = drawTail thorn' -thorn' :: ArrowHT +thorn' :: RealFloat n => ArrowHT n thorn' = headToTail thorn -- | <> -- > dart'Ex = drawTail dart' -dart' :: ArrowHT +dart' :: RealFloat n => ArrowHT n dart' = headToTail dart -- | <> -- > quillEx = drawTail quill -quill :: ArrowHT +quill :: (Floating n, Ord n) => ArrowHT n quill = arrowtailQuill (2/5 @@ turn) -- | <> -- > blockEx = drawTail block -block :: ArrowHT +block :: RealFloat n => ArrowHT n block = arrowtailBlock (7/16 @@ turn) + diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 87cd3c8b..0ac1e85a 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -67,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) @@ -78,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, (&), (.~), over) -import Data.Colour hiding (AffineSpace) +import Data.Colour hiding (AffineSpace, over) import Data.Data import Data.Default.Class import Data.Maybe (fromMaybe) @@ -89,9 +93,10 @@ import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup + -- | 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 n => Measure n none = Output 0 ultraThin = Normalized 0.0005 `atLeast` Output 0.5 veryThin = Normalized 0.001 `atLeast` Output 0.5 @@ -115,48 +120,49 @@ 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 n = LineWidth (Last (Measure n)) + deriving (Data, Typeable, Semigroup) -type instance V LineWidth = R2 +instance (Typeable n) => AttributeClass (LineWidth n) -instance Transformable LineWidth where - transform t (LineWidth (Last w)) = - LineWidth (Last (transform t w)) +type instance V (LineWidth n) = V2 +type instance N (LineWidth n) = n -instance Default LineWidth where - def = LineWidth (Last medium) +instance Floating n => Transformable (LineWidth n) where + transform t (LineWidth (Last m)) = LineWidth (Last $ scaleLocal (avgScale t) m) -getLineWidth :: LineWidth -> Measure R2 +instance Floating n => Default (LineWidth n) where + def = LineWidth (Last medium) + +getLineWidth :: LineWidth n -> Measure n getLineWidth (LineWidth (Last w)) = w -- | Set the line (stroke) width. -lineWidth :: (HasStyle a, V a ~ R2) => Measure R2 -> 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 :: (HasStyle a, V a ~ R2) => LineWidth -> 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 :: (HasStyle a, V a ~ R2) => Measure R2 -> 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 :: (HasStyle a, V a ~ R2) => Double -> 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 :: (HasStyle a, V a ~ R2) => Double -> 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 :: (HasStyle a, V a ~ R2) => Double -> 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 :: (HasStyle a, V a ~ R2) => Double -> a -> a +lwL :: (Data n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => n -> a -> a lwL w = lineWidth (Local w) ----------------------------------------------------------------- @@ -164,63 +170,63 @@ 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 n = Dashing [Measure n] (Measure n) + deriving (Data, Typeable) + +newtype DashingA n = DashingA (Last (Dashing n)) + deriving (Data, Typeable, Semigroup) -newtype DashingA = DashingA (Last Dashing) - deriving (Typeable, Data, Semigroup, Eq) -instance AttributeClass DashingA +instance Typeable n => AttributeClass (DashingA n) -type instance V DashingA = R2 +type instance V (DashingA n) = V2 +type instance N (DashingA n) = n -instance Transformable DashingA where - transform t (DashingA (Last (Dashing w v))) = - DashingA (Last (Dashing r s)) - where - r = map (transform t) w - s = transform t v +instance Floating n => Transformable (DashingA n) where + transform t (DashingA (Last (Dashing ms m))) + = DashingA (Last $ Dashing (map f ms) (f m)) + where f = scaleLocal (avgScale t) -getDashing :: DashingA -> Dashing +getDashing :: DashingA n -> Dashing n 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 - -- and off portions of the stroke. The empty - -- list indicates no dashing. - -> Measure R2 -- ^ An offset into the dash pattern at which the - -- stroke should start. +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. + -> 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 :: (HasStyle a, V a ~ R2) => [Double] -> Double -> 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 :: (HasStyle a, V a ~ R2) => [Double] -> Double -> 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 :: (HasStyle a, V a ~ R2) => [Double] -> Double -> 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 :: (HasStyle a, V a ~ R2) => [Double] -> Double -> 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) -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 n) SomeColor -- | The fraction for stop. -stopFraction :: Lens' GradientStop Double +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 @@ -230,126 +236,146 @@ stopFraction :: Lens' GradientStop Double data SpreadMethod = GradPad | GradReflect | GradRepeat -- | Linear Gradient -data LGradient = LGradient - { _lGradStops :: [GradientStop] - , _lGradStart :: P2 - , _lGradEnd :: P2 - , _lGradTrans :: T2 +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 :: Lens' LGradient [GradientStop] +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 :: Lens' LGradient T2 +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 :: Lens' LGradient P2 +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 :: Lens' LGradient P2 +lGradEnd :: Lens' (LGradient n) (Point V2 n) -- | For setting the spread method. -lGradSpreadMethod :: Lens' LGradient SpreadMethod +lGradSpreadMethod :: Lens' (LGradient n) SpreadMethod -- | Radial Gradient -data RGradient = RGradient - { _rGradStops :: [GradientStop] - , _rGradCenter0 :: P2 - , _rGradRadius0 :: Double - , _rGradCenter1 :: P2 - , _rGradRadius1 :: Double - , _rGradTrans :: T2 +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 :: Lens' RGradient [GradientStop] +rGradStops :: Lens' (RGradient n) [GradientStop n] -- | The center point of the inner circle. -rGradCenter0 :: Lens' RGradient P2 +rGradCenter0 :: Lens' (RGradient n) (Point V2 n) -- | The radius of the inner cirlce in 'Local' coordinates. -rGradRadius0 :: Lens' RGradient Double +rGradRadius0 :: Lens' (RGradient n) n -- | The center of the outer circle. -rGradCenter1 :: Lens' RGradient P2 +rGradCenter1 :: Lens' (RGradient n) (Point V2 n) -- | The radius of the outer circle in 'Local' coordinates. -rGradRadius1 :: Lens' RGradient Double +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 :: Lens' RGradient T2 +rGradTrans :: Lens' (RGradient n) (Transformation V2 n) -- | For setting the spread method. -rGradSpreadMethod :: Lens' RGradient 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 = SC SomeColor | LG LGradient | RG RGradient - 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 :: Color a => a -> Texture +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 :: Texture -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 :: Texture -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). -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 :: [GradientStop] -> P2 -> P2 -> SpreadMethod -> Texture +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 :: [GradientStop] -> P2 -> Double - -> P2 -> Double -> SpreadMethod -> Texture +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) @@ -357,38 +383,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 = LineTexture (Last Texture) +newtype LineTexture n = LineTexture (Last (Texture n)) deriving (Typeable, Semigroup) -instance AttributeClass LineTexture +instance (Typeable n) => AttributeClass (LineTexture n) -type instance V LineTexture = R2 +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 Transformable LineTexture 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 where - def = LineTexture (Last (SC (SomeColor (black :: Colour Double)))) - -getLineTexture :: LineTexture -> Texture +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 :: LineTexture n -> Texture n getLineTexture (LineTexture (Last t)) = t -lineTexture :: (HasStyle a, V a ~ R2) => Texture-> a -> a +lineTexture :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => Texture n -> a -> a lineTexture = applyTAttr . LineTexture . Last -lineTextureA :: (HasStyle a, V a ~ R2) => LineTexture -> a -> a +lineTextureA :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => LineTexture n -> a -> a lineTextureA = applyTAttr -mkLineTexture :: Texture -> LineTexture +mkLineTexture :: Texture v -> LineTexture v mkLineTexture = LineTexture . Last -styleLineTexture :: Setter' (Style v) Texture +styleLineTexture :: Typeable n => Setter' (Style V2 n) (Texture n) styleLineTexture = sets modifyLineTexture where modifyLineTexture f s @@ -404,63 +426,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 :: (Color c, HasStyle a, V a ~ R2) => 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 :: (HasStyle a, V a ~ R2) => 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 :: (HasStyle a, V a ~ R2) => 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 :: (HasStyle a, V a ~ R2) => LGradient -> 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 :: (HasStyle a, V a ~ R2) => RGradient -> 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. -- The semigroup structure on fill texture attributes -- is that of 'Recommed . Last'. -newtype FillTexture = FillTexture (Recommend (Last Texture)) +newtype FillTexture n = FillTexture (Recommend (Last (Texture n))) deriving (Typeable, Semigroup) -instance AttributeClass FillTexture +instance Typeable n => AttributeClass (FillTexture n) -type instance V FillTexture = R2 +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 Transformable FillTexture 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 Default FillTexture where - def = FillTexture (Recommend (Last (SC - (SomeColor (transparent :: AlphaColour Double))))) - -getFillTexture :: FillTexture -> Texture +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 :: FillTexture n -> Texture n getFillTexture (FillTexture tx) = getLast . getRecommend $ tx -fillTexture :: (HasStyle a, V a ~ R2) => Texture -> 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 -> FillTexture +mkFillTexture :: Texture n -> FillTexture n mkFillTexture = FillTexture . Commit . Last -styleFillTexture :: Setter' (Style v) Texture +styleFillTexture :: (Typeable n) => Setter' (Style V2 n) (Texture n) styleFillTexture = sets modifyFillTexture where modifyFillTexture f s @@ -475,32 +493,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 :: (Color c, HasStyle a, V a ~ R2) => 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, V a ~ R2) => 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, V a ~ R2) => 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, V a ~ R2) => AlphaColour Double -> a -> a +fcA :: (HasStyle a, V a ~ V2, N a ~ 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 - 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 @@ -510,5 +528,14 @@ 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. ( +#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) + diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 9ee46b61..0b3c6428 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Combinators @@ -37,30 +37,29 @@ module Diagrams.TwoD.Combinators ) where -import Control.Lens ((&), (.~)) -import Data.AffineSpace +import Control.Lens ((&), (.~)) 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 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) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unitY) +import Diagrams.TwoD.Vector import Diagrams.Util (( # )) +import Linear.Affine +import Linear.Vector infixl 6 === infixl 6 ||| @@ -79,8 +78,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 ~ R2, Semigroup a) => a -> a -> a -(===) = beside (negateV unitY) +(===) :: (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 -- adjacent to one another, with the first diagram to the left of @@ -88,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, V a ~ R2, 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, @@ -102,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, V a ~ R2) +hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ V2, N a ~ n, TypeableFloat n) => [a] -> a hcat = hcat' def @@ -110,14 +109,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 ~ R2) - => CatOpts R2 -> [a] -> a +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, V a ~ R2) - => Scalar R2 -> [a] -> a +hsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ V2, N a ~ n, TypeableFloat n) + => n -> [a] -> a hsep s = hcat' (def & sep .~ s) -- | Lay out a list of juxtaposable objects in a column from top to @@ -131,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, V a ~ R2) +vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ V2, N a ~ n, TypeableFloat n) => [a] -> a vcat = vcat' def @@ -139,14 +138,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 ~ R2) - => CatOpts R2 -> [a] -> a -vcat' = cat' (negateV unitY) +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, V a ~ R2) - => Scalar R2 -> [a] -> a +vsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ V2, N a ~ n, TypeableFloat n) + => n -> [a] -> a vsep s = vcat' (def & sep .~ s) -- | @strutR2 v@ is a two-dimensional diagram which produces no @@ -155,7 +154,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 R2, Monoid' m) => R2 -> QDiagram b R2 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) @@ -163,14 +162,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 R2, Monoid' m) => Double -> QDiagram b R2 m -strutX d = strut (d ^& 0) +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 :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m -strutY d = strut (0 ^& d) +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 -- envelope horizontally by a factor of @s@ (factors between 0 and 1 @@ -179,8 +178,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 :: (Monoid' m, TypeableFloat 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 @@ -190,8 +189,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 :: (Monoid' m, TypeableFloat 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, @@ -199,7 +198,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, 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 @@ -209,7 +208,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, TypeableFloat n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeRight s | s >= 0 = extrudeEnvelope $ unitX ^* s | otherwise = intrudeEnvelope $ unitX ^* s @@ -219,7 +218,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, 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 @@ -229,7 +228,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, TypeableFloat n) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeTop s | s >= 0 = extrudeEnvelope $ unitY ^* s | otherwise = intrudeEnvelope $ unitY ^* s @@ -239,26 +238,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 :: ( 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 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, V t ~ R2 - , Enveloped a, V a ~ R2 +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 -- | \"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 :: (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 :: (Renderable (Path R2) b, Backend b R2) - => Double -> Colour Double -> Diagram b R2 -> Diagram b R2 +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/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs index 45572b4c..88180e6d 100644 --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -19,16 +19,16 @@ module Diagrams.TwoD.Curvature , squaredRadiusOfCurvature ) where +import Control.Lens (over) +import Control.Monad 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 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 -- along the curve. When the wheel is held straight there is zero curvature. @@ -103,35 +103,35 @@ 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 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 -- | 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 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 . over _x (join (*)) . curvaturePair s -- | 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 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 . (\(V2 p q) -> V2 (sqrt q) p) . curvaturePair s -- | Reciprocal of @squaredCurvature@ -squaredRadiusOfCurvature :: Segment Closed R2 -> Double -> PosInf Double -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 . (\(V2 p q) -> (V2 q (p * p))) . curvaturePair s -- 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 @@ -139,13 +139,14 @@ 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 :: Int)) 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 @@ -153,3 +154,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 c324ce69..1acfe937 100644 --- a/src/Diagrams/TwoD/Deform.hs +++ b/src/Diagrams/TwoD/Deform.hs @@ -1,36 +1,41 @@ 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 Linear.V2 +import Linear.Vector --- | The parallel projection onto the line x=0 -parallelX0 :: Deformation R2 -parallelX0 = Deformation (& _x .~ 0) +-- | 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 :: Deformation R2 -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 :: Deformation R2 -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 :: Deformation R2 -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 :: Deformation R2 -facingX = Deformation (\v -> v & _y //~ (v^._x)) +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 -facingY :: Deformation R2 -facingY = Deformation (\v -> v & _x //~ (v^._y)) diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index 988e4112..b5c44c0d 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -26,8 +27,8 @@ import Diagrams.Core 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 @@ -35,18 +36,18 @@ import Diagrams.TwoD.Vector (xDir) import Diagrams.Util -- | A circle of radius 1, with center at the origin. -unitCircle :: (TrailLike t, V t ~ R2) => t -unitCircle = trailLike $ glueTrail (arcT xDir fullTurn) `at` (p2 (1,0)) +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, V t ~ R2, Transformable t) => Double -> 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, V t ~ R2, Transformable t) => Double -> 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." @@ -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, 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/Image.hs b/src/Diagrams/TwoD/Image.hs index 53206e7c..e7cd2b40 100644 --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -4,6 +4,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- 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 @@ -29,23 +31,21 @@ module Diagrams.TwoD.Image , rasterDia ) where - import Codec.Picture import Codec.Picture.Types (dynamicMap) -import Data.Typeable (Typeable) import Data.Colour (AlphaColour) +import Data.Semigroup +import Data.Typeable (Typeable) 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 -import Data.AffineSpace ((.-.)) -import Data.Semigroup +import Linear.Affine data Embedded deriving Typeable data External deriving Typeable @@ -56,51 +56,56 @@ 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) ------------------------------------------------------------------------------- -- | 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 -> T2 -> DImage t +data DImage :: * -> * -> * where + DImage :: ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t deriving Typeable -type instance V (DImage a) = R2 +type instance V (DImage n a) = V2 +type instance N (DImage n a) = n -instance Transformable (DImage a) where +instance Fractional n => Transformable (DImage n a) where transform t1 (DImage iD w h t2) = DImage iD w h (t1 <> t2) -instance HasOrigin (DImage 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 a) b) => DImage a -> Diagram b R2 -image img = mkQD (Prim (img)) (getEnvelope r) (getTrace r) mempty - (Query $ \p -> Any (isInsideEvenOdd p r)) +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)) where - r :: Path R2 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 :: 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 -- of the raster data -loadImageExt :: FilePath -> IO (Either String (DImage External)) +loadImageExt :: Num n => FilePath -> IO (Either String (DImage n External)) loadImageExt path = do dImg <- readImage path return $ case dImg of @@ -113,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 :: FilePath -> Int -> Int -> DImage 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 Embedded) b - => (Int -> Int -> AlphaColour Double) -> Int -> Int -> Diagram b R2 +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 -- | Create an image "from scratch" by specifying the pixel data -raster :: (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage 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 @@ -135,5 +140,6 @@ 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 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 d2a30e56..513ad8a1 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Model @@ -20,66 +21,65 @@ module Diagrams.TwoD.Model , showLabels ) where -import Control.Lens (makeLenses, (^.)) +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.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.Text import Diagrams.TwoD.Types import Diagrams.Util -import Control.Arrow (second) -import Data.AffineSpace ((.-.)) -import Data.Default.Class -import Data.Semigroup -import Data.VectorSpace ((^*)) - -import qualified Data.Map as M - -import Data.Colour (Colour) -import Data.Colour.Names +import Linear.Affine +import Linear.Vector ------------------------------------------------------------ -- Marking the origin ------------------------------------------------------------ -data OriginOpts = OriginOpts { _oColor :: Colour Double - , _oScale :: Double - , _oMinSize :: Double - } +data OriginOpts n = OriginOpts + { _oColor :: Colour Double + , _oScale :: n + , _oMinSize :: n + } makeLenses ''OriginOpts -instance Default OriginOpts 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 R2) b, Backend b R2, Monoid' m) - => QDiagram b R2 m -> QDiagram b R2 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' :: (Renderable (Path R2) b, Backend b R2, Monoid' m) - => OriginOpts -> QDiagram b R2 m -> QDiagram b R2 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) - # fc (oo^.oColor) - # lineWidth (Output 0) - # fmap (const mempty) - (w,h) = size2D d ^* oo^.oScale - sz = maximum [w, h, oo^.oMinSize] + # fc (oo^.oColor) + # lw none + # fmap (const mempty) + V2 w h = oo^.oScale *^ size d + sz = maximum [w, h, oo^.oMinSize] ------------------------------------------------------------ -- Labeling named points ------------------------------------------------------------ -showLabels :: (Renderable Text b, Backend b R2, Semigroup m) - => QDiagram b R2 m -> QDiagram b R2 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 a9cb20ea..b93d2e88 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Offset @@ -10,15 +13,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 @@ -37,42 +40,44 @@ 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) - -unitPerp :: R2 -> R2 -unitPerp = normalized . perp - -perpAtParam :: Segment Closed R2 -> Double -> R2 -perpAtParam (Linear (OffsetClosed a)) _ = -unitPerp a -perpAtParam s@(Cubic _ _ _) t = -unitPerp a +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 + +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 @@ -103,59 +108,63 @@ perpAtParam s@(Cubic _ _ _) t = -unitPerp a -- | Options for specifying line join and segment epsilon for an offset -- involving multiple segments. -data OffsetOpts = OffsetOpts - { _offsetJoin :: LineJoin - , _offsetMiterLimit :: Double - , _offsetEpsilon :: Double - } deriving (Eq, Show) +data OffsetOpts d = OffsetOpts + { _offsetJoin :: LineJoin + , _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 - { _expandJoin :: LineJoin - , _expandMiterLimit :: Double - , _expandCap :: LineCap - , _expandEpsilon :: Double +data ExpandOpts d = ExpandOpts + { _expandJoin :: LineJoin + , _expandMiterLimit :: d + , _expandCap :: LineCap + , _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 :: 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 @@ -163,20 +172,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 + -> n -- ^ 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 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 + 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 @@ -200,7 +209,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') @@ -209,7 +218,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 :: (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] @@ -218,7 +227,7 @@ offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va -- > -- > colors = cycle [green, red] -- > --- > cubicOffsetExample :: Diagram SVG R2 +-- > cubicOffsetExample :: (OrderedField n) => Diagram SVG v -- > cubicOffsetExample = hcat . map showExample $ -- > [ bezier3 (10 ^& 0) ( 5 ^& 18) (10 ^& 20) -- > , bezier3 ( 0 ^& 20) ( 10 ^& 10) ( 5 ^& 10) @@ -231,15 +240,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, 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 --- 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)) - => Located (Trail v) -> [Located (Segment Closed v)] +-- While we build offsets and expansions we will use the [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 @@ -260,12 +269,13 @@ locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints 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' :: 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 V2 n) + -> Located (Trail V2 n) offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r ends . offset $ t where eps = opts^.offsetEpsilon @@ -277,17 +287,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 :: 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' :: OffsetOpts -> Double -> Path R2 -> Path R2 +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 :: Double -> Path R2 -> Path R2 +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 @@ -296,10 +306,10 @@ offsetPath = offsetPath' def -- > import Diagrams.TwoD.Offset -- > import Data.Default.Class -- > --- > corner :: Located (Trail R2) +-- > corner :: (OrderedField n) => Located (Trail V2 n) -- > corner = fromVertices (map p2 [(0, 0), (10, 0), (5, 6)]) `at` origin -- > --- > offsetTrailExample :: Diagram SVG R2 +-- > offsetTrailExample :: (OrderedField n) => Diagram SVG v -- > offsetTrailExample = pad 1.1 . centerXY . lwO 3 . hcat' (def & sep .~ 1 ) -- > . map (uncurry showStyle) -- > $ [ (LineJoinMiter, "LineJoinMiter") @@ -311,7 +321,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 :: (OrderedField n) => Diagram SVG v -- > offsetTrailLeftExample = pad 1.1 . centerXY . lwO 3 -- > $ (trailLike c # lc blue) -- > <> (lc green . trailLike @@ -319,7 +329,7 @@ offsetPath = offsetPath' def -- > where -- > c = reflectY corner -- > --- > offsetTrailOuterExample :: Diagram SVG R2 +-- > offsetTrailOuterExample :: (OrderedField n) => Diagram SVG v -- > offsetTrailOuterExample = pad 1.1 . centerXY . lwO 3 -- > $ (trailLike c # lc blue) -- > <> (lc green . trailLike @@ -327,7 +337,7 @@ offsetPath = offsetPath' def -- > where -- > c = hexagon 5 -withTrailL :: (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 @@ -345,57 +355,58 @@ 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' :: (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 R2) - -> Path R2 + -> 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 :: ExpandOpts -> Double -> Located (Trail' Line R2) -> Located (Trail R2) +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 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 e = atEnd t cap = fromLineCap (opts^.expandCap) -expandLoop :: ExpandOpts -> Double -> Located (Trail' Loop R2) -> Path R2 -expandLoop opts r (mapLoc wrapLoop -> t) = (trailLike $ f r) <> (trailLike . reverseDomain . f $ -r) +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 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 -- | Expand a 'Trail' with the given radius and default options. See 'expandTrail''. -expandTrail :: Double -> Located (Trail R2) -> Path R2 +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' :: ExpandOpts -> Double -> Path R2 -> Path R2 +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 :: Double -> Path R2 -> Path R2 +expandPath :: RealFloat n => n -> Path V2 n -> Path V2 n expandPath = expandPath' def -- > import Diagrams.TwoD.Offset -- > import Data.Default.Class -- > --- > expandTrailExample :: Diagram SVG R2 +-- > expandTrailExample :: (OrderedField n) => Diagram SVG v -- > expandTrailExample = pad 1.1 . centerXY . hcat' (def & sep .~ 1) -- > . map (uncurry showStyle) -- > $ [ (LineCapButt, "LineCapButt") @@ -411,7 +422,7 @@ expandPath = expandPath' def -- > # lw none # fc green) -- > === (strutY 3 <> text s # font "Helvetica" # bold) -- > --- > expandLoopExample :: Diagram SVG R2 +-- > expandLoopExample :: (OrderedField n) => Diagram SVG v -- > expandLoopExample = pad 1.1 . centerXY $ ((strokeLocT t # lw veryThick # lc white) -- > <> (stroke t' # lw none # fc green)) -- > where @@ -428,8 +439,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 :: 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 @@ -438,25 +449,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 :: LineCap -> Double -> P2 -> P2 -> P2 -> Trail R2 +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 :: Double -> P2 -> P2 -> P2 -> Trail R2 +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 :: Double -> P2 -> P2 -> P2 -> Trail R2 +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 :: Double -> P2 -> P2 -> P2 -> Trail R2 +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) @@ -464,11 +475,11 @@ capArc r c a b = trailLike . moveTo c $ fs -- Arc helpers -- always picks the shorter arc (< τ/2) -arcV :: (TrailLike t, V t ~ R2) => R2 -> R2 -> 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 :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t -arcVCW u v = arc (direction u) (negateV $ angleBetween v u) +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 -- style is given as a function to compute the join given the local information @@ -478,14 +489,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 :: RealFloat n + => n + -> (n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n) -> Bool - -> Double - -> Double - -> [Point R2] - -> [Located (Trail R2)] - -> Located (Trail R2) + -> 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' @@ -500,7 +512,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 + :: 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 @@ -510,7 +522,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 :: (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) @@ -520,19 +532,21 @@ 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 :: 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 :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +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 - :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 -joinSegmentIntersect miterLimit r e a b = + :: 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 else case traceP pa va t of @@ -547,10 +561,10 @@ joinSegmentIntersect miterLimit r e a b = where t = straight (miter vb) `at` pb va = unitPerp (pa .-. e) - vb = -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/Path.hs b/src/Diagrams/TwoD/Path.hs index f75403b7..9c598c4f 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -4,8 +4,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -45,19 +47,16 @@ 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 -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) @@ -71,6 +70,9 @@ import Diagrams.TwoD.Segment () import Diagrams.TwoD.Types import Diagrams.Util (tau) +import Linear.Affine +import Linear.Vector + ------------------------------------------------------------ -- Trail and path traces --------------------------------- ------------------------------------------------------------ @@ -79,14 +81,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 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 Traced (Path R2) where +instance RealFloat n => Traced (Path V2 n) where getTrace = F.foldMap getTrace . op Path ------------------------------------------------------------ @@ -157,11 +159,12 @@ 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 :: (TypeableFloat n, Renderable (Path V2 n) b) + => Path V2 n -> Diagram b V2 n stroke = stroke' (def :: StrokeOpts ()) -instance Renderable (Path R2) b => TrailLike (QDiagram b R2 Any) 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 @@ -171,11 +174,12 @@ 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' :: (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 @@ -196,60 +200,66 @@ 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 :: (TypeableFloat n, Renderable (Path V2 n) b) + => Trail V2 n -> Diagram b V2 n strokeTrail = stroke . pathFromTrail -- | Deprecated synonym for 'strokeTrail'. -strokeT :: (Renderable (Path R2) b) => Trail R2 -> Diagram b R2 +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' :: (Renderable (Path R2) b, IsName a) - => StrokeOpts a -> Trail R2 -> Diagram b R2 +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' :: (Renderable (Path R2) b, IsName a) - => StrokeOpts a -> Trail R2 -> Diagram b R2 +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 :: (Renderable (Path R2) b) => Trail' Line R2 -> Diagram b R2 +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 :: (Renderable (Path R2) b) => Trail' Loop R2 -> Diagram b R2 +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 :: (Renderable (Path R2) b) => Located (Trail R2) -> Diagram b R2 +strokeLocTrail :: (TypeableFloat n, Renderable (Path V2 n) b) + => Located (Trail V2 n) -> Diagram b V2 n strokeLocTrail = stroke . trailLike -- | Deprecated synonym for 'strokeLocTrail'. -strokeLocT :: (Renderable (Path R2) b) => Located (Trail R2) -> Diagram b R2 +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 :: (Renderable (Path R2) b) => Located (Trail' Line R2) -> Diagram b R2 +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 :: (Renderable (Path R2) b) => Located (Trail' Loop R2) -> Diagram b R2 +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 :: FillRule -> P2 -> Path R2 -> Bool +runFillRule :: RealFloat n => FillRule -> Point V2 n -> Path V2 n -> Bool runFillRule Winding = isInsideWinding runFillRule EvenOdd = isInsideEvenOdd @@ -258,7 +268,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 @@ -269,8 +279,8 @@ getFillRule (FillRuleA (Last r)) = r fillRule :: HasStyle a => FillRule -> a -> a fillRule = applyAttr . FillRuleA . Last -cross :: R2 -> R2 -> Double -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 @@ -278,7 +288,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 :: 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, @@ -286,17 +296,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 :: 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 :: P2 -> Path R2 -> 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 :: P2 -> Located (Trail R2) -> 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 @@ -309,10 +319,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)) @@ -323,15 +338,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 ---------------------------------------------- @@ -342,16 +357,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 = Clip [Path R2] +newtype Clip n = Clip [Path V2 n] deriving (Typeable, Semigroup) makeWrapped ''Clip -instance AttributeClass Clip +instance Typeable n => AttributeClass (Clip n) -type instance V Clip = R2 +type instance V (Clip n) = V2 +type instance N (Clip n) = n -instance Transformable Clip where +instance (OrderedField n) => Transformable (Clip n) where transform t (Clip ps) = Clip (transform t ps) -- | Clip a diagram by the given path: @@ -360,7 +376,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 :: (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 @@ -368,7 +384,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 :: (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 @@ -388,5 +404,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 :: (Renderable (Path R2) b) => Path R2 -> Diagram b R2 -> Diagram b R2 -clipped p = (withTrace p) . (withEnvelope p) . (clipBy p) +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 4804f061..9ba4bf93 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -46,26 +46,22 @@ 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.Default.Class import Data.List (maximumBy, minimumBy) 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 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 @@ -73,8 +69,12 @@ 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 = PolyPolar [Angle] [Double] +data PolyType n = PolyPolar [Angle n] [n] -- ^ A \"polar\" polygon. -- -- * The first argument is a list of /central/ @@ -91,7 +91,7 @@ data PolyType = PolyPolar [Angle] [Double] -- circle) can be constructed using a second -- argument of @(repeat r)@. - | PolySides [Angle] [Double] + | PolySides [Angle n] [n] -- ^ A polygon determined by the distance between -- successive vertices and the angles formed by -- each three successive vertices. In other @@ -116,53 +116,54 @@ data PolyType = PolyPolar [Angle] [Double] -- angles and /n-1/ edge lengths. Extra angles or -- lengths are ignored. - | PolyRegular Int Double + | 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 = NoOrient -- ^ No special orientation; the first - -- vertex will be at (1,0). - | OrientH -- ^ Orient /horizontally/, so the - -- bottommost edge is parallel to - -- the x-axis. This is the default. - | OrientV -- ^ Orient /vertically/, so the - -- leftmost edge is parallel to the - -- y-axis. - | OrientTo R2 -- ^ Orient so some edge is - -- /facing/ /in/ /the/ /direction/ - -- /of/, that is, perpendicular - -- to, the given vector. - deriving (Eq, Ord, Show, Read) +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 = PolygonOpts - { _polyType :: PolyType - , _polyOrient :: PolyOrientation - , _polyCenter :: P2 +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 PolyType +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 PolyOrientation +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 P2 +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 Default PolygonOpts where +instance Num n => Default (PolygonOpts n) where def = PolygonOpts (PolyRegular 5 1) OrientH origin -- | Generate a polygon. See 'PolygonOpts' for more information. -polyTrail :: PolygonOpts -> Located (Trail R2) +polyTrail :: RealFloat n => PolygonOpts n -> Located (Trail V2 n) 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 :: (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 -- (central angles and radii). See 'PolyPolar'. -polyPolarTrail :: [Angle] -> [Double] -> Located (Trail R2) +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 @@ -190,52 +191,52 @@ 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 :: [Angle] -> [Double] -> Located (Trail R2) +polySidesTrail :: RealFloat 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 :: Int -> Double -> Located (Trail R2) +polyRegularTrail :: RealFloat 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 :: R2 -> Located (Trail R2) -> T2 +orient :: RealFloat n => V2 n -> Located (Trail V2 n) -> Transformation V2 n orient v = orientPoints v . trailVertices -orientPoints :: R2 -> [P2] -> T2 +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 + -- a :: Angle (Scalar v) a = minimumBy (comparing $ abs . view rad) . map (angleFromNormal . (.-. x)) $ [n1,n2] - v' = normalized v - angleFromNormal :: R2 -> Angle + 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') - phi :: Angle + o' = signorm o + theta = acos (v' `dot` o') + -- phi :: Angle (Scalar v) phi | theta <= tau/4 = tau/4 - theta @@ rad | otherwise = theta - tau/4 @@ rad @@ -275,10 +276,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 @@ -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 :: OrderedField n => StarOpts -> [Point V2 n] -> Path V2 n 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 1f3327dd..7530bfb9 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -22,10 +23,7 @@ module Diagrams.TwoD.Segment where import Control.Applicative (liftA2) -import Control.Lens ((^.)) - -import Data.AffineSpace -import Data.VectorSpace +import Control.Lens ((^.)) import Diagrams.Core @@ -39,14 +37,18 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Diagrams.Util +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. -} -instance Traced (Segment Closed R2) where +instance RealFloat n => Traced (Segment Closed V2 n) where getTrace = getTrace . mkFixedSeg . (`at` origin) -instance Traced (FixedSegment R2) 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 @@ -72,14 +74,15 @@ instance Traced (FixedSegment R2) 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); @@ -95,8 +98,8 @@ instance Traced (FixedSegment R2) 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 de2f1b5a..7cb75471 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -45,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 @@ -58,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. -- @@ -71,8 +71,8 @@ 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 d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` (p2 (-d/2,0)) +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, V t ~ R2) => Double -> t -vrule d = trailLike $ trailFromSegments [straight $ r2 (0, (-d))] `at` (p2 (0,d/2)) +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, V t ~ R2) => 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, V t ~ R2) => Double -> 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, V t ~ R2) => Double -> Double -> 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, V t ~ R2) => Int -> Double -> 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,90 +159,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 ~ 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, V t ~ R2) => Double -> 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, V t ~ R2) => Double -> 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, V t ~ R2) => Double -> 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, V t ~ R2) => Double -> 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, V t ~ R2) => Double -> 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, V t ~ R2) => Double -> 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, V t ~ R2) => Double -> 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, V t ~ R2) => Double -> 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, V t ~ R2) => Double -> 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, V t ~ R2) => Double -> t +dodecagon :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> 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 +266,7 @@ instance Default RoundedRectOpts where -- > & radiusBR .~ 0.1) -- > ] -roundedRect :: (TrailLike t, V t ~ R2) => Double -> Double -> Double -> 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,10 +276,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 ~ R2) => Double -> Double -> RoundedRectOpts -> 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))) + . (`at` p2 (w/2, abs rBR - h/2)) . wrapTrail . glueLine $ seg (0, h - abs rTR - abs rBR) diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index 942c1575..081efa99 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -23,6 +23,7 @@ module Diagrams.TwoD.Size -- ** Specifying sizes , SizeSpec2D(..) , mkSizeSpec + , spec2D , requiredScaleT, requiredScale @@ -30,50 +31,53 @@ module Diagrams.TwoD.Size , sized, sizedAs, sizePair ) where +import Control.Applicative +import Control.Arrow ((&&&), (***)) +import Control.Lens (Iso', iso) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + import Diagrams.Core import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -import Control.Applicative (liftA2, (<$>)) -import Control.Arrow ((&&&), (***)) -import Data.Hashable (Hashable) -import GHC.Generics (Generic) +import Linear.Vector ------------------------------------------------------------ -- Computing diagram sizes ------------------------------------------------------------ -- | Compute the width of an enveloped object. -width :: (Enveloped a, V a ~ R2) => a -> Double +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 :: (Enveloped a, V a ~ R2) => a -> Double +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 :: (Enveloped a, V a ~ R2) => a -> (Double, Double) +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 :: (Enveloped a, V a ~ R2) => a -> SizeSpec2D +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 :: (Enveloped a, V a ~ R2) => a -> Maybe (Double, Double) +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 :: (Enveloped a, V a ~ R2) => a -> Maybe (Double, Double) +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 :: (Enveloped a, V a ~ R2) => a -> P2 +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 (+) @@ -83,36 +87,47 @@ center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) ------------------------------------------------------------ -- | A specification of a (requested) rectangular size. -data SizeSpec2D = Width !Double -- ^ Specify an explicit - -- width. The height should be - -- determined automatically (so - -- as to preserve aspect ratio). - | Height !Double -- ^ Specify an explicit - -- height. The width should be - -- determined automatically (so - -- as to preserve aspect ratio). - | Dims !Double !Double -- ^ 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 SizeSpec2D +instance Hashable n => Hashable (SizeSpec2D n) -- | 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 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 :: SizeSpec2D -> (Double, Double) -> Transformation R2 -requiredScaleT spec size = scaling (requiredScale spec size) +requiredScaleT + :: (Additive v, RealFloat n) + => SizeSpec2D n -> (n, n) -> Transformation v n +requiredScaleT spec sz = scaling (requiredScale spec sz) +-- 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@, @@ -120,7 +135,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 :: (RealFloat d) => SizeSpec2D d -> (d, d) -> d requiredScale Absolute _ = 1 requiredScale (Width wSpec) (w,_) | wSpec == 0 || w == 0 = 1 @@ -137,21 +152,22 @@ 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 :: (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 :: ( Transformable a, Enveloped a, V a ~ R2 - , Enveloped b, V b ~ R2) +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) -- | 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') sizePair Absolute = (100,100) + diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index b8666863..4d778afc 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -2,7 +2,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Text @@ -36,12 +39,13 @@ 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 Linear.Affine + ------------------------------------------------------------ -- Text diagrams ------------------------------------------------------------ @@ -52,12 +56,13 @@ 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 n = Text (Transformation V2 n) (Transformation V2 n) (TextAlignment n) String deriving Typeable -type instance V Text = R2 +type instance V (Text n) = V2 +type instance N (Text n) = n -instance Transformable Text 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) @@ -65,16 +70,17 @@ 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 Floating n => HasOrigin (Text n) where moveOriginTo p = translate (origin .-. p) -instance Renderable Text NullBackend where +instance Floating n => Renderable (Text n) 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 :: Renderable Text b => TextAlignment -> String -> Diagram b R2 +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] @@ -111,7 +117,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 :: (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 @@ -119,7 +125,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 :: (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 @@ -131,7 +137,8 @@ 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 :: (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 @@ -140,7 +147,8 @@ 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 :: (OrderedField n, Typeable n, Renderable (Text n) b) + => String -> Diagram b V2 n baselineText = mkText BaselineText ------------------------------------------------------------ @@ -169,62 +177,65 @@ 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 n = FontSize (Last (Measure n, Bool)) + deriving (Typeable, Semigroup) + +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 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 n) = V2 +type instance N (FontSize n) = n -instance Default FontSize 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, -- 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 Transformable (FontSize n) where transform _ f = f -- | Extract the size from a @FontSize@ attribute. -getFontSize :: FontSize -> Measure R2 +getFontSize :: FontSize n -> Measure n getFontSize (FontSize (Last (s,_))) = s -- | Determine whether a @FontSize@ attribute began its life measured -- in 'Local' units. -getFontSizeIsLocal :: FontSize -> 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 :: (HasStyle a, V a ~ R2) => Measure R2 -> 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 :: (HasStyle a, V a ~ R2) => Double -> 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 :: (HasStyle a, V a ~ R2) => Double -> 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 :: (HasStyle a, V a ~ R2) => Double -> 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 :: (HasStyle a, V a ~ R2) => Double -> 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 :: (HasStyle a, V a ~ R2) => FontSize -> a -> a +fontSizeA :: (Data n, HasStyle a, V a ~ V2, N a ~ n) => FontSize n -> a -> a fontSizeA = applyGTAttr -------------------------------------------------- @@ -233,7 +244,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. @@ -265,7 +276,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 diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 097fd500..f5e11f25 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -18,10 +19,11 @@ module Diagrams.TwoD.Transform ( + T2 -- * Rotation - rotation, rotate, rotateBy + , rotation, rotate, rotateBy - , rotationAbout, rotateAbout + , rotationAround, rotateAround -- * Scaling , scalingX, scaleX @@ -46,33 +48,34 @@ 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.Size (height, width) import Diagrams.TwoD.Types -import Diagrams.Coordinates -import Data.AdditiveGroup -import Data.AffineSpace +import Control.Lens (review, (&), (*~), (.~), (//~), (^.)) import Data.Semigroup -import Control.Lens (review, (^.)) + +import Linear.Affine +import Linear.Vector + +type T2 = Transformation V2 -- Rotation ------------------------------------------------ -- | Create a transformation which performs a rotation about the local -- origin by the given angle. See also 'rotate'. -rotation :: Angle -> T2 +rotation :: Floating n => Angle n -> T2 n 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) + 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 -- correspond to counterclockwise rotation, negative to @@ -87,164 +90,180 @@ 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 :: (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 :: (Transformable t, V t ~ R2) => Double -> 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 -- around the local origin). -rotationAbout :: P2 -> Angle -> T2 -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 :: (Transformable t, V t ~ R2) => P2 -> Angle -> t -> t -rotateAbout p angle = rotate angle `under` translation (origin .-. p) +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 ------------------------------------------------- -- | Construct a transformation which scales by the given factor in -- the x (horizontal) direction. -scalingX :: Double -> T2 +scalingX :: (R1 v, Additive v, Floating n) => n -> Transformation v n scalingX c = fromLinear s s - where s = (\(R2 x y) -> R2 (x*c) y) <-> (\(R2 x y) -> R2 (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 :: (Transformable t, V t ~ R2) => Double -> t -> t +scaleX :: (V t ~ v, N t ~ 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 :: Double -> T2 +scalingY :: (R2 v, Additive v, Floating n) => n -> Transformation v n scalingY c = fromLinear s s - where s = (\(R2 x y) -> R2 x (y*c)) <-> (\(R2 x y) -> R2 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 :: (Transformable t, V t ~ R2) => Double -> t -> t +scaleY :: (V t ~ v, N t ~ n, Transformable t, R2 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 :: (Enveloped t, Transformable t, V t ~ R2) => Double -> 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 :: (Enveloped t, Transformable t, V t ~ R2) => Double -> 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 :: (Enveloped t, Transformable t, V t ~ R2) => Double -> 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 :: (Enveloped t, Transformable t, V t ~ R2) => Double -> 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 --------------------------------------------- -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. -translationX :: Double -> T2 -translationX x = translation (x ^& 0) +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 :: (Transformable t, V t ~ R2) => Double -> t -> t +translateX :: (V t ~ v, N t ~ 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 :: Double -> T2 -translationY y = translation (0 ^& y) +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 :: (Transformable t, V t ~ R2) => Double -> t -> t +translateY :: (V t ~ v, N t ~ n, Transformable t, R2 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 :: T2 +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 :: (Transformable t, V t ~ R2) => 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 -- bottom, i.e. sends the point (x,y) to (x,-y). -reflectionY :: T2 +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 :: (Transformable t, V t ~ R2) => t -> t +reflectY :: (V t ~ v, N t ~ n, Transformable t, R2 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 :: P2 -> R2 -> T2 +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 :: (Transformable t, V t ~ R2) => P2 -> R2 -> 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 -------------------------------------------------- +-- auxiliary functions for shearingX/shearingY +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' :: (n -> n -> n -> n) -> (n -> n -> n -> n) -> n -> V2 n -> V2 n +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)@. -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 :: 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 -- | @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 :: (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 -- 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 :: 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 -- | @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 :: (V t ~ V2, N t ~ 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 :: Transformation R2 -> ((R2, R2), R2) -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 2b5ff576..7d2c0e5c 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform.ScaleInv @@ -17,11 +22,10 @@ module Diagrams.TwoD.Transform.ScaleInv ( ScaleInv(..) , scaleInvObj, scaleInvDir, scaleInvLoc - , scaleInv, scaleInvPrim ) + , scaleInv, scaleInvPrim) where -import Control.Lens (makeLenses, view,(^.)) -import Data.AffineSpace ((.-.)) +import Control.Lens (makeLenses, view, (^.)) import Data.Semigroup import Data.Typeable @@ -30,6 +34,9 @@ import Diagrams.Core import Diagrams.TwoD.Transform import Diagrams.TwoD.Types +import Linear.Affine +import Linear.Vector + -- | 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. @@ -64,30 +71,36 @@ import Diagrams.TwoD.Types data ScaleInv t = ScaleInv { _scaleInvObj :: t - , _scaleInvDir :: R2 - , _scaleInvLoc :: P2 + , _scaleInvDir :: Vn t + , _scaleInvLoc :: Point (V t) (N t) } - deriving (Show, Typeable) + deriving Typeable + +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 :: t -> R2 -> 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) = R2 +type instance V (ScaleInv t) = V t +type instance N (ScaleInv t) = N t -instance (V t ~ R2, 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 (V t ~ R2, 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) - rot :: (Transformable t, V t ~ R2) => t -> t - rot = rotateAbout l angle + angle = transform tr v ^. _theta + + rot :: (V k ~ V t, N k ~ N t, Transformable k) => k -> k + rot = rotateAround l angle + l' = transform tr l + trans = translate (l' .-. l) {- Proof that the above satisfies the monoid action laws. @@ -100,28 +113,28 @@ instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where = 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 @@ -135,7 +148,7 @@ instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where = 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 } @@ -143,13 +156,13 @@ instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where = 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 = ??? } -} -instance (Renderable t b, V t ~ R2) => 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 @@ -167,6 +180,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 :: (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 diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 61a29779..a20018e8 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -1,13 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Types @@ -21,241 +15,78 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space - R2(..), r2, unr2, mkR2, r2Iso - , P2, p2, mkP2, unp2, p2Iso - , T2 - + V2 (..), P2, R1 (..), R2 (..) + , r2, unr2, mkR2, r2Iso + , p2, mkP2, unp2, p2Iso + , r2polarIso + , HasR (..) ) where -import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, (^.), _1, _2) - +import Control.Lens (Iso', Lens', iso, _1, _2) import Diagrams.Angle -import Diagrams.Direction -import Diagrams.Coordinates -import Diagrams.Core +import Diagrams.Points -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. --- --- * 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) = ... --- @ +import Diagrams.Core.Transform +import Diagrams.Core.V +import Linear.Metric +import Linear.V2 -data R2 = R2 {-# UNPACK #-} !Double - {-# UNPACK #-} !Double - deriving (Eq, Ord, Typeable, Data) +type P2 = Point V2 -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 +type instance V (V2 n) = V2 +type instance N (V2 n) = n -- | Construct a 2D vector from a pair of components. See also '&'. -r2 :: (Double, Double) -> R2 -r2 (x,y) = R2 x y +r2 :: (n, n) -> V2 n +r2 = uncurry V2 -- | Convert a 2D vector back into a pair of components. See also 'coords'. -unr2 :: R2 -> (Double, Double) -unr2 (R2 x y) = (x,y) +unr2 :: V2 n -> (n, n) +unr2 (V2 x y) = (x, y) -- | Curried form of `r2`. -mkR2 :: Double -> Double -> R2 -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) - -data R2Basis = XB | YB deriving (Eq, Ord, Enum) - -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)] - -instance HasBasis R2 where - type Basis R2 = R2Basis - basisValue XB = R2 1 0 - basisValue YB = R2 0 1 +mkR2 :: n -> n -> V2 n +mkR2 = V2 - 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 - -r2Iso :: Iso' R2 (Double, Double) +r2Iso :: Iso' (V2 n) (n, n) r2Iso = iso unr2 r2 -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 HasTheta (Direction R2) where - _theta = _Dir . _theta - --- | 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 :: (Double, Double) -> P2 -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 :: P2 -> (Double, Double) -unp2 (P v) = unr2 v +unp2 :: P2 n -> (n,n) +unp2 (P (V2 x y)) = (x,y) -- | Curried form of `p2`. -mkP2 :: Double -> Double -> P2 -mkP2 = curry p2 +mkP2 :: n -> n -> P2 n +mkP2 x = P . V2 x --- | Transformations in R^2. -type T2 = Transformation R2 - -instance Transformable R2 where - transform = apply - -p2Iso :: Iso' P2 (Double, Double) +p2Iso :: Iso' (Point V2 n) (n, n) p2Iso = iso unp2 p2 -instance HasX P2 where - _x = p2Iso . _1 - -instance HasY P2 where - _y = p2Iso . _2 +instance Transformable (V2 n) where + transform = apply -instance HasR P2 where - _r = _relative origin . _r +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 #-} -instance HasTheta P2 where - _theta = _relative origin . _theta +-- | A space which has magnitude '_r' that can be calculated numerically. +class HasR t where + _r :: RealFloat n => Lens' (t n) n --- | Types which can be expressed in polar 2D coordinates, as a magnitude and an angle. -class Polar t where - polar :: Iso' t (Double, Angle) +instance HasR v => HasR (Point v) where + _r = lensP . _r + {-# INLINE _r #-} -instance Polar R2 where - polar = - iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) - (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) +instance HasR V2 where + _r = r2polarIso . _1 + {-# INLINE _r #-} -instance Polar P2 where - polar = _relative origin . polar +instance HasTheta V2 where + _theta = r2polarIso . _2 + {-# INLINE _theta #-} diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 7ae5396a..20123802 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Vector @@ -21,50 +18,47 @@ module Diagrams.TwoD.Vector -- * 2D vector utilities , perp, leftTurn + -- * Synonym for R2 things ) where -import Control.Lens ((&), (.~)) +import Control.Lens (view, (&), (.~)) -import Data.VectorSpace +import Diagrams.Angle +import Diagrams.Direction -import Diagrams.Angle -import Diagrams.Direction -import Diagrams.TwoD.Types -import Diagrams.Coordinates +import Linear.Metric +import Linear.V2 +import Linear.Vector -- | The unit vector in the positive X direction. -unitX :: R2 -unitX = 1 ^& 0 - --- | The unit vector in the positive Y direction. -unitY :: R2 -unitY = 0 ^& 1 +unitX :: (R1 v, Additive v, Num n) => v n +unitX = zero & _x .~ 1 -- | The unit vector in the negative X direction. -unit_X :: R2 -unit_X = (-1) ^& 0 +unit_X :: (R1 v, Additive v, Num n) => v n +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 -unit_Y = 0 ^& (-1) +unit_Y :: (R2 v, Additive v, Num n) => v n +unit_Y = zero & _y .~ (-1) -- | The origin of the direction AffineSpace. For all d, @d .-. xDir -- = d^._theta@. -xDir :: Direction R2 +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 :: Angle -> R2 -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 +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 that of @v1@ by adding an angle 0 <= theta <= tau/2). -leftTurn :: R2 -> R2 -> 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 + 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 17ad8bef..46a00c85 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)