diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 5972358c..ce8f9d39 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -25,7 +25,8 @@ Source-repository head location: http://github.com/diagrams/diagrams-lib.git Library - Exposed-modules: Diagrams.Prelude, + Exposed-modules: Diagrams, + Diagrams.Prelude, Diagrams.Align, Diagrams.Angle, Diagrams.Animation, @@ -109,7 +110,7 @@ Library data-default-class < 0.1, fingertree >= 0.1 && < 0.2, intervals >= 0.7 && < 0.8, - lens >= 4.0 && < 4.8, + lens >= 4.6 && < 4.9, tagged >= 0.7, optparse-applicative >= 0.11 && < 0.12, filepath, diff --git a/src/Diagrams.hs b/src/Diagrams.hs new file mode 100644 index 00000000..329a88ac --- /dev/null +++ b/src/Diagrams.hs @@ -0,0 +1,150 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams +-- Copyright : (c) 2015 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- This module only contains exports defined in "diagrams-lib" or +-- "diagrams-core". This module is less likely conflict with any +-- other modules but importing "Diagrams.Prelude" is often more convenient. +-- +----------------------------------------------------------------------------- + +module Diagrams + ( + -- * 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 + + -- | Creating and using bounding boxes. + , module Diagrams.BoundingBox + + -- | 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 + + -- | Utilities for working with size. + , module Diagrams.Size + + -- | Angles + , module Diagrams.Angle + + -- | Convenience infix operators for working with coordinates. + , module Diagrams.Coordinates + + -- | Directions, distinguished from angles or vectors + , module Diagrams.Direction + + -- | A wide range of things (shapes, transformations, + -- combinators) specific to creating two-dimensional + -- diagrams. + , module Diagrams.TwoD + + -- | Extra things for three-dimensional diagrams. + , module Diagrams.ThreeD + + -- | Tools for making animations. + , module Diagrams.Animation + + -- | Various utility definitions. + , module Diagrams.Util + + ) where + +import Diagrams.Core + +import Diagrams.Align +import Diagrams.Angle +import Diagrams.Animation +import Diagrams.Attributes +import Diagrams.BoundingBox hiding (intersection, union, inside, outside, contains) +import Diagrams.Combinators +import Diagrams.Coordinates +import Diagrams.CubicSpline +import Diagrams.Deform +import Diagrams.Direction hiding (dir) +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.Size +import Diagrams.Tangent +import Diagrams.ThreeD +import Diagrams.Trace +import Diagrams.Trail hiding (linePoints, loopPoints, + trailPoints) +import Diagrams.TrailLike +import Diagrams.Transform +import Diagrams.TwoD +import Diagrams.Util + diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 5160db86..6156b736 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -36,10 +36,11 @@ module Diagrams.Angle ) where import Control.Applicative -import Control.Lens (Iso', Lens', iso, over, review, (^.)) +import Control.Lens (AReview, Iso', Lens', iso, over, review, (^.)) import Data.Fixed import Data.Monoid hiding ((<>)) import Data.Semigroup +import Text.Read import Prelude import Diagrams.Core (OrderedField) @@ -52,7 +53,18 @@ import Linear.Vector -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. newtype Angle n = Radians n - deriving (Read, Show, Eq, Ord, Enum, Functor) + deriving (Eq, Ord, Enum, Functor) + +instance Show n => Show (Angle n) where + showsPrec d (Radians a) = showParen (d > 5) $ + showsPrec 6 a . showString " @@ rad" + +instance Read n => Read (Angle n) where + readPrec = parens . prec 5 $ do + x <- readPrec + Symbol "@@" <- lexP + Ident "rad" <- lexP + pure (Radians x) type instance N (Angle n) = n @@ -74,21 +86,22 @@ 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@. +-- | The radian measure of an 'Angle' @a@ can be accessed as @a '^.' +-- rad@. A new 'Angle' can be defined in radians as @pi \@\@ +-- rad@. rad :: Iso' (Angle n) n rad = iso (\(Radians 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 +-- | The measure of an 'Angle' @a@ in full circles can be accessed as +-- @a '^.' turn@. A new 'Angle' of one-half circle can be defined in as -- @1/2 \@\@ turn@. turn :: Floating n => Iso' (Angle n) n turn = iso (\(Radians 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 \@\@ +-- | The degree measure of an 'Angle' @a@ can be accessed as @a +-- '^.' deg@. A new 'Angle' can be defined in degrees as @180 \@\@ -- deg@. deg :: Floating n => Iso' (Angle n) n deg = iso (\(Radians r) -> r / (2*pi/360)) (Radians . ( * (2*pi/360))) @@ -141,7 +154,7 @@ atan2A y x = Radians $ atan2 y x -- | Similar to 'atan2A' but without the 'RealFloat' constraint. This means it -- doesn't handle negative zero cases. However, for most geometric purposes, --- outcome will be the same. +-- the outcome will be the same. atan2A' :: OrderedField n => n -> n -> Angle n atan2A' y x = atan2' y x @@ rad @@ -156,13 +169,30 @@ atan2' y x | x==0 && y==0 = y -- must be after the other double zero tests | otherwise = x + y -- x or y is a NaN, return a NaN (via +) --- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. +-- | @30 \@\@ deg@ is an 'Angle' of the given measure and units. +-- +-- >>> pi @@ rad +-- 3.141592653589793 @@ rad +-- +-- >>> 1 @@ turn +-- 6.283185307179586 @@ rad +-- +-- >>> 30 @@ deg +-- 0.5235987755982988 @@ rad +-- +-- For 'Iso''s, ('@@') 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. +-- +-- This is the same as a flipped 'review'. -- --- 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 -> 'Iso'' s a -> s +-- ('@@') :: a -> 'Prism'' s a -> s +-- ('@@') :: a -> 'Review' s a -> s +-- ('@@') :: a -> 'Equality'' s a -> s +-- @ +(@@) :: b -> AReview a b -> a a @@ i = review i a infixl 5 @@ @@ -180,12 +210,12 @@ normalizeAngle = over rad (`mod'` (2 * pi)) ------------------------------------------------------------ -- Polar Coordinates --- | The class of types with at least one angle coordinate, called _theta. +-- | The class of types with at least one angle coordinate, called '_theta'. class HasTheta t where _theta :: RealFloat n => Lens' (t n) (Angle n) -- | The class of types with at least two angle coordinates, the second called --- _phi. _phi is the positive angle measured from the z axis. +-- '_phi'. '_phi' is the positive angle measured from the z axis. class HasTheta t => HasPhi t where _phi :: RealFloat n => Lens' (t n) (Angle n) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 97cba75e..40fb4aac 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes @@ -37,7 +38,7 @@ module Diagrams.Attributes ( , lw, lwN, lwO, lwL, lwG -- ** Dashing - , Dashing(..), DashingA, _Dashing, _DashingM, getDashing + , Dashing(..), getDashing , dashing, dashingN, dashingO, dashingL, dashingG, _dashing @@ -55,11 +56,11 @@ module Diagrams.Attributes ( -- * Line stuff -- ** Cap style - , LineCap(..), LineCapA, _LineCap + , LineCap(..) , getLineCap, lineCap, _lineCap -- ** Join style - , LineJoin(..), LineJoinA, _LineJoin + , LineJoin(..) , getLineJoin, lineJoin, _lineJoin -- ** Miter limit @@ -177,21 +178,15 @@ _lw = _lineWidth -- | Create lines that are dashing... er, dashed. data Dashing n = Dashing [n] n - deriving (Functor, Typeable) + deriving (Functor, Typeable, Eq) -newtype DashingA n = DashingA (Last (Dashing n)) - deriving (Functor, Typeable, Semigroup) +instance Semigroup (Dashing n) where + _ <> b = b -_Dashing :: Iso' (DashingA n) (Dashing n) -_Dashing = iso getDashing (DashingA . Last) +instance Typeable n => AttributeClass (Dashing n) -_DashingM :: Iso' (Measured n (DashingA n)) (Measured n (Dashing n)) -_DashingM = mapping _Dashing - -instance Typeable n => AttributeClass (DashingA n) - -getDashing :: DashingA n -> Dashing n -getDashing (DashingA (Last d)) = d +getDashing :: Dashing n -> Dashing n +getDashing = id -- | Set the line dashing style. dashing :: (N a ~ n, HasStyle a, Typeable n) @@ -201,7 +196,7 @@ dashing :: (N a ~ n, HasStyle a, Typeable n) -> Measure n -- ^ An offset into the dash pattern at which the -- stroke should start. -> a -> a -dashing ds offs = applyMAttr . distribute $ DashingA (Last (Dashing ds offs)) +dashing ds offs = applyMAttr . distribute $ Dashing ds offs -- | A convenient synonym for 'dashing (global w)'. dashingG :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a @@ -222,7 +217,7 @@ dashingL w v = dashing (map local w) (local v) -- | Lens onto a measured dashing attribute in a style. _dashing :: (Typeable n, OrderedField n) => Lens' (Style v n) (Maybe (Measured n (Dashing n))) -_dashing = atMAttr . mapping _DashingM +_dashing = atMAttr ------------------------------------------------------------------------ -- Color @@ -253,6 +248,18 @@ class Color c where data SomeColor = forall c. Color c => SomeColor c deriving Typeable +instance Show SomeColor where + showsPrec d (colorToSRGBA -> (r,g,b,a)) = + showParen (d > 10) $ showString "SomeColor " . + if a == 0 + then showString "transparent" + else showString "(sRGB " . showsPrec 11 r . showChar ' ' + . showsPrec 11 g . showChar ' ' + . showsPrec 11 b . + (if a /= 1 + then showString " `withOpacity` " . showsPrec 11 a + else id) . showChar ')' + -- | Isomorphism between 'SomeColor' and 'AlphaColour' 'Double'. _SomeColor :: Iso' SomeColor (AlphaColour Double) _SomeColor = iso toAlphaColour fromAlphaColour @@ -260,13 +267,13 @@ _SomeColor = iso toAlphaColour fromAlphaColour someToAlpha :: SomeColor -> AlphaColour Double someToAlpha (SomeColor c) = toAlphaColour c -instance (Floating a, Real a) => Color (Colour a) where - toAlphaColour = opaque . colourConvert - fromAlphaColour = colourConvert . (`over` black) +instance a ~ Double => Color (Colour a) where + toAlphaColour = opaque + fromAlphaColour = (`over` black) -instance (Floating a, Real a) => Color (AlphaColour a) where - toAlphaColour = alphaColourConvert - fromAlphaColour = alphaColourConvert +instance a ~ Double => Color (AlphaColour a) where + toAlphaColour = id + fromAlphaColour = id instance Color SomeColor where toAlphaColour (SomeColor c) = toAlphaColour c @@ -284,7 +291,7 @@ colorToSRGBA col = (r, g, b, a) colorToRGBA = colorToSRGBA {-# DEPRECATED colorToRGBA "Renamed to colorToSRGBA." #-} -alphaToColour :: (Floating a, Ord a, Fractional a) => AlphaColour a -> Colour a +alphaToColour :: (Floating a, Ord a) => AlphaColour a -> Colour a alphaToColour ac | alphaChannel ac == 0 = ac `over` black | otherwise = darken (recip (alphaChannel ac)) (ac `over` black) @@ -332,28 +339,27 @@ data LineCap = LineCapButt -- ^ Lines end precisely at their endpoints. -- centered on endpoints. | LineCapSquare -- ^ Lines are capped with a squares -- centered on endpoints. - deriving (Eq,Show,Typeable) - -newtype LineCapA = LineCapA (Last LineCap) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass LineCapA - -_LineCap :: Iso' LineCapA LineCap -_LineCap = iso getLineCap (LineCapA . Last) + deriving (Eq, Ord, Show, Typeable) instance Default LineCap where def = LineCapButt -getLineCap :: LineCapA -> LineCap -getLineCap (LineCapA (Last c)) = c +instance AttributeClass LineCap + +-- | Last semigroup structure. +instance Semigroup LineCap where + _ <> b = b + +getLineCap :: LineCap -> LineCap +getLineCap = id -- | Set the line end cap attribute. lineCap :: HasStyle a => LineCap -> a -> a -lineCap = applyAttr . LineCapA . Last +lineCap = applyAttr -- | Lens onto the line cap in a style. _lineCap :: Lens' (Style v n) LineCap -_lineCap = atAttr . mapping _LineCap . non def +_lineCap = atAttr . non def -- line join ----------------------------------------------------------- @@ -363,35 +369,34 @@ data LineJoin = LineJoinMiter -- ^ Use a \"miter\" shape (whatever that is). | LineJoinBevel -- ^ Use a \"bevel\" shape (whatever -- that is). Are these... -- carpentry terms? - deriving (Eq, Show, Typeable) + deriving (Eq, Ord, Show, Typeable) -newtype LineJoinA = LineJoinA (Last LineJoin) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass LineJoinA +instance AttributeClass LineJoin -_LineJoin :: Iso' LineJoinA LineJoin -_LineJoin = iso getLineJoin (LineJoinA . Last) +-- | Last semigroup structure. +instance Semigroup LineJoin where + _ <> b = b instance Default LineJoin where def = LineJoinMiter -getLineJoin :: LineJoinA -> LineJoin -getLineJoin (LineJoinA (Last j)) = j +getLineJoin :: LineJoin -> LineJoin +getLineJoin = id -- | Set the segment join style. lineJoin :: HasStyle a => LineJoin -> a -> a -lineJoin = applyAttr . LineJoinA . Last +lineJoin = applyAttr -- | Lens onto the line join type in a style. _lineJoin :: Lens' (Style v n) LineJoin -_lineJoin = atAttr . mapping _LineJoin . non def +_lineJoin = atAttr . non def -- miter limit --------------------------------------------------------- -- | Miter limit attribute affecting the 'LineJoinMiter' joins. -- For some backends this value may have additional effects. newtype LineMiterLimit = LineMiterLimit (Last Double) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup, Eq, Ord) instance AttributeClass LineMiterLimit _LineMiterLimit :: Iso' LineMiterLimit Double @@ -413,7 +418,7 @@ lineMiterLimitA = applyAttr -- | Lens onto the line miter limit in a style. _lineMiterLimit :: Lens' (Style v n) Double -_lineMiterLimit = atAttr . mapping _LineMiterLimit . non 10 +_lineMiterLimit = atAttr . non def . _LineMiterLimit ------------------------------------------------------------------------ -- Recommend optics diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index 77bdec7b..4b025f40 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.BoundingBox --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -23,29 +23,31 @@ ----------------------------------------------------------------------------- module Diagrams.BoundingBox - ( -- * Bounding boxes - BoundingBox - - -- * Constructing bounding boxes - , emptyBox, fromCorners, fromPoint, fromPoints - , boundingBox - - -- * Queries on bounding boxes - , isEmptyBox - , getCorners, getAllCorners - , boxExtents, boxCenter - , mCenterPoint, centerPoint - , boxTransform, boxFit - , contains, contains', boundingBoxQuery - , inside, inside', outside, outside' - - -- * Operations on bounding boxes - , union, intersection - ) where - + ( -- * Bounding boxes + BoundingBox + + -- * Constructing bounding boxes + , emptyBox, fromCorners, fromPoint, fromPoints + , boundingBox + + -- * Queries on bounding boxes + , isEmptyBox + , getCorners, getAllCorners + , boxExtents, boxCenter + , mCenterPoint, centerPoint + , boxTransform, boxFit + , contains, contains', boundingBoxQuery + , inside, inside', outside, outside' + + -- * Operations on bounding boxes + , union, intersection + ) where + +import Control.Lens (AsEmpty (..), nearly) import Data.Foldable as F import Data.Maybe (fromMaybe) import Data.Semigroup +import Text.Read import Diagrams.Align import Diagrams.Core @@ -93,6 +95,9 @@ newtype BoundingBox v n = BoundingBox (Option (NonEmptyBoundingBox v n)) deriving instance (Additive v, Ord n) => Semigroup (BoundingBox v n) deriving instance (Additive v, Ord n) => Monoid (BoundingBox v n) +instance AsEmpty (BoundingBox v n) where + _Empty = nearly emptyBox isEmptyBox + type instance V (BoundingBox v n) = v type instance N (BoundingBox v n) = n @@ -125,9 +130,23 @@ instance (Metric v, Traversable v, OrderedField n) => Alignable (BoundingBox v n defaultBoundary = envelopeP instance Show (v n) => Show (BoundingBox v n) where - show - = maybe "emptyBox" (\(l, u) -> "fromCorners " ++ show l ++ " " ++ show u) - . getCorners + showsPrec d b = case getCorners b of + Just (l, u) -> showParen (d > 10) $ + showString "fromCorners " . showsPrec 11 l . showChar ' ' . showsPrec 11 u + Nothing -> showString "emptyBox" + +instance Read (v n) => Read (BoundingBox v n) where + readPrec = parens $ + (do + Ident "emptyBox" <- lexP + pure emptyBox + ) <|> + (prec 10 $ do + Ident "fromCorners" <- lexP + l <- step readPrec + h <- step readPrec + pure . fromNonEmpty $ NonEmptyBoundingBox (l, h) + ) -- | 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. diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs index 178e5f3d..7e74924a 100644 --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -32,7 +32,7 @@ import Linear.Vector -- | @Deformations@ are a superset of the affine transformations -- represented by the 'Transformation' type. In general they are not --- invertable. @Deformation@s include projective transformations. +-- invertible. @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. newtype Deformation v u n = Deformation (Point v n -> Point u n) diff --git a/src/Diagrams/LinearMap.hs b/src/Diagrams/LinearMap.hs index 93edf87d..541e6c43 100644 --- a/src/Diagrams/LinearMap.hs +++ b/src/Diagrams/LinearMap.hs @@ -24,7 +24,7 @@ module Diagrams.LinearMap where import Control.Lens import Data.FingerTree as FT -import qualified Data.Foldable as F +import qualified Data.Foldable as F import Diagrams.Core import Diagrams.Core.Transform @@ -91,7 +91,7 @@ instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Trail u m) {-# INLINE vmap #-} instance LinearMappable (Point v n) (Point u m) where - vmap f (P v) = P (f v) + vmap f (P v) = P (f v) {-# INLINE vmap #-} instance r ~ FixedSegment u m => LinearMappable (FixedSegment v n) r where @@ -109,8 +109,8 @@ instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Path u m) vmap f = _Wrapped . mapped %~ vmap f {-# INLINE vmap #-} --- | Affine linear maps. Unlike Transformation these do not have to be --- invertable so we can map between spaces. +-- | Affine linear maps. Unlike 'Transformation' these do not have to be +-- invertible so we can map between spaces. data AffineMap v u n = AffineMap (LinearMap v u n) (u n) -- | Make an affine map from a linear function and a translation. diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs index 010d4228..ad7bf655 100644 --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Located --- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -19,21 +19,20 @@ module Diagrams.Located ( Located (..) - , at, viewLoc, mapLoc, located, + , at, viewLoc, mapLoc, located, _loc ) where -import Control.Lens (Lens) +import Control.Lens (Lens, Lens') import Data.Functor ((<$>)) +import Text.Read import Linear.Affine import Linear.Vector import Diagrams.Core -import Diagrams.Core.Points () import Diagrams.Core.Transform import Diagrams.Parametric - -- for GHC 7.4 type family bug -- | \"Located\" things, /i.e./ things with a concrete location: -- intuitively, @Located a ~ (Point, a)@. Wrapping a translationally @@ -84,16 +83,32 @@ 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, N a ~ N b) => (a -> b) -> Located a -> Located b +mapLoc :: SameSpace a b => (a -> b) -> Located a -> Located b mapLoc f (Loc p a) = Loc p (f a) -- | A lens giving access to the object within a 'Located' wrapper. -located :: (V a ~ V a', N a ~ N a') => Lens (Located a) (Located a') a a' +located :: SameSpace a b => Lens (Located a) (Located b) a b located f (Loc p a) = Loc p <$> f a +-- | Lens onto the location of something 'Located'. +_loc :: Lens' (Located a) (Point (V a) (N a)) +_loc f (Loc p a) = flip Loc a <$> f p + 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) + +instance (Show (V a (N a)), Show a) => Show (Located a) where + showsPrec d (Loc p a) = showParen (d > 5) $ + showsPrec 6 a . showString " `at` " . showsPrec 6 p + +instance (Read (V a (N a)), Read a) => Read (Located a) where + readPrec = parens . prec 5 $ do + a <- readPrec + Punc "`" <- lexP + Ident "at" <- lexP + Punc "`" <- lexP + p <- readPrec + return (Loc p a) type instance V (Located a) = V a type instance N (Located a) = N a @@ -126,7 +141,7 @@ 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 - n |> (Loc p a) = Loc p (n |> a) + n .>> (Loc p a) = Loc p (n .>> a) type instance Codomain (Located a) = Point (Codomain a) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 1138dbef..00d79aac 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -61,8 +61,7 @@ module Diagrams.Path ) where import Control.Arrow ((***)) -import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, over, view, (%~), - _Unwrapped', _Wrapped, Each (..), traversed) +import Control.Lens hiding ((#), transform, at) import qualified Data.Foldable as F import Data.List (partition) import Data.Semigroup @@ -77,7 +76,6 @@ import Diagrams.Trail import Diagrams.TrailLike import Diagrams.Transform -import Linear.Affine import Linear.Metric import Linear.Vector @@ -115,7 +113,10 @@ instance Wrapped (Path v n) where instance Rewrapped (Path v n) (Path v' n') instance Each (Path v n) (Path v' n') (Located (Trail v n)) (Located (Trail v' n')) where - each = _Wrapped . traversed + each = _Wrapped . traverse + +instance AsEmpty (Path v n) where + _Empty = _Wrapped' . _Empty -- | Extract the located trails making up a 'Path'. pathTrails :: Path v n -> [Located (Trail v n)] @@ -261,9 +262,12 @@ 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, Metric v, OrderedField n) => n -> Path v n -> Path v n -scalePath d p = (scale d `under` translation (origin .-. pathCentroid p)) p +scalePath d p = under (movedFrom (pathCentroid p)) (scale d) p -- | Reverse all the component trails of a path. reversePath :: (Metric v, OrderedField n) => Path v n -> Path v n reversePath = _Wrapped . mapped %~ reverseLocTrail +-- | Same as 'reversePath'. +instance (Metric v, OrderedField n) => Reversing (Path v n) where + reversing = _Wrapped' . mapped %~ reversing diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index fb556ff8..c42d1950 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Prelude --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -12,167 +12,83 @@ ----------------------------------------------------------------------------- module Diagrams.Prelude - ( - -- * Core library - -- | The core definitions of transformations, diagrams, - -- backends, and so on. - module Diagrams.Core - - -- * Standard library - - -- | Attributes (color, line style, etc.) and styles. - , module Diagrams.Attributes - - -- | Alignment of diagrams relative to their envelopes. - , module Diagrams.Align - - -- | Combining multiple diagrams into one. - , module Diagrams.Combinators - - -- | Giving concrete locations to translation-invariant things. - , module Diagrams.Located - - -- | Linear and cubic bezier segments. - , module Diagrams.Segment - - -- | Trails. - , module Diagrams.Trail - - -- | Parametrization of segments and trails. - , module Diagrams.Parametric - - -- | Adjusting the length of parameterized objects. - , module Diagrams.Parametric.Adjust - - -- | Computing tangent and normal vectors of segments and - -- trails. - , module Diagrams.Tangent - - -- | Trail-like things. - , module Diagrams.TrailLike - - -- | Paths. - , module Diagrams.Path - - -- | Cubic splines. - , module Diagrams.CubicSpline - - -- | Some additional transformation-related functions, like - -- conjugation of transformations. - , module Diagrams.Transform - - -- | Projective transformations and other deformations - -- lacking an inverse. - , module Diagrams.Deform - - -- | Giving names to subdiagrams and later retrieving - -- subdiagrams by name. - , module Diagrams.Names - - -- | Envelopes, aka functional bounding regions. - , module Diagrams.Envelope - - -- | Traces, aka embedded raytracers, for finding points on - -- the boundary of a diagram. - , module Diagrams.Trace - - -- | A query is a function that maps points in a vector space - -- to values in some monoid; they can be used to annotate - -- the points of a diagram with some values. - , module Diagrams.Query - - -- | Utilities for working with points. - , module Diagrams.Points - - -- | Utilities for working with size. - , module Diagrams.Size - - -- | Angles - , module Diagrams.Angle - - -- | Convenience infix operators for working with coordinates. - , module Diagrams.Coordinates - - -- | Directions, distinguished from angles or vectors - , module Diagrams.Direction - - -- | A wide range of things (shapes, transformations, - -- combinators) specific to creating two-dimensional - -- diagrams. - , module Diagrams.TwoD - - -- | Extra things for three-dimensional diagrams. - , module Diagrams.ThreeD - - -- | Tools for making animations. - , module Diagrams.Animation - - -- | Various utility definitions. - , module Diagrams.Util - - -- * Convenience re-exports - -- | For representing and operating on colors. - , module Data.Colour - - -- | A large list of color names. - , module Data.Colour.Names - -- | Semigroups and monoids show up all over the place, so things from - -- Data.Semigroup and Data.Monoid often come in handy. - , module Data.Semigroup - - -- | For computing with vectors. - , module Linear.Vector - - -- | For computing with points and vectors. - , module Linear.Affine - - -- | For computing with dot products and norm. - , module Linear.Metric - - -- | For working with 'Active' (i.e. animated) things. - , module Data.Active - - -- | Essential Lens Combinators - , (&), (.~), (%~) - - , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 - ) where - -import Diagrams.Core - -import Diagrams.Align -import Diagrams.Angle -import Diagrams.Animation -import Diagrams.Attributes -import Diagrams.Combinators -import Diagrams.Coordinates -import Diagrams.CubicSpline -import Diagrams.Deform -import Diagrams.Direction hiding (dir) -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.Size -import Diagrams.Tangent -import Diagrams.ThreeD -import Diagrams.Trace -import Diagrams.Trail hiding (linePoints, loopPoints, trailPoints) -import Diagrams.TrailLike -import Diagrams.Transform -import Diagrams.TwoD -import Diagrams.Util + ( + -- * Diagrams library + -- | Exports from this library for working with diagrams. + module Diagrams + + -- * Convenience re-exports + + -- | For working with default values. Diagrams also exports 'with', + -- an alias for 'def'. + , module Data.Default.Class + + -- | For representing and operating on colors. + , module Data.Colour + + -- | A large list of color names. + , module Data.Colour.Names + + -- | Specify your own colours. + , module Data.Colour.SRGB + + -- | Semigroups and monoids show up all over the place, so things from + -- Data.Semigroup and Data.Monoid often come in handy. + , module Data.Semigroup + + -- | For computing with vectors. + , module Linear.Vector + + -- | For computing with points and vectors. + , module Linear.Affine + + -- | For computing with dot products and norm. + , module Linear.Metric + + -- | For working with 'Active' (i.e. animated) things. + , module Data.Active + + -- | Most of the lens package. The following functions are not + -- exported from lens because they either conflict with + -- diagrams or may conflict with other libraries: + -- + -- * 'Control.Lens....' + -- * 'Control.Lens..>' + -- * 'Control.Lens.<.>' + -- * 'Control.Lens.argument' + -- * 'Control.Lens.at' + -- * 'Control.Lens.beside' + -- * 'Control.Lens.children' + -- * 'Control.Lens.coerce' + -- * 'Control.Lens.contains' + -- * 'Control.Lens.index' + -- * 'Control.Lens.indexed' + -- * 'Control.Lens.indices' + -- * 'Control.Lens.inside' + -- * 'Control.Lens.levels' + -- * 'Control.Lens.none' + -- * 'Control.Lens.outside' + -- * 'Control.Lens.singular' + -- * 'Control.Lens.transform' + , module Control.Lens + + , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 + ) where + +import Diagrams import Control.Applicative -import Control.Lens ((%~), (&), (.~)) +import Control.Lens hiding (argument, at, backwards, + beside, children, coerce, contains, + indexed, indices, inside, levels, + none, outside, singular, transform, + ( # ), (...), (.>), (<.>)) import Data.Active -import Data.Colour hiding (AffineSpace (..), atop, over) +import Data.Default.Class +import Data.Colour hiding (AffineSpace (..), atop, + over) import Data.Colour.Names hiding (tan) +import Data.Colour.SRGB import Data.Semigroup import Linear.Affine diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index c6816329..1a4a40b0 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -46,6 +46,7 @@ module Diagrams.Segment -- * Constructing and modifying segments , Segment(..), straight, bezier3, bézier3, reverseSegment, mapSegmentVectors + , openLinear, openCubic -- * Fixed (absolutely located) segments , FixedSegment(..) @@ -63,8 +64,7 @@ module Diagrams.Segment ) where -import Control.Lens (Each (..), Rewrapped, Wrapped (..), - iso, makeLenses, op, over) +import Control.Lens hiding (at, transform) import Data.FingerTree import Data.Monoid.MList import Data.Semigroup @@ -121,6 +121,11 @@ instance Each (Offset c v n) (Offset c v' n') (v n) (v' n') where each _ OffsetOpen = pure OffsetOpen {-# INLINE each #-} +-- | Reverses the direction of closed offsets. +instance (Additive v, Num n) => Reversing (Offset c v n) where + reversing (OffsetClosed off) = OffsetClosed $ negated off + reversing a@OffsetOpen = a + type instance V (Offset c v n) = v type instance N (Offset c v n) = n @@ -150,13 +155,31 @@ data Segment c v n -- second control point, and ending -- point, respectively. - deriving (Show, Functor, Eq, Ord) + deriving (Functor, Eq, Ord) + +instance Show (v n) => Show (Segment c v n) where + showsPrec d seg = case seg of + Linear (OffsetClosed v) -> showParen (d > 10) $ + showString "straight " . showsPrec 11 v + Cubic v1 v2 (OffsetClosed v3) -> showParen (d > 10) $ + showString "bézier3 " . showsPrec 11 v1 . showChar ' ' + . showsPrec 11 v2 . showChar ' ' + . showsPrec 11 v3 + Linear OffsetOpen -> showString "openLinear" + Cubic v1 v2 OffsetOpen -> showParen (d > 10) $ + showString "openCubic " . showsPrec 11 v1 . showChar ' ' + . showsPrec 11 v2 + instance Each (Segment c v n) (Segment c v' n') (v n) (v' n') where each f (Linear offset) = Linear <$> each f offset each f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> each f offset {-# INLINE each #-} +-- | Reverse the direction of a segment. +instance (Additive v, Num n) => Reversing (Segment Closed v n) where + reversing = reverseSegment + -- | Map over the vectors of each segment. mapSegmentVectors :: (v n -> v' n') -> Segment c v n -> Segment c v' n' mapSegmentVectors = over each @@ -222,6 +245,16 @@ segOffset :: Segment Closed v n -> v n segOffset (Linear (OffsetClosed v)) = v segOffset (Cubic _ _ (OffsetClosed v)) = v +-- | An open linear segment. This means the trail makes a straight line +-- from the last segment the beginning to form a loop. +openLinear :: Segment Open v n +openLinear = Linear OffsetOpen + +-- | An open cubic segment. This means the trail makes a cubic bézier +-- with control vectors @v1@ and @v2@ to form a loop. +openCubic :: v n -> v n -> Segment Open v n +openCubic v1 v2 = Cubic v1 v2 OffsetOpen + ------------------------------------------------------------ -- Computing segment envelope ------------------------------ ------------------------------------------------------------ @@ -289,7 +322,7 @@ reverseSegment :: (Num n, Additive v) => Segment Closed v n -> Segment Closed v reverseSegment (Linear (OffsetClosed v)) = straight (negated v) reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negated x2) -instance (Metric v, Floating n, Ord n, Additive v) +instance (Metric v, OrderedField n) => HasArcLength (Segment Closed v n) where arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ norm x1 @@ -339,6 +372,11 @@ instance Each (FixedSegment v n) (FixedSegment v' n') (Point v n) (Point v' n') each f (FCubic p0 p1 p2 p3) = FCubic <$> f p0 <*> f p1 <*> f p2 <*> f p3 {-# INLINE each #-} +-- | Reverses the control points. +instance Reversing (FixedSegment v n) where + reversing (FLinear p0 p1) = FLinear p1 p0 + reversing (FCubic p0 p1 p2 p3) = FCubic p3 p2 p1 p0 + instance (Additive v, Num n) => Transformable (FixedSegment v n) where transform t = over each (papply t) diff --git a/src/Diagrams/Size.hs b/src/Diagrams/Size.hs index 9b69ca5a..eea56e91 100644 --- a/src/Diagrams/Size.hs +++ b/src/Diagrams/Size.hs @@ -92,7 +92,8 @@ getSpec :: (Functor v, Num n, Ord n) => SizeSpec v n -> v (Maybe n) getSpec (SizeSpec sp) = mfilter (>0) . Just <$> sp -- | Make a 'SizeSpec' from a vector of maybe values. Any negative values will --- be ignored. +-- be ignored. For 2D 'SizeSpec's see 'mkWidth' and 'mkHeight' from +-- "Diagrams.TwoD.Size". mkSizeSpec :: (Functor v, Num n) => v (Maybe n) -> SizeSpec v n mkSizeSpec = dims . fmap (fromMaybe 0) @@ -147,7 +148,7 @@ sizedAs :: (InSpace v n a, SameSpace a b, HasLinearMap v, HasBasis v, Transforma sizedAs other = sized (dims $ size other) -- | Get the adjustment to fit a 'BoundingBox' in the given 'SizeSpec'. The --- vector is the new size and the transformation to position the lower +-- vector is the new size and the transformation to position the lower -- corner at the origin and scale to the size spec. sizeAdjustment :: (Additive v, Foldable v, OrderedField n) => SizeSpec v n -> BoundingBox v n -> (v n, Transformation v n) diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs index 5f40c47b..92c234df 100644 --- a/src/Diagrams/Tangent.hs +++ b/src/Diagrams/Tangent.hs @@ -75,15 +75,15 @@ instance (DomainBounds t, EndValues (Tangent t)) -- * @Located (Trail V2) -> Double -> V2 Double@ -- -- See the instances listed for the 'Tangent' newtype for more. -tangentAtParam :: Parametric (Tangent t) => t -> N t -> Codomain (Tangent t) (N t) +tangentAtParam :: Parametric (Tangent t) => t -> N t -> Vn 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) (N t) +tangentAtStart :: EndValues (Tangent t) => t -> Vn t tangentAtStart = atStart . Tangent -- | Compute the tangent vector at the end of a segment or trail. -tangentAtEnd :: EndValues (Tangent t) => t -> Codomain (Tangent t) (N t) +tangentAtEnd :: EndValues (Tangent t) => t -> Vn t tangentAtEnd = atEnd . Tangent -------------------------------------------------- @@ -102,6 +102,15 @@ instance (Additive v, Num n) atEnd (Tangent (Linear (OffsetClosed v))) = v atEnd (Tangent (Cubic _ c2 (OffsetClosed x2))) = x2 ^-^ c2 +instance (Additive v, Num n) + => Parametric (Tangent (FixedSegment v n)) where + atParam (Tangent fSeg) = atParam $ Tangent (fromFixedSeg fSeg) + +instance (Additive v, Num n) + => EndValues (Tangent (FixedSegment v n)) where + atStart (Tangent fSeg) = atStart $ Tangent (fromFixedSeg fSeg) + atEnd (Tangent fSeg) = atEnd $ Tangent (fromFixedSeg fSeg) + ------------------------------------------------------------ -- Normal ------------------------------------------------------------ @@ -119,20 +128,20 @@ instance (Additive v, Num n) -- -- See the instances listed for the 'Tangent' newtype for more. normalAtParam - :: (Codomain (Tangent t) ~ V2, Parametric (Tangent t), Floating (N t)) - => t -> N t -> Codomain (Tangent t) (N t) + :: (InSpace V2 n t, Parametric (Tangent t), Floating n) + => t -> n -> V2 n normalAtParam t p = normize (t `tangentAtParam` p) -- | Compute the normal vector at the start of a segment or trail. normalAtStart - :: (Codomain (Tangent t) ~ V2, EndValues (Tangent t), Floating (N t)) - => t -> Codomain (Tangent t) (N t) + :: (InSpace V2 n t, EndValues (Tangent t), Floating n) + => t -> V2 n normalAtStart = normize . tangentAtStart -- | Compute the normal vector at the end of a segment or trail. normalAtEnd - :: (Codomain (Tangent t) ~ V2, EndValues (Tangent t), Floating (N t)) - => t -> Codomain (Tangent t) (N t) + :: (InSpace V2 n t, EndValues (Tangent t), Floating n) + => t -> V2 n normalAtEnd = normize . tangentAtEnd -- | Construct a normal vector from a tangent. diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 36239866..0c543165 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -22,8 +22,9 @@ module Diagrams.ThreeD.Transform ( T3 -- * Rotation - ,aboutX, aboutY, aboutZ - , rotationAbout, pointAt, pointAt' + , aboutX, aboutY, aboutZ + , rotationAbout, rotateAbout + , pointAt, pointAt' -- * Scaling , scalingX, scalingY, scalingZ @@ -103,11 +104,12 @@ aboutY (view rad -> a) = fromOrthogonal r where -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. -rotationAbout :: Floating n - => Point V3 n -- ^ origin of rotation - -> Direction V3 n -- ^ direction of rotation axis - -> Angle n -- ^ angle of rotation - -> Transformation V3 n +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, @@ -119,6 +121,16 @@ rotationAbout (P t) d (view rad -> a) ^+^ cross w v ^* sin θ ^+^ w ^* ((w `dot` v) * (1 - cos θ)) +-- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ +-- passing through @p@. +rotateAbout + :: (InSpace V3 n t, Floating n, Transformable t) + => Point V3 n -- ^ origin of rotation + -> Direction V3 n -- ^ direction of rotation axis + -> Angle n -- ^ angle of rotation + -> t -> t +rotateAbout p d theta = transform (rotationAbout p d theta) + -- | @pointAt about initial final@ produces a rotation which brings -- the direction @initial@ to point in the direction @final@ by first -- panning around @about@, then tilting about the axis perpendicular @@ -186,8 +198,10 @@ reflectZ :: (InSpace v n t, R3 v, Transformable t) => t -> t reflectZ = transform reflectionZ -- | @reflectionAcross p v@ is a reflection across the plane through --- the point @p@ and normal to vector @v@. -reflectionAcross :: (Metric v, R3 v, Fractional n) +-- the point @p@ and normal to vector @v@. This also works as a 2D +-- transform where @v@ is the normal to the line passing through point +-- @p@. +reflectionAcross :: (Metric v, Fractional n) => Point v n -> v n -> Transformation v n reflectionAcross p v = conjugate (translation (origin .-. p)) reflect @@ -197,7 +211,8 @@ reflectionAcross p 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@. -reflectAcross :: (InSpace v n t, Metric v, R3 v, Fractional n, Transformable t) +-- the point @p@ and the vector @v@. This also works as a 2D transform +-- where @v@ is the normal to the line passing through point @p@. +reflectAcross :: (InSpace v n t, Metric v, Fractional n, Transformable t) => Point v n -> v n -> t -> t reflectAcross p v = transform (reflectionAcross p v) diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index 8421d130..f011eec5 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -18,7 +19,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Trail --- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -54,6 +55,7 @@ module Diagrams.Trail -- ** Generic trails , Trail(..) + , _Line, _Loop , wrapTrail, wrapLine, wrapLoop , onTrail, onLine @@ -65,6 +67,7 @@ module Diagrams.Trail , lineFromVertices, trailFromVertices , lineFromOffsets, trailFromOffsets , lineFromSegments, trailFromSegments + , loopFromSegments -- * Eliminating trails @@ -104,9 +107,9 @@ module Diagrams.Trail ) where import Control.Arrow ((***)) -import Control.Lens (AnIso', Rewrapped, Wrapped (..), cloneIso, iso, op, view, - (^.)) -import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), (|>)) +import Control.Lens hiding (at, transform, (<|), (|>)) +import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), + (<|), (|>)) import qualified Data.FingerTree as FT import Data.Fixed import qualified Data.Foldable as F @@ -114,7 +117,7 @@ import Data.Monoid.MList import Data.Semigroup import qualified Numeric.Interval.Kaucher as I -import Diagrams.Core hiding ((|>)) +import Diagrams.Core import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment @@ -143,6 +146,20 @@ instance ( Metric (V a), OrderedField (N a) => Transformable (FingerTree m a) where transform = FT.fmap' . transform +instance (FT.Measured m a, FT.Measured n b) + => Cons (FingerTree m a) (FingerTree n b) a b where + _Cons = prism (uncurry (FT.<|)) $ \aas -> case FT.viewl aas of + a :< as -> Right (a, as) + EmptyL -> Left mempty + {-# INLINE _Cons #-} + +instance (FT.Measured m a, FT.Measured n b) + => Snoc (FingerTree m a) (FingerTree n b) a b where + _Snoc = prism (uncurry (FT.|>)) $ \aas -> case FT.viewr aas of + as :> a -> Right (as, a) + EmptyR -> Left mempty + {-# INLINE _Snoc #-} + ------------------------------------------------------------ -- Segment trees ----------------------------------------- ------------------------------------------------------------ @@ -155,24 +172,28 @@ instance ( Metric (V a), OrderedField (N a) -- beginning which have a combined arc length of at least 5). newtype SegTree v n = SegTree (FingerTree (SegMeasure v n) (Segment Closed v n)) - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Monoid, Transformable, FT.Measured (SegMeasure v n)) 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 + {-# INLINE _Wrapped' #-} + +instance (Metric v, OrderedField n, Metric u, OrderedField n') + => Cons (SegTree v n) (SegTree u n') (Segment Closed v n) (Segment Closed u n') where + _Cons = _Wrapped . _Cons . bimapping id _Unwrapped + {-# INLINE _Cons #-} + +instance (Metric v, OrderedField n, Metric u, OrderedField n') + => Snoc (SegTree v n) (SegTree u n') (Segment Closed v n) (Segment Closed u n') where + _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id + {-# INLINE _Snoc #-} instance Rewrapped (SegTree v n) (SegTree v' n') type instance V (SegTree v n) = v type instance N (SegTree v n) = n -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 n) = v instance (Metric v, OrderedField n, Real n) @@ -188,38 +209,44 @@ type SplitResult v n = ((SegTree v n, n -> n), (SegTree v n, n -> n)) splitAtParam' :: (Metric v, OrderedField n, Real n) => SegTree v n -> n -> SplitResult v n splitAtParam' tree@(SegTree t) p - | p < 0 = case FT.viewl t of - EmptyL -> emptySplit - seg :< t' -> - case seg `splitAtParam` (p * tSegs) of - (seg1, seg2) -> ( (SegTree $ FT.singleton seg1, \u -> u * p) - , (SegTree $ seg2 <| t', \u -> 1 - (1 - u) * tSegs / (tSegs + 1)) - ) - | p >= 1 = case FT.viewr t of - EmptyR -> emptySplit - t' :> seg -> - case seg `splitAtParam` (1 - (1 - p)*tSegs) of - (seg1, seg2) -> ( (SegTree $ t' |> seg1, \u -> u * tSegs / (tSegs + 1)) - , (SegTree $ FT.singleton seg2, \u -> (u - p) / (1 - p)) - ) - | otherwise = case FT.viewl after of - EmptyL -> emptySplit - seg :< after' -> - let (n, p') = propFrac $ p * tSegs - f p n u | u * tSegs < n = u * tSegs / (n + 1) - | otherwise = (n + (u * tSegs - n) / (p * tSegs - n)) / (n+1) - in case seg `splitAtParam` p' of - (seg1, seg2) -> ( ( SegTree $ before |> seg1 , f p n ) - , ( SegTree $ seg2 <| after' - , \v -> 1 - f (1 - p) (tSegs - n - 1) (1 - v) - ) - ) + | p < 0 = + case FT.viewl t of + EmptyL -> emptySplit + seg :< t' -> + case seg `splitAtParam` (p * tSegs) of + (seg1, seg2) -> + ( (SegTree $ FT.singleton seg1, (*p)) + , (SegTree $ seg2 <| t', \u -> 1 - (1 - u) * tSegs / (tSegs + 1)) + ) + | p >= 1 = + case FT.viewr t of + EmptyR -> emptySplit + t' :> seg -> + case seg `splitAtParam` (1 - (1 - p)*tSegs) of + (seg1, seg2) -> + ( (SegTree $ t' |> seg1, \u -> u * tSegs / (tSegs + 1)) + , (SegTree $ FT.singleton seg2, \u -> (u - p) / (1 - p)) + ) + | otherwise = + case FT.viewl after of + EmptyL -> emptySplit + seg :< after' -> + let (n, p') = propFrac $ p * tSegs + f p n u | u * tSegs < n = u * tSegs / (n + 1) + | otherwise = (n + (u * tSegs - n) / (p * tSegs - n)) / (n+1) + in case seg `splitAtParam` p' of + (seg1, seg2) -> + ( ( SegTree $ before |> seg1 , f p n ) + , ( SegTree $ seg2 <| after' + , \v -> 1 - f (1 - p) (tSegs - n - 1) (1 - v) + ) + ) where - (before, after) = FT.split ((p * tSegs <) . numSegs) t - tSegs = numSegs t - emptySplit = let t' = (tree, id) in (t',t') + (before, after) = FT.split ((p * tSegs <) . numSegs) t + tSegs = numSegs t + emptySplit = let t' = (tree, id) in (t',t') - propFrac x = let m = signum x * mod1 x in (x - m, m) + propFrac x = let m = signum x * mod1 x in (x - m, m) instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where splitAtParam tree p = let ((a,_),(b,_)) = splitAtParam' tree p in (a,b) @@ -378,9 +405,16 @@ withTrail' :: (Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail' l v n - withTrail' line _ t@(Line{}) = line t withTrail' _ loop t@(Loop{}) = loop t -deriving instance Show (v n) => Show (Trail' l v n) -deriving instance Eq (v n) => Eq (Trail' l v n) -deriving instance Ord (v n) => Ord (Trail' l v n) +deriving instance Eq (v n) => Eq (Trail' l v n) +deriving instance Ord (v n) => Ord (Trail' l v n) + +instance Show (v n) => Show (Trail' l v n) where + showsPrec d (Line (SegTree ft)) = showParen (d > 10) $ + showString "lineFromSegments " . showList (F.toList ft) + + showsPrec d (Loop (SegTree ft) o) = showParen (d > 10) $ + showString "loopFromSegments " . showList (F.toList ft) . + showChar ' ' . showsPrec 11 o type instance V (Trail' l v n) = v type instance N (Trail' l v n) = n @@ -397,6 +431,9 @@ instance (Metric v, OrderedField n) => Monoid (Trail' Line v n) where mempty = emptyLine mappend = (<>) +instance (Metric v, OrderedField n) => AsEmpty (Trail' Line v n) where + _Empty = nearly emptyLine isLineEmpty + instance (HasLinearMap v, Metric v, OrderedField n) => Transformable (Trail' l v n) where transform tr (Line t ) = Line (transform tr t) @@ -486,6 +523,22 @@ instance (Metric v, OrderedField n, Real n) (\lp -> arcLengthToParam eps (cutLoop lp) l) tr +instance Rewrapped (Trail' Line v n) (Trail' Line v' n') +instance Wrapped (Trail' Line v n) where + type Unwrapped (Trail' Line v n) = SegTree v n + _Wrapped' = iso (\(Line x) -> x) Line + {-# INLINE _Wrapped' #-} + +instance (Metric v, OrderedField n, Metric u, OrderedField n') + => Cons (Trail' Line v n) (Trail' Line u n') (Segment Closed v n) (Segment Closed u n') where + _Cons = _Wrapped . _Cons . bimapping id _Unwrapped + {-# INLINE _Cons #-} + +instance (Metric v, OrderedField n, Metric u, OrderedField n') + => Snoc (Trail' Line v n) (Trail' Line u n') (Segment Closed v n) (Segment Closed u n') where + _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id + {-# INLINE _Snoc #-} + -------------------------------------------------- -- Extracting segments @@ -663,10 +716,13 @@ instance (OrderedField n, Metric v) => Semigroup (Trail v n) 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 n, Metric v) => Monoid (Trail v n) where +instance (Metric v, OrderedField n) => Monoid (Trail v n) where mempty = wrapLine emptyLine mappend = (<>) +instance (Metric v, OrderedField n) => AsEmpty (Trail v n) where + _Empty = nearly emptyTrail isTrailEmpty + type instance V (Trail v n) = v type instance N (Trail v n) = n @@ -706,6 +762,25 @@ instance (Metric v, OrderedField n, Real n) arcLengthBounded = withLine . arcLengthBounded arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr +-- lens instrances ----------------------------------------------------- + +-- | Prism onto a 'Line'. +_Line :: Prism' (Trail v n) (Trail' Line v n) +_Line = _Wrapped' . _Left + +-- | Prism onto a 'Loop'. +_Loop :: Prism' (Trail v n) (Trail' Loop v n) +_Loop = _Wrapped' . _Right + +instance Rewrapped (Trail v n) (Trail v' n') +instance Wrapped (Trail v n) where + type Unwrapped (Trail v n) = Either (Trail' Line v n) (Trail' Loop v n) + _Wrapped' = iso getTrail (either Trail Trail) + where + getTrail :: Trail v n -> Either (Trail' Line v n) (Trail' Loop v n) + getTrail (Trail t@(Line {})) = Left t + getTrail (Trail t@(Loop {})) = Right t + -------------------------------------------------- -- Constructors and eliminators for Trail @@ -782,6 +857,12 @@ lineFromSegments :: (Metric v, OrderedField n) => [Segment Closed v n] -> Trail' Line v n lineFromSegments = Line . SegTree . FT.fromList +-- | Construct a loop from a list of closed segments and an open segment +-- that completes the loop. +loopFromSegments :: (Metric v, OrderedField n) + => [Segment Closed v n] -> Segment Open v n -> Trail' Loop v n +loopFromSegments segs = Loop (SegTree (FT.fromList segs)) + -- | @trailFromSegments === 'wrapTrail' . 'lineFromSegments'@, for -- conveniently constructing a @Trail@ instead of a @Trail'@. trailFromSegments :: (Metric v, OrderedField n) @@ -1101,7 +1182,7 @@ loopVertices = loopVertices' tolerance -- The other points connecting segments are included if the slope at the -- 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. +-- be in order to declare them equal. segmentVertices' :: (Metric v, OrderedField n) => n -> Point v n -> [Segment Closed v n] -> [Point v n] segmentVertices' toler p ts = @@ -1175,3 +1256,21 @@ reverseLocLoop :: (Metric v, OrderedField n) => Located (Trail' Loop v n) -> Located (Trail' Loop v n) reverseLocLoop = mapLoc reverseLoop +-- | Same as 'reverseLine' or 'reverseLoop'. +instance (Metric v, OrderedField n) => Reversing (Trail' l v n) where + reversing t@(Line _) = onLineSegments (reverse . map reversing) t + reversing t@(Loop _ _) = glueLine . reversing . cutLoop $ t + +-- | Same as 'reverseTrail'. +instance (Metric v, OrderedField n) => Reversing (Trail v n) where + reversing (Trail t) = Trail (reversing t) + +-- | Same as 'reverseLocLine' or 'reverseLocLoop'. +instance (Metric v, OrderedField n) => Reversing (Located (Trail' l v n)) where + reversing l@(Loc _ Line {}) = reverseLocLine l + reversing l@(Loc _ Loop {}) = reverseLocLoop l + +-- | Same as 'reverseLocTrail'. +instance (Metric v, OrderedField n) => Reversing (Located (Trail v n)) where + reversing = reverseLocTrail + diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs index b0e9fdf8..b8e3cd4b 100644 --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Transform --- Copyright : (c) 2011-13 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-15 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -11,7 +14,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE TypeFamilies #-} module Diagrams.Transform ( -- * Transformations @@ -24,7 +26,7 @@ module Diagrams.Transform , translation, translate, moveTo, place, scaling, scale -- * Miscellaneous transformation-related utilities - , conjugate, under + , conjugate, underT, transformed, translated, movedTo, movedFrom -- * The HasOrigin class @@ -32,6 +34,7 @@ module Diagrams.Transform ) where +import Control.Lens hiding (transform) import Data.Semigroup import Diagrams.Core @@ -42,21 +45,79 @@ import Linear.Vector -- inverse of @t1@. conjugate :: (Additive v, Num n, Functor v) => Transformation v n -> Transformation v n -> Transformation v n -conjugate t1 t2 = inv t1 <> t2 <> t1 +conjugate t1 t2 = inv t1 <> t2 <> t1 --- | Carry out some transformation \"under\" another one: @f ``under`` +-- | Carry out some transformation \"under\" another one: @f ``underT`` -- t@ first applies @t@, then @f@, then the inverse of @t@. For --- example, @'scaleX' 2 ``under`` 'rotation' (-1/8 \@\@ Turn)@ +-- example, @'scaleX' 2 ``underT`` 'rotation' (-1/8 \@\@ Turn)@ -- is the transformation which scales by a factor of 2 along the -- diagonal line y = x. -- -- Note that -- --- @ --- (transform t2) `under` t1 == transform (conjugate t1 t2) --- @ +-- @ +-- (transform t2) `underT` t1 == transform (conjugate t1 t2) +-- @ -- -- for all transformations @t1@ and @t2@. -under :: (InSpace v n a, SameSpace a b, Num n, Functor v, Transformable a, Transformable b) +-- +-- See also the isomorphisms like 'transformed', 'movedTo', +-- 'movedFrom', and 'translated'. +underT :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) => (a -> b) -> Transformation v n -> a -> b -f `under` t = transform (inv t) . f . transform t +f `underT` t = transform (inv t) . f . transform t + +-- | Use a 'Transformation' to make an 'Iso' between an object +-- transformed and untransformed. This is useful for carrying out +-- functions 'under' another transform: +-- +-- @ +-- under (transformed t) f == transform (inv t) . f . transform t +-- under (transformed t1) (transform t2) == transform (conjugate t1 t2) +-- transformed t ## a == transform t a +-- a ^. transformed t == transform (inv t) a +-- @ +transformed :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) + => Transformation v n -> Iso a b a b +transformed t = iso (transform $ inv t) (transform t) + +-- | Use a 'Point' to make an 'Iso' between an object +-- moved to and from that point: +-- +-- @ +-- under (movedTo p) f == moveTo (-p) . f . moveTo p +-- over (movedTo p) f == moveTo p . f . moveTo (-p) +-- movedTo p == from (movedFrom p) +-- movedTo p ## a == moveTo p a +-- a ^. movedTo p == moveOriginTo p a +-- @ +movedTo :: (InSpace v n a, SameSpace a b, HasOrigin a, HasOrigin b) + => Point v n -> Iso a b a b +movedTo p = iso (moveTo (negated p)) (moveTo p) + +-- | Use a 'Transformation' to make an 'Iso' between an object +-- transformed and untransformed. We have +-- +-- @ +-- under (movedFrom p) f == moveTo p . f . moveTo (-p) +-- movedFrom p == from (movedTo p) +-- movedFrom p ## a == moveOriginTo p a +-- a ^. movedFrom p == moveTo p a +-- over (movedFrom p) f == moveTo (-p) . f . moveTo p +-- @ +movedFrom :: (InSpace v n a, SameSpace a b, HasOrigin a, HasOrigin b) + => Point v n -> Iso a b a b +movedFrom p = iso (moveOriginTo (negated p)) (moveOriginTo p) + +-- | Use a vector to make an 'Iso' between an object translated and +-- untranslated. +-- +-- @ +-- under (translated v) f == translate (-v) . f . translate v +-- translated v ## a == translate v a +-- a ^. translated v == translate (-v) a +-- over (translated v) f == translate v . f . translate (-v) +-- @ +translated :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) + => v n -> Iso a b a b +translated = transformed . translation diff --git a/src/Diagrams/Transform/Matrix.hs b/src/Diagrams/Transform/Matrix.hs index 36a92801..212117e6 100644 --- a/src/Diagrams/Transform/Matrix.hs +++ b/src/Diagrams/Transform/Matrix.hs @@ -12,10 +12,10 @@ module Diagrams.Transform.Matrix where import Control.Applicative -import Control.Arrow ((&&&)) +import Control.Arrow ((&&&)) import Control.Lens import Data.Distributive -import qualified Data.Foldable as F +import qualified Data.Foldable as F import Data.Functor.Rep import Diagrams.Core.Transform as D @@ -34,9 +34,15 @@ mkMat t = distribute . tabulate $ apply t . unit . el mkMatHomo :: Num n => Transformation V3 n -> M44 n mkMatHomo t = mkTransformationMat (mkMat t) (transl t) +-- | Make a 2D transformation from a 2x2 transform matrix and a +-- translation vector. If the matrix is not invertible, 'Nothing' is +-- returned. fromMat22 :: (Epsilon n, Floating n) => M22 n -> V2 n -> Maybe (T2 n) fromMat22 m v = flip (fromMatWithInv m) v <$> inv22 m +-- | Make a 3D transformation from a 3x3 transform matrix and a +-- translation vector. If the matrix is not invertible, 'Nothing' is +-- returned. fromMat33 :: (Epsilon n, Floating n) => M33 n -> V3 n -> Maybe (T3 n) fromMat33 m v = flip (fromMatWithInv m) v <$> inv33 m @@ -51,9 +57,12 @@ fromMatWithInv m m_ v = ((*! distribute m) <-> (*! distribute m_)) v --- are these useful? +-- | Prism onto a 2D transformation from a 2x2 transform matrix and +-- translation vector. mat22 :: (Epsilon n, Floating n) => Prism' (M22 n, V2 n) (T2 n) mat22 = prism' (mkMat &&& transl) (uncurry fromMat22) +-- | Prism onto a 2D transformation from a 2x2 transform matrix and +-- translation vector. mat33 :: (Epsilon n, Floating n) => Prism' (M33 n, V3 n) (T3 n) mat33 = prism' (mkMat &&& transl) (uncurry fromMat33) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index b871eb6e..fe113c20 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -70,6 +70,8 @@ module Diagrams.TwoD -- * Angles , tau + , angleV + , angleDir -- * Paths -- ** Stroking @@ -82,7 +84,7 @@ module Diagrams.TwoD , intersectPointsP, intersectPointsP' -- ** Clipping - , clipBy, clipTo, clipped + , clipBy, clipTo, clipped, _clip -- * Shapes -- ** Rules @@ -214,7 +216,7 @@ module Diagrams.TwoD , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop - , view + , rectEnvelope -- ** Background @@ -256,7 +258,7 @@ module Diagrams.TwoD , rGradTrans, rGradSpreadMethod, defaultRG, _RG, mkRadialGradient -- ** Colors - , fillColor, _SC, fc, fcA, recommendFillColor + , fillColor, _SC, _AC, fc, fcA, recommendFillColor , lineColor, lc, lcA -- * Visual aids for understanding the internal model diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 2bd344f5..9752cfc7 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -226,8 +226,10 @@ tailLength :: Lens' (ArrowOpts n) (Measure n) -- | Set both the @headLength@ and @tailLength@ simultaneously. lengths :: Traversal' (ArrowOpts n) (Measure n) -lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts ^. headLength) - <*> f (opts ^. tailLength) +lengths f opts = + (\h t -> opts & headLength .~ h & tailLength .~ t) + <$> f (opts ^. headLength) + <*> f (opts ^. tailLength) -- | A lens for setting or modifying the texture of an arrowhead. For -- example, one may write @... (with & headTexture .~ grad)@ to get an @@ -279,9 +281,9 @@ colorJoint sStyle = o = fmap getOpacity . getAttr $ sStyle in case (c, o) of - (Nothing, Nothing) -> fillColor (black :: Colour Double) mempty + (Nothing, Nothing) -> fillColor black mempty (Just t, Nothing) -> fillTexture t mempty - (Nothing, Just o') -> opacity o' . fillColor (black :: Colour Double) $ mempty + (Nothing, Just o') -> opacity o' . fillColor black $ mempty (Just t, Just o') -> opacity o' . fillTexture t $ mempty -- | Get line width from a style. diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 59373ba2..861aeae3 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -30,7 +31,7 @@ module Diagrams.TwoD.Attributes ( -- * Textures - Texture(..), solid, _SC, _LG, _RG, defaultLG, defaultRG + Texture(..), solid, _SC, _AC, _LG, _RG, defaultLG, defaultRG , GradientStop(..), stopColor, stopFraction, mkStops , SpreadMethod(..), lineLGradient, lineRGradient @@ -77,6 +78,7 @@ import Diagrams.Located (unLoc) import Diagrams.Path (Path, pathTrails) import Diagrams.Trail (isLoop) import Diagrams.TwoD.Types +import Diagrams.Util ----------------------------------------------------------------- @@ -195,6 +197,10 @@ type instance N (Texture n) = n makePrisms ''Texture +-- | Prism onto an 'AlphaColour' 'Double' of a 'SC' texture. +_AC :: Prism' (Texture n) (AlphaColour Double) +_AC = _SC . _SomeColor + instance Floating n => Transformable (Texture n) where transform t (LG lg) = LG $ transform t lg transform t (RG rg) = RG $ transform t rg @@ -275,7 +281,7 @@ instance Floating n => Transformable (LineTexture n) where transform t (LineTexture (Last tx)) = LineTexture (Last $ transform t tx) instance Default (LineTexture n) where - def = LineTexture (Last (SC (SomeColor (black :: Colour Double)))) + def = _LineTexture . _SC ## SomeColor black mkLineTexture :: Texture n -> LineTexture n mkLineTexture = LineTexture . Last @@ -283,43 +289,42 @@ mkLineTexture = LineTexture . Last getLineTexture :: LineTexture n -> Texture n getLineTexture (LineTexture (Last t)) = t -lineTexture :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => Texture n -> a -> a +lineTexture :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Texture n -> a -> a lineTexture = applyTAttr . LineTexture . Last -lineTextureA :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => LineTexture n -> a -> a +lineTextureA :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => LineTexture n -> a -> a lineTextureA = applyTAttr _lineTexture :: (Floating n, Typeable n) => Lens' (Style V2 n) (Texture n) _lineTexture = atTAttr . anon def isDef . _LineTexture where - isDef (LineTexture (Last (SC sc))) = toAlphaColour sc == opaque black - isDef _ = False + isDef = anyOf (_LineTexture . _AC) (== opaque black) -- | Set the line (stroke) color. This function is polymorphic in the -- color type (so it can be used with either 'Colour' or -- 'AlphaColour'), but this can sometimes create problems for type -- inference, so the 'lc' and 'lcA' variants are provided with more -- concrete types. -lineColor :: (Typeable n, Floating n, Color c, HasStyle a, V a ~ V2, N a ~ n) => c -> a -> a +lineColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => c -> a -> a lineColor = lineTexture . SC . SomeColor -- | A synonym for 'lineColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). See comment in 'lineColor' about backends. -lc :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => Colour Double -> a -> a +lc :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Colour Double -> a -> a lc = lineColor -- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). See comment in 'lineColor' -- about backends. -lcA :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => AlphaColour Double -> a -> a +lcA :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => AlphaColour Double -> a -> a lcA = lineColor -- | Apply a linear gradient. -lineLGradient :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => LGradient n -> a -> a +lineLGradient :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => LGradient n -> a -> a lineLGradient g = lineTexture (LG g) -- | Apply a radial gradient. -lineRGradient :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => RGradient n -> a -> a +lineRGradient :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => RGradient n -> a -> a lineRGradient g = lineTexture (RG g) -- Fill Texture -------------------------------------------------------- @@ -351,12 +356,12 @@ instance Floating n => Transformable (FillTexture n) where transform = over (_FillTexture . _recommend) . transform instance Default (FillTexture n) where - def = review (_FillTexture . _Recommend . _SC . _SomeColor) transparent + def = mkFillTexture $ _AC ## transparent getFillTexture :: FillTexture n -> Texture n getFillTexture (FillTexture tx) = getLast . getRecommend $ tx -fillTexture :: (HasStyle a, V a ~ V2, N a ~ n, Typeable n, Floating n) => Texture n -> a -> a +fillTexture :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Texture n -> a -> a fillTexture = applyTAttr . mkFillTexture mkFillTexture :: Texture n -> FillTexture n @@ -366,11 +371,10 @@ mkFillTexture = FillTexture . Commit . Last _fillTextureR :: (Typeable n, Floating n) => Lens' (Style V2 n) (Recommend (Texture n)) _fillTextureR = atTAttr . anon def isDef . _FillTexture where - isDef (FillTexture (Recommend (Last (SC sc)))) = toAlphaColour sc == transparent - isDef _ = False + isDef = anyOf (_FillTexture . _Recommend . _AC) (== transparent) --- | Commit a fill texture in a style. This is *not* a valid lens --- because the resulting texture is always 'Commit' (see 'committed'). +-- | Commit a fill texture in a style. This is /not/ a valid setter +-- because it doesn't abide the functor law (see 'committed'). _fillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n) _fillTexture = _fillTextureR . committed @@ -378,24 +382,24 @@ _fillTexture = _fillTextureR . committed -- 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 ~ V2, N a ~ n, Typeable n, Floating n) => c -> a -> a +fillColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => 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 ~ V2, N a ~ n, Typeable n, Floating n) => c -> a -> a +recommendFillColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => 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 ~ V2, N a ~ n, Floating n, Typeable n) => Colour Double -> a -> a +fc :: (InSpace V2 n a, Floating n, Typeable n, HasStyle a) => 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 ~ V2, N a ~ n, Floating n, Typeable n) => AlphaColour Double -> a -> a +fcA :: (InSpace V2 n a, Floating n, Typeable n, HasStyle a) => AlphaColour Double -> a -> a fcA = fillColor -- Split fills --------------------------------------------------------- diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 01bd4270..daf76ed2 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -31,7 +31,7 @@ module Diagrams.TwoD.Combinators , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop - , view + , rectEnvelope , boundingRect, bg, bgFrame @@ -60,8 +60,8 @@ import Diagrams.TwoD.Vector import Diagrams.Util (( # )) import Linear.Affine -import Linear.Vector import Linear.Metric +import Linear.Vector infixl 6 === infixl 6 ||| @@ -235,14 +235,14 @@ extrudeTop s | s >= 0 = extrudeEnvelope $ unitY ^* s | otherwise = intrudeEnvelope $ unitY ^* s --- | @view p v@ sets the envelope of a diagram to a rectangle whose +-- | @rectEnvelope p v@ sets the envelope of a diagram to a rectangle whose -- lower-left corner is at @p@ and whose upper-right corner is at @p -- .+^ v@. Useful for selecting the rectangular portion of a -- diagram which should actually be \"viewed\" in the final render, -- if you don't want to see the entire diagram. -view :: forall b n m. (OrderedField n, Monoid' m) +rectEnvelope :: forall b n m. (OrderedField n, Monoid' m) => 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 :: Path V2 n) +rectEnvelope p (V2 w h) = withEnvelope (rect w h # alignBL # moveTo p :: Path V2 n) -- | Construct a bounding rectangle for an enveloped object, that is, -- the smallest axis-aligned rectangle which encloses the object. diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 86bef595..7bc4c3dc 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -45,7 +45,8 @@ module Diagrams.TwoD.Path -- * Clipping - , Clip(..), clipBy, clipTo, clipped + , Clip(..), _Clip, _clip + , clipBy, clipTo, clipped -- * Intersections @@ -55,10 +56,7 @@ module Diagrams.TwoD.Path ) where import Control.Applicative (liftA2) -import Control.Lens (Lens, Lens', generateSignatures, - lensRules, makeLensesWith, - makeWrapped, op, (.~), (^.), - _Wrapped') +import Control.Lens hiding (transform, at) import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable @@ -374,12 +372,22 @@ makeWrapped ''Clip instance Typeable n => AttributeClass (Clip n) +instance AsEmpty (Clip n) where + _Empty = _Clip . _Empty + type instance V (Clip n) = V2 type instance N (Clip n) = n instance (OrderedField n) => Transformable (Clip n) where transform t (Clip ps) = Clip (transform t ps) +_Clip :: Iso (Clip n) (Clip n') [Path V2 n] [Path V2 n'] +_Clip = _Wrapped + +-- | Lens onto the Clip in a style. An empty list means no clipping. +_clip :: Typeable n => Lens' (Style v n) [Path V2 n] +_clip = atAttr . non' _Empty . _Clip + -- | Clip a diagram by the given path: -- -- * Only the parts of the diagram which lie in the interior of the diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 23cb3c59..f3bf06d2 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -35,7 +35,7 @@ module Diagrams.TwoD.Text ( , FontSlant(..), FontSlantA, _FontSlant , getFontSlant, fontSlant, italic, oblique, _fontSlant -- ** Font weight - , FontWeight(..), FontWeightA, _FontWeight + , FontWeight(..) , getFontWeight, fontWeight, bold, _fontWeight ) where @@ -84,9 +84,10 @@ instance Floating n => Renderable (Text n) NullBackend where -- | @TextAlignment@ specifies the alignment of the text's origin. data TextAlignment n = BaselineText | BoxAlignedText n n +-- | Make a text from a 'TextAlignment'. mkText :: (TypeableFloat n, Renderable (Text n) b) => TextAlignment n -> String -> QDiagram b V2 n Any -mkText a t = recommendFillColor (black :: Colour Double) +mkText a t = recommendFillColor black -- See Note [recommendFillColor] . recommendFontSize (local 1) -- See Note [recommendFontSize] @@ -310,32 +311,31 @@ oblique = fontSlant FontSlantOblique -------------------------------------------------- -- Font weight -data FontWeight = FontWeightNormal - | FontWeightBold - deriving (Eq, Show) - -- | The @FontWeightA@ attribute specifies the weight (normal or bold) -- that should be used for all text within a diagram. Inner -- @FontWeightA@ attributes override outer ones. -newtype FontWeightA = FontWeightA (Last FontWeight) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass FontWeightA +data FontWeight = FontWeightNormal + | FontWeightBold + deriving (Eq, Ord, Show, Typeable) + +instance AttributeClass FontWeight + +-- | Last semigroup structure +instance Semigroup FontWeight where + _ <> b = b instance Default FontWeight where def = FontWeightNormal -_FontWeight :: Iso' FontWeightA FontWeight -_FontWeight = iso getFontWeight (FontWeightA . Last) - --- | Extract the font weight from a 'FontWeightA' attribute. -getFontWeight :: FontWeightA -> FontWeight -getFontWeight (FontWeightA (Last w)) = w +-- | Extract the font weight. +getFontWeight :: FontWeight -> FontWeight +getFontWeight = id -- | Specify the weight (normal or bold) that should be -- used for all text within a diagram. See also 'bold' -- for a useful special case. fontWeight :: HasStyle a => FontWeight -> a -> a -fontWeight = applyAttr . FontWeightA . Last +fontWeight = applyAttr -- | Set all text using a bold font weight. bold :: HasStyle a => a -> a @@ -343,4 +343,5 @@ bold = fontWeight FontWeightBold -- | Lens onto the font weight in a style. _fontWeight :: (Typeable n, OrderedField n) => Lens' (Style v n) FontWeight -_fontWeight = atAttr . mapping _FontWeight . non def +_fontWeight = atAttr . non def + diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 3a12044b..f85df88e 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -1,13 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -21,7 +22,7 @@ module Diagrams.TwoD.Transform ( T2 -- * Rotation - , rotation, rotate, rotateBy + , rotation, rotate, rotateBy, rotated , rotationAround, rotateAround , rotationTo, rotateTo @@ -58,7 +59,7 @@ import Diagrams.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -import Control.Lens (review, view, (&), (*~), (.~), (//~)) +import Control.Lens hiding (at, transform) import Data.Semigroup import Linear.Affine @@ -97,20 +98,35 @@ rotate = transform . rotation rotateBy :: (InSpace V2 n t, Transformable t, Floating n) => n -> t -> t rotateBy = transform . rotation . review turn +-- | Use an 'Angle' to make an 'Iso' between an object +-- rotated and unrotated. This us useful for performing actions +-- 'under' a rotation: +-- +-- @ +-- under (rotated t) f = rotate (negated t) . f . rotate t +-- rotated t ## a = rotate t a +-- a ^. rotated t = rotate (-t) a +-- over (rotated t) f = rotate t . f . rotate (negated t) +-- @ +rotated :: (InSpace V2 n a, Floating n, SameSpace a b, Transformable a, Transformable b) + => Angle n -> Iso a b a b +rotated = transformed . rotation + -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). rotationAround :: Floating n => P2 n -> Angle n -> T2 n -rotationAround p angle = conjugate (translation (origin .-. p)) (rotation angle) +rotationAround p theta = + conjugate (translation (origin .-. p)) (rotation theta) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. -rotateAround :: (InSpace V2 n t, Transformable t, Floating n) => P2 n -> Angle n -> t -> t -rotateAround p angle = rotate angle `under` translation (origin .-. p) +rotateAround :: (InSpace V2 n t, Transformable t, Floating n) + => P2 n -> Angle n -> t -> t +rotateAround p theta = transform (rotationAround p theta) --- | The rotation that aligns the x-axis with the given non-zero vector. +-- | The rotation that aligns the x-axis with the given direction. rotationTo :: OrderedField n => Direction V2 n -> T2 n rotationTo (view _Dir -> V2 x y) = rotation (atan2A' y x) --- could be done with Direction -- | Rotate around the local origin such that the x axis aligns with the -- given direction. @@ -211,16 +227,17 @@ reflectionY = fromSymmetric $ (_y *~ (-1)) <-> (_y *~ (-1)) reflectY :: (InSpace v n t, R2 v, Transformable t) => t -> t reflectY = transform reflectionY --- | @reflectionAbout p v@ is a reflection in the line determined by --- the point @p@ and vector @v@. -reflectionAbout :: OrderedField n => P2 n -> V2 n -> T2 n -reflectionAbout p v = - conjugate (rotationTo (direction $ negated v) <> translation (origin .-. p)) +-- | @reflectionAbout p d@ is a reflection in the line determined by +-- the point @p@ and direction @d@. +reflectionAbout :: OrderedField n => P2 n -> Direction V2 n -> T2 n +reflectionAbout p d = + conjugate (rotationTo d <> translation (origin .-. p)) reflectionY --- | @reflectAbout p v@ reflects a diagram in the line determined by --- the point @p@ and the vector @v@. -reflectAbout :: (InSpace V2 n t, OrderedField n, Transformable t) => P2 n -> V2 n -> t -> t +-- | @reflectAbout p d@ reflects a diagram in the line determined by +-- the point @p@ and direction @d@. +reflectAbout :: (InSpace V2 n t, OrderedField n, Transformable t) + => P2 n -> Direction V2 n -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Shears -------------------------------------------------- diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 36a72281..f0fe07c7 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -15,7 +15,7 @@ module Diagrams.TwoD.Vector , xDir, yDir -- * Converting between vectors and angles - , e, angleDir + , angleV, angleDir, e -- * 2D vector utilities , perp, leftTurn, cross2 @@ -54,14 +54,19 @@ xDir = dir unitX yDir :: (R2 v, Additive v, Num n) => Direction v n yDir = dir unitY +-- | A direction at a specified angle counter-clockwise from the 'xDir'. +angleDir :: Floating n => Angle n -> Direction V2 n +angleDir = dir . angleV + +-- | A unit vector at a specified angle counter-clockwise from the +-- positive x-axis +angleV :: Floating n => Angle n -> V2 n +angleV = angle . view rad + -- | A unit vector at a specified angle counter-clockwise from the -- positive X axis. e :: Floating n => Angle n -> V2 n -e = angle . view rad - --- | A direction at a specified angle counter-clockwise from the 'xDir'. -angleDir :: Floating n => Angle n -> Direction V2 n -angleDir = dir . e +e = angleV -- | @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 diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs index 8c922356..480b50c0 100644 --- a/src/Diagrams/Util.hs +++ b/src/Diagrams/Util.hs @@ -15,6 +15,7 @@ module Diagrams.Util with , applyAll , (#) + , (##) , iterateN @@ -27,6 +28,7 @@ module Diagrams.Util import Data.Default.Class import Data.Monoid +import Control.Lens hiding (( # )) -- | Several functions exported by the diagrams library take a number -- of arguments giving the user control to \"tweak\" various aspects @@ -67,6 +69,13 @@ infixl 8 # (#) :: a -> (a -> b) -> b (#) = flip ($) +-- | A replacement for lenses' @#@ operator. @(##) = 'review'@. +(##) :: AReview t b -> b -> t +(##) = review +{-# INLINE (##) #-} +infixr 8 ## + + -- | @iterateN n f x@ returns the list of the first @n@ iterates of -- @f@ starting at @x@, that is, the list @[x, f x, f (f x), ...]@ -- of length @n@. (Note that the last element of the list will be