Intersections

diagrams-lib.cabal

@@ -83,8 +83,10 @@ Library
                        Diagrams.TwoD.Model,
                        Diagrams.TwoD.Offset,
                        Diagrams.TwoD.Path,
+                       Diagrams.TwoD.Points,
                        Diagrams.TwoD.Polygons,
                        Diagrams.TwoD.Segment,
+                       Diagrams.TwoD.Segment.Bernstein,
                        Diagrams.TwoD.Size,
                        Diagrams.TwoD.Shapes,
                        Diagrams.TwoD.Text,

src/Diagrams/Path.hs

@@ -36,6 +36,7 @@ module Diagrams.Path
          -- * Constructing paths
          -- $construct
 
+       , ToPath (..)
        , pathFromTrail
        , pathFromTrailAt
        , pathFromLocTrail
@@ -61,7 +62,7 @@ module Diagrams.Path
 
 import           Control.Arrow        ((***))
 import           Control.Lens         (Rewrapped, Wrapped (..), iso, mapped, op, over, view, (%~),
-                                       _Unwrapped', _Wrapped)
+                                       _Unwrapped', _Wrapped, Each (..), traversed)
 import qualified Data.Foldable        as F
 import           Data.List            (partition)
 import           Data.Semigroup
@@ -113,6 +114,9 @@ instance Wrapped (Path v n) where
 
 instance Rewrapped (Path v n) (Path v' n')
 
+instance Each (Path v n) (Path v' n') (Located (Trail v n)) (Located (Trail v' n')) where
+  each = _Wrapped . traversed
+
 -- | Extract the located trails making up a 'Path'.
 pathTrails :: Path v n -> [Located (Trail v n)]
 pathTrails = op Path
@@ -138,7 +142,7 @@ instance (HasLinearMap v, Metric v, OrderedField n)
   transform = over _Wrapped . map . transform
 
 instance (Metric v, OrderedField n) => Enveloped (Path v n) where
-  getEnvelope = F.foldMap trailEnvelope . op Path --view pathTrails
+  getEnvelope = F.foldMap trailEnvelope . op Path
           -- this type signature is necessary to work around an apparent bug in ghc 6.12.1
     where trailEnvelope :: Located (Trail v n) -> Envelope v n
           trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t)
@@ -157,6 +161,43 @@ instance (HasLinearMap v, Metric v, OrderedField n)
 --  Constructing paths  ------------------------------------
 ------------------------------------------------------------
 
+-- | Type class for things that can be converted to a 'Path'.
+--
+--   Note that this class is very different from 'TrailLike'. 'TrailLike' is
+--   usually the result of a library function to give you a convenient,
+--   polymorphic result ('Path', 'Diagram' etc.).
+--
+class ToPath t where
+  -- | 'toPath' takes something that can be converted to 'Path' and returns
+  --    the 'Path'.
+  toPath :: (Metric (V t), OrderedField (N t)) => t -> Path (V t) (N t)
+
+instance ToPath (Path v n) where
+  toPath = id
+
+instance ToPath (Trail v n) where
+  toPath = pathFromTrail
+
+instance ToPath (Located (Trail v n)) where
+  toPath = pathFromLocTrail
+
+instance ToPath (Located (Trail' l v n)) where
+  toPath = pathFromLocTrail . mapLoc Trail
+
+instance ToPath (Located (Segment Closed v n)) where
+  toPath (viewLoc -> (p,seg))
+    = Path [trailFromSegments [seg] `at` p]
+
+instance ToPath (Located [Segment Closed v n]) where
+  toPath (viewLoc -> (p,segs))
+    = Path [trailFromSegments segs `at` p]
+
+instance ToPath (FixedSegment v n) where
+  toPath = toPath . fromFixedSeg
+
+instance ToPath a => ToPath [a] where
+  toPath = F.foldMap toPath
+
 -- $construct
 -- Since paths are 'TrailLike', any function producing a 'TrailLike'
 -- can be used to construct a (singleton) path.  The functions in this

src/Diagrams/Points.hs

@@ -18,7 +18,6 @@ module Diagrams.Points
        , centroid
        , pointDiagram
        , _Point, lensP
-       , project
        ) where
 
 import           Diagrams.Core        (pointDiagram)
@@ -27,7 +26,6 @@ import           Diagrams.Core.Points
 import           Data.Foldable        as F
 
 import           Linear.Affine
-import           Linear.Metric
 import           Linear.Vector
 
 -- | The centroid of a set of /n/ points is their sum divided by /n/.

src/Diagrams/Prelude.hs

@@ -148,7 +148,7 @@ import           Diagrams.Combinators
 import           Diagrams.Coordinates
 import           Diagrams.CubicSpline
 import           Diagrams.Deform
-import           Diagrams.Direction
+import           Diagrams.Direction         hiding (dir)
 import           Diagrams.Envelope
 import           Diagrams.Located
 import           Diagrams.Names

src/Diagrams/Segment.hs

@@ -63,8 +63,8 @@ module Diagrams.Segment
 
        ) where
 
-import           Control.Lens             (Rewrapped, Traversal, Wrapped (..), iso, makeLenses, op,
-                                           over)
+import           Control.Lens             (Rewrapped, Wrapped (..), iso, makeLenses, op,
+                                           over, Each (..))
 import           Data.FingerTree
 import           Data.Monoid.MList
 import           Data.Semigroup
@@ -116,9 +116,10 @@ instance Functor v => Functor (Offset c v) where
   fmap _ OffsetOpen       = OffsetOpen
   fmap f (OffsetClosed v) = OffsetClosed (fmap f v)
 
