From 77e6f9f96b79a18f962b5a9663b06737747e89f7 Mon Sep 17 00:00:00 2001 From: jeffrey rosenbluth Date: Tue, 31 Dec 2013 22:58:10 -0500 Subject: [PATCH 1/9] added clipTo --- src/Diagrams/TwoD.hs | 2 +- src/Diagrams/TwoD/Path.hs | 17 ++++++++++++----- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 5d4ef621..0e3d494a 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -84,7 +84,7 @@ module Diagrams.TwoD , StrokeOpts(..), vertexNames, queryFillRule -- ** Clipping - , clipBy + , clipBy, clipTo -- * Shapes -- ** Rules diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 72044c72..d84dad0f 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 ) where import Control.Applicative (liftA2) @@ -361,7 +361,14 @@ 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. Set the trace to the +-- pointwise minimum of their traces. +clipTo :: (Renderable (Path R2) b) => Path R2 -> Diagram b R2 -> Diagram b R2 +clipTo p d = setTrace (getTrace p <> getTrace d) . 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 From a97d2174a7145e1d8f14670e5fecb0459a93c463 Mon Sep 17 00:00:00 2001 From: jeffrey rosenbluth Date: Wed, 1 Jan 2014 18:21:44 -0500 Subject: [PATCH 2/9] added clipped and mdified clipTo not to set the trace --- src/Diagrams/TwoD.hs | 2 +- src/Diagrams/TwoD/Path.hs | 15 +++++++++++---- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 0e3d494a..d46c30f6 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -84,7 +84,7 @@ module Diagrams.TwoD , StrokeOpts(..), vertexNames, queryFillRule -- ** Clipping - , clipBy, clipTo + , clipBy, clipTo, clipped -- * Shapes -- ** Rules diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index d84dad0f..36b10ab6 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -41,7 +41,7 @@ module Diagrams.TwoD.Path -- * Clipping - , Clip(..), clipBy, clipTo + , Clip(..), clipBy, clipTo, clipped ) where import Control.Applicative (liftA2) @@ -56,6 +56,7 @@ import Data.AffineSpace import Data.Default.Class import Data.VectorSpace +import Diagrams.Combinators (withEnvelope, withTrace) import Diagrams.Coordinates import Diagrams.Core import Diagrams.Located (Located, mapLoc, unLoc) @@ -362,13 +363,19 @@ clipBy :: (HasStyle a, V a ~ R2) => Path R2 -> a -> a clipBy = applyTAttr . Clip . (:[]) -- | Clip a diagram to the given path setting its envelope to the pointwise --- minimum of the envelopes of the diagram and path. Set the trace to the --- pointwise minimum of their traces. +-- minimum of the envelopes of the diagram and path. XXX The trace is left +-- unchanged but should probably be the trace of the intersection of the +-- clip path and diagram. clipTo :: (Renderable (Path R2) b) => Path R2 -> Diagram b R2 -> Diagram b R2 -clipTo p d = setTrace (getTrace p <> getTrace d) . toEnvelope $ clipBy p d +clipTo p d = 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 + +-- | 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) \ No newline at end of file From f4aba13f7a1d46aa1601256eadabdf6c31e7aa55 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Thu, 2 Jan 2014 01:22:37 +0000 Subject: [PATCH 3/9] Another attempt at a proper intersection Trace in clipTo --- src/Diagrams/TwoD/Path.hs | 42 +++++++++++++++++++++++++++++++-------- 1 file changed, 34 insertions(+), 8 deletions(-) diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 36b10ab6..714601af 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -54,6 +54,7 @@ import Data.Typeable import Data.AffineSpace import Data.Default.Class +import Data.Monoid.Inf import Data.VectorSpace import Diagrams.Combinators (withEnvelope, withTrace) @@ -168,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 @@ -362,20 +363,45 @@ instance Transformable Clip where clipBy :: (HasStyle a, V a ~ R2) => Path R2 -> a -> a clipBy = applyTAttr . Clip . (:[]) --- | Clip a diagram to the given path setting its envelope to the pointwise --- minimum of the envelopes of the diagram and path. XXX The trace is left --- unchanged but should probably be the trace of the intersection of the --- clip path and diagram. +-- | 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 = toEnvelope $ clipBy p d +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 tryTrace + -- Find the first Trace result that is part of the intersection + tryTrace pt v = let + -- locate the point corresponding to a trace distance + newPt d = pt .+^ v ^* d + -- handle an intersection with the trace of d + dTest dDist = if testPt (newPt dDist) pQuery + then (Finite dDist) else tryTrace (newPt dDist) v + -- handle an intersection with the trace of p + pTest pDist = if testPt (newPt pDist) (query d) + then (Finite pDist) else tryTrace (newPt pDist) v + in + case (appTrace (getTrace p) pt v, appTrace (getTrace d) pt v) of + -- No intersections + (Infinity, Infinity) -> Infinity + -- One intersection, test if it counts, recurse if not + (Infinity, Finite dDist) -> dTest dDist + (Finite pDist, Infinity) -> pTest pDist + -- Two intersections, use the nearest or recurse + (Finite pDist, Finite dDist) -> + if pDist < dDist then pTest pDist else dTest dDist + -- Check if pt is inside the Path / Diagram + testPt pt q = getAny $ runQuery q pt + pQuery = Query $ Any . flip (runFillRule Winding) p -- | 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) \ No newline at end of file +clipped p = (withTrace p) . (withEnvelope p) . (clipBy p) From cf768519029b35b3ad4fc491acf50eb3b6eab067 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Thu, 2 Jan 2014 01:36:04 +0000 Subject: [PATCH 4/9] Fix variable shadowing --- src/Diagrams/TwoD/Path.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 714601af..ef871f26 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -380,7 +380,7 @@ clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d -- Find the first Trace result that is part of the intersection tryTrace pt v = let -- locate the point corresponding to a trace distance - newPt d = pt .+^ v ^* d + newPt dist = pt .+^ v ^* dist -- handle an intersection with the trace of d dTest dDist = if testPt (newPt dDist) pQuery then (Finite dDist) else tryTrace (newPt dDist) v From b1f21edbfc3af04e074236f74e37c5ff8233e865 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sat, 18 Jan 2014 18:23:39 +0000 Subject: [PATCH 5/9] Trace of intersections, using new SortedList Trace --- src/Diagrams/TwoD/Path.hs | 34 ++++++++++------------------------ 1 file changed, 10 insertions(+), 24 deletions(-) diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index ef871f26..01ddc967 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -60,6 +60,7 @@ 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 @@ -376,30 +377,15 @@ clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d toEnvelope = case (envP, envD) of (Just eP, Just eD) -> setEnvelope . mkEnvelope $ \v -> min (eP v) (eD v) (_, _) -> id - intersectionTrace = Trace tryTrace - -- Find the first Trace result that is part of the intersection - tryTrace pt v = let - -- locate the point corresponding to a trace distance - newPt dist = pt .+^ v ^* dist - -- handle an intersection with the trace of d - dTest dDist = if testPt (newPt dDist) pQuery - then (Finite dDist) else tryTrace (newPt dDist) v - -- handle an intersection with the trace of p - pTest pDist = if testPt (newPt pDist) (query d) - then (Finite pDist) else tryTrace (newPt pDist) v - in - case (appTrace (getTrace p) pt v, appTrace (getTrace d) pt v) of - -- No intersections - (Infinity, Infinity) -> Infinity - -- One intersection, test if it counts, recurse if not - (Infinity, Finite dDist) -> dTest dDist - (Finite pDist, Infinity) -> pTest pDist - -- Two intersections, use the nearest or recurse - (Finite pDist, Finite dDist) -> - if pDist < dDist then pTest pDist else dTest dDist - -- Check if pt is inside the Path / Diagram - testPt pt q = getAny $ runQuery q pt - pQuery = Query $ Any . flip (runFillRule Winding) p + 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. From 82122c60ae81c153cec536b4ebbd4e69d8cad9b8 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sat, 18 Jan 2014 18:24:11 +0000 Subject: [PATCH 6/9] haddock: fix typo --- src/Diagrams/TwoD/Arrow.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 6f48f04d..ec288265 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -449,7 +449,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 From 36667b034b1e7b7d3b9f5329f9d237cd2c26e035 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sat, 18 Jan 2014 18:27:01 +0000 Subject: [PATCH 7/9] clipTo test (Trace of intersections) jeffryrosenbluth's test design I added arrows to the graphical output --- test/clipTo.hs | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) create mode 100644 test/clipTo.hs 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 From 1c33e5add0c28b54154ad4d4a4964544a33b7935 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sat, 18 Jan 2014 18:42:04 +0000 Subject: [PATCH 8/9] -Wall: don't import Data.Monoid.Inf --- src/Diagrams/TwoD/Path.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 01ddc967..d3c8d2db 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -54,7 +54,6 @@ import Data.Typeable import Data.AffineSpace import Data.Default.Class -import Data.Monoid.Inf import Data.VectorSpace import Diagrams.Combinators (withEnvelope, withTrace) From d5477d21d8ea1d3fbb2626c0232a206e9dd8db12 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Sat, 18 Jan 2014 16:34:17 +0000 Subject: [PATCH 9/9] -Wall: remove unneeded imports --- src/Diagrams/TwoD/Arrow.hs | 2 +- src/Diagrams/TwoD/Arrowheads.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index ec288265..28cb6b1c 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -100,7 +100,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 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 ((<$>))