diff --git a/Diagrams/TwoD/Boolean.hs b/Diagrams/TwoD/Boolean.hs new file mode 100644 --- /dev/null +++ b/Diagrams/TwoD/Boolean.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Set operations on paths. As a side effect it removes overlapping +-- regions. Since `Path` is `TrailLike`, you can use these operations +-- directly on most diagrams combinators which generate `Loop`s, like +-- `circle` or `fromSegments`. `Line`s are discarded, only `Loop`s +-- are used. If you have several paths, you can combine them first +-- with `<>`. Use `toPath` if you want to convert a `Trail` or +-- `Located Trail` to a `Path`. The `FillRule` argument determines +-- how /insideness/ is calculated. + +module Diagrams.TwoD.Boolean + (-- * operations on Paths + union, difference, intersection, exclusion, + -- * operations on Paths with tolerance + union', difference', intersection', exclusion', + -- * operations on Loops + loopUnion, loopDifference, + loopIntersection, loopExclusion,) + where +import Diagrams.Prelude +import Data.Maybe +import qualified Geom2D.CubicBezier as C + +fillrule :: FillRule -> C.FillRule +fillrule Winding = C.NonZero +fillrule EvenOdd = C.EvenOdd + +loop2path :: Located (Trail' Loop V2 Double) -> C.ClosedPath Double +loop2path t = + C.ClosedPath $ go x0 y0 (lineSegments $ cutLoop $ unLoc t) + where + (P (V2 x0 y0)) = loc t + go :: Double -> Double -> [Segment Closed V2 Double] -> [(C.DPoint, C.PathJoin Double)] + go _ _ [] = [] + go x y (Linear (OffsetClosed (V2 x3 y3)):r) = + (C.Point x y, C.JoinLine) : + go (x+x3) (y+y3) r + go x y (Cubic (V2 x1 y1) (V2 x2 y2) (OffsetClosed (V2 x3 y3)):r) = + (C.Point x y, C.JoinCurve (C.Point (x+x1) (y+y1)) (C.Point (x+x2) (y+y2))) : + go (x+x3) (y+y3) r + +path2loop :: C.ClosedPath Double -> Located (Trail' Loop V2 Double) +path2loop (C.ClosedPath []) = fromSegments [] `at` origin +path2loop (C.ClosedPath ((C.Point x0 y0, join):r)) = + fromSegments (go x0 y0 join r) `at` P (V2 x0 y0) + where go x y C.JoinLine [] = + [straight (V2 (x0-x) (y0-y))] + go x y C.JoinLine ((C.Point x2 y2, join'):r') = + straight (V2 (x2-x) (y2-y)): + go x2 y2 join' r' + go x y (C.JoinCurve (C.Point x1 y1) (C.Point x2 y2)) r' = + case r' of + [] -> [bezier3 (V2 (x1-x) (y1-y)) + (V2 (x2-x) (y2-y)) (V2 (x0-x) (y0-y))] + ((C.Point x3 y3, join'):r'') -> + bezier3 (V2 (x1-x) (y1-y)) (V2 (x2-x) (y2-y)) + (V2 (x3-x) (y3-y)) : + go x3 y3 join' r'' + +trail2loop :: Located (Trail V2 Double) -> Maybe (Located (Trail' Loop V2 Double)) +trail2loop = located (withTrail (const Nothing) Just) + +offsetMax :: Offset c V2 Double -> Double +offsetMax (OffsetClosed (V2 m n)) = max (abs m) (abs n) +offsetMax OffsetOpen = 0 + +segmentMax :: Segment c V2 Double -> Double +segmentMax (Linear o) = + offsetMax o +segmentMax (Cubic (V2 a b) (V2 c d) o) = + maximum [offsetMax o, abs a, abs b, + abs c, abs d] + +loopMax :: Trail' Loop V2 Double -> Double +loopMax l = maximum (segmentMax lastSeg: map segmentMax segs) + where (segs, lastSeg) = loopSegments l + +defaultTol :: Double +defaultTol = 1e-7 + +loop2trail :: Located (Trail' Loop V2 Double) -> Located (Trail V2 Double) +loop2trail = over located wrapLoop + +-- | Remove overlapping regions in the path. If you have several +-- paths, combine them using `<>` first. +-- +-- <> +-- +-- > example = strokePath $ union Winding $ +-- > (square 1) <> circle 0.5 # translate (V2 0.5 (-0.5)) + +union :: FillRule -> Path V2 Double -> Path V2 Double +union fill p = + Path $ map loop2trail $ + loopUnion tol fill loops + where loops = mapMaybe trail2loop $ + pathTrails p + tol = maximum (map (loopMax.unLoc) loops) * + defaultTol + +-- | Intersection of two paths. First overlap is removed in the two +-- input arguments, then the intersection is calculated. +-- +-- <> +-- +-- > example = strokePath $ +-- > intersection Winding (square 1) $ +-- > circle 0.5 # translate (V2 0.5 (-0.5)) +intersection :: FillRule -> Path V2 Double -> Path V2 Double -> Path V2 Double +intersection fill p1 p2 = + Path $ map loop2trail $ + loopIntersection tol fill loops1 loops2 + where loops1 = mapMaybe trail2loop $ + pathTrails p1 + loops2 = mapMaybe trail2loop $ + pathTrails p2 + tol = max (maximum (map (loopMax.unLoc) loops1)) + (maximum (map (loopMax.unLoc) loops2)) + * defaultTol +-- | Difference of two paths. First overlap is removed in the two +-- input arguments, then the difference is calculated. +-- +-- <> +-- +-- > example = strokePath $ +-- > difference Winding (square 1) $ +-- > circle 0.5 # translate (V2 0.5 (-0.5)) +difference :: FillRule -> Path V2 Double -> Path V2 Double -> Path V2 Double +difference fill p1 p2 = + Path $ map loop2trail $ + loopDifference tol fill loops1 loops2 + where loops1 = mapMaybe trail2loop $ + pathTrails p1 + loops2 = mapMaybe trail2loop $ + pathTrails p2 + tol = max (maximum (map (loopMax.unLoc) loops1)) + (maximum (map (loopMax.unLoc) loops2)) + * defaultTol + +-- | Exclusion (exclusive or) of two paths. First overlap is removed in the two +-- input arguments, then the exclusion is calculated. +-- +-- <> +-- +-- > example = fc grey $ strokePath $ +-- > exclusion Winding (square 1) $ +-- > circle 0.5 # translate (V2 0.5 (-0.5)) +exclusion :: FillRule -> Path V2 Double -> Path V2 Double -> Path V2 Double +exclusion fill p1 p2 = + Path $ map loop2trail $ + loopExclusion tol fill loops1 loops2 + where loops1 = mapMaybe trail2loop $ + pathTrails p1 + loops2 = mapMaybe trail2loop $ + pathTrails p2 + tol = max (maximum (map (loopMax.unLoc) loops1)) + (maximum (map (loopMax.unLoc) loops2)) + * defaultTol + +-- | Like `union`, but takes a tolerance parameter. +union' :: Double -> FillRule -> Path V2 Double -> Path V2 Double +union' tol fill p = + Path $ map loop2trail $ + loopUnion tol fill $ + mapMaybe trail2loop $ + pathTrails p + +-- | Like `intersection`, but takes a tolerance parameter. +intersection' :: Double -> FillRule -> Path V2 Double -> Path V2 Double -> Path V2 Double +intersection' tol fill p1 p2 = + Path $ map loop2trail $ + loopIntersection tol fill + (mapMaybe trail2loop $ pathTrails p1) + (mapMaybe trail2loop $ pathTrails p2) + + +-- | Like `difference`, but takes a tolerance parameter. +difference' :: Double -> FillRule -> Path V2 Double -> Path V2 Double -> Path V2 Double +difference' tol fill p1 p2 = + Path $ map loop2trail $ + loopDifference tol fill + (mapMaybe trail2loop $ pathTrails p1) + (mapMaybe trail2loop $ pathTrails p2) + +-- | Like `exclusion`, but takes a tolerance parameter. +exclusion' :: Double -> FillRule -> Path V2 Double -> Path V2 Double -> Path V2 Double +exclusion' tol fill p1 p2 = + Path $ map loop2trail $ + loopExclusion tol fill + (mapMaybe trail2loop $ pathTrails p1) + (mapMaybe trail2loop $ pathTrails p2) + +-- | Union of a list of loops. +loopUnion :: Double -> FillRule + -> [Located (Trail' Loop V2 Double)] + -> [Located (Trail' Loop V2 Double)] +loopUnion tol fill p = + map path2loop $ C.union (map loop2path p) (fillrule fill) tol + +-- | Difference between loops. The loops in both lists are first merged using `union`. +loopDifference :: Double -> FillRule + -> [Located (Trail' Loop V2 Double)] + -> [Located (Trail' Loop V2 Double)] + -> [Located (Trail' Loop V2 Double)] +loopDifference tol fill p1 p2 = + map path2loop $ C.difference (map loop2path p1) + (map loop2path p2) (fillrule fill) tol + +-- | Intersection of loops. The loops in both lists are first merged using `union`. +loopIntersection :: Double -> FillRule + -> [Located (Trail' Loop V2 Double)] + -> [Located (Trail' Loop V2 Double)] + -> [Located (Trail' Loop V2 Double)] +loopIntersection tol fill p1 p2 = + map path2loop $ C.intersection (map loop2path p1) + (map loop2path p2) (fillrule fill) tol + +-- | Exclusion (xor) of loops. The loops in both lists are first merged using `union`. +loopExclusion :: Double -> FillRule + -> [Located (Trail' Loop V2 Double)] + -> [Located (Trail' Loop V2 Double)] + -> [Located (Trail' Loop V2 Double)] +loopExclusion tol fill p1 p2 = + map path2loop $ C.exclusion (map loop2path p1) + (map loop2path p2) (fillrule fill) tol + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2015, Kristof Bastiaensen +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. Neither the name of the organisation nor the + names of its contributors may be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/diagrams-boolean.cabal b/diagrams-boolean.cabal new file mode 100644 --- /dev/null +++ b/diagrams-boolean.cabal @@ -0,0 +1,25 @@ +Name: diagrams-boolean +Version: 0.1.0 +Synopsis: boolean operations on Diagrams paths +Category: Graphics +Copyright: Kristof Bastiaensen (2015) +Stability: Unstable +License: BSD3 +License-file: LICENSE +Author: Kristof Bastiaensen +Maintainer: Kristof Bastiaensen +Bug-Reports: https://github.com/kuribas/diagrams-boolean/issues +Build-type: Simple +Cabal-version: >=1.8 +Description: set operations (union, intersection, difference and exclusion) on paths in Diagrams. +extra-doc-files: samples/union.svg, samples/difference.svg, samples/exclusion.svg, samples/intersection.svg + +source-repository head + type: git + location: https://github.com/kuribas/diagrams-boolean + +Library + Ghc-options: -Wall + Build-depends: base >= 3 && < 5, diagrams-lib >= 1.3, cubicbezier >= 0.4.0 + Exposed-Modules: + Diagrams.TwoD.Boolean diff --git a/samples/difference.svg b/samples/difference.svg new file mode 100644 --- /dev/null +++ b/samples/difference.svg @@ -0,0 +1,12 @@ + + + + + + + + + + + diff --git a/samples/exclusion.svg b/samples/exclusion.svg new file mode 100644 --- /dev/null +++ b/samples/exclusion.svg @@ -0,0 +1,12 @@ + + + + + + + + + + + diff --git a/samples/intersection.svg b/samples/intersection.svg new file mode 100644 --- /dev/null +++ b/samples/intersection.svg @@ -0,0 +1,12 @@ + + + + + + + + + + + diff --git a/samples/union.svg b/samples/union.svg new file mode 100644 --- /dev/null +++ b/samples/union.svg @@ -0,0 +1,12 @@ + + + + + + + + + + +