added clipTo

src/Diagrams/TwoD.hs

@@ -83,7 +83,7 @@ module Diagrams.TwoD
        , StrokeOpts(..), vertexNames, queryFillRule
 
          -- ** Clipping
-       , clipBy
+       , clipBy, clipTo, clipped
 
          -- * Shapes
          -- ** Rules

src/Diagrams/TwoD/Arrow.hs

@@ -103,7 +103,7 @@ import           Control.Lens                     (Lens', Setter', Traversal',
 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
@@ -452,7 +452,7 @@ arrowBetween'
 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
 

src/Diagrams/TwoD/Arrowheads.hs

@@ -55,7 +55,7 @@ module Diagrams.TwoD.Arrowheads
        , ArrowHT
        ) where
 
-import           Control.Lens            (from, (&), (.~), (^.))
+import           Control.Lens            ((&), (.~))
 import           Data.AffineSpace
 import           Data.Default.Class
 import           Data.Functor            ((<$>))

src/Diagrams/TwoD/Path.hs

@@ -41,7 +41,7 @@ module Diagrams.TwoD.Path
 
          -- * Clipping
 
-       , Clip(..), clipBy
+       , Clip(..), clipBy, clipTo, clipped
        ) where
 
 import           Control.Applicative   (liftA2)
@@ -56,8 +56,10 @@ import           Data.AffineSpace
 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,8 +169,8 @@ instance Renderable (Path R2) b => TrailLike (QDiagram b R2 Any) where
 --
 --     * 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
@@ -361,7 +363,30 @@ instance Transformable Clip where
 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)

test/clipTo.hs

@@ -0,0 +1,52 @@
+import Data.Maybe
+
+import Diagrams.Prelude
+import Diagrams.Backend.SVG.CmdLine
+
+clipPath :: Path R2
+clipPath = square 2 # alignR
+
+loopyStar :: Diagram B R2
+loopyStar = mconcat
+          . map (cubicSpline True)
+          . pathVertices
+          . star (StarSkip 3)
+          $ regPoly 7 1
+
+clippedStar :: Diagram B R2
+clippedStar = clipTo clipPath (loopyStar # fc lightgray)
+
+example :: Diagram B R2
+example = position (zip pts dots)
+       <> traceArrows # lc cyan
+       <> clippedStar
+       <> loopyStar
+
+pts :: [P2]
+pts = [ (-1) ^& 0.9, (-0.65) ^& 0.65, (-0.25) ^& 0.65, (-0.25) ^& 0.4
+      , (-0.1) ^& 0.9, 0.1 ^& 0.9, 0.25 ^& 0.4, 0.25 ^& 0.65
+      , 0.65 ^& 0.65, 1 ^& 0.9 ]
+
+vecs :: [R2]
+vecs = [unitX, unitY, unit_X, unit_Y]
+
+tracePt :: P2 -> [Double]
+tracePt p = map (maybe 0 magnitude) vs where
+  vs = (rayTraceV p) <$> vecs <*> [clippedStar]
+
+traceArrows :: Diagram B R2
+traceArrows = mconcat $ map ptArrows pts where
+  ptArrows p = mconcat $
+               map (arrowAt' (with & headSize .~ 0.1) p)
+               . catMaybes $ rayTraceV p <$> vecs <*> [clippedStar]
+
+traces :: [[Double]]
+traces = map tracePt pts
+
+dots :: [Diagram B R2]
+dots = repeat (circle 0.015 # fc red # lw 0)
+
+main :: IO ()
+main = do
+  putStr $ unlines $ map show traces
+  mainWith $ example # centerXY # pad 1.1