-offsetVector :: Traversal (Offset c v n) (Offset c v' n') (v n) (v' n')
-offsetVector f (OffsetClosed v) = OffsetClosed <$> f v
-offsetVector _ OffsetOpen       = pure OffsetOpen
+instance Each (Offset c v n) (Offset c v' n') (v n) (v' n') where
+  each f (OffsetClosed v) = OffsetClosed <$> f v
+  each _ OffsetOpen       = pure OffsetOpen
+  {-# INLINE each #-}
 
 type instance V (Offset c v n) = v
 type instance N (Offset c v n) = n
@@ -151,21 +152,14 @@ data Segment c v n
 
   deriving (Show, Functor, Eq, Ord)
 
--- this is provided as a replacement of the previous fmap functionality. (Now
--- fmap is only over the number type)
-
--- Prehaps a traversal is overkill. Only really need to map over segment vectors.
-
--- | A traversal of the vectors that make up a segment.
-segmentVectors :: Traversal (Segment c v n) (Segment c v' n') (v n) (v' n')
-segmentVectors f (Linear offset)      = Linear <$> offsetVector f offset
-segmentVectors f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> offsetVector f offset
+instance Each (Segment c v n) (Segment c v' n') (v n) (v' n') where
+  each f (Linear offset)      = Linear <$> each f offset
+  each f (Cubic v1 v2 offset) = Cubic  <$> f v1 <*> f v2 <*> each f offset
+  {-# INLINE each #-}
 
 -- | Map over the vectors of each segment.
 mapSegmentVectors :: (v n -> v' n') -> Segment c v n -> Segment c v' n'
-mapSegmentVectors = over segmentVectors
--- mapSegmentVectors f (Linear offset) = Linear $ over offsetVector f offset
--- mapSegmentVectors f (Cubic v1 v2 offset) = Cubic (f v1) (f v2) (over offsetVector f offset)
+mapSegmentVectors = over each
 
 -- Note, can't yet have Haddock comments on GADT constructors; see
 -- http://trac.haskell.org/haddock/ticket/43. For now we don't need
@@ -340,31 +334,16 @@ data FixedSegment v n = FLinear (Point v n) (Point v n)
 type instance V (FixedSegment v n) = v
 type instance N (FixedSegment v n) = n
 
+instance Each (FixedSegment v n) (FixedSegment v' n') (Point v n) (Point v' n') where
+  each f (FLinear p0 p1)      = FLinear <$> f p0 <*> f p1
+  each f (FCubic p0 p1 p2 p3) = FCubic  <$> f p0 <*> f p1 <*> f p2 <*> f p3
+  {-# INLINE each #-}
+
 instance (Additive v, Num n) => Transformable (FixedSegment v n) where
-  transform t (FLinear p1 p2)
-    = FLinear
-      (transform t p1)
-      (transform t p2)
-
-  transform t (FCubic p1 c1 c2 p2)
-    = FCubic
-      (transform t p1)
-      (transform t c1)
-      (transform t c2)
-      (transform t p2)
+  transform t = over each (papply t)
 
 instance (Additive v, Num n) => HasOrigin (FixedSegment v n) where
-  moveOriginTo o (FLinear p1 p2)
-    = FLinear
-      (moveOriginTo o p1)
-      (moveOriginTo o p2)
-
-  moveOriginTo o (FCubic p1 c1 c2 p2)
-    = FCubic
-      (moveOriginTo o p1)
-      (moveOriginTo o c1)
-      (moveOriginTo o c2)
-      (moveOriginTo o p2)
+  moveOriginTo o = over each (moveOriginTo o)
 
 instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where
   getEnvelope f = moveTo p (getEnvelope s)

src/Diagrams/ThreeD/Transform.hs

@@ -63,9 +63,6 @@ import           Linear.Metric
 import           Linear.V3               (cross)
 import           Linear.Vector
 
--- | Type alias for transformations in R3.
-type T3 = Transformation V3
-
 -- | Create a transformation which rotates by the given angle about
 --   a line parallel the Z axis passing through the local origin.
 --   A positive angle brings positive x-values towards the positive-y axis.

src/Diagrams/ThreeD/Types.hs

@@ -18,7 +18,7 @@ module Diagrams.ThreeD.Types
        , p3, unp3, mkP3
        , r3Iso, p3Iso, project
        , r3SphericalIso, r3CylindricalIso
-       , V3 (..), P3
+       , V3 (..), P3,      T3
        , R1 (..), R2 (..), R3 (..)
 
        ) where
@@ -39,6 +39,7 @@ import           Linear.V3           as V
 -- Basic R3 types
 
 type P3 = Point V3
+type T3 = Transformation V3
 
 r3Iso :: Iso' (V3 n) (n, n, n)
 r3Iso = iso unr3 r3

src/Diagrams/TwoD.hs

@@ -78,6 +78,8 @@ module Diagrams.TwoD
        , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop
        , FillRule(..), fillRule
        , StrokeOpts(..), vertexNames, queryFillRule
+       , intersectPoints, intersectPoints'
+       , intersectPointsP, intersectPointsP'
 
          -- ** Clipping
        , clipBy, clipTo, clipped

src/Diagrams/TwoD/Model.hs

@@ -101,10 +101,10 @@ showOrigin = showOrigin' def
 showOrigin' :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' m)
            => OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m
 showOrigin' oo d = o <> d
-  where o     = stroke (circle sz)
-                  # fc (oo^.oColor)
-                  # lw none
-                  # fmap (const mempty)
+  where o      = strokeP (circle sz)
+                   # fc (oo^.oColor)
+                   # lw none
+                   # fmap (const mempty)
         V2 w h = oo^.oScale *^ size d
         sz     = maximum [w, h, oo^.oMinSize]