├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── computational-geometry.cabal ├── computational-geometry.nix ├── default.nix ├── images ├── set-operation-examples.png └── setops3d.gif └── src ├── Data └── EqZero.hs └── Geometry ├── Plane └── General.hs ├── SetOperations.hs └── SetOperations ├── BRep.hs ├── BSP.hs ├── Clip.hs ├── CrossPoint.hs ├── Facet.hs ├── Merge.hs ├── Types.hs └── Volume.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | result 3 | *.[ao] 4 | *.hi 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | 2 | language: nix 3 | script: nix-build default.nix --argstr compiler $GHC_VERSION 4 | env: 5 | - GHC_VERSION=ghc802 6 | 7 | before_install: 8 | - > 9 | if ! echo "$TRAVIS_COMMIT_MESSAGE" \ 10 | | grep -qvE '\[(skip travis|travis skip)\]' 11 | then 12 | echo "[skip travis] has been found, exiting." 13 | exit 14 | fi 15 | - > 16 | if ! git diff --name-only $TRAVIS_COMMIT_RANGE \ 17 | | grep -qvE '\.md$' 18 | then 19 | echo "Only docs were updated, stopping build process." 20 | exit 21 | fi 22 | 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Maksymilian Owsianny 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Maksymilian Owsianny nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Linux Build Status][linux-build-icon]][linux-build] [![Hackage][hackage-version-icon]][hackage-link] 2 | 3 | # Computational Geometry 4 | 5 | Collection of algorithms in Computational Geometry, specifically in the context 6 | of procedural graphics generation. This is very much a work in progress. 7 | 8 | Currently I'm working on set operations of polytopes. You can read more about 9 | that in [This Blog Post][blog-post]. 10 | 11 | ![Set Operations Example][setops3d] 12 | 13 | [linux-build-icon]: https://img.shields.io/travis/MaxOw/computational-geometry/master.svg?label=build 14 | [linux-build]: https://travis-ci.org/MaxOw/computational-geometry 15 | [blog-post]: https://MaxOw.github.io/posts/computational-geometry-set-operations-on-polytopes.html 16 | [setops3d]: https://MaxOw.github.io/images/setops3d.gif 17 | 18 | [hackage-version-icon]: https://img.shields.io/badge/hackage-latest-orange.svg 19 | 20 | [hackage-link]: https://hackage.haskell.org/package/computational-geometry 21 | -------------------------------------------------------------------------------- /computational-geometry.cabal: -------------------------------------------------------------------------------- 1 | Name : computational-geometry 2 | Version : 0.1.0.3 3 | Synopsis : Collection of algorithms in Computational Geometry. 4 | License : BSD3 5 | License-File : LICENSE 6 | Author : Maksymilian Owsianny 7 | Maintainer : Maksymilian.Owsianny@gmail.com 8 | Bug-Reports : https//github.com/MaxOw/computational-geometry/issues 9 | Category : Graphics, Math 10 | Build-Type : Simple 11 | Cabal-Version : >= 1.18 12 | 13 | Description: 14 | Collection of algorithms in Computational Geometry. 15 | 16 | Extra-Source-Files : README.md, images/*.png, images/*.gif 17 | Extra-Doc-Files : images/*.png, images/*.gif 18 | 19 | Source-Repository head 20 | type: git 21 | location: https://github.com/MaxOw/computational-geometry.git 22 | 23 | Library 24 | default-language : Haskell2010 25 | hs-source-dirs : src 26 | ghc-options : -O2 -Wall 27 | 28 | exposed-modules: 29 | Data.EqZero 30 | Geometry.Plane.General 31 | Geometry.SetOperations 32 | Geometry.SetOperations.Types 33 | Geometry.SetOperations.Volume 34 | Geometry.SetOperations.Merge 35 | Geometry.SetOperations.BSP 36 | Geometry.SetOperations.CrossPoint 37 | Geometry.SetOperations.Facet 38 | Geometry.SetOperations.Clip 39 | Geometry.SetOperations.BRep 40 | 41 | default-extensions: 42 | NoImplicitPrelude 43 | DoAndIfThenElse 44 | LambdaCase 45 | MultiWayIf 46 | TupleSections 47 | OverloadedStrings 48 | 49 | build-depends : base >= 4.5 && < 5.0 50 | , protolude 51 | , containers 52 | , vector 53 | , linear 54 | 55 | , lens-family-core 56 | , ansi-wl-pprint 57 | 58 | -------------------------------------------------------------------------------- /computational-geometry.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, ansi-wl-pprint, base, containers, lens-family 2 | , linear, protolude, stdenv, vector 3 | }: 4 | mkDerivation { 5 | pname = "computational-geometry"; 6 | version = "0.1.0"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | ansi-wl-pprint base containers lens-family linear protolude vector 10 | ]; 11 | description = "Collection of algorithms in Computational Geometry"; 12 | license = stdenv.lib.licenses.bsd3; 13 | } 14 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler }: 2 | nixpkgs.haskell.packages.${compiler}.callPackage ./computational-geometry.nix { } 3 | -------------------------------------------------------------------------------- /images/set-operation-examples.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/MaxOw/computational-geometry/20c93aa05b151b115250a18d1203fdf9a01f705e/images/set-operation-examples.png -------------------------------------------------------------------------------- /images/setops3d.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/MaxOw/computational-geometry/20c93aa05b151b115250a18d1203fdf9a01f705e/images/setops3d.gif -------------------------------------------------------------------------------- /src/Data/EqZero.hs: -------------------------------------------------------------------------------- 1 | {-# Language MultiParamTypeClasses #-} 2 | {-# Language FlexibleInstances #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.EqZero 6 | -- Copyright : (C) 2017 Maksymilian Owsianny 7 | -- License : BSD-style (see LICENSE) 8 | -- Maintainer : Maksymilian.Owsianny@gmail.com 9 | -- 10 | -------------------------------------------------------------------------------- 11 | module Data.EqZero where 12 | 13 | import Protolude 14 | import Linear.Epsilon (nearZero) 15 | import Foreign.C (CFloat, CDouble) 16 | 17 | -------------------------------------------------------------------------------- 18 | 19 | -- | Convenient universal zero equality predicate that warps to zero within some 20 | -- epsilon for floating point numbers. 21 | class EqZero a where 22 | eqZero :: a -> Bool 23 | 24 | {- 25 | instance (Num a, Eq a) => EqZero Exact a where 26 | eqZero _ = (==0) 27 | 28 | instance Epsilon a => EqZero NonExact a where 29 | eqZero _ = nearZero 30 | -} 31 | 32 | -- | Greater or equal to zero predicate. 33 | geqZero :: (EqZero n, Ord n, Num n) => n -> Bool 34 | geqZero n = eqZero n || n > 0 35 | 36 | instance EqZero Float where eqZero = nearZero 37 | instance EqZero Double where eqZero = nearZero 38 | instance EqZero CFloat where eqZero = nearZero 39 | instance EqZero CDouble where eqZero = nearZero 40 | instance EqZero Rational where eqZero = (==0) 41 | 42 | -------------------------------------------------------------------------------- /src/Geometry/Plane/General.hs: -------------------------------------------------------------------------------- 1 | {-# Language MultiParamTypeClasses #-} 2 | {-# Language FlexibleInstances #-} 3 | {-# Language FlexibleContexts #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Geometry.Plane.General 7 | -- Copyright : (C) 2017 Maksymilian Owsianny 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : Maksymilian.Owsianny@gmail.com 10 | -- 11 | -- General representation of a plane. Plane in the General Form is Hession 12 | -- Normal Form scaled by an arbitrary non-zero scalar. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | module Geometry.Plane.General 16 | ( Plane (..) 17 | , Plane2, Plane3 18 | , Plane2D, Plane3D 19 | 20 | , MakePlane (..) 21 | , unsafeMakePlane 22 | , flipPlane 23 | 24 | , collinear 25 | -- , coincidence, coorientation 26 | 27 | , PlanesRelation (..), Incidence (..), Orientation (..) 28 | , planesRelation 29 | , isParallel 30 | 31 | ) where 32 | 33 | import Protolude hiding (zipWith, zero) 34 | import Data.Maybe (fromJust) 35 | import qualified Data.List as List 36 | import Linear 37 | -- import Linear.Solve 38 | import Linear.Affine (Point, (.-.)) 39 | import qualified Linear.Affine as Point 40 | import Data.EqZero 41 | 42 | -- | Internally Plane is represented as a pair (sN, sO) where N is a normal 43 | -- vector of a plane O is the distance of that plane from the origin and s is an 44 | -- arbitrary non-zero scalar. 45 | data Plane v n = Plane 46 | { planeVector :: !(v n) 47 | , planeLast :: !n 48 | } deriving (Eq, Ord, Show) 49 | 50 | type Plane2 = Plane V2 51 | type Plane3 = Plane V3 52 | 53 | type Plane2D = Plane V2 Double 54 | type Plane3D = Plane V3 Double 55 | 56 | instance (NFData (v n), NFData n) => NFData (Plane v n) where 57 | rnf (Plane vs l) = rnf vs `seq` rnf l 58 | 59 | -- | Flip plane orientation. 60 | flipPlane :: (Functor v, Num n) => Plane v n -> Plane v n 61 | flipPlane (Plane v n) = Plane (fmap negate v) (negate n) 62 | 63 | class MakePlane v n where 64 | -- | Make plane from vector of points. Returns Nothing if vectors between 65 | -- points are linearly dependent 66 | makePlane :: v (Point v n) -> Maybe (Plane v n) 67 | 68 | instance (Num n, Eq n) => MakePlane V3 n where 69 | makePlane (V3 p1 p2 p3) 70 | | n == zero = Nothing 71 | | otherwise = Just $ Plane n d 72 | where 73 | n = cross (p2 .-. p1) (p3 .-. p1) 74 | d = negate $ dot n $ unPoint p1 75 | 76 | -- | Assumes that points form a valid plane (i.e. vectors between all points are 77 | -- linearly independent). 78 | unsafeMakePlane :: MakePlane v n => v (Point v n) -> Plane v n 79 | unsafeMakePlane = fromJust . makePlane 80 | 81 | {- 82 | makePlane :: (Applicative v, Solve v n, Num n) 83 | => v (Point v n) -> Maybe (Plane v n) 84 | -- makePlane ps = Plane <$> solve ups (pure 1) <*> pure 1 85 | makePlane ps = uncurry Plane <$> solve ups (pure 1) 86 | where 87 | ups = fmap unPoint ps 88 | 89 | -- | Assumes that points form a valid plane (i.e. vectors between all points are 90 | -- linearly independent). 91 | unsafeMakePlane :: (Applicative v, Solve v n, Num n) 92 | => v (Point v n) -> Plane v n 93 | -- unsafeMakePlane ps = Plane (fromJust $ solve ups (pure 1)) 1 94 | -- unsafeMakePlane ps = Plane v d 95 | unsafeMakePlane ps = case solve ups (pure 1) of 96 | Just (v, d) -> Plane v d 97 | Nothing -> error "Bla" -- . toS $ List.unlines $ map show ps 98 | where 99 | -- Just (v, d) = solve ups (pure 1) 100 | ups = fmap unPoint ps 101 | -} 102 | 103 | -- | Convert point to a vector. 104 | unPoint :: Point v n -> v n 105 | unPoint (Point.P x) = x 106 | 107 | -------------------------------------------------------------------------------- 108 | 109 | -- | Test whether two vectors are collinear. 110 | collinear :: (Foldable v, Num n, EqZero n) => v n -> v n -> Bool 111 | collinear v w = all f $ combinations 2 $ zipWith (,) v w 112 | where 113 | f [(a, b), (c, d)] = eqZero $ a*d - b*c 114 | f _ = False -- To silence exhaustiveness checker 115 | 116 | -- | All n-combinations of a given list. 117 | combinations :: Int -> [a] -> [[a]] 118 | combinations k is 119 | | k <= 0 = [ [] ] 120 | | otherwise = [ x:r | x:xs <- tails is, r <- combinations (k-1) xs ] 121 | 122 | -- | Zip two `Foldable` structures to a list with a given function. 123 | zipWith :: Foldable f => (a -> b -> c) -> f a -> f b -> [c] 124 | zipWith f a b = List.zipWith f (toList a) (toList b) 125 | 126 | -- | Test co-incidence of two planes assuming collinearity. 127 | coincidence :: (Foldable v, Num n, EqZero n) => Plane v n -> Plane v n -> Bool 128 | coincidence (Plane v1 d1) (Plane v2 d2) = all f $ zipWith (,) v1 v2 129 | where 130 | f (x1, x2) = eqZero $ x1*d2 - x2*d1 131 | 132 | -- | Test co-orientation of two assuming collinearity. 133 | coorientation :: (Foldable v, Num n, Ord n, EqZero n) 134 | => Plane v n -> Plane v n -> Bool 135 | coorientation (Plane v1 d1) (Plane v2 d2) 136 | = all geqZero $ d1*d2 : zipWith (*) v1 v2 137 | 138 | -------------------------------------------------------------------------------- 139 | 140 | data PlanesRelation = Parallel Incidence Orientation | Crossing deriving Show 141 | data Incidence = CoIncident | NonIncident deriving Show 142 | data Orientation = CoOriented | AntiOriented deriving Show 143 | 144 | -- | Relate two planes on Parallelism, Incidence and Orientation. 145 | planesRelation :: (Foldable v, Num n, Ord n, EqZero n) 146 | => Plane v n -> Plane v n -> PlanesRelation 147 | planesRelation p1@(Plane v1 _) p2@(Plane v2 _) 148 | | collinear v1 v2 = Parallel incidence orientation 149 | | otherwise = Crossing 150 | where 151 | incidence = bool NonIncident CoIncident $ coincidence p1 p2 152 | orientation = bool AntiOriented CoOriented $ coorientation p1 p2 153 | 154 | isParallel :: (Foldable v, Num n, Ord n, EqZero n) 155 | => Plane v n -> Plane v n -> Bool 156 | isParallel a b = case planesRelation a b of 157 | Parallel _ _ -> True 158 | Crossing -> False 159 | 160 | -------------------------------------------------------------------------------- /src/Geometry/SetOperations.hs: -------------------------------------------------------------------------------- 1 | {-# Language ConstraintKinds #-} 2 | {-# OPTIONS_HADDOCK prune #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Geometry.SetOperations 6 | -- Copyright : (C) 2017 Maksymilian Owsianny 7 | -- License : BSD-style (see LICENSE) 8 | -- Maintainer : Maksymilian.Owsianny@gmail.com 9 | -- 10 | -- Set Operations of Polytopes. You can read about implementation details of 11 | -- this algorithm in a dedicated . 12 | -- 13 | -- Small example: 14 | -- 15 | -- > test :: SetOperation -> Double -> PolyT3D 16 | -- > test op t = fromVolume $ merge op boxA boxB 17 | -- > where 18 | -- > boxA = cube 19 | -- > boxB = toVolume $ Poly3 (papply tr <$> ps) is 20 | -- > Poly3 ps is = cubePoly3 21 | -- > tr = translation (V3 (sin (t*0.3) * 0.3) 0.2 0.3) 22 | -- > <> aboutX (t*20 @@ deg) 23 | -- > <> aboutY (t*3 @@ deg) 24 | -- 25 | -- Rendered: 26 | -- 27 | -- <> 28 | -- 29 | -------------------------------------------------------------------------------- 30 | module Geometry.SetOperations ( 31 | 32 | -- * Base Functionality 33 | Volume, emptyVolume 34 | , toVolume, fromVolume 35 | 36 | , SetOperation (..) 37 | , merge, merges 38 | 39 | -- * Selected Merge Operations 40 | , union, unions 41 | , intersection, intersections 42 | , difference, differences 43 | 44 | -- * Conversion from/to BReps 45 | , FromPolytopeRep 46 | , ToPolytopeRep 47 | 48 | , Poly3 (..) 49 | , PolyT3 (..) 50 | 51 | -- * Primitives 52 | , cubePoly3, cube 53 | 54 | -- * Specializations/Synonyms 55 | , toVolume3D 56 | , fromVolume3D 57 | , Volume2D, Volume3D 58 | 59 | , Poly3D 60 | , PolyT3D 61 | , Merge 62 | 63 | ) where 64 | 65 | import Protolude 66 | 67 | import Linear 68 | import Linear.Affine (Point) 69 | import qualified Linear.Affine as Point 70 | 71 | import qualified Data.Vector as T 72 | 73 | import Geometry.SetOperations.Types 74 | import Geometry.SetOperations.Volume 75 | import Geometry.SetOperations.Clip 76 | import Geometry.SetOperations.BRep 77 | 78 | -------------------------------------------------------------------------------- 79 | 80 | -- | Convert an arbitrary polytope boundary representation into a Volume. 81 | toVolume :: (FromPolytopeRep p b v n, Clip b v n, Functor v, Num n) 82 | => p v n -> Volume b v n 83 | toVolume = makeVolume . fromPolytopeRep 84 | 85 | -- | Recover a boundary representation of a Volume. 86 | fromVolume :: ToPolytopeRep p b v n => Volume b v n -> p v n 87 | fromVolume = toPolytopeRep . volumeFacets 88 | 89 | -- | Convert a simple 3-BRep polyhedron to a Volume. 90 | toVolume3D :: Poly3D -> Volume3D 91 | toVolume3D = toVolume 92 | 93 | -- | Reconstruct a triangulated 3-BRep from a Volume. 94 | fromVolume3D :: Volume3D -> PolyT3D 95 | fromVolume3D = fromVolume 96 | 97 | -------------------------------------------------------------------------------- 98 | 99 | type Merge b v n = (Clip b v n, Functor v, Num n) 100 | 101 | -- | Merge two Volumes under a specified Set Operation. 102 | merge :: Merge b v n 103 | => SetOperation -> Volume b v n -> Volume b v n -> Volume b v n 104 | merge = mergeVolumes 105 | 106 | -- | Merges list of Volumes under a specified Set Operation. Empty list equals 107 | -- empty set. 108 | merges :: Merge b v n => SetOperation -> [Volume b v n] -> Volume b v n 109 | merges _ [] = emptyVolume 110 | merges op (v:vs) = foldl' (merge op) v vs 111 | -- As to not leak memory on folding just a strict left fold is not enough. The 112 | -- merge operation also needs to be strict since it operates on record with lazy 113 | -- fields of spine lazy structures. Should I change representation to strict or 114 | -- just deepseq it here? TODO: Fix this. 115 | 116 | -------------------------------------------------------------------------------- 117 | 118 | -- | Union of two volumes. Convenience synonym for `merge Union` 119 | union :: Merge b v n => Volume b v n -> Volume b v n -> Volume b v n 120 | union = merge Union 121 | 122 | -- | Union of list of volumes. 123 | unions :: Merge b v n => [Volume b v n] -> Volume b v n 124 | unions = merges Union 125 | 126 | -- | Intersection of two volumes. 127 | intersection :: Merge b v n => Volume b v n -> Volume b v n -> Volume b v n 128 | intersection = merge Intersection 129 | 130 | -- | Intersection of list of volumes. 131 | intersections :: Merge b v n => [Volume b v n] -> Volume b v n 132 | intersections = merges Intersection 133 | 134 | -- | Difference between two volumes. 135 | difference :: Merge b v n => Volume b v n -> Volume b v n -> Volume b v n 136 | difference = merge Difference 137 | 138 | -- | Subtract list of volumes from a given volume. 139 | differences :: Merge b v n => Volume b v n -> [Volume b v n] -> Volume b v n 140 | differences = foldl' (merge Difference) 141 | 142 | -------------------------------------------------------------------------------- 143 | 144 | p3 :: a -> a -> a -> Point V3 a 145 | p3 x y z = Point.P $ V3 x y z 146 | 147 | -- | Cube represented as a denormalized list of polygons. 148 | cubePoly3 :: Poly3D 149 | cubePoly3 = Poly3 (T.fromList ps) is 150 | where 151 | ps = map (subtract 0.5) $ 152 | [ p3 0 0 0, p3 1 0 0, p3 1 0 1, p3 0 0 1 153 | , p3 0 1 0, p3 1 1 0, p3 1 1 1, p3 0 1 1 ] 154 | 155 | is = map reverse 156 | [ [ 0, 1, 2, 3 ] 157 | , [ 1, 5, 6, 2 ] 158 | , [ 3, 2, 6, 7 ] 159 | , [ 0, 3, 7, 4 ] 160 | , [ 7, 6, 5, 4 ] 161 | , [ 0, 4, 5, 1 ] 162 | ] 163 | 164 | -- | Cube volume. 165 | cube :: Volume3D 166 | cube = toVolume cubePoly3 167 | 168 | -------------------------------------------------------------------------------- /src/Geometry/SetOperations/BRep.hs: -------------------------------------------------------------------------------- 1 | {-# Language MultiParamTypeClasses #-} 2 | {-# Language TypeSynonymInstances #-} 3 | {-# Language FlexibleInstances #-} 4 | {-# Language FlexibleContexts #-} 5 | -------------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Geometry.SetOperations.BRep 8 | -- Copyright : (C) 2017 Maksymilian Owsianny 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : Maksymilian.Owsianny@gmail.com 11 | -- 12 | -- Boundary representations for conversion to and from BSP/Volumes. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | module Geometry.SetOperations.BRep 16 | ( FromPolytopeRep (..) 17 | , ToPolytopeRep (..) 18 | 19 | , Poly3 (..), Poly3D 20 | , PolyT3 (..), PolyT3D 21 | ) where 22 | 23 | import Protolude 24 | import Linear.Affine (Point) 25 | import Linear 26 | import qualified Data.Map as Map 27 | 28 | import Data.EqZero 29 | 30 | -- import qualified Data.Vector.Generic as Vector 31 | import Data.Vector.Generic ((!)) 32 | import qualified Data.Vector as T 33 | 34 | import Geometry.Plane.General 35 | import Geometry.SetOperations.Facet 36 | import Geometry.SetOperations.CrossPoint 37 | import Geometry.SetOperations.Clip 38 | 39 | -- | Convert from polytope to a list of Facets. 40 | class FromPolytopeRep p b v n where 41 | fromPolytopeRep :: p v n -> [Facet b v n] 42 | 43 | -- | Convert from list of Facets to a polytope boundary representation. 44 | class ToPolytopeRep p b v n where 45 | toPolytopeRep :: [Facet b v n] -> p v n 46 | 47 | -------------------------------------------------------------------------------- 48 | 49 | -- | Indexed 3-BRep as a list of convex polygons. Continent as a way to 50 | -- introduce new base shapes into the constructive geometry context. 51 | data Poly3 v n = Poly3 (T.Vector (Point v n)) [[Int]] 52 | type Poly3D = Poly3 V3 Double 53 | 54 | instance ( MakePlane v n, Eq (v n), Foldable v, Applicative v, R3 v 55 | , Num n, Ord n, EqZero n 56 | ) => FromPolytopeRep Poly3 (FB3 v n) v n where 57 | fromPolytopeRep = makeFacets3 58 | 59 | {-# SPECIALIZE makeFacets3 :: Poly3D -> [Facet3D] #-} 60 | 61 | -- I assume valid indexes for now, without checks. 62 | -- Will need to make it safe in the future. 63 | -- There is also assumption that each point is shared by 3 planes 64 | -- and that each eadge is shared by 2 planes. 65 | makeFacets3 :: (MakePlane v n, Foldable v, Applicative v, R3 v, Ord n, EqZero n) 66 | => (Num n, Eq (v n)) 67 | => Poly3 v n -> [Facet (FB3 v n) v n] 68 | makeFacets3 (Poly3 ps is) = zipWith Facet planes boundries 69 | where 70 | points = map (map (ps!)) is 71 | planes = map (\(a:b:c:_) -> unsafeMakePlane $ vec3 a b c) points 72 | 73 | mkPlaneEdge (p, es) = map (,[p]) es 74 | 75 | edges = map (map mkOrdPair . edges2) is 76 | edgesMap = Map.fromListWith (<>) $ concatMap mkPlaneEdge $ zip planes edges 77 | 78 | edgePlanePairs = map (mapMaybe (flip Map.lookup edgesMap)) edges 79 | edgePlanes = zipWith edgeOnly planes edgePlanePairs 80 | edgeOnly p es = map (\(a:b:_) -> if p == a then b else a) es 81 | 82 | uniqueCrossPoints = fmap toCrossPoint ps 83 | crossPoints = map (map (uniqueCrossPoints!)) is 84 | 85 | boundries = zipWith (\a b -> zip a b) crossPoints edgePlanes 86 | 87 | data OrdPair a = OrdPair !a !a deriving (Show, Eq, Ord) 88 | mkOrdPair :: Ord a => (a, a) -> OrdPair a 89 | mkOrdPair (a, b) = if a > b then OrdPair a b else OrdPair b a 90 | 91 | {-# INLINE edges2 #-} 92 | edges2 :: [a] -> [(a,a)] 93 | edges2 as = zip as (drop 1 $ cycle as) 94 | 95 | -------------------------------------------------------------------------------- 96 | 97 | -- | Simple direct 3-BRep as a list of triangles. Useful as an output after 98 | -- performing specified set operations of the base shapes for rendering. 99 | newtype PolyT3 v n = PolyT3 [ [Point v n] ] 100 | 101 | type PolyT3D = PolyT3 V3 Double 102 | 103 | instance ToPolytopeRep PolyT3 (FB3 v n) v n where 104 | toPolytopeRep fs = PolyT3 (concatMap f fs) 105 | where 106 | f (Facet _ bd) = tris $ map (getPoint . fst) bd 107 | 108 | tris :: [a] -> [[a]] 109 | tris ps = take triNum $ concat $ zipWith mkTri pps rps 110 | where 111 | triNum = length ps - 2 112 | pps = egs ps 113 | rps = egs $ reverse ps 114 | egs xs = zip xs $ drop 1 xs 115 | mkTri (a,b) (n,m) = [[a, m, n], [m, a, b]] 116 | 117 | -------------------------------------------------------------------------------- /src/Geometry/SetOperations/BSP.hs: -------------------------------------------------------------------------------- 1 | {-# Language PatternSynonyms #-} 2 | {-# Language DeriveFunctor #-} 3 | {-# Language OverloadedStrings #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Geometry.SetOperations.BSP 7 | -- Copyright : (C) 2017 Maksymilian Owsianny 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : Maksymilian.Owsianny@gmail.com 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Geometry.SetOperations.BSP 13 | ( BinaryTree (..) 14 | , LeafColor (..) 15 | , swapColor 16 | 17 | , BSP 18 | , cmp 19 | , pattern In 20 | , pattern Out 21 | 22 | , constructBSP 23 | , splitWith 24 | , destructBinaryTree 25 | 26 | , prettyBSP, renderH, denormalizeBSP 27 | ) where 28 | 29 | import Prelude (id) 30 | import Protolude hiding ((<>)) 31 | import Data.Monoid ((<>)) 32 | 33 | import Lens.Family (over) 34 | import Lens.Family.Stock (both) 35 | -- import Control.Lens (over, both) 36 | 37 | import Data.List (unzip) 38 | import Data.IntMap (IntMap) 39 | import qualified Data.IntMap as IntMap 40 | import qualified Data.Map as Map 41 | 42 | import Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>), dot, empty) 43 | 44 | -- import Geometry.Plane.General 45 | import Geometry.SetOperations.Facet 46 | import Geometry.SetOperations.Clip 47 | 48 | -------------------------------------------------------------------------------- 49 | 50 | -- | Binary Tree parametrized by leafs and nodes 51 | data BinaryTree l n 52 | = Node (BinaryTree l n) !n (BinaryTree l n) 53 | | Leaf !l 54 | deriving (Eq, Show, Functor) 55 | 56 | instance Bifunctor BinaryTree where 57 | bimap f _ (Leaf x) = Leaf (f x) 58 | bimap f g (Node l n r) = Node (bimap f g l) (g n) (bimap f g r) 59 | 60 | data LeafColor = Green | Red deriving (Eq, Show) 61 | 62 | {-# INLINE swapColor #-} 63 | swapColor :: LeafColor -> LeafColor 64 | swapColor Green = Red 65 | swapColor Red = Green 66 | 67 | type BSP = BinaryTree LeafColor 68 | 69 | -- | Complementary set 70 | cmp :: BSP a -> BSP a 71 | cmp = first swapColor 72 | 73 | pattern In :: BSP a 74 | pattern In = Leaf Green 75 | 76 | pattern Out :: BSP a 77 | pattern Out = Leaf Red 78 | 79 | -------------------------------------------------------------------------------- 80 | 81 | constructBSP :: Clip b v n => (Facet b v n -> c) -> [Facet b v n] -> BSP c 82 | constructBSP _ [] = Out 83 | constructBSP f (facet@(Facet s _):fs) = case splitWith (splitFacet s) fs of 84 | ([], rs) -> Node In c (constructBSP f rs) 85 | (ls, []) -> Node (constructBSP f ls) c Out 86 | (ls, rs) -> Node (constructBSP f ls) c (constructBSP f rs) 87 | where 88 | c = f facet 89 | 90 | splitWith :: (a -> (Maybe a, Maybe a)) -> [a] -> ([a], [a]) 91 | splitWith f = over both catMaybes . unzip . map f 92 | 93 | destructBinaryTree :: BinaryTree l n -> [n] 94 | destructBinaryTree = flip go [] 95 | where 96 | go (Node l p r) = (p:) . go l . go r 97 | go _ = identity 98 | 99 | -------------------------------------------------------------------------------- 100 | -- Pretty Printing - for debugging 101 | -------------------------------------------------------------------------------- 102 | 103 | type Context k = k -> Doc 104 | 105 | -- | Pretty print BSP tree to stdout. 106 | prettyBSP :: (Ord f) => BSP f -> IO () 107 | prettyBSP bsp = putDoc $ renderH id int bspId <+> linebreak 108 | where 109 | (bspId, _) = denormalizeBSP bsp 110 | 111 | -- | Render BSP into a horizontal tree with a given context. 112 | renderH :: (Doc -> Doc) -> Context k -> BSP k -> Doc 113 | renderH _ _ In = dullcyan "✔" 114 | renderH _ _ Out = red "✗" 115 | renderH ind k (Node left pivot right) = vcat 116 | [ dullblue (k pivot) 117 | , ind $ "├ " <> renderH (ind . ("│ "<>)) k left 118 | , ind $ "└ " <> renderH (ind . (" "<>)) k right 119 | ] 120 | 121 | -- | Denormalize BSP with integers at nodes and IntMap of values. 122 | denormalizeBSP :: Ord n => BSP n -> (BSP Int, IntMap n) 123 | denormalizeBSP bsp = (fmap f bsp, fsMap) 124 | where 125 | fs = ordNub $ destructBinaryTree bsp 126 | isMap = Map.fromList $ zip fs [0..] 127 | fsMap = IntMap.fromList $ zip [0..] fs 128 | 129 | f p = Map.findWithDefault (-1) p isMap 130 | 131 | -------------------------------------------------------------------------------- /src/Geometry/SetOperations/Clip.hs: -------------------------------------------------------------------------------- 1 | {-# Language MultiParamTypeClasses #-} 2 | {-# Language TypeSynonymInstances #-} 3 | {-# Language FlexibleInstances #-} 4 | {-# Language DefaultSignatures #-} 5 | -------------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Geometry.SetOperations.Clip 8 | -- Copyright : (C) 2017 Maksymilian Owsianny 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : Maksymilian.Owsianny@gmail.com 11 | -- 12 | -------------------------------------------------------------------------------- 13 | module Geometry.SetOperations.Clip 14 | ( Clip (..) 15 | , vec3 16 | ) where 17 | 18 | import Data.Function (id) 19 | import Data.List (zipWith3, unzip) 20 | import Protolude 21 | import Linear 22 | import Lens.Family ((.~), over) 23 | import Lens.Family.Stock (both) 24 | -- import Control.Lens ((.~), over, both) 25 | 26 | import Data.EqZero 27 | import Geometry.Plane.General 28 | import Geometry.SetOperations.Facet 29 | import Geometry.SetOperations.CrossPoint 30 | 31 | -------------------------------------------------------------------------------- 32 | 33 | class Clip b v n where 34 | clipFacet :: Plane v n -- ^ Clipping plane 35 | -> Facet b v n -- ^ Facet to clip 36 | -> Maybe (Facet b v n) 37 | 38 | splitFacet :: Plane v n -- ^ Splitting plane 39 | -> Facet b v n -- ^ Facet to split 40 | -> (Maybe (Facet b v n), Maybe (Facet b v n)) 41 | 42 | clipFacet p f = fst $ splitFacet p f 43 | default splitFacet :: (Functor v, Num n) 44 | => Plane v n -> Facet b v n 45 | -> (Maybe (Facet b v n), Maybe (Facet b v n)) 46 | splitFacet p f = (clipFacet p f, clipFacet (flipPlane p) f) 47 | 48 | {-# MINIMAL (clipFacet | splitFacet) #-} 49 | 50 | -------------------------------------------------------------------------------- 51 | 52 | splitCoincident :: (Foldable v, Num n, Ord n, EqZero n) 53 | => Plane v n -> Facet b v n 54 | -> (Maybe (Facet b v n), Maybe (Facet b v n)) 55 | -> (Maybe (Facet b v n), Maybe (Facet b v n)) 56 | splitCoincident h f@(Facet s _) othercase = case planesRelation h s of 57 | Parallel CoIncident CoOriented -> (Just f, Nothing) 58 | Parallel CoIncident AntiOriented -> (Nothing, Just f) 59 | _ -> othercase 60 | 61 | vec2 :: (R2 v, Applicative v) => n -> n -> v n 62 | vec2 x y = pure x & _xy .~ (V2 x y) 63 | 64 | instance 65 | ( MakeCrossPoint v n, R2 v, Applicative v 66 | , Foldable v, Num n, Ord n, EqZero n ) 67 | => Clip (FB2 v n) v n where 68 | splitFacet h f@(Facet s (a, b)) = splitCoincident h f othercase 69 | where 70 | mc = makeCrossPoint $ vec2 h s 71 | go x y = Just $ Facet s (x, y) 72 | 73 | othercase = table (orientation a h) (orientation b h) 74 | table P M = (mc >>= \c -> go a c, mc >>= \c -> go c b) 75 | table M P = (mc >>= \c -> go c b, mc >>= \c -> go a c) 76 | table P _ = (Just f, Nothing) 77 | table _ P = (Just f, Nothing) 78 | table M _ = (Nothing, Just f) 79 | table _ M = (Nothing, Just f) 80 | -- This last case is not needed and is only here for completeness. 81 | -- It could happen if someone wrongly created a facet with edge 82 | -- points not lying on the facet plane (line). In such case, that 83 | -- facet is simply discarded by the splitting function. 84 | table Z Z = (Nothing, Nothing) 85 | 86 | -------------------------------------------------------------------------------- 87 | 88 | vec3 :: (R3 v, Applicative v) => n -> n -> n -> v n 89 | vec3 x y z = pure x & _xyz .~ (V3 x y z) 90 | 91 | instance 92 | ( MakeCrossPoint v n, R3 v, Applicative v 93 | , Foldable v, Num n, Ord n, EqZero n ) 94 | => Clip (FB3 v n) v n where 95 | splitFacet h f@(Facet s ps) = splitCoincident h f othercase 96 | where 97 | mc v = makeCrossPoint $ vec3 s h v 98 | go ops@(_:_:_:_) = Just $ Facet s ops 99 | go _ = Nothing 100 | ss = map (flip orientation h . fst) ps 101 | 102 | othercase = over both go $ splitFast mc h ss ps 103 | 104 | splitFast 105 | :: (p -> Maybe c) -- ^ Make CrossPoint from V 106 | -> p -- ^ Clipping plane H 107 | -> [Sign] -- ^ Points signs relative to H 108 | -> [(c, p)] -- ^ Cross Boundry 109 | -> ([(c, p)], [(c, p)]) -- ^ Result 110 | splitFast mkP h ss pvs 111 | | all (/= M) ss = (pvs, []) 112 | | all (/= P) ss = ([], pvs) 113 | | otherwise = (compose outPlus, compose outMinus) 114 | where 115 | (outPlus, outMinus) = unzip $ zipWith3 table pvs ss (dropCycle 1 ss) 116 | 117 | table (p, v) P M = case mkP v of 118 | Nothing -> (mk1 (p, v), id) 119 | Just c -> (mk2 (p, v) (c, h), mk1 (c, v)) 120 | table (p, v) M P = case mkP v of 121 | Nothing -> (id, mk1 (p, v)) 122 | Just c -> (mk1 (c, v), mk2 (p, v) (c, h)) 123 | 124 | table (p, v) Z M = (mk1 (p, v), mk1 (p, h)) 125 | table (p, v) Z P = (mk1 (p, h), mk1 (p, v)) 126 | 127 | table pv P _ = (mk1 pv, id) 128 | table pv M _ = (id, mk1 pv) 129 | 130 | table _ _ _ = (id, id) -- This case should never happen 131 | -- If it happens it means that it's a concave boundry. 132 | 133 | {-# INLINE compose #-} 134 | compose :: [([a] -> [a])] -> [a] 135 | compose fs = foldr (.) id fs [] 136 | 137 | {-# INLINE mk1 #-} 138 | mk1 :: a -> ([a] -> [a]) 139 | mk1 a = (a:) 140 | 141 | {-# INLINE mk2 #-} 142 | mk2 :: a -> a -> ([a] -> [a]) 143 | mk2 a b = (a:) . (b:) 144 | 145 | {-# INLINE dropCycle #-} 146 | dropCycle :: Int -> [a] -> [a] 147 | dropCycle n = drop n . cycle 148 | 149 | -------------------------------------------------------------------------------- /src/Geometry/SetOperations/CrossPoint.hs: -------------------------------------------------------------------------------- 1 | {-# Language MultiParamTypeClasses #-} 2 | {-# Language FlexibleInstances #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Geometry.SetOperations.CrossPoint 6 | -- Copyright : (C) 2017 Maksymilian Owsianny 7 | -- License : BSD-style (see LICENSE) 8 | -- Maintainer : Maksymilian.Owsianny@gmail.com 9 | -- 10 | -------------------------------------------------------------------------------- 11 | module Geometry.SetOperations.CrossPoint 12 | ( Sign (..) 13 | , toSign 14 | 15 | , CrossPoint (..) 16 | , MakeCrossPoint (..) 17 | , toCrossPoint 18 | 19 | ) where 20 | 21 | import Protolude 22 | import Linear 23 | import Linear.Affine (Point) 24 | import qualified Linear.Affine as Point 25 | 26 | import Data.EqZero 27 | import Geometry.Plane.General 28 | 29 | -------------------------------------------------------------------------------- 30 | 31 | data Sign = M | Z | P deriving (Show, Eq) 32 | 33 | toSign :: (EqZero n, Ord n, Num n) => n -> Sign 34 | toSign x 35 | | eqZero x = Z 36 | | x < 0 = M 37 | | otherwise = P 38 | 39 | data CrossPoint v n = CP 40 | { orientation :: Plane v n -> Sign 41 | , getPoint :: Point v n 42 | } 43 | 44 | -- | Convert a point to CrossPoint 45 | toCrossPoint :: (EqZero n, Foldable v, Num n, Ord n) 46 | => Point v n -> CrossPoint v n 47 | toCrossPoint pt = CP orient pt 48 | where 49 | orient p = toSign . ((planeLast p) +) . sum 50 | $ zipWith (*) (toList $ planeVector p) (toList pt) 51 | 52 | class MakeCrossPoint v n where 53 | makeCrossPoint :: v (Plane v n) -> Maybe (CrossPoint v n) 54 | 55 | instance (Fractional n, Ord n, EqZero n) => MakeCrossPoint V2 n where 56 | makeCrossPoint planes 57 | | eqZero d2 = Nothing 58 | | otherwise = Just $ CP orient solved 59 | where 60 | V2 (Plane (V2 a b) c) 61 | (Plane (V2 d e) f) = planes 62 | -- orient (Plane (V2 g h) i) = toSign $ d2*(g*d0 - h*d1 + i*d2) 63 | orient (Plane (V2 g h) i) = toSign $ g*dd0 + h*dd1 + i 64 | 65 | dd0 = d2*d0 66 | dd1 = d2*d1 67 | 68 | d0 = b*f - c*e 69 | d1 = a*f - c*d 70 | d2 = a*e - b*d 71 | 72 | dd = 1/d2 73 | solved = Point.P $ V2 (dd*d0) (dd*d1) 74 | 75 | instance (Fractional n, Ord n, EqZero n) => MakeCrossPoint V3 n where 76 | makeCrossPoint planes 77 | | eqZero d3 = Nothing 78 | | otherwise = Just $ CP orient solved 79 | where 80 | V3 (Plane (V3 a b c) d) 81 | (Plane (V3 e f g) h) 82 | (Plane (V3 i j k) l) = planes 83 | orient (Plane (V3 m n o) p) = toSign $ -d3*(m*d0 - n*d1 + o*d2 - p*d3) 84 | 85 | d0 = k*m1 - j*m0 + l*m2 86 | d1 = k*m3 - i*m0 + l*m4 87 | d2 = j*m3 - i*m1 + l*m5 88 | d3 = i*m2 - j*m4 + k*m5 89 | 90 | m0 = c*h - d*g 91 | m1 = b*h - d*f 92 | m2 = c*f - b*g 93 | m3 = a*h - d*e 94 | m4 = c*e - a*g 95 | m5 = b*e - a*f 96 | 97 | dd = 1/d3 98 | solved = Point.P $ V3 (-dd*d0) (dd*d1) (-dd*d2) 99 | 100 | -------------------------------------------------------------------------------- /src/Geometry/SetOperations/Facet.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Geometry.SetOperations.Facet 4 | -- Copyright : (C) 2017 Maksymilian Owsianny 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : Maksymilian.Owsianny@gmail.com 7 | -- 8 | -------------------------------------------------------------------------------- 9 | module Geometry.SetOperations.Facet 10 | ( Facet (..) 11 | , Facet2D, Facet3D 12 | , flipFacet 13 | , FB2, FB3 14 | 15 | ) where 16 | 17 | import Protolude 18 | import Linear (V2, V3) 19 | 20 | import Geometry.Plane.General 21 | import Geometry.SetOperations.CrossPoint 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | data Facet b v n = Facet 26 | { facetPlane :: Plane v n 27 | , facetBoundary :: b 28 | } 29 | 30 | -- | Flip orientation of a facet. 31 | flipFacet :: (Functor v, Num n) => Facet b v n -> Facet b v n 32 | flipFacet (Facet p b) = Facet (flipPlane p) b 33 | 34 | type FB3 v n = [(CrossPoint v n, Plane v n)] 35 | type FB2 v n = (CrossPoint v n, CrossPoint v n) 36 | 37 | type Facet2D = Facet (FB2 V2 Double) V2 Double 38 | type Facet3D = Facet (FB3 V3 Double) V3 Double 39 | 40 | -------------------------------------------------------------------------------- /src/Geometry/SetOperations/Merge.hs: -------------------------------------------------------------------------------- 1 | {-# Language MultiParamTypeClasses #-} 2 | {-# Language TypeSynonymInstances #-} 3 | {-# Language FlexibleInstances #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Geometry.SetOperations.Merge 7 | -- Copyright : (C) 2017 Maksymilian Owsianny 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : Maksymilian.Owsianny@gmail.com 10 | -- 11 | -- Set Operations of Polytopes by BSP Merging. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | module Geometry.SetOperations.Merge 15 | ( BSP 16 | , BSP3D, BSP2D 17 | 18 | , Universe (..) 19 | , universePlanes, universeBox 20 | , splitRegion 21 | 22 | , mergeBSPs 23 | , trim 24 | 25 | , makeBSP 26 | , toBoundary 27 | ) where 28 | 29 | import Protolude 30 | import Prelude (id) 31 | 32 | import Lens.Family (over) 33 | import Lens.Family.Stock (both, _2) 34 | -- import Control.Lens (over, both, _2) 35 | 36 | import Data.Maybe (fromMaybe, fromJust) 37 | import Linear 38 | 39 | import Geometry.SetOperations.Types 40 | import Geometry.SetOperations.BSP 41 | import Geometry.SetOperations.Facet 42 | import Geometry.SetOperations.CrossPoint 43 | import Geometry.SetOperations.Clip 44 | import Geometry.Plane.General 45 | import Data.EqZero 46 | 47 | type BSP2D = BSP Facet2D 48 | type BSP3D = BSP Facet3D 49 | 50 | -------------------------------------------------------------------------------- 51 | 52 | -- Arbitrary selected as sufficient by independent comity (not really). 53 | universeSize :: Num n => n 54 | universeSize = 500 55 | 56 | clipPlanes :: Clip b v n => Facet b v n -> [Plane v n] -> Facet b v n 57 | clipPlanes = foldr (\p f -> fromMaybe f $ clipFacet p f) 58 | 59 | class Clip b v n => Universe b v n where 60 | -- | Turn plane into a Facet by clipping it by the universe box. 61 | makeFacet :: Plane v n -> Facet b v n 62 | 63 | instance (Ord n, Fractional n, EqZero n) => Universe (FB2 V2 n) V2 n where 64 | makeFacet p = clipPlanes baseFacet ps 65 | where 66 | baseFacet = Facet p (a, b) 67 | Just a = makeCrossPoint (V2 p pa) 68 | Just b = makeCrossPoint (V2 p pb) 69 | (pa:pb:ps) = filter (not . isParallel p) universePlanes 70 | 71 | instance (Ord n, Fractional n, EqZero n) => Universe (FB3 V3 n) V3 n where 72 | makeFacet p = Facet p es 73 | where 74 | ps = filter (not . isParallel p) universePlanes 75 | es = zipWith mkBd ps $ drop 1 $ cycle ps 76 | mkBd a b = (fromJust . makeCrossPoint $ V3 p a b, b) 77 | 78 | -- | Planes bounding the UniverseBox. 79 | universePlanes :: (Applicative v, Traversable v, Num n) => [Plane v n] 80 | universePlanes = positive ++ negative 81 | where 82 | toPlane v = Plane v universeSize 83 | positive = map toPlane (basisFor $ pure 0) 84 | negative = map flipPlane positive 85 | 86 | -- | List of facets bounding the Universe. 87 | universeBox :: (Universe b v n, Applicative v, Traversable v, Num n) 88 | => [Facet b v n] 89 | universeBox = map makeFacet universePlanes 90 | 91 | -- | Split a region within a Universe bounded by a list of Facets. 92 | splitRegion :: (Universe b v n, Functor v, Num n) 93 | => Plane v n -> [Facet b v n] -> ([Facet b v n], [Facet b v n]) 94 | splitRegion h fs = (flipFacet lid : plusC, lid : minusC) 95 | where 96 | (plusC, minusC) = splitWith (splitFacet h) fs 97 | lid = clipPlanes (makeFacet h) (map facetPlane fs) 98 | 99 | {- 100 | type Merge b v n = 101 | (Universe b v n, Applicative v, Traversable v, Num n, Ord n, EqZero n) 102 | -} 103 | 104 | -- | Perform a given SetOperation of two BSPs by merging 105 | mergeBSPs 106 | :: (Universe b v n, Applicative v, Traversable v, Num n, Ord n, EqZero n) 107 | => SetOperation 108 | -> BSP (Facet b v n) 109 | -> BSP (Facet b v n) 110 | -> BSP (Facet b v n) 111 | mergeBSPs op (Node treeL p treeR) nodeR@(Node _ f _) = 112 | collapse $ Node mTreeL p mTreeR 113 | where 114 | ff = facetPlane f 115 | pp = facetPlane p 116 | regions = splitRegion ff universeBox 117 | (partL, partR) = partitionBSP regions pp nodeR 118 | mTreeL = mergeBSPs op treeL partL 119 | mTreeR = mergeBSPs op treeR partR 120 | mergeBSPs op s1 s2 = setOperation op s1 s2 121 | 122 | partitionBSP 123 | :: (Universe b v n, Functor v, Foldable v, Num n, Ord n, EqZero n) 124 | => ([Facet b v n], [Facet b v n]) 125 | -> Plane v n 126 | -> BSP (Facet b v n) 127 | -> (BSP (Facet b v n), BSP (Facet b v n)) 128 | partitionBSP _ _ (Leaf c) = (Leaf c, Leaf c) 129 | partitionBSP regions p (Node treeP f treeM) = case planesRelation p ff of 130 | Parallel CoIncident CoOriented -> (treeP, treeM) 131 | Parallel CoIncident AntiOriented -> (treeM, treeP) 132 | othercase -> if 133 | | null regionPR -> (Node treeP f treeML, treeMR) 134 | | null regionMR -> (Node treePL f treeM, treePR) 135 | | null regionPL -> (treeML, Node treeP f treeMR) 136 | | null regionML -> (treePL, Node treePR f treeM) 137 | 138 | | otherwise -> (Node treePL f treeML, Node treePR f treeMR) 139 | where 140 | ff = facetPlane f 141 | (treePL, treePR) = partitionBSP (regionPL, regionPR) p treeP 142 | (treeML, treeMR) = partitionBSP (regionML, regionMR) p treeM 143 | 144 | (regionP , regionM ) = regions 145 | (regionPL, regionPR) = splitRegion p regionP 146 | (regionML, regionMR) = splitRegion p regionM 147 | 148 | setOperation :: SetOperation -> BSP a -> BSP a -> BSP a 149 | 150 | setOperation Union In set = In 151 | setOperation Union Out set = set 152 | setOperation Union set In = In 153 | setOperation Union set Out = set 154 | 155 | setOperation Intersection In set = set 156 | setOperation Intersection Out set = Out 157 | setOperation Intersection set In = set 158 | setOperation Intersection set Out = Out 159 | 160 | setOperation Difference In set = cmp set 161 | setOperation Difference Out set = Out 162 | setOperation Difference set In = Out 163 | setOperation Difference set Out = set 164 | 165 | setOperation SymmetricDifference In set = cmp set 166 | setOperation SymmetricDifference Out set = set 167 | setOperation SymmetricDifference set In = cmp set 168 | setOperation SymmetricDifference set Out = set 169 | 170 | collapse :: BSP n -> BSP n 171 | collapse (Node In _ In ) = In 172 | collapse (Node Out _ Out) = Out 173 | collapse other = other 174 | 175 | isBoundary :: Clip b v n => BSP (Facet b v n) -> Facet b v n -> Bool 176 | isBoundary In _ = True 177 | isBoundary Out _ = False 178 | isBoundary (Node l s r) f = lcnd || rcnd 179 | where 180 | (lh, rh) = splitFacet (facetPlane s) f 181 | lcnd = fromMaybe False (isBoundary l <$> lh) 182 | rcnd = fromMaybe False (isBoundary r <$> rh) 183 | 184 | -- | Optimize a resulting BSP after merging by removing superficial splitting 185 | -- planes. 186 | trim :: Clip b v n => BSP (Facet b v n) -> BSP (Facet b v n) 187 | trim (Node Out f r) 188 | | isBoundary r f = Node Out f (trim r) 189 | | otherwise = trim r 190 | trim (Node l f Out) 191 | | isBoundary l f = Node (trim l) f Out 192 | | otherwise = trim l 193 | trim other = other 194 | 195 | -------------------------------------------------------------------------------- 196 | 197 | -- | Make a BSP from a list of bounding facets. 198 | makeBSP :: Clip b v n => [Facet b v n] -> BSP (Facet b v n) 199 | makeBSP = constructBSP id 200 | 201 | -- | Reconstruct boundary facets from the BSP. 202 | toBoundary :: (Clip b v n, Functor v, Num n) 203 | => BSP (Facet b v n) -> [Facet b v n] 204 | toBoundary bsp 205 | = removeColors 206 | . map (over _2 flipFacet) 207 | . applyColors 208 | $ destructBinaryTree bsp 209 | where 210 | applyColors xs = go xs bsp [] 211 | where 212 | go [] _ = id 213 | go fs In = foldr (\f cs -> ((True , f):) . cs) id fs 214 | go fs Out = foldr (\f cs -> ((False, f):) . cs) id fs 215 | go fs (Node l s r) = go ls l . go rs r 216 | where 217 | sp = facetPlane s 218 | (ls, rs) = splitWith (splitFacet sp) fs 219 | 220 | removeColors xs = go xs bsp [] 221 | where 222 | go [] _ = id 223 | go fs In = foldr (\(a,b) cs -> if not a then (b:) . cs else cs) id fs 224 | go fs Out = foldr (\(a,b) cs -> if a then (b:) . cs else cs) id fs 225 | go fs (Node l s r) = go ls l . go rs r 226 | where 227 | (ls, rs) = splitWith coloredSplit fs 228 | sp = facetPlane s 229 | coloredSplit (b, f) = over both (fmap (b,)) $ splitFacet sp f 230 | 231 | 232 | -------------------------------------------------------------------------------- /src/Geometry/SetOperations/Types.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Geometry.SetOperations.Types 4 | -- Copyright : (C) 2017 Maksymilian Owsianny 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : Maksymilian.Owsianny@gmail.com 7 | -- 8 | -------------------------------------------------------------------------------- 9 | module Geometry.SetOperations.Types 10 | ( SetOperation (..) 11 | ) where 12 | 13 | -------------------------------------------------------------------------------- 14 | 15 | -- | Four basic set operations: 16 | -- 17 | -- <> 18 | 19 | data SetOperation 20 | = Union 21 | | Intersection 22 | | Difference 23 | | SymmetricDifference 24 | 25 | -------------------------------------------------------------------------------- /src/Geometry/SetOperations/Volume.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Geometry.SetOperations.Volume 4 | -- Copyright : (C) 2017 Maksymilian Owsianny 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : Maksymilian.Owsianny@gmail.com 7 | -- 8 | -- Set Operations of Polytopes by Boundary Filtering. 9 | -- 10 | -------------------------------------------------------------------------------- 11 | module Geometry.SetOperations.Volume 12 | ( Volume (..) 13 | , makeVolume 14 | , emptyVolume 15 | , mergeVolumes 16 | 17 | , Volume2D, Volume3D 18 | ) where 19 | 20 | import Protolude 21 | import Linear (V2, V3) 22 | 23 | import Geometry.SetOperations.Merge 24 | import Geometry.SetOperations.Types 25 | import Geometry.SetOperations.BSP 26 | import Geometry.SetOperations.Facet 27 | import Geometry.SetOperations.Clip 28 | import Geometry.Plane.General 29 | 30 | -------------------------------------------------------------------------------- 31 | 32 | -- | Volume, currently represented as a list of Facets and a BSP Tree. 33 | data Volume b v n = Volume 34 | { volumeFacets :: [Facet b v n] 35 | , volumeTree :: BSP (Plane v n) 36 | } 37 | 38 | type Volume2D = Volume (FB2 V2 Double) V2 Double 39 | type Volume3D = Volume (FB3 V3 Double) V3 Double 40 | 41 | -- | Construct Volume from a list of Facets representing it's boundary. 42 | makeVolume :: Clip b v n => [Facet b v n] -> Volume b v n 43 | makeVolume fs = Volume fs (constructBSP facetPlane fs) 44 | 45 | -- | Empty volume. 46 | emptyVolume :: Volume b v n 47 | emptyVolume = Volume [] Out 48 | 49 | -------------------------------------------------------------------------------- 50 | 51 | {-# SPECIALIZE 52 | mergeVolumes :: SetOperation -> Volume2D -> Volume2D -> Volume2D #-} 53 | {-# SPECIALIZE 54 | mergeVolumes :: SetOperation -> Volume3D -> Volume3D -> Volume3D #-} 55 | 56 | -- | Merge two Volumes under a specified Set Operation. 57 | mergeVolumes :: (Clip b v n, Functor v, Num n) 58 | => SetOperation -> Volume b v n -> Volume b v n -> Volume b v n 59 | mergeVolumes op volumeA volumeB = case op of 60 | Difference -> filterBoth isOut isInFlip 61 | Intersection -> filterBoth isIn isIn 62 | Union -> filterBoth isOut isOut 63 | SymmetricDifference -> filterBoth isEither isEither 64 | where 65 | isInFlip x fs = case x of Red -> []; Green -> map flipFacet fs 66 | isIn x fs = case x of Red -> []; Green -> fs 67 | isOut x fs = case x of Red -> fs; Green -> [] 68 | isEither x fs = case x of Red -> fs; Green -> map flipFacet fs 69 | 70 | Volume facetsA treeA = volumeA 71 | Volume facetsB treeB = volumeB 72 | 73 | filterBoth f g = makeVolume $ 74 | filterWith f facetsA treeB <> 75 | filterWith g facetsB treeA 76 | 77 | filterWith _ [] _ = [] 78 | filterWith f fs t = case t of 79 | Leaf x -> f x fs 80 | Node treeL p treeR -> 81 | filterWith f partL treeL <> 82 | filterWith f partR treeR 83 | where (partL, partR) = splitWith (splitFacet p) fs 84 | 85 | --------------------------------------------------------------------------------