packages feed

diagrams-lib 1.0.1 → 1.1

raw patch · 45 files changed

+1479/−485 lines, 45 filesdep −NumInstancesdep ~arraydep ~diagrams-coredep ~lens

Dependencies removed: NumInstances

Dependency ranges changed: array, diagrams-core, lens

Files

CHANGES.markdown view
@@ -1,3 +1,72 @@+1.1 (8 March 2014)+------------------++* **New features**++    - Support for `Deformation`s, arbitrary (non-affine)+      transformations on objects such as points, paths, and located+      trails (though not on diagrams).++    - New functions `clipTo`, which clips a diagram's envelope and+      trace along with its visual representation, and `clipped`, which+      clips the diagram's visual representation but replaces its+      envelope and trace with those of the clipping path.++    - New `arrowV` function, for creating an arrow with the direction+      and magnitude of a given vector.++    - `gap` traversal, for setting the head and tail gaps of an arrow+      simultaneously.++    - Generalized types for `centerXY` and `snugXY`, based on new+      `basis` function from `diagrams-core++    - New 3D `Transform`s, alignment, and 3D-specific `Prelude`.++    - New `frame` function similar to `pad`, but increases the envelope+      of a diagram by an amount specified in local units in every direction+      irrespective of the local origin.++    - New `splitFills` function for pushing fill attributes down to+      subtrees containing only loops (mostly of relevance only to+      backend implementors).++* **New instances**++    - `Typeable` instances for all data types that are used as diagram+      primitives.+    - `Sectionable` instance for `FixedSegment`.++* **API changes**++    - `Angle` is now a type, rather than a class.  It uses a single+      internal representation for angles, and lenses `turn`, `rad,`+      and `deg` are supplied for constructing (using `@@`) and viewing+      (using `^.`) `Angle`s in various units.  In addition, the `Num`+      instance for `Angle` has been removed, eliminating a class of+      errors where a bare number is interpreted in units other than+      what you expect.++    - Removed `Num` instance for angles.++* **Dependency/version changes**++    - Require `lens >= 4.0`.+	- Allow `array-0.5`.+	- Allow `hashable-1.1`.+	- Remove `NumInstances` dependency.++* **Bug fixes**++    - Exclude joins in offsets on close segments (#160).+    - Exclude extra segment when joining loops in offset (#155).++* **Performance improvements**++    - `colorToSRGBA` function now avoids expensive matrix operations,+      offering dramatic speedups in rendering diagrams with many color+      attributes.+ 1.0.1 (26 January 2014) -----------------------
LICENSE view
@@ -1,7 +1,8 @@-Copyright (c) 2011-2013 diagrams-lib team:+Copyright (c) 2011-2014 diagrams-lib team:    Jan Bracker <jan.bracker@googlemail.com>   Daniel Bergey <bergey@alum.mit.edu>+  Denys Duchier <denys.duchier@univ-orleans.fr>   Daniil Frumin <difrumin@gmail.com>   Niklas Haas <nand@lavabit.com>   Peter Hall <peter.hall@memorphic.com>
diagrams-lib.cabal view
@@ -1,5 +1,5 @@ Name:                diagrams-lib-Version:             1.0.1+Version:             1.1 Synopsis:            Embedded domain-specific language for declarative graphics Description:         Diagrams is a flexible, extensible EDSL for creating                      graphics of many types.  Graphics can be created@@ -19,17 +19,19 @@ Cabal-version:       >=1.10 Extra-source-files:  CHANGES.markdown, README.markdown, diagrams/*.svg Extra-doc-files:     diagrams/*.svg-Tested-with:         GHC == 7.4.2, GHC == 7.6.1+Tested-with:         GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1 Source-repository head   type:     git   location: http://github.com/diagrams/diagrams-lib.git  Library   Exposed-modules:     Diagrams.Prelude,+                       Diagrams.Prelude.ThreeD,                        Diagrams.Align,                        Diagrams.Combinators,                        Diagrams.Coordinates,                        Diagrams.Attributes,+                       Diagrams.Attributes.Compile,                        Diagrams.Points,                        Diagrams.Located,                        Diagrams.Parametric,@@ -43,6 +45,7 @@                        Diagrams.Solve,                        Diagrams.Tangent,                        Diagrams.Transform,+                       Diagrams.Deform                        Diagrams.BoundingBox,                        Diagrams.Names,                        Diagrams.Envelope,@@ -54,6 +57,7 @@                        Diagrams.TwoD.Arrow,                        Diagrams.TwoD.Arrowheads,                        Diagrams.TwoD.Combinators,+                       Diagrams.TwoD.Deform,                        Diagrams.TwoD.Transform,                        Diagrams.TwoD.Transform.ScaleInv,                        Diagrams.TwoD.Ellipse,@@ -70,13 +74,15 @@                        Diagrams.TwoD.Text,                        Diagrams.TwoD.Image,                        Diagrams.TwoD.Adjust,-                       Diagrams.ThreeD.Types,-                       Diagrams.ThreeD.Shapes,-                       Diagrams.ThreeD.Vector,-                       Diagrams.ThreeD.Transform,+                       Diagrams.ThreeD.Align,                        Diagrams.ThreeD.Camera,+                       Diagrams.ThreeD.Deform,                        Diagrams.ThreeD.Light,-                       Diagrams.ThreeD+                       Diagrams.ThreeD.Shapes,+                       Diagrams.ThreeD.Transform,+                       Diagrams.ThreeD.Types,+                       Diagrams.ThreeD.Vector,+                       Diagrams.ThreeD,                        Diagrams.Animation,                        Diagrams.Animation.Active,                        Diagrams.Util,@@ -84,21 +90,20 @@                        Diagrams.Backend.CmdLine   Build-depends:       base >= 4.2 && < 4.8,                        containers >= 0.3 && < 0.6,-                       array >= 0.3 && < 0.5,+                       array >= 0.3 && < 0.6,                        semigroups >= 0.3.4 && < 0.13,                        monoid-extras >= 0.3 && < 0.4,-                       diagrams-core >= 1.0 && < 1.1,+                       diagrams-core >= 1.1 && < 1.2,                        active >= 0.1 && < 0.2,                        vector-space >= 0.7.7 && < 0.9,                        vector-space-points >= 0.1.2 && < 0.2,                        MemoTrie >= 0.6 && < 0.7,-                       NumInstances >= 1.2 && < 1.4,                        colour >= 2.3.2 && < 2.4,                        data-default-class < 0.1,                        pretty >= 1.0.1.2 && < 1.2,                        fingertree >= 0.1 && < 0.2,                        intervals >= 0.3 && < 0.5,-                       lens >= 3.9 && < 3.11,+                       lens >= 4.0 && < 4.1,                        tagged >= 0.7,                        optparse-applicative >= 0.7 && < 0.8,                        filepath,
src/Diagrams/Align.hs view
@@ -29,13 +29,14 @@         , align        , snug-       , center+       , centerV, center        , snugBy-       , snugCenter+       , snugCenterV, snugCenter         ) where  import           Diagrams.Core+import           Diagrams.Util    (applyAll)  import           Data.AffineSpace (alerp, (.-.)) import           Data.VectorSpace@@ -140,15 +141,28 @@       => V a -> a -> a snug v = snugBy  v 1 --- | @center v@ centers an enveloped object along the direction of+-- | @centerV v@ centers an enveloped object along the direction of --   @v@.-center :: ( Alignable a, HasOrigin a, Num (Scalar (V a))+centerV :: ( Alignable a, HasOrigin a, Num (Scalar (V a))           , Fractional (Scalar (V a))) => V a -> a -> a-center v = alignBy v 0+centerV v = alignBy v 0 --- | Like @center@ using trace.-snugCenter+-- | @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+  where+    fs = map centerV basis++-- | Like @centerV@ using trace.+snugCenterV   :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a)    => V a -> a -> a-snugCenter v = (alignBy' traceBoundary) v 0+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+  where+    fs = map snugCenterV basis
src/Diagrams/Attributes.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE ExistentialQuantification  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-} ----------------------------------------------------------------------------- -- | -- Module      :  Diagrams.Attributes@@ -37,7 +39,7 @@   , Opacity, getOpacity, opacity    -- ** Converting colors-  , toRGBAUsingSpace, colorToSRGBA, colorToRGBA+  , colorToSRGBA, colorToRGBA    -- * Lines   -- ** Width@@ -55,20 +57,28 @@   -- ** Dashing   , Dashing(..), DashingA, getDashing, dashing +  -- * Compilation utilities+  , splitFills+   ) where -import           Control.Lens          (Setter, sets)+import           Control.Lens                (Setter, sets) import           Data.Colour-import           Data.Colour.RGBSpace-import           Data.Colour.SRGB      (sRGBSpace)+import           Data.Colour.RGBSpace        (RGB (..))+import           Data.Colour.SRGB            (toSRGB) import           Data.Default.Class-import           Data.Maybe            (fromMaybe)+import           Data.Maybe                  (fromMaybe) import           Data.Monoid.Recommend import           Data.Semigroup import           Data.Typeable +import           Diagrams.Attributes.Compile import           Diagrams.Core-import           Diagrams.Core.Style   (setAttr)+import           Diagrams.Core.Style         (setAttr)+import           Diagrams.Core.Types         (RTree)+import           Diagrams.Located            (unLoc)+import           Diagrams.Path               (Path, pathTrails)+import           Diagrams.Trail              (isLoop)  ------------------------------------------------------------ --  Color  -------------------------------------------------@@ -226,20 +236,14 @@   toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c   fromAlphaColour = FillColor . Commit . Last . fromAlphaColour --- | Convert to an RGB space while preserving the alpha channel.-toRGBAUsingSpace :: Color c => RGBSpace Double -> c-                            -> (Double, Double, Double, Double)-toRGBAUsingSpace s col = (r,g,b,a)-  where c' = toAlphaColour col-        c  = toRGBUsingSpace s (alphaToColour c')-        a  = alphaChannel  c'-        r  = channelRed   c-        g  = channelGreen c-        b  = channelBlue  c- -- | Convert to sRGBA. colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double)-colorToSRGBA = toRGBAUsingSpace sRGBSpace+colorToSRGBA col = (r, g, b, a)+  where+    c' = toAlphaColour col+    c = alphaToColour c'+    a = alphaChannel c'+    RGB r g b = toSRGB c  colorToRGBA = colorToSRGBA {-# DEPRECATED colorToRGBA "Renamed to colorToSRGBA." #-}@@ -396,3 +400,22 @@                      --   stroke should start.         -> a -> a dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs)))++------------------------------------------------------------++data FillLoops v = FillLoops++instance Typeable v => SplitAttribute (FillLoops v) where+  type AttrType (FillLoops v) = FillColor+  type PrimType (FillLoops v) = Path v++  primOK _ = all (isLoop . unLoc) . pathTrails++-- | Push fill attributes down until they are at the root of subtrees+--   containing only loops. This makes life much easier for backends,+--   which typically have a semantics where fill attributes are+--   applied to lines/non-closed paths as well as loops/closed paths,+--   whereas in the semantics of diagrams, fill attributes only apply+--   to loops.+splitFills :: forall b v a. Typeable v => RTree b v a -> RTree b v a+splitFills = splitAttr (FillLoops :: FillLoops v)
+ src/Diagrams/Attributes/Compile.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Attributes.Compile+-- Copyright   :  (c) 2014 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- XXX+--+-----------------------------------------------------------------------------++module Diagrams.Attributes.Compile (+    SplitAttribute(..), splitAttr+  ) where++import           Data.Typeable++import           Control.Arrow       (second)+import           Control.Lens        ((%~), (&), _Wrapping')+import qualified Data.Map            as M+import           Data.Semigroup      ((<>))+import           Data.Tree           (Tree (..))++import           Diagrams.Core+import           Diagrams.Core.Style (Style (..), attrToStyle)+import           Diagrams.Core.Types (RNode (..), RTree)++------------------------------------------------------------++-- This is a sort of roundabout, overly-general way to define+-- splitFills; it's done this way to facilitate testing.++class (AttributeClass (AttrType code), Typeable (PrimType code)) => SplitAttribute code where+  type AttrType code :: *+  type PrimType code :: *++  primOK :: code -> PrimType code -> Bool++-- | Push certain attributes down until they are at the roots of trees+--   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 code = fst . splitAttr' Nothing+  where++  -- splitAttr' is where the most interesting logic happens.+  -- Mutually recursive with splitAttr'Forest. rebuildNode and+  -- applyMfc are helper functions.+  --+  -- Input: attribute to apply to "safe" subtrees.+  --+  -- 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)++  -- RStyle node: Check for the special attribute, and split it out of+  -- the style, combining it with the incoming attribute.  Recurse and+  -- rebuild. The tricky bit is that we use some knot-tying to+  -- determine the right attribute to pass down to the subtrees based+  -- on this computed Bool: if all subtrees are safe, then we will+  -- apply the attribute at the root of this tree, and pass Nothing to+  -- all the subtrees.  Otherwise, we pass the given attribute along.+  -- This works out because the attribute does not need to be+  -- pattern-matched until actually applying it at some root, so the+  -- recursion can proceed and the Bool values be computed with the+  -- actual value of the attributes nodes filled in lazily.+  splitAttr' mattr (Node (RStyle sty) cs) = (t', ok)+    where+      mattr' = mattr <> getAttr sty+      sty' = sty & _Wrapping' Style %~ M.delete ty+      ty   = show . typeOf $ (undefined :: AttrType code)+      (cs', ok) = splitAttr'Forest mattr' cs+      t' | ok        = rebuildNode Nothing ok (RStyle sty) cs'+         | otherwise = rebuildNode mattr ok (RStyle sty') cs'++  -- RPrim node: check whether it+  --   * is some sort of prim not under consideration: don't apply the attribute; return True+  --   * is unsafe: don't apply the attribute; return False+  --   * is safe  :  do   apply the attribute; return True+  splitAttr' mattr (Node rp@(RPrim _ (Prim prm)) _) =+      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)++  -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild.  Note+  -- we assume that transformations do not affect the attributes.+  splitAttr' mattr (Node nd cs)    = (t', ok)+    where+      (cs', ok) = splitAttr'Forest mattr cs+      t'        = rebuildNode mattr ok nd cs'++  -- 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 mattr cs = (cs', ok)+    where+      (cs', ok) = second and . unzip . map (splitAttr' mattr) $ cs++  -- Given a fill attribute, a Bool indicating whether the given+  -- 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 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 Nothing  t = t+  applyMattr (Just a) t = Node (RStyle $ attrToStyle a) [t]
src/Diagrams/Combinators.hs view
@@ -20,7 +20,7 @@           withEnvelope, withTrace        , phantom, strut-       , pad+       , pad, frame        , extrudeEnvelope, intrudeEnvelope           -- * Binary operations@@ -37,8 +37,11 @@         ) where -import           Control.Lens       ( (&), (%~), (.~), Lens', makeLensesWith-                                    , lensRules, lensField, generateSignatures, unwrapping)+import           Data.Typeable++import           Control.Lens       (Lens', generateSignatures, lensField,+                                     lensRules, makeLensesWith, (%~), (&), (.~),+                                     (^.), _Wrapping) import           Data.AdditiveGroup import           Data.AffineSpace   ((.+^)) import           Data.Default.Class@@ -82,7 +85,7 @@  -- | @phantom x@ produces a \"phantom\" diagram, which has the same --   envelope and trace as @x@ but produces no output.-phantom :: (Backend b (V a), Enveloped a, Traced a, Monoid' m) => a -> QDiagram b (V a) m+phantom :: (Backend b (V a), Typeable (V a), Enveloped a, Traced a, Monoid' m) => a -> QDiagram b (V a) m phantom a = mkQD nullPrim (getEnvelope a) (getTrace a) mempty mempty  -- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of@@ -97,6 +100,16 @@     => Scalar v -> QDiagram b v m -> QDiagram b v 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 s d = setEnvelope (onEnvelope t (d^.envelope)) d+  where+    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 --   oriented along the vector @v@, with local origin at its@@ -108,7 +121,8 @@ --   <<diagrams/src_Diagrams_Combinators_strutEx.svg#diagram=strutEx&width=300>> -- --   > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1-strut :: ( Backend b v, InnerSpace v+strut :: ( Backend b v, Typeable v+         , InnerSpace v          , OrderedField (Scalar v)          , Monoid' m          )@@ -156,10 +170,10 @@   :: ( 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-deformEnvelope s v d = setEnvelope (getEnvelope d & unwrapping Envelope %~ deform) d+deformEnvelope s v d = setEnvelope (getEnvelope d & _Wrapping Envelope %~ deformE) d   where-    deform = Option . fmap deform' . getOption-    deform' env v'+    deformE = Option . fmap deformE' . getOption+    deformE' env v'         | dot > 0 = Max $ getMax (env v') + (dot * s) / magnitude v'         | otherwise = env v'       where@@ -360,9 +374,9 @@ --     default is 0. -- --   'CatOpts' is an instance of 'Default', so 'with' may be used for---   the second argument, as in @cat' (1,2) with {sep = 2}@.+--   the second argument, as in @cat' (1,2) (with & sep .~ 2)@. -----   Note that @cat' v with {catMethod = Distrib} === mconcat@+--   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
src/Diagrams/CubicSpline.hs view
@@ -31,9 +31,6 @@ import           Diagrams.Trail import           Diagrams.TrailLike            (TrailLike (..)) --- for e.g. the Fractional (Double, Double) instance-import           Data.NumInstances.Tuple       ()- import           Data.AffineSpace.Point import           Data.VectorSpace
+ src/Diagrams/Deform.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances       #-}++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+import Diagrams.Parametric+import Diagrams.Path+import Diagrams.Segment+import Diagrams.Trail++------------------------------------------------------------+-- Deformations++-- | @Deformations@ are a superset of the affine transformations+-- represented by the 'Transformation' type.  In general they are not+-- 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)++instance Semigroup (Deformation v) where+    (Deformation p1) <> (Deformation p2) = Deformation (p1 . p2)++instance Monoid (Deformation v) 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 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++-- | @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++------------------------------------------------------------+-- Instances++instance Deformable (Point v) 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,+-- the deformation of a @Segment@ can be approximated to arbitrary+-- 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 epsilon t s+    | goodEnough epsilon t s = [approx t s]+    | otherwise  = concatMap (deformSegment epsilon t) [s1, s2]+  where+    (s1, s2) = splitAtParam s 0.5++approx :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) =>+          Deformation v -> FixedSegment v -> FixedSegment v+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 e t s =+    all (< e) [magnitude $ 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)
src/Diagrams/Path.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}@@ -57,6 +58,8 @@         ) where +import           Data.Typeable+ import           Diagrams.Align import           Diagrams.Core import           Diagrams.Core.Points ()@@ -68,8 +71,8 @@ import           Diagrams.Transform  import           Control.Arrow        ((***))-import           Control.Lens         ( Wrapped(..), mapped, over, view, iso-                                      , unwrapped, wrapped, (%~), op)+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)@@ -85,11 +88,14 @@ --   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)+  deriving (Semigroup, Monoid, Typeable) -instance Wrapped [Located (Trail v)] [Located (Trail v')] (Path v) (Path v')-  where wrapped = iso Path $ \(Path x) -> x+instance Wrapped (Path v) where+    type Unwrapped (Path v) = [Located (Trail v)]+    _Wrapped' = iso (\(Path x) -> x) Path +instance Rewrapped (Path v) (Path v')+ -- | Extract the located trails making up a 'Path'. pathTrails :: Path v -> [Located (Trail v)] pathTrails = op Path@@ -101,7 +107,7 @@ type instance V (Path v) = v  instance VectorSpace v => HasOrigin (Path v) where-  moveOriginTo = over unwrapped . map . moveOriginTo+  moveOriginTo = over _Wrapped' . map . moveOriginTo   --moveOriginTo = over pathTrails . map . moveOriginTo  -- | Paths are trail-like; a trail can be used to construct a@@ -112,7 +118,7 @@ -- See Note [Transforming paths] instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v))     => Transformable (Path v) where-  transform = over unwrapped . map . transform+  transform = over _Wrapped . map . transform  {- ~~~~ Note [Transforming paths] @@ -196,7 +202,7 @@ --   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 p = (view wrapped *** view wrapped) . partition p . op Path+partitionPath p = (view _Unwrapped' *** view _Unwrapped') . partition p . op Path  ------------------------------------------------------------ --  Modifying paths  ---------------------------------------@@ -210,4 +216,4 @@  -- | Reverse all the component trails of a path. reversePath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Path v-reversePath = unwrapped . mapped %~ reverseLocTrail+reversePath = _Wrapped . mapped %~ reverseLocTrail
src/Diagrams/Prelude.hs view
@@ -61,6 +61,10 @@          --   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@@ -124,6 +128,7 @@ import           Diagrams.Combinators import           Diagrams.Coordinates import           Diagrams.CubicSpline+import           Diagrams.Deform import           Diagrams.Envelope import           Diagrams.Located import           Diagrams.Names
+ src/Diagrams/Prelude/ThreeD.hs view
@@ -0,0 +1,150 @@+{-# 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++         -- | 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++         -- | Convenience infix operators for working with coordinates.+        , module Diagrams.Coordinates++         -- | 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.Animation+import           Diagrams.Attributes+import           Diagrams.Combinators+import           Diagrams.Coordinates+import           Diagrams.CubicSpline+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+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               ((&), (.~), (%~))
src/Diagrams/Segment.hs view
@@ -64,7 +64,7 @@         ) where -import           Control.Lens (makeLenses, Wrapped(..), iso, op)+import           Control.Lens (makeLenses, Wrapped(..), Rewrapped, iso, op) import           Control.Applicative (liftA2) import           Data.AffineSpace import           Data.FingerTree@@ -375,6 +375,35 @@            p3  = alerp p21 p22 t +instance Num (Scalar v) => DomainBounds (FixedSegment v)++instance (VectorSpace v, Num (Scalar v)) => EndValues (FixedSegment v) 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+  splitAtParam (FLinear p0 p1) t = (left, right)+    where left  = FLinear p0 p+          right = FLinear p  p1+          p = alerp p0 p1 t+  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+          -- second round+          b   = alerp a  p  t+          c   = alerp p  d  t+          -- final round+          cut = alerp b  c  t++  reverseDomain (FLinear p0 p1) = FLinear p1 p0+  reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0+ ------------------------------------------------------------ --  Segment measures  -------------------------------------- ------------------------------------------------------------@@ -387,9 +416,12 @@ newtype SegCount = SegCount (Sum Int)   deriving (Semigroup, Monoid) -instance Wrapped (Sum Int) (Sum Int) SegCount SegCount-  where wrapped = iso SegCount $ \(SegCount x) -> x+instance Wrapped SegCount where+    type Unwrapped SegCount = Sum Int+    _Wrapped' = iso (\(SegCount x) -> x) SegCount +instance Rewrapped SegCount SegCount+ -- | A type to represent the total arc length of a chain of --   segments. The first component is a \"standard\" arc length, --   computed to within a tolerance of @10e-6@.  The second component is@@ -399,13 +431,13 @@ newtype ArcLength v   = ArcLength (Sum (Interval (Scalar v)), Scalar v -> Sum (Interval (Scalar v))) -instance (Scalar v ~ u, Scalar v' ~ u', u ~ u') => Wrapped-    (Sum (Interval u), u  -> Sum (Interval u ))-    (Sum (Interval u'), u' -> Sum (Interval u'))-    (ArcLength v)-    (ArcLength v')-  where wrapped = iso ArcLength $ \(ArcLength x) -> x+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 Rewrapped (ArcLength v) (ArcLength v')+ -- | Project out the cached arc length, stored together with error --   bounds. getArcLengthCached :: ArcLength v -> Interval (Scalar v)@@ -433,8 +465,11 @@ --   segments. newtype TotalOffset v = TotalOffset v -instance Wrapped v v (TotalOffset v) (TotalOffset v)-  where wrapped = iso TotalOffset $ \(TotalOffset x) -> x+instance Wrapped (TotalOffset v) where+    type Unwrapped (TotalOffset v) = v+    _Wrapped' = iso (\(TotalOffset x) -> x) TotalOffset++instance Rewrapped (TotalOffset v) (TotalOffset v')  instance AdditiveGroup v => Semigroup (TotalOffset v) where   TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2)
src/Diagrams/ThreeD.hs view
@@ -31,18 +31,19 @@ --     for rendering 3D geometry to (2D) images. ----------------------------------------------------------------------------- module Diagrams.ThreeD-       ( module Diagrams.ThreeD.Types+       ( module Diagrams.ThreeD.Align+       , module Diagrams.ThreeD.Camera+       , module Diagrams.ThreeD.Light+       , module Diagrams.ThreeD.Shapes        , module Diagrams.ThreeD.Transform+       , module Diagrams.ThreeD.Types        , module Diagrams.ThreeD.Vector-       , module Diagrams.ThreeD.Shapes-       , module Diagrams.ThreeD.Light-       , module Diagrams.ThreeD.Camera        ) where --import Diagrams.ThreeD.Transform-import Diagrams.ThreeD.Vector-import Diagrams.ThreeD.Light-import Diagrams.ThreeD.Types+import Diagrams.ThreeD.Align import Diagrams.ThreeD.Camera+import Diagrams.ThreeD.Light import Diagrams.ThreeD.Shapes+import Diagrams.ThreeD.Transform+import Diagrams.ThreeD.Types+import Diagrams.ThreeD.Vector
+ src/Diagrams/ThreeD/Align.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.ThreeD.Align+-- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Alignment combinators specialized for three dimensions.  See+-- "Diagrams.Align" for more general alignment combinators.+--+-- The basic idea is that alignment is achieved by moving diagrams'+-- local origins relative to their envelopes or traces (or some other+-- sort of boundary).  For example, to align several diagrams along+-- their tops, we first move their local origins to the upper edge of+-- their boundary (using e.g. @map 'alignZMax'@), and then put them+-- together with their local origins along a line (using e.g. 'cat'+-- from "Diagrams.Combinators").+--+-----------------------------------------------------------------------------++module Diagrams.ThreeD.Align+    ( -- * Absolute alignment+      -- ** Align by envelope+      alignXMin, alignXMax, alignYMin, alignYMax, alignZMin, alignZMax++      -- ** Align by trace+    , snugXMin, snugXMax, snugYMin, snugYMax, snugZMin, snugZMax++      -- * Relative alignment+    , alignX, snugX, alignY, snugY, alignZ, snugZ++      -- * Centering+    , centerX, centerY, centerZ+    , centerXY, centerXZ, centerYZ, centerXYZ+    , snugCenterX, snugCenterY, snugCenterZ+    , snugCenterXY, snugCenterXZ, snugCenterYZ, snugCenterXYZ++    ) where++import           Diagrams.Core++import           Diagrams.Align+import           Diagrams.ThreeD.Types+import           Diagrams.ThreeD.Vector++import           Data.VectorSpace++-- | Translate the diagram along unitX so that all points have+-- positive x-values.+alignXMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a+alignXMin = align (negateV unitX)++snugXMin :: (Fractional (Scalar (V a)), Alignable a, Traced a,+      HasOrigin a, V a ~ R3) => a -> a+snugXMin = snug (negateV unitX)++-- | Translate the diagram along unitX so that all points have+-- negative x-values.+alignXMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a+alignXMax = align unitX++snugXMax :: (Fractional (Scalar (V a)), Alignable a, Traced a,+      HasOrigin a, V a ~ R3) => a -> a+snugXMax = snug unitX+++-- | Translate the diagram along unitY so that all points have+-- negative y-values.+alignYMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a+alignYMax = 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 = 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+-- negative z-values.+alignZMax :: (Alignable a, HasOrigin a, V a ~ R3) => 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 = 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 = alignBy unitZ++snugZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,+      HasOrigin a, V a ~ R3) => Double -> 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++snugCenterZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,+      HasOrigin a, V a ~ R3) => 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 = centerX . centerZ++snugCenterXZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,+      HasOrigin a, V a ~ R3) => a -> a+snugCenterXZ = snugCenterX . snugCenterZ+++-- | Center along both the Y- and Z-axes.+centerYZ :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a+centerYZ = centerZ . centerY++snugCenterYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,+      HasOrigin a, V a ~ R3) => 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 = centerX . centerY . centerZ++snugCenterXYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a,+      HasOrigin a, V a ~ R3) => a -> a+snugCenterXYZ = snugCenterX . snugCenterY . snugCenterZ
src/Diagrams/ThreeD/Camera.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}  ----------------------------------------------------------------------------- -- |@@ -28,32 +29,35 @@        )        where -import Control.Lens            (makeLenses)-import Data.Monoid-import Data.Cross+import           Control.Lens           (makeLenses)+import           Data.Cross+import           Data.Monoid+import           Data.Typeable -import Diagrams.Core-import Diagrams.ThreeD.Types-import Diagrams.ThreeD.Vector+import           Diagrams.Core+import           Diagrams.ThreeD.Types+import           Diagrams.ThreeD.Vector  -- Parameterize Camera on the lens type, so that Backends can express which -- lenses they handle. data Camera l = Camera-    { camLoc   :: P3-    , forward  :: R3-    , up       :: R3-    , lens     :: l+    { camLoc  :: P3+    , forward :: R3+    , up      :: R3+    , lens    :: l     }+  deriving Typeable -class CameraLens l where+class Typeable l => CameraLens l where     -- | The natural aspect ratio of the projection.     aspect :: l -> Double  -- | A perspective projection data PerspectiveLens = PerspectiveLens-                     { _horizontalFieldOfView :: Deg -- ^ Horizontal field of view.-                     , _verticalFieldOfView   :: Deg -- ^ Vertical field of view.+                     { _horizontalFieldOfView :: Angle -- ^ Horizontal field of view.+                     , _verticalFieldOfView   :: Angle -- ^ Vertical field of view.                      }+  deriving Typeable  makeLenses ''PerspectiveLens @@ -65,6 +69,7 @@                { _orthoWidth  :: Double -- ^ Width                , _orthoHeight :: Double -- ^ Height                }+  deriving Typeable  makeLenses ''OrthoLens @@ -104,15 +109,15 @@  -- | mm50 has the field of view of a 50mm lens on standard 35mm film, -- hence an aspect ratio of 3:2.-mm50 = PerspectiveLens 40.5 27+mm50 = PerspectiveLens (40.5 @@ deg) (27 @@ deg) --- | mm50Wide has the same vertical field of view as mm50, but an+-- | mm50blWide has the same vertical field of view as mm50, but an -- aspect ratio of 1.6, suitable for wide screen computer monitors.-mm50Wide = PerspectiveLens 43.2 27+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.-mm50Narrow = PerspectiveLens 36 27+mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg)  camForward :: Direction d => Camera l -> d camForward = direction . forward
+ src/Diagrams/ThreeD/Deform.hs view
@@ -0,0 +1,51 @@+module Diagrams.ThreeD.Deform where++import Control.Lens++import Diagrams.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 )++-- | The parallel projection onto the plane z=0+parallelZ0 :: Deformation R3+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))++facingY :: Deformation R3+facingY = Deformation (\v -> v & _x //~ (v^._y) & _z //~ (v^._y))++facingZ :: Deformation R3+facingZ = Deformation (\v -> v & _x //~ (v^._z) & _y //~ (v^._z))
src/Diagrams/ThreeD/Light.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}  ----------------------------------------------------------------------------- -- |@@ -15,16 +16,19 @@  module Diagrams.ThreeD.Light where -import Data.Colour-import Data.Monoid+import           Data.Colour+import           Data.Monoid+import           Data.Typeable -import Diagrams.Core-import Diagrams.ThreeD.Types-import Diagrams.ThreeD.Vector+import           Diagrams.Core+import           Diagrams.ThreeD.Types+import           Diagrams.ThreeD.Vector  data PointLight = PointLight P3 (Colour Double)+  deriving Typeable  data ParallelLight = ParallelLight R3 (Colour Double)+  deriving Typeable  type instance V PointLight = R3 type instance V ParallelLight = R3
src/Diagrams/ThreeD/Shapes.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE TypeFamilies-           , FlexibleContexts-           , MultiParamTypeClasses-           , ViewPatterns-  #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-} ----------------------------------------------------------------------------- -- | -- Module      :  Diagrams.ThreeD.Shapes@@ -20,19 +19,17 @@        , sphere        ) where -import Prelude hiding (minimum)-import Data.Semigroup--import Data.AffineSpace-import Data.Monoid.Inf (minimum)-import Data.VectorSpace--import Diagrams.Core+import           Data.Typeable -import Diagrams.ThreeD.Types-import Diagrams.Solve+import           Data.AffineSpace+import           Data.Semigroup+import           Data.VectorSpace+import           Diagrams.Core+import           Diagrams.Solve+import           Diagrams.ThreeD.Types  data Ellipsoid = Ellipsoid T3+  deriving Typeable  type instance V Ellipsoid = R3 @@ -51,7 +48,7 @@               mempty               (Query sphereQuery)   where sphereEnv v = 1 / magnitude v-        sphereTrace p v = minimum (quadForm a b c)+        sphereTrace p v = mkSortedList $ quadForm a b c           where a = v <.> v                 b = 2 *^ p' <.> v                 c = p' <.> p' - 1
src/Diagrams/ThreeD/Transform.hs view
@@ -16,16 +16,42 @@ -- ----------------------------------------------------------------------------- -module Diagrams.ThreeD.Transform where+module Diagrams.ThreeD.Transform+       (+         -- * Rotation+         aboutX, aboutY, aboutZ+       , rotationAbout, pointAt, pointAt' +       -- * Scaling+       , scalingX, scalingY, scalingZ+       , scaleX, scaleY, scaleZ+       , scaling, scale++       -- * Translation+       , translationX, translateX+       , translationY, translateY+       , translationZ, translateZ+       , translation, translate++         -- * Reflection+       , reflectionX, reflectX+       , reflectionY, reflectY+       , reflectionZ, reflectZ+       , reflectionAbout, reflectAbout++       -- * Utilities for Backends+       , onBasis+       ) where+ import           Diagrams.Core import qualified Diagrams.Core.Transform as T +import           Diagrams.Transform import           Diagrams.ThreeD.Types import           Diagrams.ThreeD.Vector import           Diagrams.Coordinates -import           Control.Lens                   ((*~), (//~))+import           Control.Lens                   (view, (*~), (//~)) import           Data.Semigroup  import           Data.AffineSpace@@ -37,39 +63,39 @@ --   A positive angle brings positive x-values towards the positive-y axis. -- --   The angle can be expressed using any type which is an---   instance of 'Angle'.  For example, @aboutZ (1\/4 ::---   'Turn')@, @aboutZ (tau\/4 :: 'Rad')@, and @aboutZ (90 ::---   'Deg')@ all represent the same transformation, namely, a+--   instance of 'Angle'.  For example, @aboutZ (1\/4 \@\@+--   'turn')@, @aboutZ (tau\/4 \@\@ 'rad')@, and @aboutZ (90 \@\@+--   'deg')@ all represent the same transformation, namely, a --   counterclockwise rotation by a right angle.  For more general rotations, --   see 'rotationAbout'. -- --   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 a => a -> T3+aboutZ :: Angle -> T3 aboutZ ang = fromLinear r (linv r) where   r = rot theta <-> rot (-theta)-  Rad theta = convertAngle ang+  theta = view rad ang   rot th (coords -> x :& y :& z) = (cos th * x - sin th * y) ^&                                    (sin th * x + cos th * y) ^&                                    z  -- | Like 'aboutZ', but rotates about the X axis, bringing positive y-values -- towards the positive z-axis.-aboutX :: Angle a => a -> T3+aboutX :: Angle -> T3 aboutX ang = fromLinear r (linv r) where   r = rot theta <-> rot (-theta)-  Rad theta = convertAngle ang+  theta = view rad ang   rot th (coords -> x :& y :& z) = (x) ^&                                    (cos th * y - sin th * z) ^&                                    (sin th * y + cos th * z)  -- | Like 'aboutZ', but rotates about the Y axis, bringing postive -- x-values towards the negative z-axis.-aboutY :: Angle a => a -> T3+aboutY :: Angle -> T3 aboutY ang = fromLinear r (linv r) where   r = rot theta <-> rot (-theta)-  Rad theta = convertAngle ang+  theta = view rad ang   rot th (coords -> x :& y :& z) = (cos th * x + sin th * z) ^&                                     y ^&                                     (-sin th * x + cos th * z)@@ -77,17 +103,17 @@ -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ --   passing through @p@. rotationAbout-  :: (Angle a, Direction d)+  :: Direction d   => P3     -- ^ origin of rotation   -> d      -- ^ direction of rotation axis-  -> a      -- ^ angle of rotation+  -> Angle      -- ^ angle of rotation   -> T3 rotationAbout p d a   = mconcat [translation (negateV t),              fromLinear r (linv r),              translation t] where     r = rot theta <-> rot (-theta)-    Rad theta = convertAngle a+    theta = view rad a     w = fromDirection d     rot :: Double -> R3 -> R3     rot th v = v ^* cos th ^+^@@ -110,10 +136,10 @@ pointAt' :: R3 -> R3 -> R3 -> T3 pointAt' about initial final = tilt <> pan where   inPanPlane    = final ^-^ project final initial-  panAngle      = angleBetween initial inPanPlane :: Turn-  pan           = rotationAbout origin (direction about :: Spherical Turn) panAngle-  tiltAngle     = angleBetween initial inPanPlane :: Turn-  tiltDir       = direction $ cross3 inPanPlane about :: Spherical Turn+  panAngle      = angleBetween initial inPanPlane+  pan           = rotationAbout origin (direction about :: Spherical) panAngle+  tiltAngle     = angleBetween initial inPanPlane+  tiltDir       = direction $ cross3 inPanPlane about :: Spherical   tilt          = rotationAbout origin tiltDir tiltAngle  -- Scaling -------------------------------------------------@@ -150,6 +176,85 @@ -- uniformly, use 'scale'. scaleZ :: (Transformable t, V t ~ R3) => Double -> 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)++-- | Translate a diagram by the given distance in the y+--   direction.+translateZ :: (Transformable t, V t ~ R3) => Double -> 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 = 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 = transform reflectionZ++-- | @reflectionAbout p v@ is a reflection across the plane through+--   the point @p@ and normal to vector @v@.+reflectionAbout :: P3 -> R3 -> T3+reflectionAbout 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+--   the point @p@ and the vector @v@.+reflectAbout :: (Transformable t, V t ~ R3) => P3 -> R3 -> t -> t+reflectAbout p v = transform (reflectionAbout p v)++-- Utilities ----------------------------------------  -- | Get the matrix equivalent of an affine transform, as a triple of --   columns paired with the translation vector.  This is mostly
src/Diagrams/ThreeD/Types.hs view
@@ -29,13 +29,8 @@          -- * Two-dimensional angles          -- | These are defined in "Diagrams.TwoD.Types" but          --   reëxported here for convenience.-       , Angle(..)-       , Turn(Turn), asTurn-       , CircleFrac-       , Rad(Rad), asRad-       , Deg(Deg), asDeg--       , fullTurn, convertAngle, angleRatio+       , Angle, rad, turn, deg, (@@)+       , fullTurn, angleRatio           -- * Directions in 3D        , Direction(..)@@ -43,8 +38,8 @@        , asSpherical        ) where -import           Control.Applicative-import           Control.Lens           (Iso', iso, over, Wrapped, wrapped, _1, _2, _3)+import           Control.Lens           (Iso', iso, over, Wrapped(..), Rewrapped+                                        , _1, _2, _3)  import           Diagrams.Core import           Diagrams.TwoD.Types@@ -78,10 +73,13 @@ unr3 = unR3  -- | Lens wrapped isomorphisms for R3.-instance Wrapped (Double, Double, Double) (Double, Double, Double) R3 R3 where-  wrapped = iso r3 unr3-  {-# INLINE wrapped #-}+instance Wrapped R3 where+    type Unwrapped R3 = (Double, Double, Double)+    _Wrapped' = iso unr3 r3+    {-# INLINE _Wrapped' #-} +instance Rewrapped R3 R3+ type instance V R3 = R3  instance VectorSpace R3 where@@ -139,35 +137,28 @@ -- based on that of the Angle class in 2D.  class Direction d where-    -- | Convert to polar angles-    toSpherical :: Angle a => d -> Spherical a+    -- | Convert to spherical coördinates+    toSpherical :: d -> Spherical -    -- | Convert from polar angles-    fromSpherical :: Angle a => Spherical a -> d+    -- | Convert from spherical coördinates+    fromSpherical :: Spherical -> d  -- | A direction expressed as a pair of spherical coordinates. -- `Spherical 0 0` is the direction of `unitX`.  The first coordinate -- represents rotation about the Z axis, the second rotation towards the Z axis.-data Spherical a = Spherical a a+data Spherical = Spherical Angle Angle                    deriving (Show, Read, Eq) -instance Applicative Spherical where-    pure a = Spherical a a-    Spherical a b <*> Spherical c d = Spherical (a c) (b d)--instance Functor Spherical where-    fmap f s = pure f <*> s--instance (Angle a) => Direction (Spherical a) where-    toSpherical = fmap convertAngle-    fromSpherical = fmap convertAngle+instance Direction Spherical where+    toSpherical = id+    fromSpherical = id  -- | The identity function with a restricted type, for conveniently -- restricting unwanted polymorphism.  For example, @fromDirection -- . asSpherical . camForward@ gives a unit vector pointing in the -- direction of the camera view.  Without @asSpherical@, the -- intermediate type would be ambiguous.-asSpherical :: Spherical Turn -> Spherical Turn+asSpherical :: Spherical -> Spherical asSpherical = id  instance HasX R3 where
src/Diagrams/ThreeD/Vector.hs view
@@ -20,7 +20,7 @@          direction, fromDirection, angleBetween, angleBetweenDirs        ) where -import Control.Lens (op)+import Control.Lens ((^.)) import Data.VectorSpace import Data.Cross @@ -61,24 +61,23 @@   | otherwise = fromSpherical $ Spherical θ φ where   r = magnitude v   (x,y,z) = unr3 v-  φ = Rad . asin $ z / r-  θ = Rad . atan2 y $ x-  zero = Rad $ 0+  φ = asin (z / r) @@ rad+  θ = atan2 y x @@ rad+  zero = 0 @@ rad  -- | @fromDirection d@ is the unit vector in the direction @d@. fromDirection :: Direction d => d -> R3 fromDirection (toSpherical -> (Spherical θ' φ')) = r3 (x,y,z) where-  θ = op Rad $ θ'-  φ = op Rad $ φ'+  θ = θ'^.rad+  φ = φ'^.rad   x = cos θ * cos φ   y = sin θ * cos φ   z = sin φ  -- | compute the positive angle between the two vectors in their common plane-angleBetween  :: (Angle a, Num a, Ord a) => R3 -> R3 -> a-angleBetween v1 v2 = convertAngle . Rad $-                     atan2 (magnitude $ cross3 v1 v2) (v1 <.> v2)+angleBetween  :: R3 -> R3 -> Angle+angleBetween v1 v2 = atan2 (magnitude $ cross3 v1 v2) (v1 <.> v2) @@ rad  -- | compute the positive angle between the two vectors in their common plane-angleBetweenDirs  :: (Direction d, Angle a, Num a, Ord a) => d -> d -> a+angleBetweenDirs  :: Direction d => d -> d -> Angle angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2)
src/Diagrams/Trail.hs view
@@ -103,7 +103,7 @@        ) where  import           Control.Arrow       ((***))-import           Control.Lens        (AnIso', iso, view, op, Wrapped(..))+import           Control.Lens        (AnIso', iso, view, op, Wrapped(..), Rewrapped) import           Data.AffineSpace import           Data.FingerTree     (FingerTree, ViewL (..), ViewR (..), (<|),                                       (|>))@@ -151,11 +151,11 @@ newtype SegTree v = SegTree (FingerTree (SegMeasure v) (Segment Closed v))   deriving (Eq, Ord, Show) -instance Wrapped (FingerTree (SegMeasure v) (Segment Closed v))-                 (FingerTree (SegMeasure v) (Segment Closed v))-                 (SegTree v)-                 (SegTree v)-  where wrapped = iso SegTree $ \(SegTree x) -> x+instance Wrapped (SegTree v) where+    type Unwrapped (SegTree v) = FingerTree (SegMeasure v) (Segment Closed v)+    _Wrapped' = iso (\(SegTree x) -> x) SegTree++instance Rewrapped (SegTree v) (SegTree v')  type instance V (SegTree v) = v
src/Diagrams/TrailLike.hs view
@@ -30,7 +30,7 @@  import           Data.AffineSpace ((.-.)) import           Data.VectorSpace-import           Control.Lens (view, wrapped)+import           Control.Lens (view, _Unwrapped')  import           Diagrams.Core import           Diagrams.Located@@ -96,7 +96,7 @@ -- | Translationally invariant things are trail-like as long as the --   underlying type is. instance TrailLike t => TrailLike (TransInv t) where-  trailLike = view wrapped . trailLike+  trailLike = view _Unwrapped' . trailLike  -- | 'Located' things are trail-like as long as the underlying type --   is.  The location is taken to be the location of the input
src/Diagrams/Transform.hs view
@@ -41,7 +41,7 @@  -- | Carry out some transformation \"under\" another one: @f ``under`` --   t@ first applies @t@, then @f@, then the inverse of @t@.  For---   example, @'scaleX' 2 ``under`` 'rotationBy' (-1/8 :: Turn)@+--   example, @'scaleX' 2 ``under`` 'rotation' (-1/8 \@\@ Turn)@ --   is the transformation which scales by a factor of 2 along the --   diagonal line y = x. --
src/Diagrams/TwoD.hs view
@@ -69,11 +69,10 @@           -- * Angles        , tau-       , Angle(..)-       , Turn(..), asTurn, CircleFrac-       , Rad(..), asRad-       , Deg(..), asDeg-       , fullTurn, fullCircle, convertAngle+       , Angle+       , rad, turn, deg+       , fullTurn, fullCircle, angleRatio+       , (@@)           -- * Paths          -- ** Stroking@@ -84,7 +83,7 @@        , StrokeOpts(..), vertexNames, queryFillRule           -- ** Clipping-       , clipBy+       , clipBy, clipTo, clipped           -- * Shapes          -- ** Rules@@ -134,12 +133,13 @@        , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR           -- ** Arrows-       , arrow, arrow'+       , arrowV, arrowV'        , arrowAt, arrowAt'        , arrowBetween, arrowBetween'        , connect, connect'        , connectPerim, connectPerim'        , connectOutside, connectOutside'+       , arrow, arrow'        , straightShaft        , module Diagrams.TwoD.Arrowheads @@ -152,6 +152,7 @@        , tailSize        , headGap        , tailGap+       , gap        , headColor        , headStyle        , tailColor@@ -188,6 +189,10 @@        , shearingX, shearX        , shearingY, shearY +         -- * Deformations - non-affine transforms+       , parallelX0, perspectiveX1, parallelY0, perspectiveY1+       , facingX, facingY+          -- * Combinators          -- ** Combining multiple diagrams        , (===), (|||), atAngle@@ -246,6 +251,7 @@ import           Diagrams.TwoD.Model import           Diagrams.TwoD.Path import           Diagrams.TwoD.Polygons+import           Diagrams.TwoD.Deform import           Diagrams.TwoD.Shapes import           Diagrams.TwoD.Size import           Diagrams.TwoD.Text
src/Diagrams/TwoD/Align.hs view
@@ -144,8 +144,8 @@  -- | Center along both the X- and Y-axes. centerXY :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a-centerXY = centerX . centerY+centerXY = center  snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a,       HasOrigin a, V a ~ R2) => a -> a-snugCenterXY = snugCenterX . snugCenterY+snugCenterXY = snugCenter
src/Diagrams/TwoD/Arc.hs view
@@ -31,11 +31,12 @@ import           Diagrams.TwoD.Transform import           Diagrams.TwoD.Types import           Diagrams.TwoD.Vector    (direction, e, unitX)-import           Diagrams.Util           (tau, ( # ))+import           Diagrams.Util           (( # )) +import           Control.Lens            ((^.)) import           Data.AffineSpace        ((.-.)) import           Data.Semigroup          ((<>))-import           Data.VectorSpace        (magnitude, negateV, (*^), (^-^))+import           Data.VectorSpace import           Diagrams.Coordinates  -- For details of this approximation see:@@ -45,27 +46,27 @@ --   the positive y direction and sweeps counterclockwise through @s@ --   radians.  The approximation is only valid for angles in the first --   quadrant.-bezierFromSweepQ1 :: Rad -> Segment Closed R2-bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ bezier3 c2 c1 p0-  where p0@(coords -> x :& y) = rotate (s/2) v+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  -- | @bezierFromSweep s@ constructs a series of 'Cubic' segments that --   start in the positive y direction and sweep counter clockwise---   through @s@ radians.  If @s@ is negative, it will start in the+--   through the angle @s@.  If @s@ is negative, it will start in the --   negative y direction and sweep clockwise.  When @s@ is less than --   0.0001 the empty list results.  If the sweep is greater than tau---   then it is truncated to tau.-bezierFromSweep :: Rad -> [Segment Closed R2]+--   radians then it is truncated to one full revolution.+bezierFromSweep :: Angle -> [Segment Closed R2] bezierFromSweep s-  | s > tau    = bezierFromSweep tau-  | s < 0      = fmap reflectY . bezierFromSweep $ (-s)-  | s < 0.0001 = []-  | s < tau/4  = [bezierFromSweepQ1 s]-  | otherwise  = bezierFromSweepQ1 (tau/4)-          : map (rotateBy (1/4)) (bezierFromSweep (max (s - tau/4) 0))+  | s > fullTurn = bezierFromSweep fullTurn+  | 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))  {- ~~~~ Note [segment spacing]@@ -89,29 +90,29 @@  -- | Given a start angle @s@ and an end angle @e@, @'arcT' s e@ is the --   'Trail' of a radius one arc counterclockwise between the two angles.-arcT :: Angle a => a -> a -> Trail R2+arcT :: Angle -> Angle -> Trail R2 arcT start end-    | end' < start' = arcT start' (end' + fromIntegral d)-    | otherwise     = (if sweep >= tau then glueTrail else id)+    | end' < start' = arcT start (end ^+^ (fromIntegral d @@ turn))+    | otherwise     = (if sweep >= fullTurn then glueTrail else id)                     $ trailFromSegments bs-  where sweep = convertAngle $ end - start+  where sweep = end ^-^ start         bs    = map (rotate start) . bezierFromSweep $ sweep          -- We want to compare the start and the end and in case         -- there isn't some law about 'Angle' ordering, we use a         -- known 'Angle' for that.-        start' = convertAngle start :: Turn-        end'   = convertAngle end+        start' = start^.turn+        end'   = end^.turn         d      = ceiling (start' - end') :: Integer  -- | Given a start angle @s@ and an end angle @e@, @'arc' s e@ is the --   path of a radius one arc counterclockwise between the two angles. --   The origin of the arc is its center.-arc :: (Angle a, TrailLike t, V t ~ R2) => a -> a -> t+arc :: (TrailLike t, V t ~ R2) => Angle -> Angle -> t arc start end = trailLike $ arcT start end `at` (rotate start $ p2 (1,0))  -- | Like 'arc' but clockwise.-arcCW :: (Angle a, TrailLike t, V t ~ R2) => a -> a -> t+arcCW :: (TrailLike t, V t ~ R2) => Angle -> Angle -> t arcCW start end = trailLike $                             -- flipped arguments to get the path we want                             -- then reverse the trail to get the cw direction.@@ -129,9 +130,9 @@ -- --   <<diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg#diagram=arc'Ex&width=300>> -----   > arc'Ex = mconcat [ arc' r 0 (1/4 :: Turn) | r <- [0.5,-1,1.5] ]+--   > arc'Ex = mconcat [ arc' r 0 (1/4 \@\@ turn) | r <- [0.5,-1,1.5] ] --   >        # centerXY # pad 1.1-arc' :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p+arc' :: (TrailLike p, V p ~ R2) => Double -> Angle -> Angle -> p arc' r start end = trailLike $ scale (abs r) ts `at` (rotate start $ p2 (abs r,0))   where ts | r < 0     = reverseTrail $ arcT end start            | otherwise = arcT start end@@ -142,13 +143,13 @@ --   <<diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg#diagram=wedgeEx&width=400>> -- --   > wedgeEx = hcat' (with & sep .~ 0.5)---   >   [ wedge 1 (0 :: Turn) (1/4)---   >   , wedge 1 (7/30 :: Turn) (11/30)---   >   , wedge 1 (1/8 :: Turn) (7/8)+--   >   [ wedge 1 (0 \@\@ turn) (1/4)+--   >   , wedge 1 (7/30 \@\@ turn) (11/30)+--   >   , wedge 1 (1/8 \@\@ turn) (7/8) --   >   ] --   >   # fc blue --   >   # centerXY # pad 1.1-wedge :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p+wedge :: (TrailLike p, V p ~ R2) => Double -> Angle -> Angle -> p wedge r a1 a2 = trailLike . (`at` origin) . glueTrail . wrapLine               $ fromOffsets [r *^ e a1]                 <> arc a1 a2 # scale r@@ -166,7 +167,7 @@ --   >   [ 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 p q ht = trailLike (a # rotateBy (direction v) # moveTo p)+arcBetween p q ht = trailLike (a # rotate (direction v) # moveTo p)   where     h = abs ht     isStraight = h < 0.00001@@ -174,10 +175,10 @@     d = magnitude (q .-. p)     th  = acos ((d*d - 4*h*h)/(d*d + 4*h*h))     r = d/(2*sin th)-    mid | ht >= 0    = tau/4-        | otherwise = 3*tau/4-    st  = mid - Rad th-    end = mid + Rad th+    mid | ht >= 0    = fullTurn ^/ 4+        | otherwise = 3 *^ fullTurn ^/ 4+    st  = mid ^-^ (th @@ rad)+    end = mid ^+^ (th @@ rad)     a | isStraight       = fromOffsets [d *^ unitX]       | otherwise@@ -194,13 +195,13 @@ --   <<diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg#diagram=annularWedgeEx&width=400>> -- --   > annularWedgeEx = hcat' (with & sep .~ 0.50)---   >   [ annularWedge 1 0.5 (0 :: Turn) (1/4)---   >   , annularWedge 1 0.3 (7/30 :: Turn) (11/30)---   >   , annularWedge 1 0.7 (1/8 :: Turn) (7/8)+--   >   [ annularWedge 1 0.5 (0 \@\@ turn) (1/4)+--   >   , annularWedge 1 0.3 (7/30 \@\@ turn) (11/30)+--   >   , annularWedge 1 0.7 (1/8 \@\@ turn) (7/8) --   >   ] --   >   # fc blue --   >   # centerXY # pad 1.1-annularWedge :: (Angle a, TrailLike p, V p ~ R2) => Double -> Double -> a -> a -> p+annularWedge :: (TrailLike p, V p ~ R2) => Double -> Double -> Angle -> Angle -> p annularWedge r1' r2' a1 a2 = trailLike . (`at` o) . glueTrail . wrapLine               $ fromOffsets [(r1'-r2') *^ e a1]                 <> arc a1 a2 # scale r1'
src/Diagrams/TwoD/Arrow.hs view
@@ -46,7 +46,7 @@ --   > --   > -- Connect two diagrams and two points on their trails. --   > ex12 = dias # connect "first" "second"---   >             # connectPerim "first" "second" (15/16 :: Turn) (9/16 :: Turn)+--   >             # connectPerim "first" "second" (15/16 \@\@ turn) (9/16 \@\@ turn) --   > --   > -- Place an arrow at (0,0) the size and direction of (0,1). --   > ex3 = arrowAt origin unit_Y@@ -54,8 +54,8 @@ --   > example2 = (ex12 <> ex3) # centerXY # pad 1.1           -- * Creating arrows-         arrow-       , arrow'+         arrowV+       , arrowV'        , arrowAt        , arrowAt'        , arrowBetween@@ -66,8 +66,10 @@        , connectPerim'        , connectOutside        , connectOutside'-       , straightShaft +       , arrow+       , arrow'+          -- * Options        , ArrowOpts(..) @@ -78,27 +80,30 @@        , tailSize        , headGap        , tailGap+       , gap        , headColor        , headStyle        , tailColor        , tailStyle        , shaftColor        , shaftStyle+       , straightShaft           -- | See "Diagrams.TwoD.Arrowheads" for a list of standard          --   arrowheads and help creating your own.        , module Diagrams.TwoD.Arrowheads        ) where +import           Control.Applicative              ((<*>)) import           Control.Arrow                    (first)-import           Control.Lens                     (Lens', Setter',+import           Control.Lens                     (Lens', Setter', Traversal',                                                    generateSignatures,                                                    lensRules, makeLensesWith,                                                    (%~), (&), (.~), (^.)) import           Data.AffineSpace import           Data.Default.Class import           Data.Functor                     ((<$>))-import           Data.Maybe                       (fromJust, fromMaybe)+import           Data.Maybe                       (fromMaybe) import           Data.Monoid                      (mempty, (<>)) import           Data.Monoid.Coproduct            (untangle) import           Data.Monoid.Split@@ -117,7 +122,7 @@ import           Diagrams.Trail import           Diagrams.TwoD.Arrowheads import           Diagrams.TwoD.Path               (strokeT)-import           Diagrams.TwoD.Transform          (rotate, rotateBy, translateX)+import           Diagrams.TwoD.Transform          (rotate, translateX) import           Diagrams.TwoD.Transform.ScaleInv (scaleInvPrim) import           Diagrams.TwoD.Types import           Diagrams.TwoD.Vector             (direction, unitX, unit_X)@@ -176,9 +181,13 @@  -- | Distance to leave between the head and the target point. headGap :: Lens' ArrowOpts Double+ -- | Distance to leave between the starting point and the tail. tailGap :: Lens' ArrowOpts Double +gap :: Traversal' ArrowOpts Double+gap f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap)+ -- | 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:@@ -373,8 +382,8 @@      -- Build an arrow and set its endpoints to the image under tr of origin and (len,0).     dArrow sty tr ln = (h' <> t' <> shaft)-               # moveOriginBy (tWidth *^ (unit_X # rotateBy tAngle))-               # rotateBy (direction (q .-. p) - dir)+               # moveOriginBy (tWidth *^ (unit_X # rotate tAngle))+               # rotate (direction (q .-. p) ^-^ dir)                # moveTo p       where @@ -398,7 +407,7 @@         shaftTrail           = rawShaftTrail             -- rotate it so it is pointing in the positive X direction-          # rotateBy (- direction (trailOffset rawShaftTrail))+          # rotate (negateV direction (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)@@ -409,8 +418,8 @@         hWidth = hWidth' + opts^.headGap          -- Calculate the angles that the head and tail should point.-        tAngle = direction . tangentAtStart $ shaftTrail :: Turn-        hAngle = direction . tangentAtEnd $ shaftTrail :: Turn+        tAngle = direction . tangentAtStart $ shaftTrail+        hAngle = direction . tangentAtEnd $ shaftTrail          -- 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@@ -420,9 +429,9 @@         shaft = strokeT shaftTrail' # applyStyle (shaftSty opts)          -- Adjust the head and tail to point in the directions of the shaft ends.-        h' = h # rotateBy hAngle+        h' = h # rotate hAngle                # moveTo (origin .+^ shaftTrail' `atParam` domainUpper shaftTrail')-        t' = t # rotateBy tAngle+        t' = t # rotate tAngle          -- Find out what direction the arrow is pointing so we can set it back         -- to point in the direction unitX when we are done.@@ -443,18 +452,31 @@ arrowBetween' opts s e = arrowAt' opts s (e .-. s)  -- | Create an arrow starting at s with length and direction determined by---   the vectore v.+--   the vector v. arrowAt :: Renderable (Path R2) b => P2 -> R2 -> Diagram b R2 arrowAt s v = arrowAt' def s v  arrowAt'   :: Renderable (Path R2) b =>      ArrowOpts -> P2 -> R2 -> Diagram b R2-arrowAt' opts s v = arrow' opts len # rotateBy dir # moveTo s+arrowAt' opts s v = arrow' opts len # rotate dir # moveTo s   where     len = magnitude v     dir = direction v +-- | @arrowV v@ creates an arrow with the direction and magnitude of+--   the vector @v@ (with its tail at the origin), using default+--   parameters.+arrowV :: Renderable (Path R2) b => R2 -> Diagram b R2+arrowV = arrowV' def++-- | @arrowV' v@ creates an arrow with the direction and magnitude of+--   the vector @v@ (with its tail at the origin).+arrowV'+  :: Renderable (Path R2) b+  => ArrowOpts -> R2 -> Diagram b R2+arrowV' opts = arrowAt' opts origin+ -- | Connect two diagrams with a straight arrow. connect   :: (Renderable (Path R2) b, IsName n1, IsName n2)@@ -474,14 +496,14 @@ -- | Connect two diagrams at point on the perimeter of the diagrams, choosen --   by angle. connectPerim-  :: (Renderable (Path R2) b, IsName n1, IsName n2, Angle a)- => n1 -> n2 -> a -> a+  :: (Renderable (Path R2) b, IsName n1, IsName n2)+ => n1 -> n2 -> Angle -> Angle   -> (Diagram b R2 -> Diagram b R2) connectPerim = connectPerim' def  connectPerim'-  :: (Renderable (Path R2) b, IsName n1, IsName n2, Angle a)-  => ArrowOpts -> n1 -> n2 -> a -> a+  :: (Renderable (Path R2) b, IsName n1, IsName n2)+  => ArrowOpts -> n1 -> n2 -> Angle -> Angle   -> (Diagram b R2 -> Diagram b R2) connectPerim' opts n1 n2 a1 a2 =   withName n1 $ \sub1 ->@@ -508,6 +530,9 @@   withName n2 $ \b2 ->     let v = location b2 .-. location b1         midpoint = location b1 .+^ (v/2)-        s = fromJust $ traceP midpoint (-v) b1-        e = fromJust $ traceP midpoint v b2-    in atop (arrowBetween' opts s e)+        s' = traceP midpoint (-v) b1+        e' = traceP midpoint v b2+    in+      case (s', e') of+        (Just s,  Just e)  -> atop (arrowBetween' opts s e)+        (_, _)             -> id
src/Diagrams/TwoD/Arrowheads.hs view
@@ -56,8 +56,8 @@        ) where  import           Control.Lens            ((&), (.~))-import           Data.Default.Class import           Data.AffineSpace+import           Data.Default.Class import           Data.Functor            ((<$>)) import           Data.Maybe              (fromMaybe) import           Data.Monoid             (mempty, (<>))@@ -103,27 +103,29 @@  -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg#diagram=tri25Ex&width=120>> ---   > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 :: Turn) & shaftStyle %~ lw 0)+--   > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 \@\@ turn) & shaftStyle %~ lw 0) --   >           origin (r2 (0.001, 0)) --   >        <> square 0.6 # alignL # lw 0-arrowheadTriangle :: Angle a => a -> ArrowHT+arrowheadTriangle :: Angle -> ArrowHT arrowheadTriangle theta = aHead   where     aHead size _ = (p, mempty)       where-        p = polygon (def & polyType .~ PolyPolar [theta, (-2 * theta)]+        p = polygon (def & polyType .~ PolyPolar [theta, (negateV 2 *^ theta)]             (repeat (htRadius * size)) & polyOrient .~ NoOrient)  # alignL  -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like.-arrowheadDart :: Angle a => a -> ArrowHT+arrowheadDart :: Angle -> ArrowHT arrowheadDart theta = aHead   where     aHead size shaftWidth = (dartP # moveOriginTo (dartVertices !! 2), joint)       where-        a = toTurn theta         r = htRadius * size-        dartP = polygon (def & polyType .~ PolyPolar [a, 1/2 - a, 1/2 - a]-               [r, r, 0.1 * size, r]  & polyOrient .~ NoOrient)+        dartP = polygon+                ( def & polyType .~ PolyPolar [theta, (1/2 @@ turn) ^-^ theta, (1/2 @@ turn) ^-^ theta]+                                              [r, r, 0.1 * size, r]+                      & polyOrient .~ NoOrient+                )         dartVertices =  (concat . pathVertices) $ dartP         m = magnitude (dartVertices !! 1 .-. dartVertices !! 3)         s = 1 - shaftWidth / m@@ -135,7 +137,7 @@                              , dartVertices !! 2 ]) # alignR  -- | Isoceles triangle with curved concave base. Inkscape type 2.-arrowheadSpike :: Angle a => a -> ArrowHT+arrowheadSpike :: Angle -> ArrowHT arrowheadSpike theta = aHead   where     aHead size shaftWidth = (barb # moveOriginBy (m *^ unit_X) , joint)@@ -144,11 +146,11 @@         a' = reflectY a         l1 = trailFromSegments [straight (unit_X2 ^+^ a)]         l2 = trailFromSegments [reverseSegment . straight $ (unit_X2 ^+^ a')]-        c  = reflectX $ arc' htRadius theta (-theta)+        c  = reflectX $ arc' htRadius theta (negateV theta)         barb = (closedPath $ (l1 <> c <> l2)) # scale size         m = xWidth barb --c `atParam` 0.5-        b =  Rad $ asin ((shaftWidth / 2) / (htRadius  * size))-        c' = arc' htRadius (-b ) b # scale size+        b =  asin ((shaftWidth / 2) / (htRadius  * size)) @@ rad+        c' = arc' htRadius (negateV b) b # scale size         joint = (closedPath $ (c')) # centerY # alignR         xWidth p = pa + pb           where@@ -156,7 +158,7 @@             pb = fromMaybe 0 (magnitude <$> traceV origin unit_X p)  -- | Curved sides, linear concave base. Illustrator CS5 #3-arrowheadThorn :: Angle a => a -> Double -> ArrowHT+arrowheadThorn :: Angle -> Double -> ArrowHT arrowheadThorn theta r = aHead   where     aHead size shaftWidth = (thornP # moveOriginTo (thornVertices !! 2), joint)@@ -165,7 +167,7 @@         c1 = curvedSide theta         l1 = straight $ (reflectY a) ^-^ (unit_X2 # scale r)         l2 = straight $ unit_X2 # scale r ^-^ a-        c2 = c1 # rotate (-theta)+        c2 = c1 # rotate (negateV theta)         thornP = (closedPath $ trailFromSegments [c1, l1, l2, c2]) # scale size         thornVertices =  (concat . pathVertices) $ thornP         m = magnitude (thornVertices !! 1 .-. thornVertices !! 3)@@ -178,7 +180,7 @@                              , thornVertices !! 2 ]) # alignR  -- | Make a side for the thorn head.-curvedSide :: Angle a => a -> Segment Closed R2+curvedSide :: Angle -> Segment Closed R2 curvedSide theta = bezier3 ctrl1 ctrl2 end   where     v0    = scaleR unit_X@@ -202,7 +204,7 @@         smooth [] = mempty         smooth (x:xs) = cubicSpline True x <> smooth xs -arrowheadMissile :: Angle a => a -> ArrowHT+arrowheadMissile :: Angle -> ArrowHT arrowheadMissile theta = smoothArrowhead $ arrowheadDart theta  -- Standard heads ---------------------------------------------------------@@ -213,31 +215,31 @@  --   > triEx = drawHead tri tri :: ArrowHT-tri = arrowheadTriangle (1/3 :: Turn)+tri = arrowheadTriangle (1/3 @@ turn)  -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg#diagram=spikeEx&width=100>>  --   > spikeEx = drawHead spike spike :: ArrowHT-spike = arrowheadSpike (3/8 :: Turn)+spike = arrowheadSpike (3/8 @@ turn)  -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg#diagram=thornEx&width=100>>  --   > thornEx = drawHead thorn thorn :: ArrowHT-thorn = arrowheadThorn (3/8 :: Turn) 1+thorn = arrowheadThorn (3/8 @@ turn) 1  -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg#diagram=dartEx&width=100>>  --   > dartEx = drawHead dart dart :: ArrowHT-dart = arrowheadDart (2/5 :: Turn)+dart = arrowheadDart (2/5 @@ turn)  -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_missileEx.svg#diagram=missileEx&width=100>>  --   > missileEx = drawHead missile missile :: ArrowHT-missile = arrowheadMissile (2/5 :: Turn)+missile = arrowheadMissile (2/5 @@ turn)  -- Tails ------------------------------------------------------------------ --   > drawTail t = arrowAt' (with  & arrowTail .~ t & shaftStyle %~ lw 0 & arrowHead .~ noHead)@@ -255,7 +257,7 @@         t = reflectX t'         j = reflectX j' -arrowtailBlock :: Angle a => a -> ArrowHT+arrowtailBlock :: Angle -> ArrowHT arrowtailBlock theta = aTail   where    aTail size _ = (t, mempty)@@ -268,16 +270,15 @@         x = magnitude b  -- | The angle is where the top left corner intersects the circle.-arrowtailQuill :: Angle a => a -> ArrowHT+arrowtailQuill :: Angle -> ArrowHT arrowtailQuill theta =aTail   where    aTail size shaftWidth = (t, j)       where         t = ( closedPath $ trailFromVertices [v0, v1, v2, v3, v4, v5, v0] )             # scale size # alignR-        theta' = toTurn theta         v0 = p2 (0.5, 0)-        v2 = p2 (unr2 $ e theta' # scaleR)+        v2 = p2 (unr2 $ e theta # scaleR)         v1 = v2 # translateX (5/4 * htRadius)         v3 = p2 (-0.1, 0)         v4 = v2 # reflectY@@ -329,10 +330,10 @@  --   > quillEx = drawTail quill quill :: ArrowHT-quill = arrowtailQuill (2/5 :: Turn)+quill = arrowtailQuill (2/5 @@ turn)  -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg#diagram=blockEx&width=100>>  --   > blockEx = drawTail block block :: ArrowHT-block = arrowtailBlock (2/5 :: Turn)+block = arrowtailBlock (2/5 @@ turn)
src/Diagrams/TwoD/Combinators.hs view
@@ -76,7 +76,7 @@ -- --   to place @c@ above @d@.  The local origin of the resulting --   combined diagram is the same as the local origin of the first.---   @(|||)@ is associative and has 'mempty' as an identity.  See the+--   @(===)@ 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)@@ -84,7 +84,7 @@ -- | Place two diagrams (or other juxtaposable objects) horizontally --   adjacent to one another, with the first diagram to the left of --   the second.  The local origin of the resulting combined diagram---   is the same as the local origin of the first.  @(===)@ is+--   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@@ -95,7 +95,7 @@ --   'th' 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.-atAngle :: (Juxtaposable a, V a ~ R2, Semigroup a, Angle b) => b -> a -> a -> a+atAngle :: (Juxtaposable a, V a ~ R2, Semigroup a) => Angle -> a -> a -> a atAngle th = beside (fromDirection th)  -- | Lay out a list of juxtaposable objects in a row from left to right,
src/Diagrams/TwoD/Curvature.hs view
@@ -20,7 +20,6 @@     ) where  import           Data.Monoid.Inf-import           Data.NumInstances.Tuple () import           Data.VectorSpace  import           Control.Arrow        (first, second)@@ -147,7 +146,7 @@   where     (x' ,y' ) = seg `tangentAtParam` t     (x'',y'') = secondDerivative-    secondDerivative = (6*(3*t-2))*^b + (6-18*t)*^c + (6*t)*^d+    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 -- <http://en.wikipedia.org/wiki/Curvature>
+ src/Diagrams/TwoD/Deform.hs view
@@ -0,0 +1,36 @@+module Diagrams.TwoD.Deform where++import Control.Lens++import Diagrams.Deform++import Diagrams.Coordinates+import Diagrams.TwoD.Types++-- | The parallel projection onto the line x=0+parallelX0 :: Deformation R2+parallelX0 = Deformation (& _x .~ 0)++-- | The perspective division onto the line x=1 along lines going+-- through the origin.+perspectiveX1 :: Deformation R2+perspectiveX1 = Deformation (\p -> p & _y //~ (p^._x) & _x .~ 1)++-- | The parallel projection onto the line y=0+parallelY0 :: Deformation R2+parallelY0 = Deformation (& _y .~ 0)++-- | The perspective division onto the line y=1 along lines going+-- through the origin.+perspectiveY1 :: Deformation R2+perspectiveY1 = Deformation (\p -> p & _x //~ (p^._y) & _y .~ 1)++-- | The viewing transform for a viewer facing along the positive X+-- axis.  X coördinates stay fixed, while Y coördinates are compressed+-- with increasing distance.  @asDeformation (translation unitX) <>+-- parallelX0 <> frustrumX = perspectiveX1@+facingX :: Deformation R2+facingX = Deformation (\v -> v & _y //~ (v^._x))++facingY :: Deformation R2+facingY = Deformation (\v -> v & _x //~ (v^._y))
src/Diagrams/TwoD/Ellipse.hs view
@@ -22,6 +22,8 @@     , ellipseXY     ) where +import           Data.AdditiveGroup+ import           Diagrams.Core  import           Diagrams.Located        (at)@@ -33,7 +35,7 @@  -- | A circle of radius 1, with center at the origin. unitCircle :: (TrailLike t, V t ~ R2) => t-unitCircle = trailLike $ arcT 0 (tau::Rad) `at` (p2 (1,0))+unitCircle = trailLike $ arcT zeroV fullTurn `at` (p2 (1,0))  -- | A circle of the given radius, centered at the origin.  As a path, --   it begins at (r,0).
src/Diagrams/TwoD/Image.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-} ----------------------------------------------------------------------------- -- | -- Module      :  Diagrams.TwoD.Image@@ -19,19 +20,20 @@     , image     ) where -import Control.Lens (makeLenses)+import           Control.Lens         (makeLenses)+import           Data.Typeable -import Diagrams.Core+import           Diagrams.Core -import Diagrams.Path-import Diagrams.TwoD.Types-import Diagrams.TwoD.Path-import Diagrams.TwoD.Shapes-import Diagrams.TwoD.Size (SizeSpec2D(..))+import           Diagrams.Path+import           Diagrams.TwoD.Path+import           Diagrams.TwoD.Shapes+import           Diagrams.TwoD.Size   (SizeSpec2D (..))+import           Diagrams.TwoD.Types -import Data.AffineSpace ((.-.))+import           Data.AffineSpace     ((.-.)) -import Data.Semigroup+import           Data.Semigroup  -- | An external image primitive, representing an image the backend --   should import from another file when rendering.@@ -39,6 +41,7 @@                    , _imgSize   :: SizeSpec2D                    , _imgTransf :: T2                    }+  deriving Typeable  makeLenses ''Image
src/Diagrams/TwoD/Offset.hs view
@@ -38,9 +38,10 @@     ) where  import Control.Applicative-import Control.Lens            hiding (at, moveTo)+import Control.Lens            hiding (at)  import Data.AffineSpace+import Data.Maybe              (catMaybes) import Data.Monoid import Data.Monoid.Inf import Data.VectorSpace@@ -263,9 +264,10 @@                         --   loop.              -> Located (Trail R2)              -> Located (Trail R2)-offsetTrail' opts r t = joinSegments j isLoop (opts^.offsetMiterLimit) r ends . offset $ t+offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r ends . offset $ t     where-      offset = map (bindLoc (offsetSegment (opts^.offsetEpsilon) r)) . locatedTrailSegments+      eps = opts^.offsetEpsilon+      offset = map (bindLoc (offsetSegment eps r)) . locatedTrailSegments       ends | isLoop    = (\(a:as) -> as ++ [a]) . trailVertices $ t            | otherwise = tail . trailVertices $ t       j = fromLineJoin (opts^.offsetJoin)@@ -356,8 +358,10 @@ expandLine :: ExpandOpts -> Double -> Located (Trail' Line R2) -> Located (Trail R2) expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r)     where-      offset r' = map (bindLoc (offsetSegment (opts^.expandEpsilon) r')) . locatedTrailSegments-      f r' = joinSegments (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends . offset r' $ t+      eps = opts^.expandEpsilon+      offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments+      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@@ -366,8 +370,10 @@ expandLoop :: ExpandOpts -> Double -> Located (Trail' Loop R2) -> Path R2 expandLoop opts r (mapLoc wrapLoop -> t) = (trailLike $ f r) <> (trailLike . reverseDomain . f $ -r)     where-      offset r' = map (bindLoc (offsetSegment (opts^.expandEpsilon) r')) . locatedTrailSegments-      f r' = joinSegments (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends . offset r' $ t+      eps = opts^.expandEpsilon+      offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments+      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''.@@ -456,10 +462,10 @@  -- Arc helpers arcV :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t-arcV u v = arc (direction u) (direction v :: Turn)+arcV u v = arc (direction u) (direction v)  arcVCW :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t-arcVCW u v = arcCW (direction u) (direction v :: Turn)+arcVCW u v = arcCW (direction u) (direction v)   -- | Join together a list of located trails with the given join style.  The@@ -470,20 +476,25 @@ --   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 -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2)+joinSegments :: Double+             -> (Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2)              -> Bool              -> Double              -> Double              -> [Point R2]              -> [Located (Trail R2)]              -> Located (Trail R2)-joinSegments _ _ _ _ _ [] = mempty `at` origin-joinSegments _ _ _ _ [] _ = mempty `at` origin-joinSegments j isLoop ml r es ts@(t:_) = t'+joinSegments _ _ _ _ _ _ [] = mempty `at` origin+joinSegments _ _ _ _ _ [] _ = mempty `at` origin+joinSegments epsilon j isLoop ml r es ts@(t:_) = t'   where-    t' | isLoop    = mapLoc (glueTrail . (<> mconcat (take (length ts) $ ss es (ts ++ [t])))) t-       | otherwise = mapLoc (<> mconcat (ss es ts)) t-    ss es' ts' = [j ml r e a b <> unLoc b | (e,(a,b)) <- zip es' . (zip <*> tail) $ ts']+    t' | isLoop    = mapLoc (glueTrail . (<> f (take (length ts * 2 - 1) $ ss es (ts ++ [t])))) t+       | otherwise = mapLoc (<> f (ss es ts)) t+    ss es' ts' = concat [[test a b $ j ml r e a b, Just $ unLoc b] | (e,(a,b)) <- zip es' . (zip <*> tail) $ ts']+    test a b tj+        | atStart b `distance` atEnd a > epsilon = Just tj+        | otherwise                              = Nothing+    f = mconcat . catMaybes  -- | Take a join style and give the join function to be used by joinSegments. fromLineJoin
src/Diagrams/TwoD/Path.hs view
@@ -41,13 +41,13 @@           -- * Clipping -       , Clip(..), clipBy+       , Clip(..), clipBy, clipTo, clipped        ) where  import           Control.Applicative   (liftA2) import           Control.Lens          ( makeWrapped, makeLensesWith, (.~), (^.)                                        , generateSignatures, lensRules, op-                                       , Lens, Lens', unwrapped)+                                       , Lens, Lens', _Wrapped') import qualified Data.Foldable         as F import           Data.Semigroup import           Data.Typeable@@ -56,8 +56,10 @@ import           Data.Default.Class import           Data.VectorSpace +import           Diagrams.Combinators  (withEnvelope, withTrace) import           Diagrams.Coordinates import           Diagrams.Core+import           Diagrams.Core.Trace import           Diagrams.Located      (Located, mapLoc, unLoc) import           Diagrams.Parametric import           Diagrams.Path@@ -167,12 +169,12 @@ -- --     * Names can be assigned to the path's vertices -----   'StrokeOpts' is an instance of 'Default', so @stroke' 'with' {---   ... }@ syntax may be used.+--   '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' opts path-  | null (pLines ^. unwrapped) =           mkP pLoops-  | null (pLoops ^. unwrapped) = mkP pLines+  | null (pLines ^. _Wrapped') =           mkP pLoops+  | null (pLoops ^. _Wrapped') = mkP pLines   | otherwise                   = mkP pLines <> mkP pLoops   where     (pLines,pLoops) = partitionPath (isLine . unLoc) path@@ -361,7 +363,30 @@ clipBy :: (HasStyle a, V a ~ R2) => Path R2 -> a -> a clipBy = applyTAttr . Clip . (:[]) --- XXX Should include a 'clipTo' function which clips a diagram AND--- restricts its envelope.  It will have to take a *pointwise minimum*--- of the diagram's current envelope and the path's envelope.  Not--- sure of the best way to do this at the moment.+-- | Clip a diagram to the given path setting its envelope to the+--   pointwise minimum of the envelopes of the diagram and path. The+--   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 p d = setTrace intersectionTrace . toEnvelope $ clipBy p d+  where+    envP = appEnvelope . getEnvelope $ p+    envD = appEnvelope . getEnvelope $ d+    toEnvelope = case (envP, envD) of+      (Just eP, Just eD) -> setEnvelope . mkEnvelope $ \v -> min (eP v) (eD v)+      (_, _)             -> id+    intersectionTrace = Trace intersections+    intersections pt v =+        -- on boundary of d, inside p+        onSortedList (filter pInside) (appTrace (getTrace d) pt v) <>+        -- or on boundary of p, inside d+        onSortedList (filter dInside) (appTrace (getTrace p) pt v) where+          newPt dist = pt .+^ v ^* dist+          pInside dDist = runFillRule Winding (newPt dDist) p+          dInside pDist = getAny . sample d $ newPt pDist++-- | 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)
src/Diagrams/TwoD/Polygons.hs view
@@ -45,7 +45,8 @@      ) where -import           Control.Lens            hiding (transform, at, (<.>), (&), (#))+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,@@ -57,8 +58,7 @@  import           Data.AffineSpace        ((.+^), (.-.)) import           Data.Default.Class-import           Data.VectorSpace        (magnitude, normalized, project, (<.>),-                                          (^*))+import           Data.VectorSpace  import           Diagrams.Core import           Diagrams.Located@@ -72,7 +72,7 @@ import           Diagrams.Util           (tau, ( # ))  -- | Method used to determine the vertices of a polygon.-data PolyType = forall a. Angle a => PolyPolar [a] [Double]+data PolyType = PolyPolar [Angle] [Double]                 -- ^ A \"polar\" polygon.                 --                 --   * The first argument is a list of /central/@@ -89,7 +89,7 @@                 --   circle) can be constructed using a second                 --   argument of @(repeat r)@. -              | forall a. Angle a => PolySides [a] [Double]+              | PolySides [Angle] [Double]                 -- ^ A polygon determined by the distance between                 --   successive vertices and the angles formed by                 --   each three successive vertices.  In other@@ -180,7 +180,7 @@  -- | Generate the located trail of a polygon specified by polar data --   (central angles and radii). See 'PolyPolar'.-polyPolarTrail :: Angle a => [a] -> [Double] -> Located (Trail R2)+polyPolarTrail :: [Angle] -> [Double] -> Located (Trail R2) polyPolarTrail [] _ = emptyTrail `at` origin polyPolarTrail _ [] = emptyTrail `at` origin polyPolarTrail ans (r:rs) = tr `at` p1@@ -189,16 +189,16 @@     tr = closeTrail . trailFromVertices $            zipWith              (\a l -> rotate a . scale l $ p2 (1,0))-             (scanl (+) 0 ans)+             (scanl (^+^) zeroV 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 a => [a] -> [Double] -> Located (Trail R2)+polySidesTrail :: [Angle] -> [Double] -> Located (Trail R2) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1))   where-    ans'    = scanl (+) 0 ans+    ans'    = scanl (^+^) zeroV ans     offsets = zipWith rotate ans' (map (unitY ^*) ls)     ps      = scanl (.+^) origin offsets     tr      = closeTrail . trailFromOffsets $ offsets@@ -206,7 +206,7 @@ -- | Generate the vertices of a regular polygon.  See 'PolyRegular'. polyRegularTrail :: Int -> Double -> Located (Trail R2) polyRegularTrail n r = polyPolarTrail-                         (take (n-1) . repeat $ (tau::Rad) / fromIntegral n)+                         (take (n-1) . repeat $ fullTurn ^/ fromIntegral n)                          (repeat r)  -- | Generate a transformation to orient a trail.  @orient v t@@@ -223,17 +223,21 @@                   (zip3 (tail (cycle xs)) xs (last xs : init xs))     distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p)     sndOf3 (_,b,_) = b-    a = minimumBy (comparing abs) . map (angleFromNormal . (.-. x)) $ [n1,n2]+    a :: Angle+    a = minimumBy (comparing $ abs . view rad)+        . map (angleFromNormal . (.-. x)) $ [n1,n2]     v' = normalized v+    angleFromNormal :: R2 -> Angle     angleFromNormal o       | leftTurn o' v' = phi-      | otherwise      = negate phi+      | otherwise      = negateV phi       where         o' = normalized o         theta = acos (v' <.> o')+        phi :: Angle         phi-          | theta <= tau/4 = Rad $ tau/4 - theta-          | otherwise      = Rad $ theta - tau/4+          | theta <= tau/4 = tau/4 - theta @@ rad+          | otherwise      = theta - tau/4 @@ rad  ------------------------------------------------------------ -- Function graphs
src/Diagrams/TwoD/Segment.hs view
@@ -24,7 +24,6 @@ import           Control.Applicative     (liftA2)  import           Data.AffineSpace-import           Data.Monoid.Inf         hiding (minimum) import           Data.VectorSpace  import           Diagrams.Core@@ -38,6 +37,10 @@ import           Diagrams.TwoD.Vector import           Diagrams.Util +{- All instances of Traced should maintain the invariant that the list of+   traces is sorted in increasing order.+-}+ instance Traced (Segment Closed R2) where   getTrace = getTrace . mkFixedSeg . (`at` origin) @@ -73,8 +76,8 @@       t1     = (perp v0 <.> p) / det     in       if det == 0 || t0 < 0 || t0 > 1-        then Infinity-        else Finite t1+        then mkSortedList []+        else mkSortedList [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);@@ -90,7 +93,7 @@     let       bez'@(FCubic x1 c1 c2 x2) =         bez # moveOriginTo p1-            # rotateBy (negate (direction v1))+            # rotate (negateV (direction v1))             # scale (1/magnitude v1)       [y0,y1,y2,y3] = map (snd . unp2) [x1,c1,c2,x2]       a  = -y0 + 3*y1 - 3*y2 + y3@@ -100,7 +103,5 @@       ts = filter (liftA2 (&&) (>= 0) (<= 1)) (cubForm a b c d)       xs = map (fst . unp2 . atParam bez') ts     in-      case xs of-        [] -> Infinity-        _  -> Finite (minimum xs)+      mkSortedList xs
src/Diagrams/TwoD/Shapes.hs view
@@ -59,7 +59,7 @@  import           Diagrams.Util -import           Control.Lens            (makeLenses, op, (.~), (^.), (&))+import           Control.Lens            (makeLenses, op, (&), (.~), (^.)) import           Data.Default.Class import           Data.Semigroup @@ -140,7 +140,7 @@ regPoly :: (TrailLike t, V t ~ R2) => Int -> Double -> t regPoly n l = polygon (def & polyType .~                                PolySides-                                 (repeat (1/ fromIntegral n :: Turn))+                                 (repeat (1/fromIntegral n @@ turn))                                  (replicate (n-1) l)                            & polyOrient .~ OrientH                            )@@ -311,4 +311,4 @@         mkCorner k r | r == 0    = mempty                      | r < 0     = doArc 3 2                      | otherwise = doArc 0 1-                     where doArc d d' = arc' r ((k+d)/4) ((k+d')/4:: Turn)+                     where doArc d d' = arc' r ((k+d)/4 @@ turn) ((k+d')/4 @@ turn)
src/Diagrams/TwoD/Text.hs view
@@ -54,6 +54,7 @@ --   vector space of the text to the vector space in which it is --   embedded. data Text = Text T2 TextAlignment String+  deriving Typeable  type instance V Text = R2
src/Diagrams/TwoD/Transform.hs view
@@ -59,50 +59,52 @@ import           Diagrams.TwoD.Vector    (direction) import           Diagrams.Coordinates +import           Data.AdditiveGroup import           Data.AffineSpace import           Data.Semigroup+import           Control.Lens            (review, (^.))  -- Rotation ------------------------------------------------  -- | Create a transformation which performs a rotation about the local --   origin by the given angle.  See also 'rotate'.-rotation :: Angle a => a -> T2+rotation :: Angle -> T2 rotation ang = fromLinear r (linv r)   where     r            = rot theta <-> rot (-theta)-    Rad theta    = convertAngle ang+    theta    = ang^.rad     rot th (coords -> x :& y) = (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---   clockwise. The angle can be expressed using any type which is an---   instance of 'Angle'.  For example, @rotate (1\/4 ::---   'Turn')@, @rotate (tau\/4 :: 'Rad')@, and @rotate (90 ::---   'Deg')@ all represent the same transformation, namely, a---   counterclockwise rotation by a right angle.  To rotate about some---   point other than the local origin, see 'rotateAbout'.+--   clockwise. The angle can be expressed using any of the 'Iso's on+--   'Angle'.  For example, @rotate (1\/4 \@\@ 'turn')@, @rotate+--   (tau\/4 \@\@ rad)@, and @rotate (90 \@\@ deg)@ all+--   represent the same transformation, namely, a counterclockwise+--   rotation by a right angle.  To rotate about some point other than+--   the local origin, see 'rotateAbout'. -----   Note that writing @rotate (1\/4)@, with no type annotation, 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 is specialized to take a 'Turn' argument.-rotate :: (Transformable t, V t ~ R2, Angle a) => a -> t -> t+--   Note that writing @rotate (1\/4)@, with no 'Angle' constructor,+--   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 = transform . rotation --- | A synonym for 'rotate', specialized to only work with---   @Turn@ arguments; it can be more convenient to write---   @rotateBy (1\/4)@ than @'rotate' (1\/4 :: 'Turn')@.-rotateBy :: (Transformable t, V t ~ R2) => Turn -> t -> t-rotateBy = 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 = transform . rotation . review turn  -- | @rotationAbout p@ is a rotation about the point @p@ (instead of --   around the local origin).-rotationAbout :: Angle a => P2 -> a -> T2+rotationAbout :: P2 -> Angle -> T2 rotationAbout p angle = conjugate (translation (origin .-. p)) (rotation angle)  -- | @rotateAbout p@ is like 'rotate', except it rotates around the --   point @p@ instead of around the local origin.-rotateAbout :: (Transformable t, V t ~ R2, Angle a) => P2 -> a -> t -> t+rotateAbout :: (Transformable t, V t ~ R2) => P2 -> Angle -> t -> t rotateAbout p angle = rotate angle `under` translation (origin .-. p)  -- Scaling -------------------------------------------------@@ -203,7 +205,7 @@ --   the point @p@ and vector @v@. reflectionAbout :: P2 -> R2 -> T2 reflectionAbout p v =-  conjugate (rotation (-direction v :: Rad) <> translation (origin .-. p))+  conjugate (rotation (negateV $ direction v) <> translation (origin .-. p))             reflectionY  -- | @reflectAbout p v@ reflects a diagram in the line determined by
src/Diagrams/TwoD/Transform/ScaleInv.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell       #-}@@ -20,8 +21,10 @@     where  import           Control.Lens            (makeLenses, view)+import           Data.AdditiveGroup import           Data.AffineSpace        ((.-.)) import           Data.Semigroup+import           Data.Typeable  import           Diagrams.Core import           Diagrams.TwoD.Transform@@ -61,11 +64,11 @@  data ScaleInv t =   ScaleInv-  { _scaleInvObj  :: t+  { _scaleInvObj :: t   , _scaleInvDir :: R2   , _scaleInvLoc :: P2   }-  deriving (Show)+  deriving (Show, Typeable)  makeLenses ''ScaleInv @@ -82,8 +85,7 @@ instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where   transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l'     where-      angle :: Rad-      angle = direction (transform tr v) - direction v+      angle = direction (transform tr v) ^-^ direction v       rot :: (Transformable t, V t ~ R2) => t -> t       rot = rotateAbout l angle       l'  = transform tr l@@ -184,6 +186,6 @@ --   scale-invariant things will be used only as \"decorations\" (/e.g./ --   arrowheads) which should not affect the envelope, trace, and --   query.-scaleInvPrim :: (Transformable t, Renderable t b, V t ~ R2, Monoid m)+scaleInvPrim :: (Transformable t, Typeable t, Renderable t b, V t ~ R2, Monoid m)              => t -> R2 -> QDiagram b R2 m scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty
src/Diagrams/TwoD/Types.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeOperators              #-} {-# LANGUAGE TypeSynonymInstances       #-}@@ -26,25 +26,21 @@        , T2           -- * Angles-       , Angle(..)--       , Turn(..), asTurn, CircleFrac-       , Rad(..), asRad-       , Deg(..), asDeg-       , fullTurn, fullCircle, convertAngle, angleRatio+       , Angle+       , rad, turn, deg+       , fullTurn, fullCircle, angleRatio+       , (@@)        ) where -import           Control.Lens            (Iso', Wrapped, iso, makeWrapped, op,-                                          wrapped, _1, _2)+import           Control.Lens            (Iso', Wrapped(..), Rewrapped, iso+                                         , review , (^.), _1, _2)  import           Diagrams.Coordinates import           Diagrams.Core-import           Diagrams.Util           (tau)  import           Data.AffineSpace.Point import           Data.Basis import           Data.MemoTrie           (HasTrie (..))-import           Data.NumInstances.Tuple () import           Data.VectorSpace  import           Data.Typeable@@ -136,10 +132,13 @@ mkR2 = curry r2  -- | Lens wrapped isomorphisms for R2.-instance Wrapped (Double, Double) (Double, Double) R2 R2 where-  wrapped = iso r2 unr2-  {-# INLINE wrapped #-}+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@@ -239,98 +238,52 @@ ------------------------------------------------------------ -- Angles --- | Newtype wrapper used to represent angles as fractions of a---   circle.  For example, 1\/3 turn = tau\/3 radians = 120 degrees.-newtype Turn = Turn Double-  deriving (Read, Show, Eq, Ord, Enum, Fractional, Num, Real, RealFrac, AdditiveGroup)--makeWrapped ''Turn--instance VectorSpace Turn where-  type Scalar Turn = Double-  s *^ Turn t = Turn (s*t)---- | The identity function with a restricted type, for conveniently--- declaring that some value should have type 'Turn'.  For example,--- @rotation . asTurn . fromRational@ constructs a rotation from a--- rational value considered as a @Turn@.  Without @asTurn@, the angle--- type would be ambiguous.-asTurn :: Turn -> Turn-asTurn = id---- | Deprecated synonym for 'Turn', retained for backwards compatibility.-type CircleFrac = Turn---- | Newtype wrapper for representing angles in radians.-newtype Rad = Rad Double-  deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac, AdditiveGroup)--makeWrapped ''Rad--instance VectorSpace Rad where-  type Scalar Rad = Double-  s *^ Rad r = Rad (s*r)---- | The identity function with a restricted type, for conveniently--- declaring that some value should have type 'Rad'.  For example,--- @rotation . asRad . fromRational@ constructs a rotation from a--- rational value considered as a value in radians.  Without @asRad@,--- the angle type would be ambiguous.-asRad :: Rad -> Rad-asRad = id---- | Newtype wrapper for representing angles in degrees.-newtype Deg = Deg Double-  deriving (Read, Show, Eq, Ord, Enum, Fractional, Num, Real, RealFrac, AdditiveGroup)--makeWrapped ''Deg--instance VectorSpace Deg where-  type Scalar Deg = Double-  s *^ Deg d = Deg (s*d)---- | The identity function with a restricted type, for conveniently--- declaring that some value should have type 'Deg'.  For example,--- @rotation . asDeg . fromIntegral@ constructs a rotation from an--- integral value considered as a value in degrees.  Without @asDeg@,--- the angle type would be ambiguous.-asDeg :: Deg -> Deg-asDeg = id---- | Type class for types that measure angles.-class Num a => Angle a where-  -- | Convert to a turn, /i.e./ a fraction of a circle.-  toTurn   :: a -> Turn+-- | 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) -  -- | Convert from a turn, /i.e./ a fraction of a circle.-  fromTurn :: Turn -> a+instance VectorSpace Angle where+  type Scalar Angle = Double+  s *^ Radians t = Radians (s*t) -instance Angle Turn where-  toTurn   = id-  fromTurn = id+-- | The radian measure of an @Angle@ @a@ can be accessed as @a+-- ^. rad@.  A new @Angle@ can be defined in radians as @pi \@\@ rad@.+rad :: Iso' Angle Double+rad = iso (\(Radians r) -> r) Radians --- | tau radians = 1 full turn.-instance Angle Rad where-  toTurn   = Turn . (/tau) . op Rad-  fromTurn = Rad . (*tau) . op Turn+-- | 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))) --- | 360 degrees = 1 full turn.-instance Angle Deg where-  toTurn   = Turn . (/360) . op Deg-  fromTurn = Deg . (*360) . op 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)))  -- | An angle representing one full turn.-fullTurn :: Angle a => a-fullTurn = fromTurn 1+fullTurn :: Angle+fullTurn = 1 @@ turn  -- | Deprecated synonym for 'fullTurn', retained for backwards compatibility.-fullCircle :: Angle a => a+fullCircle :: Angle fullCircle = fullTurn --- | Convert between two angle representations.-convertAngle :: (Angle a, Angle b) => a -> b-convertAngle = fromTurn . toTurn+-- | Calculate ratio between two angles.+angleRatio :: Angle -> Angle -> Double+angleRatio a b = (a^.rad) / (b^.rad) --- | Calculate ratio between two angles-angleRatio :: Angle a => a -> a -> Double-angleRatio a b = op Turn (toTurn a) / op Turn (toTurn b)++-- | @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.+(@@) :: b -> Iso' a b -> a+-- The signature above is slightly specialized, in favor of readability+a @@ i = review i a++infixl 5 @@
src/Diagrams/TwoD/Vector.hs view
@@ -22,6 +22,8 @@        , perp, leftTurn        ) where +import           Control.Lens         ((^.))+import           Data.AdditiveGroup import           Data.VectorSpace     ((<.>)) import           Diagrams.TwoD.Types import           Diagrams.Coordinates@@ -45,25 +47,25 @@ -- | Compute the direction of a vector, measured counterclockwise from --   the positive x-axis as a fraction of a full turn.  The zero --   vector is arbitrarily assigned the direction 0.-direction :: Angle a => R2 -> a-direction (coords -> x :& y) = convertAngle . Rad $ atan2 y x+direction :: R2 -> Angle+direction (coords -> x :& y) = atan2 y x @@ rad  -- | Compute the counterclockwise angle from the first vector to the second.-angleBetween :: (Angle a, Num a, Ord a) => R2 -> R2 -> a+angleBetween :: R2 -> R2 -> Angle angleBetween v1 v2-  | d2 > d1   = d2 - d1-  | otherwise = fullTurn + d2 - d1+  | d2 > d1   = d2 ^-^ d1+  | otherwise = fullTurn ^+^ d2 ^-^ d1   where     d1 = direction v1     d2 = direction v2  -- | Convert an angle into a unit vector pointing in that direction.-fromDirection :: Angle a => a -> R2+fromDirection :: Angle -> R2 fromDirection a = cos a' ^& sin a'-  where Rad a' = convertAngle a+  where a' = a^.rad  -- | A convenient synonym for 'fromDirection'.-e :: Angle a => a -> R2+e :: Angle -> R2 e = fromDirection  -- | @perp v@ is perpendicular to and has the same magnitude as @v@.