diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 862c4fc6..44cc9680 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -83,7 +83,7 @@ module Diagrams.TwoD , StrokeOpts(..), vertexNames, queryFillRule -- ** Clipping - , clipBy + , clipBy, clipTo, clipped -- * Shapes -- ** Rules diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index a22932c9..252f84e1 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/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 diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 28157e12..c0182077 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/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 ((<$>)) diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 72044c72..d3c8d2db 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/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) diff --git a/test/clipTo.hs b/test/clipTo.hs new file mode 100644 index 00000000..2dc2b38d --- /dev/null +++ b/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