diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -47,7 +47,7 @@ * A KD-Tree. The base tree is static. HGeometry also includes a datastructure/data type for planar graphs. In -particular, it has a `EdgeOracle' data structure, that can be built in $O(n)$ +particular, it has a `EdgeOracle` data structure, that can be built in \(O(n)\) time that can test if the graph contains an edge in constant time. Numeric Types diff --git a/benchmark/Algorithms/Geometry/ConvexHull/Bench.hs b/benchmark/Algorithms/Geometry/ConvexHull/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/Bench.hs @@ -0,0 +1,72 @@ +module Algorithms.Geometry.ConvexHull.Bench where + +import qualified Algorithms.Geometry.ConvexHull.DivideAndConqueror as DivideAndConqueror +import qualified Algorithms.Geometry.ConvexHull.GrahamScan as GrahamScan + +-- | copies of the convex hull algo with different point types +import qualified Algorithms.Geometry.ConvexHull.GrahamV2 as GV +import qualified Algorithms.Geometry.ConvexHull.GrahamFam as GFam +import qualified Algorithms.Geometry.ConvexHull.GrahamFamPeano as GPeano +import qualified Algorithms.Geometry.ConvexHull.GrahamFam6 as GFam6 +import qualified Algorithms.Geometry.ConvexHull.GrahamFixed as GFix + + +import Benchmark.Util +import Control.DeepSeq +import Criterion.Main +import Criterion.Types +import Data.Ext +import Data.Geometry.Point +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Proxy +import Test.QuickCheck +import Test.QuickCheck.HGeometryInstances () + +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMainWith cfg [ benchmark ] + where + cfg = defaultConfig { reportFile = Just "bench.html" } + +benchmark :: Benchmark +benchmark = bgroup "convexHullBench" + [ env (genPts (Proxy :: Proxy Int) 10000) benchBuild + ] + +-------------------------------------------------------------------------------- + +genPts :: (Ord r, Arbitrary r) => proxy r -> Int -> IO (NonEmpty (Point 2 r :+ ())) +genPts _ n = generate (NonEmpty.fromList <$> vectorOf n arbitrary) + +-- | Benchmark building the convexHull +benchBuild :: (Ord r, Num r, NFData r) => NonEmpty (Point 2 r :+ ()) -> Benchmark +benchBuild ps = bgroup "build" [ bgroup (show n) (build $ take' n ps) + | n <- sizes' ps + ] + where + take' n = NonEmpty.fromList . NonEmpty.take n + sizes' _ = [2000] + + build pts = [ bench "sort" $ nf NonEmpty.sort pts + , bench "sort_Linear.V2" $ nf NonEmpty.sort ptsV2 + , bench "sort_FamPeano" $ nf NonEmpty.sort ptsFamPeano + , bench "sort_Family" $ nf NonEmpty.sort ptsFam + , bench "sort_Family6" $ nf NonEmpty.sort ptsFam6 + , bench "sort_Fixed" $ nf NonEmpty.sort ptsFix + + , bench "grahamScan" $ nf GrahamScan.convexHull pts + , bench "grahamScan_Linear.V2" $ nf GV.convexHull ptsV2 + , bench "grahamScan_FamPeano" $ nf GPeano.convexHull ptsFamPeano + , bench "grahamScan_Family" $ nf GFam.convexHull ptsFam + , bench "grahamScan_Fixed" $ nf GFix.convexHull ptsFix + + , bench "Div&Conq" $ nf DivideAndConqueror.convexHull pts + ] + where + ptsV2 = fmap (GV.fromP) pts + ptsFamPeano = fmap (GPeano.fromP) pts + ptsFam = fmap (GFam.fromP) pts + ptsFam6 = fmap (GFam6.fromP) pts + ptsFix = fmap (GFix.fromP) pts diff --git a/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam.hs b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE UndecidableInstances #-} +module Algorithms.Geometry.ConvexHull.GrahamFam( convexHull + , upperHull + , lowerHull, fromP + ) where + +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Ext +import Data.Geometry.Point +import qualified Data.Geometry.Vector.VectorFamily as VF +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import GHC.TypeLits + + +newtype MyPoint d r = MyPoint (VF.Vector d r) + +deriving instance (VF.Arity d, Eq r) => Eq (MyPoint d r) +deriving instance (VF.Arity d, Ord r) => Ord (MyPoint d r) +deriving instance (VF.Arity d, Show r) => Show (MyPoint d r) +deriving instance (NFData (VF.Vector d r)) => NFData (MyPoint d r) + +pattern MyPoint2 x y = MyPoint (VF.Vector2 x y) + + +-- instance (NFData r, Arity d) => NFData (MyPoint d r) where +-- rnf (MyPoint x y) = rnf (x,y) +-- rnf (MyP p) = rnf p + +toP :: MyPoint 2 r :+ e -> Point 2 r :+ e +toP (MyPoint2 x y :+ e) = Point2 x y :+ e + +fromP :: Point 2 r :+ e -> MyPoint 2 r :+ e +fromP (Point2 x y :+ e) = MyPoint2 x y :+ e + + +subt :: Num r => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r +(MyPoint2 x y) `subt` (MyPoint2 a b) = MyPoint2 (x-a) (y-b) + +newtype ConvexPolygon p r = ConvexPolygon [Point 2 r :+ p] deriving (Show,Eq,NFData) + +-- | \(O(n \log n)\) time ConvexHull using Graham-Scan. The resulting polygon is +-- given in clockwise order. +convexHull :: (Ord r, Num r) + => NonEmpty (MyPoint 2 r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon $ [toP p] +convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps + uh = NonEmpty.tail . hull' $ ps' + lh = NonEmpty.tail . hull' $ reverse ps' + in ConvexPolygon . map toP . reverse $ lh ++ uh + +upperHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +upperHull = hull id + + +lowerHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +lowerHull = hull reverse + + +-- | Helper function so that that can compute both the upper or the lower hull, depending +-- on the function f +hull :: (Ord r, Num r) + => ([MyPoint 2 r :+ p] -> [MyPoint 2 r :+ p]) + -> NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +hull _ h@(_ :| []) = h +hull f pts = hull' . f + . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts + +incXdecY :: Ord r => (MyPoint 2 r) :+ p -> (MyPoint 2 r) :+ q -> Ordering +incXdecY (MyPoint2 px py :+ _) (MyPoint2 qx qy :+ _) = + compare px qx <> compare qy py + + +-- | Precondition: The list of input points is sorted +hull' :: (Ord r, Num r) => [MyPoint 2 r :+ p] -> NonEmpty (MyPoint 2 r :+ p) +hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps + where + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' + + cleanMiddle h@[_,_] = h + cleanMiddle h@(z:y:x:rest) + | rightTurn (x^.core) (y^.core) (z^.core) = h + | otherwise = cleanMiddle (z:x:rest) + cleanMiddle _ = error "cleanMiddle: too few points" + +rightTurn :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> Bool +rightTurn a b c = ccwP a b c == CW + + + +ccwP :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> CCW +ccwP p q r = case z `compare` 0 of + LT -> CW + GT -> CCW + EQ -> CoLinear + where + + MyPoint2 ux uy = q `subt` p + MyPoint2 vx vy = r `subt` p + z = ux * vy - uy * vx diff --git a/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam6.hs b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam6.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam6.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE UndecidableInstances #-} +module Algorithms.Geometry.ConvexHull.GrahamFam6( convexHull + , upperHull + , lowerHull, fromP + ) where + +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Ext +import Data.Geometry.Point +import qualified Data.Geometry.Vector.VectorFamily6 as VF +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import GHC.TypeLits + + +newtype MyPoint d r = MyPoint (VF.Vector d r) + +deriving instance (VF.Arity d, Eq r) => Eq (MyPoint d r) +deriving instance (VF.Arity d, Ord r) => Ord (MyPoint d r) +deriving instance (VF.Arity d, Show r) => Show (MyPoint d r) +deriving instance (NFData (VF.Vector d r)) => NFData (MyPoint d r) + +pattern MyPoint2 x y = MyPoint (VF.Vector2 x y) + + +-- instance (NFData r, Arity d) => NFData (MyPoint d r) where +-- rnf (MyPoint x y) = rnf (x,y) +-- rnf (MyP p) = rnf p + +toP :: MyPoint 2 r :+ e -> Point 2 r :+ e +toP (MyPoint2 x y :+ e) = Point2 x y :+ e + +fromP :: Point 2 r :+ e -> MyPoint 2 r :+ e +fromP (Point2 x y :+ e) = MyPoint2 x y :+ e + + +subt :: Num r => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r +(MyPoint2 x y) `subt` (MyPoint2 a b) = MyPoint2 (x-a) (y-b) + +newtype ConvexPolygon p r = ConvexPolygon [Point 2 r :+ p] deriving (Show,Eq,NFData) + +-- | \(O(n \log n)\) time ConvexHull using Graham-Scan. The resulting polygon is +-- given in clockwise order. +convexHull :: (Ord r, Num r) + => NonEmpty (MyPoint 2 r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon $ [toP p] +convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps + uh = NonEmpty.tail . hull' $ ps' + lh = NonEmpty.tail . hull' $ reverse ps' + in ConvexPolygon . map toP . reverse $ lh ++ uh + +upperHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +upperHull = hull id + + +lowerHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +lowerHull = hull reverse + + +-- | Helper function so that that can compute both the upper or the lower hull, depending +-- on the function f +hull :: (Ord r, Num r) + => ([MyPoint 2 r :+ p] -> [MyPoint 2 r :+ p]) + -> NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +hull _ h@(_ :| []) = h +hull f pts = hull' . f + . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts + +incXdecY :: Ord r => (MyPoint 2 r) :+ p -> (MyPoint 2 r) :+ q -> Ordering +incXdecY (MyPoint2 px py :+ _) (MyPoint2 qx qy :+ _) = + compare px qx <> compare qy py + + +-- | Precondition: The list of input points is sorted +hull' :: (Ord r, Num r) => [MyPoint 2 r :+ p] -> NonEmpty (MyPoint 2 r :+ p) +hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps + where + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' + + cleanMiddle h@[_,_] = h + cleanMiddle h@(z:y:x:rest) + | rightTurn (x^.core) (y^.core) (z^.core) = h + | otherwise = cleanMiddle (z:x:rest) + cleanMiddle _ = error "cleanMiddle: too few points" + +rightTurn :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> Bool +rightTurn a b c = ccwP a b c == CW + + + +ccwP :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> CCW +ccwP p q r = case z `compare` 0 of + LT -> CW + GT -> CCW + EQ -> CoLinear + where + + MyPoint2 ux uy = q `subt` p + MyPoint2 vx vy = r `subt` p + z = ux * vy - uy * vx diff --git a/benchmark/Algorithms/Geometry/ConvexHull/GrahamFamPeano.hs b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFamPeano.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFamPeano.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE UndecidableInstances #-} +module Algorithms.Geometry.ConvexHull.GrahamFamPeano( convexHull + , upperHull + , lowerHull, fromP + ) where + +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Ext +import Data.Geometry.Point +import qualified Data.Vector.Fixed.Cont as V +import qualified Data.Geometry.Vector.VectorFamilyPeano as VF +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import GHC.TypeLits +import qualified Linear.V2 as V2 + + +newtype MyPoint d r = MyPoint (VF.VectorFamily d r) + +deriving instance (VF.ImplicitArity d, Eq r) => Eq (MyPoint d r) +deriving instance (VF.ImplicitArity d, Ord r) => Ord (MyPoint d r) +deriving instance (VF.ImplicitArity d, Show r) => Show (MyPoint d r) +deriving instance (NFData (VF.VectorFamily d r)) => NFData (MyPoint d r) + +pattern Vector2 x y = VF.VectorFamily (V2.V2 x y) + +pattern MyPoint2 x y = MyPoint (Vector2 x y) + + +-- instance (NFData r, Arity d) => NFData (MyPoint d r) where +-- rnf (MyPoint x y) = rnf (x,y) +-- rnf (MyP p) = rnf p + +toP :: MyPoint VF.Two r :+ e -> Point 2 r :+ e +toP (MyPoint2 x y :+ e) = Point2 x y :+ e + +fromP :: Point 2 r :+ e -> MyPoint VF.Two r :+ e +fromP (Point2 x y :+ e) = MyPoint2 x y :+ e + + +subt :: Num r => MyPoint VF.Two r -> MyPoint VF.Two r -> MyPoint VF.Two r +(MyPoint2 x y) `subt` (MyPoint2 a b) = MyPoint2 (x-a) (y-b) + +newtype ConvexPolygon p r = ConvexPolygon [Point 2 r :+ p] deriving (Show,Eq,NFData) + +-- | \(O(n \log n)\) time ConvexHull using Graham-Scan. The resulting polygon is +-- given in clockwise order. +convexHull :: (Ord r, Num r) + => NonEmpty (MyPoint VF.Two r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon $ [toP p] +convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps + uh = NonEmpty.tail . hull' $ ps' + lh = NonEmpty.tail . hull' $ reverse ps' + in ConvexPolygon . map toP . reverse $ lh ++ uh + +upperHull :: (Ord r, Num r) => NonEmpty (MyPoint VF.Two r :+ p) -> NonEmpty (MyPoint VF.Two r :+ p) +upperHull = hull id + + +lowerHull :: (Ord r, Num r) => NonEmpty (MyPoint VF.Two r :+ p) -> NonEmpty (MyPoint VF.Two r :+ p) +lowerHull = hull reverse + + +-- | Helper function so that that can compute both the upper or the lower hull, depending +-- on the function f +hull :: (Ord r, Num r) + => ([MyPoint VF.Two r :+ p] -> [MyPoint VF.Two r :+ p]) + -> NonEmpty (MyPoint VF.Two r :+ p) -> NonEmpty (MyPoint VF.Two r :+ p) +hull _ h@(_ :| []) = h +hull f pts = hull' . f + . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts + +incXdecY :: Ord r => (MyPoint VF.Two r) :+ p -> (MyPoint VF.Two r) :+ q -> Ordering +incXdecY (MyPoint2 px py :+ _) (MyPoint2 qx qy :+ _) = + compare px qx <> compare qy py + + +-- | Precondition: The list of input points is sorted +hull' :: (Ord r, Num r) => [MyPoint VF.Two r :+ p] -> NonEmpty (MyPoint VF.Two r :+ p) +hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps + where + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' + + cleanMiddle h@[_,_] = h + cleanMiddle h@(z:y:x:rest) + | rightTurn (x^.core) (y^.core) (z^.core) = h + | otherwise = cleanMiddle (z:x:rest) + cleanMiddle _ = error "cleanMiddle: too few points" + +rightTurn :: (Ord r, Num r) => MyPoint VF.Two r -> MyPoint VF.Two r -> MyPoint VF.Two r -> Bool +rightTurn a b c = ccwP a b c == CW + + + +ccwP :: (Ord r, Num r) => MyPoint VF.Two r -> MyPoint VF.Two r -> MyPoint VF.Two r -> CCW +ccwP p q r = case z `compare` 0 of + LT -> CW + GT -> CCW + EQ -> CoLinear + where + + MyPoint2 ux uy = q `subt` p + MyPoint2 vx vy = r `subt` p + z = ux * vy - uy * vx diff --git a/benchmark/Algorithms/Geometry/ConvexHull/GrahamFixed.hs b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFixed.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFixed.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE UndecidableInstances #-} +module Algorithms.Geometry.ConvexHull.GrahamFixed( convexHull + , upperHull + , lowerHull, fromP + ) where + +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Ext +import Data.Geometry.Point +import Data.Vector.Fixed (Arity) +import qualified Data.Geometry.Vector.VectorFixed as VF +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import GHC.TypeLits + + +newtype MyPoint d r = MyPoint (VF.Vector d r) + +deriving instance (Arity d, Eq r) => Eq (MyPoint d r) +deriving instance (Arity d, Ord r) => Ord (MyPoint d r) +deriving instance (Arity d, Show r) => Show (MyPoint d r) +deriving instance (NFData (VF.Vector d r)) => NFData (MyPoint d r) + +pattern MyPoint2 x y = MyPoint (VF.Vector2 x y) + + +-- instance (NFData r, Arity d) => NFData (MyPoint d r) where +-- rnf (MyPoint x y) = rnf (x,y) +-- rnf (MyP p) = rnf p + +toP :: MyPoint 2 r :+ e -> Point 2 r :+ e +toP (MyPoint2 x y :+ e) = Point2 x y :+ e + +fromP :: Point 2 r :+ e -> MyPoint 2 r :+ e +fromP (Point2 x y :+ e) = MyPoint2 x y :+ e + + +subt :: Num r => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r +(MyPoint2 x y) `subt` (MyPoint2 a b) = MyPoint2 (x-a) (y-b) + +newtype ConvexPolygon p r = ConvexPolygon [Point 2 r :+ p] deriving (Show,Eq,NFData) + +-- | \(O(n \log n)\) time ConvexHull using Graham-Scan. The resulting polygon is +-- given in clockwise order. +convexHull :: (Ord r, Num r) + => NonEmpty (MyPoint 2 r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon $ [toP p] +convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps + uh = NonEmpty.tail . hull' $ ps' + lh = NonEmpty.tail . hull' $ reverse ps' + in ConvexPolygon . map toP . reverse $ lh ++ uh + +upperHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +upperHull = hull id + + +lowerHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +lowerHull = hull reverse + + +-- | Helper function so that that can compute both the upper or the lower hull, depending +-- on the function f +hull :: (Ord r, Num r) + => ([MyPoint 2 r :+ p] -> [MyPoint 2 r :+ p]) + -> NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +hull _ h@(_ :| []) = h +hull f pts = hull' . f + . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts + +incXdecY :: Ord r => (MyPoint 2 r) :+ p -> (MyPoint 2 r) :+ q -> Ordering +incXdecY (MyPoint2 px py :+ _) (MyPoint2 qx qy :+ _) = + compare px qx <> compare qy py + + +-- | Precondition: The list of input points is sorted +hull' :: (Ord r, Num r) => [MyPoint 2 r :+ p] -> NonEmpty (MyPoint 2 r :+ p) +hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps + where + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' + + cleanMiddle h@[_,_] = h + cleanMiddle h@(z:y:x:rest) + | rightTurn (x^.core) (y^.core) (z^.core) = h + | otherwise = cleanMiddle (z:x:rest) + cleanMiddle _ = error "cleanMiddle: too few points" + +rightTurn :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> Bool +rightTurn a b c = ccwP a b c == CW + + + +ccwP :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> CCW +ccwP p q r = case z `compare` 0 of + LT -> CW + GT -> CCW + EQ -> CoLinear + where + + MyPoint2 ux uy = q `subt` p + MyPoint2 vx vy = r `subt` p + z = ux * vy - uy * vx diff --git a/benchmark/Algorithms/Geometry/ConvexHull/GrahamV2.hs b/benchmark/Algorithms/Geometry/ConvexHull/GrahamV2.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/GrahamV2.hs @@ -0,0 +1,95 @@ +{-# Language DeriveGeneric #-} +module Algorithms.Geometry.ConvexHull.GrahamV2( convexHull + , upperHull + , lowerHull, fromP + ) where + + +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Ext +import Data.Geometry.Point +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import GHC.Generics +import qualified Linear.V2 as V2 + + + +newtype MyPoint r = MKPoint (V2.V2 r) deriving (Show,Eq,Ord,Generic) +-- data MyPoint r = MyPoint !r !r deriving (Show,Eq,Ord,Generic) + +pattern MyPoint x y = MKPoint (V2.V2 x y) + +instance NFData r => NFData (MyPoint r) + + +toP (MyPoint x y :+ e) = Point2 x y :+ e +fromP (Point2 x y :+ e) = MyPoint x y :+ e + +(MyPoint x y) `subt` (MyPoint a b) = MyPoint (x-a) (y-b) + + +newtype ConvexPolygon p r = ConvexPolygon [Point 2 r :+ p] deriving (Show,Eq,NFData) + +-- | \(O(n \log n)\) time ConvexHull using Graham-Scan. The resulting polygon is +-- given in clockwise order. +convexHull :: (Ord r, Num r) + => NonEmpty (MyPoint r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon $ [toP p] +convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps + uh = NonEmpty.tail . hull' $ ps' + lh = NonEmpty.tail . hull' $ reverse ps' + in ConvexPolygon . map toP . reverse $ lh ++ uh + +upperHull :: (Ord r, Num r) => NonEmpty (MyPoint r :+ p) -> NonEmpty (MyPoint r :+ p) +upperHull = hull id + + +lowerHull :: (Ord r, Num r) => NonEmpty (MyPoint r :+ p) -> NonEmpty (MyPoint r :+ p) +lowerHull = hull reverse + + +-- | Helper function so that that can compute both the upper or the lower hull, depending +-- on the function f +hull :: (Ord r, Num r) + => ([MyPoint r :+ p] -> [MyPoint r :+ p]) + -> NonEmpty (MyPoint r :+ p) -> NonEmpty (MyPoint r :+ p) +hull _ h@(_ :| []) = h +hull f pts = hull' . f + . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts + +incXdecY :: Ord r => (MyPoint r) :+ p -> (MyPoint r) :+ q -> Ordering +incXdecY (MyPoint px py :+ _) (MyPoint qx qy :+ _) = + compare px qx <> compare qy py + + +-- | Precondition: The list of input points is sorted +hull' :: (Ord r, Num r) => [MyPoint r :+ p] -> NonEmpty (MyPoint r :+ p) +hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps + where + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' + + cleanMiddle h@[_,_] = h + cleanMiddle h@(z:y:x:rest) + | rightTurn (x^.core) (y^.core) (z^.core) = h + | otherwise = cleanMiddle (z:x:rest) + cleanMiddle _ = error "cleanMiddle: too few points" + +rightTurn :: (Ord r, Num r) => MyPoint r -> MyPoint r -> MyPoint r -> Bool +rightTurn a b c = ccwP a b c == CW + + + +ccwP :: (Ord r, Num r) => MyPoint r -> MyPoint r -> MyPoint r -> CCW +ccwP p q r = case z `compare` 0 of + LT -> CW + GT -> CCW + EQ -> CoLinear + where + + MyPoint ux uy = q `subt` p + MyPoint vx vy = r `subt` p + z = ux * vy - uy * vx diff --git a/benchmark/Benchmark/Util.hs b/benchmark/Benchmark/Util.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark/Util.hs @@ -0,0 +1,7 @@ +module Benchmark.Util where + + + +-- | Generates different size benchmarks +sizes :: Foldable f => f a -> [Int] +sizes xs = let n = length xs in (\i -> n*i `div` 100) <$> [5,10..100] diff --git a/benchmark/Benchmarks.hs b/benchmark/Benchmarks.hs --- a/benchmark/Benchmarks.hs +++ b/benchmark/Benchmarks.hs @@ -1,69 +1,6 @@ module Main where -import Control.DeepSeq -import Control.Lens -import Criterion.Main -import Data.Ext -import Data.Geometry.Interval -import qualified Data.Geometry.IntervalTree as IT -import Data.Geometry.SegmentTree (I(..)) -import qualified Data.Geometry.SegmentTree as SegTree -import qualified Data.List.NonEmpty as NonEmpty -import QuickCheck.Instances -import Test.QuickCheck - - --- | generates n random intervals -genIntervals :: (Ord r, Arbitrary r) - => proxy r -> Int -> IO [Interval () r] -genIntervals _ n | n <= 0 = error "genIntervals: need n > 0" - | otherwise = generate (vectorOf n arbitrary) - -genQueries :: (Ord r, Arbitrary r) - => proxy r -> Int -> IO [r] -genQueries _ n | n <= 0 = error "genQueries: need n > 0" - | otherwise = generate (vectorOf n arbitrary) - - --- genQuerySetup :: (Ord r, Arbitrary r) --- => proxy r -> Int -> IO (Int,IT.IntervalTree (I (Interval () r)) r, [r]) --- genQuerySetup p n = (\is qs -> (n, IT.fromIntervals . fmap I $ is, qs)) --- <$> genIntervals p n --- <*> genQueries p n - - -main = defaultMain [ - bgroup "IntervalTree" [ env (genIntervals (I (5 :: Int)) (100000 :: Int)) benchBuild - -- env (genIntervals (I (5 :: Int)) (100000 :: Int)) benchQueryIT - ] - ] - -benchBuild :: (Ord r, NFData r) => [Interval () r] -> Benchmark -benchBuild is = bgroup "build" [ bench (show n) $ nf IT.fromIntervals (take n is') - | n <- sizes is - ] - where - is' = I <$> is - -benchQueryIT :: (Ord r, Arbitrary r, NFData r) => [Interval () r] -> Benchmark -benchQueryIT is = bgroup "queries" - [ env (setup n) (\(t,qs) -> - bench ("queries on size" ++ show n) $ whnf (queryAll t) qs) - | n <- sizes is - ] - where - is' = I <$> is - r = is^.to head.start.core - setup n = (IT.fromIntervals (take n is'),) <$> genQueries (I r) 100000 - queryAll t = map (flip IT.search t) - - --- benchQueryIT :: Ord r --- => (Int, IT.IntervalTree (I (Interval () r)) r, [r]) -> Benchmark --- benchQueryIT (n,t,qs) = bgroup "queries" [ bench "query" $ whnf (flip IT.search t) q --- | q <- qs --- ] - +import qualified Algorithms.Geometry.ConvexHull.Bench as M -sizes :: [a] -> [Int] -sizes xs = let n = length xs in (\i -> n*i `div` 100) <$> [5,10..100] +main :: IO () +main = M.main diff --git a/benchmark/Data/Geometry/IntervalTreeBench.hs b/benchmark/Data/Geometry/IntervalTreeBench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Data/Geometry/IntervalTreeBench.hs @@ -0,0 +1,79 @@ +module Data.Geometry.IntervalTreeBench where + +import Benchmark.Util +import Control.DeepSeq +import Control.Lens +import Criterion.Main +import Criterion.Types +import Data.Ext +import Data.Geometry.Interval +import qualified Data.Geometry.IntervalTree as IT +import Data.Geometry.SegmentTree (I(..)) +import qualified Data.Geometry.SegmentTree as SegTree +import qualified Data.List.NonEmpty as NonEmpty +import Debug.Trace +import Test.QuickCheck +import Test.QuickCheck.HGeometryInstances () + +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMainWith cfg [ intervalBench ] + where + cfg = defaultConfig { reportFile = Just "bench.html" } + +intervalBench :: Benchmark +intervalBench = bgroup "IntervalTree" + [ -- env (genIntervals (I (5 :: Int)) 1000) benchBuild + env (genIntervals (I (5 :: Int)) 100) benchQueryIT + ] + +-------------------------------------------------------------------------------- + +-- | generates n random intervals +genIntervals :: (Ord r, Arbitrary r) + => proxy r -> Int -> IO [Interval () r] +genIntervals _ n | n <= 0 = error "genIntervals: need n > 0" + | otherwise = generate (vectorOf n arbitrary) + +genQueries :: (Ord r, Arbitrary r) + => proxy r -> Int -> IO [r] +genQueries _ n | n <= 0 = error "genQueries: need n > 0" + | otherwise = generate (vectorOf n arbitrary) + + +-- genQuerySetup :: (Ord r, Arbitrary r) +-- => proxy r -> Int -> IO (Int,IT.IntervalTree (I (Interval () r)) r, [r]) +-- genQuerySetup p n = (\is qs -> (n, IT.fromIntervals . fmap I $ is, qs)) +-- <$> genIntervals p n +-- <*> genQueries p n + + +-- | Benchmark building the interval tree +benchBuild :: (Ord r, NFData r) => [Interval () r] -> Benchmark +benchBuild is = bgroup "build" [ bench (show n) $ nf IT.fromIntervals (take n is') + | n <- sizes is + ] + where + is' = I <$> is + +benchQueryIT :: (Ord r, Arbitrary r, NFData r) => [Interval () r] -> Benchmark +benchQueryIT is = bgroup "queries" + [ env (setup' n) (\(t,qs) -> + bench ("queries on size" ++ show n) $ whnf (queryAll t) qs) + | n <- sizes is + ] + where + is' = I <$> is + r = is^.to head.start.core + setup' n = traceShow "setup" $ setup n + + setup n = (IT.fromIntervals (take n is'),) <$> genQueries (I r) 100000 + queryAll t = map (flip IT.search t) + + +-- benchQueryIT :: Ord r +-- => (Int, IT.IntervalTree (I (Interval () r)) r, [r]) -> Benchmark +-- benchQueryIT (n,t,qs) = bgroup "queries" [ bench "query" $ whnf (flip IT.search t) q +-- | q <- qs +-- ] diff --git a/benchmark/Data/Geometry/Vector/VectorFamily6.hs b/benchmark/Data/Geometry/Vector/VectorFamily6.hs new file mode 100644 --- /dev/null +++ b/benchmark/Data/Geometry/Vector/VectorFamily6.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Geometry.Vector.VectorFamily6 where + +import Control.Applicative (liftA2) +import Control.DeepSeq +import Control.Lens hiding (element) +-- import Data.Aeson (ToJSON(..),FromJSON(..)) +import qualified Data.Foldable as F +import qualified Data.Geometry.Vector.VectorFixed as FV +import Data.Maybe (fromMaybe) +import Data.Proxy +import Data.Semigroup +import Data.Traversable (foldMapDefault,fmapDefault) +import qualified Data.Vector.Fixed as V +import Data.Vector.Fixed.Cont (Peano(..), PeanoNum(..), Fun(..)) +import GHC.TypeLits +import Linear.Affine (Affine(..)) +import Linear.Metric +import qualified Linear.V2 as L2 +import qualified Linear.V3 as L3 +import qualified Linear.V4 as L4 +import Linear.Vector + +-------------------------------------------------------------------------------- +-- * d dimensional Vectors + + +type One = S Z +type Two = S One +type Three = S Two +type Four = S Three +type Many d = S (S (S (S (S d)))) + + +type family FromPeano (d :: PeanoNum) :: Nat where + FromPeano Z = 0 + FromPeano (S d) = 1 + FromPeano d + + +data SingPeano (d :: PeanoNum) where + SZ :: SingPeano Z + SS :: !(SingPeano d) -> SingPeano (S d) + +class ImplicitPeano (d :: PeanoNum) where + implicitPeano :: SingPeano d +instance ImplicitPeano Z where + implicitPeano = SZ +instance ImplicitPeano d => ImplicitPeano (S d) where + implicitPeano = SS implicitPeano + +-- | Mapping between the implementation type, and the actual implementation. +type family VectorFamilyF (d :: PeanoNum) :: * -> * where + VectorFamilyF Z = Const () + VectorFamilyF One = Identity + VectorFamilyF Two = L2.V2 + VectorFamilyF Three = L3.V3 + VectorFamilyF Four = L4.V4 + VectorFamilyF (Many d) = FV.Vector (FromPeano (Many d)) + + +-- | Datatype representing d dimensional vectors. The default implementation is +-- based n VectorFixed. However, for small vectors we automatically select a +-- more efficient representation. +newtype VectorFamily (d :: PeanoNum) (r :: *) = + VectorFamily { _unVF :: VectorFamilyF d r } + +type ImplicitArity d = (ImplicitPeano d, V.Arity (FromPeano d)) + + + +instance (Eq r, ImplicitArity d) => Eq (VectorFamily d r) where + (VectorFamily u) == (VectorFamily v) = case (implicitPeano :: SingPeano d) of + SZ -> u == v + (SS SZ) -> u == v + (SS (SS SZ)) -> u == v + (SS (SS (SS SZ))) -> u == v + (SS (SS (SS (SS SZ)))) -> u == v + (SS (SS (SS (SS (SS _))))) -> u == v + {-# INLINE (==) #-} + +instance (Ord r, ImplicitArity d) => Ord (VectorFamily d r) where + (VectorFamily u) `compare` (VectorFamily v) = case (implicitPeano :: SingPeano d) of + SZ -> u `compare` v + (SS SZ) -> u `compare` v + (SS (SS SZ)) -> u `compare` v + (SS (SS (SS SZ))) -> u `compare` v + (SS (SS (SS (SS SZ)))) -> u `compare` v + (SS (SS (SS (SS (SS _))))) -> u `compare` v + {-# INLINE compare #-} + + +instance ImplicitArity d => Functor (VectorFamily d) where + fmap f = VectorFamily . g f . _unVF + where g = case (implicitPeano :: SingPeano d) of + SZ -> fmap + (SS SZ) -> fmap + (SS (SS SZ)) -> fmap + (SS (SS (SS SZ))) -> fmap + (SS (SS (SS (SS SZ)))) -> fmap + (SS (SS (SS (SS (SS _))))) -> fmap + {-# INLINE fmap #-} + + +instance ImplicitArity d => Foldable (VectorFamily d) where + foldMap f = g f . _unVF + where g = case (implicitPeano :: SingPeano d) of + SZ -> foldMap + (SS SZ) -> foldMap + (SS (SS SZ)) -> foldMap + (SS (SS (SS SZ))) -> foldMap + (SS (SS (SS (SS SZ)))) -> foldMap + (SS (SS (SS (SS (SS _))))) -> foldMap + {-# INLINE foldMap #-} + +instance ImplicitArity d => Traversable (VectorFamily d) where + traverse f = fmap VectorFamily . g f . _unVF + where g = case (implicitPeano :: SingPeano d) of + SZ -> traverse + (SS SZ) -> traverse + (SS (SS SZ)) -> traverse + (SS (SS (SS SZ))) -> traverse + (SS (SS (SS (SS SZ)))) -> traverse + (SS (SS (SS (SS (SS _))))) -> traverse + {-# INLINE traverse #-} + +instance ImplicitArity d => Applicative (VectorFamily d) where + pure = VectorFamily . case (implicitPeano :: SingPeano d) of + SZ -> pure + (SS SZ) -> pure + (SS (SS SZ)) -> pure + (SS (SS (SS SZ))) -> pure + (SS (SS (SS (SS SZ)))) -> pure + (SS (SS (SS (SS (SS _))))) -> pure + {-# INLINE pure #-} + liftA2 f (VectorFamily u) (VectorFamily v) = VectorFamily $ + case (implicitPeano :: SingPeano d) of + SZ -> liftA2 f u v + (SS SZ) -> liftA2 f u v + (SS (SS SZ)) -> liftA2 f u v + (SS (SS (SS SZ))) -> liftA2 f u v + (SS (SS (SS (SS SZ)))) -> liftA2 f u v + (SS (SS (SS (SS (SS _))))) -> liftA2 f u v + {-# INLINE liftA2 #-} + + + + +type instance V.Dim (VectorFamily d) = FromPeano d + + + + +instance ImplicitArity d => V.Vector (VectorFamily d) r where + construct = fmap VectorFamily $ case (implicitPeano :: SingPeano d) of + SZ -> Fun $ Const () + (SS SZ) -> V.construct + (SS (SS SZ)) -> Fun L2.V2 + (SS (SS (SS SZ))) -> Fun L3.V3 + (SS (SS (SS (SS SZ)))) -> Fun L4.V4 + (SS (SS (SS (SS (SS _))))) -> V.construct + {-# INLINE construct #-} + inspect (VectorFamily v) ff@(Fun f) = case (implicitPeano :: SingPeano d) of + SZ -> f + (SS SZ) -> V.inspect v ff + (SS (SS SZ)) -> let (L2.V2 x y) = v in f x y + (SS (SS (SS SZ))) -> let (L3.V3 x y z) = v in f x y z + (SS (SS (SS (SS SZ)))) -> let (L4.V4 x y z w) = v in f x y z w + (SS (SS (SS (SS (SS _))))) -> V.inspect v ff + {-# INLINE inspect #-} + -- basicIndex (VectorFamily v) i = case (implicitPeano :: SingPeano d) of + -- SZ -> err + -- (SS SZ) -> if i == 0 then runIdentity v else err + -- (SS (SS SZ)) -> let (L2.V2 x y) = v in f x y + -- (SS (SS (SS SZ))) -> let (L3.V3 x y z) = v in f x y z + -- (SS (SS (SS (SS SZ)))) -> let (L4.V4 x y z w) = v in f x y z w + -- (SS (SS (SS (SS (SS _))))) -> V.basicIndex v i + -- where + -- err = error "VectorFamily: basicIndex out of range" + -- {-# INLINE basicIndex #-} + + +instance (ImplicitArity d, Show r) => Show (VectorFamily d r) where + show v = mconcat [ "Vector", show $ F.length v , " " + , show $ F.toList v ] + +deriving instance (NFData (VectorFamilyF d r)) => NFData (VectorFamily d r) + + +type instance Index (VectorFamily d r) = Int +type instance IxValue (VectorFamily d r) = r + +-------------------------------------------------------------------------------- + + +newtype Vector (d :: Nat) (r :: *) = MKVector { _unV :: VectorFamily (Peano d) r } + +type instance V.Dim (Vector d) = d + + +type instance Index (Vector d r) = Int +type instance IxValue (Vector d r) = r + +type Arity d = ImplicitArity (Peano d) + +deriving instance (Eq r, Arity d) => Eq (Vector d r) +deriving instance (Ord r, Arity d) => Ord (Vector d r) + +deriving instance Arity d => Functor (Vector d) +deriving instance Arity d => Foldable (Vector d) +deriving instance Arity d => Traversable (Vector d) + +instance (Arity d, Show r) => Show (Vector d r) where + show v = mconcat [ "Vector", show $ F.length v , " " + , show $ F.toList v ] + + +deriving instance (NFData (VectorFamily (Peano d) r)) => NFData (Vector d r) + + + + +-------------------------------------------------------------------------------- +-- * Convenience "constructors" + +pattern Vector :: VectorFamilyF (Peano d) r -> Vector d r +pattern Vector v = MKVector (VectorFamily v) + +pattern Vector1 :: r -> Vector 1 r +pattern Vector1 x = (Vector (Identity x)) + +pattern Vector2 :: r -> r -> Vector 2 r +pattern Vector2 x y = (Vector (L2.V2 x y)) + +pattern Vector3 :: r -> r -> r -> Vector 3 r +pattern Vector3 x y z = (Vector (L3.V3 x y z)) + +pattern Vector4 :: r -> r -> r -> r -> Vector 4 r +pattern Vector4 x y z w = (Vector (L4.V4 x y z w)) + +-------------------------------------------------------------------------------- + +-- -- destruct :: (Vec d r, Vec (d + 1) r, 1 <= (d + 1)) +-- -- => Vector (d + 1) r -> (r, Vector d r) +-- -- destruct (Vector v) = (V.head v, Vector $ V.tail v) + + +-- -- -- vectorFromList :: Arity d => [a] -> Maybe (Vector d a) +-- -- vectorFromList = fmap Vector . V.fromListM + +-- -- vectorFromListUnsafe :: V.Arity d => [a] -> Vector d a +-- -- vectorFromListUnsafe = Vector . V.fromList + + -------------------------------------------------------------------------------- + +-- | Cross product of two three-dimensional vectors +cross :: Num r => Vector 3 r -> Vector 3 r -> Vector 3 r +(Vector u) `cross` (Vector v) = Vector $ u `L3.cross` v diff --git a/benchmark/WSPDBench.hs b/benchmark/WSPDBench.hs new file mode 100644 --- /dev/null +++ b/benchmark/WSPDBench.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module WSPDBench where + +import Control.DeepSeq +import Control.Lens +import Criterion.Main +import Data.Ext +import Data.Geometry.Point +import Demo.ExpectedPairwiseDistance + + +readInput' :: FilePath -> Int -> IO [Point 2 Double :+ _] +readInput' fp k = take k <$> readInput fp + + +benchWSPD :: Benchmark +benchWSPD = bgroup "Well-Separated Pair Decomposition" + [ env (readInput' "pco.9420_convert.txt" 200) $ \pts -> bgroup "pco" + [ bench "exact" $ nf pairwiseDist pts + , bench "wspd 0.05" $ nf (approxPairwiseDistance 0.05) pts + , bench "wspd 0.10" $ nf (approxPairwiseDistance 0.10) pts + , bench "wspd 0.20" $ nf (approxPairwiseDistance 0.20) pts + ] + ] + +-- main = defaultMain [ benchWSPD ] diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,60 @@ +#### 0.7 ### + +- Compatibility with GHC 8.0-8.4 +- Implemented more Algorithms and Data Structures. This includes + * Polygon triangulation +- A new implementation of PlanarSubdivision that now also supports disconnected + subdivsions. +- Performance improvements by changing to a different Vector + implementation. For low dimensional vectors (of dimension at most four) we + now essentially use the types from + [linear](https://hackage.haskell.org/package/linear), this gives significant + speedups on several small benchmarks. +- bugfixes. + +#### 0.6 ### + +- Implemented more Algorithms and Data Structures. This includes + * Bentley-Ottmannn line-segment intersection, + * Well-Separated Pair decompositions, + * extremal point/tangents for Convex hulls, + * Minkowski sum for convex polygons, + * one dimensional segment trees, + * one dimensional interval trees, and a + * KD-tree. +- Several bug fixes, including a very stupid bug in Box +- Separate ConvexPolygon type. +- More thorough testing for some of the algorithms. +- Started work on a proper representation for planar subdivsions. This includes + a representation of planar graphs that support querying if two vertices are + connected by an edge in $O(1)$ time. +- Dropped support for GHC 7.8 + +#### 0.5 ### + +- Implemented several algorithms, including Delaunay Triangulation, EMST, and +Douglas Peucker. +- Revamped the data types for Intersections + +#### 0.4 ### + +- Major rewrite from scratch, providing much stronger type-level + guarantees. Incompatible with older versions. +- Convex Hull and Smallest enclosing disk algorithms. +- HGeometry now includes some very experimental and preliminary support for + reading and writing Ipe7 files. + +#### 0.2 & 0.3 ### + +- Internal releases. + +### 0.1.1 ### + +- Fixed a bug in point on n the line segment test +- Generalized the types of inCircle, inDisc, onCircle, onDisc etc. We now need + only that the type representing precision model implements the typeclass + `Num` instead of `Floating'. + +### 0.1 ### + +- Initial release. diff --git a/examples/BAPC2014/Armybase.lhs b/examples/BAPC2014/Armybase.lhs --- a/examples/BAPC2014/Armybase.lhs +++ b/examples/BAPC2014/Armybase.lhs @@ -60,7 +60,7 @@ -> triangArea :: Triangle p Int -> Half +> triangArea :: Triangle 2 p Int -> Half > triangArea = Half . doubleArea @@ -193,7 +193,7 @@ > findLargestTriang :: Point 2 Int -> Point 2 Int -> -> Unimodal (Array Int) (Point 2 Int) -> Triangle () Int +> -> Unimodal (Array Int) (Point 2 Int) -> Triangle 2 () Int > findLargestTriang p q us = triang . ternarySearchArray area' $ us > where > triang v = Triangle (ext p) (ext q) (ext v) diff --git a/examples/Demo/Delaunay.hs b/examples/Demo/Delaunay.hs --- a/examples/Demo/Delaunay.hs +++ b/examples/Demo/Delaunay.hs @@ -4,7 +4,6 @@ import Algorithms.Geometry.DelaunayTriangulation.DivideAndConqueror import Algorithms.Geometry.DelaunayTriangulation.Types import Algorithms.Geometry.EuclideanMST.EuclideanMST -import Control.Applicative import Control.Lens import Data.Data import Data.Ext @@ -12,7 +11,6 @@ import Data.Geometry.Ipe import qualified Data.List.NonEmpty as NonEmpty import Data.Semigroup -import Data.Traversable import Options.Applicative diff --git a/examples/Demo/ExpectedPairwiseDistance.hs b/examples/Demo/ExpectedPairwiseDistance.hs --- a/examples/Demo/ExpectedPairwiseDistance.hs +++ b/examples/Demo/ExpectedPairwiseDistance.hs @@ -20,7 +20,7 @@ import Data.Data import Data.Semigroup import qualified Data.Set as Set -import GHC.TypeLits (natVal,KnownNat) +import GHC.TypeLits import Options.Applicative hiding ((<>)) @@ -56,7 +56,7 @@ -- -- running time: $O(n(1/eps)^d + n\log n)$, where $n$ is the number of points approxExpectedPairwiseDistance :: (Floating r, Ord r - , AlwaysTrueWSPD d, Index' 0 d + , Arity d, Arity (d+1), 1 <= d , Show r, Show p) => r -> Int -> [Point d r :+ p] -> r approxExpectedPairwiseDistance eps k pts = @@ -73,7 +73,7 @@ -- | $(1+\eps)$-approximation of the sum of the pairwise distances. -- -- running time: $O(n(1/eps)^d + n\log n)$, where $n$ is the number of points -approxPairwiseDistance :: (Floating r, Ord r, AlwaysTrueWSPD d, Index' 0 d +approxPairwiseDistance :: (Floating r, Ord r, Arity d, Arity (d+1), 1 <= d , Show r, Show p) => r -> [Point d r :+ p] -> r approxPairwiseDistance _ [] = 0 @@ -179,7 +179,7 @@ -- | Computes all pairs of points that are uncovered by the WSPD with separation s -uncovered :: (Floating r, Ord r, AlwaysTrueWSPD d, Ord p) +uncovered :: (Floating r, Ord r, Arity d, Arity (d+1), Ord p) => [Point d r :+ p] -> r -> SplitTree d p r a -> [(Point d r :+ p, Point d r :+ p)] uncovered pts s t = Set.toList $ allPairs `Set.difference` covered where diff --git a/examples/Demo/GPXParser.hs b/examples/Demo/GPXParser.hs --- a/examples/Demo/GPXParser.hs +++ b/examples/Demo/GPXParser.hs @@ -85,7 +85,7 @@ extract = (\(Text s) -> s) . head . eChildren readTime' :: String -> UTCTime -readTime' = readTime defaultTimeLocale "%0C%y-%m-%dT%TZ" +readTime' = parseTimeOrError True defaultTimeLocale "%0C%y-%m-%dT%TZ" -- instance ReadGPX Position where -- parseGPX x@(Element "Position" _ _) = (\l l' -> Position $ point2 l l') <$> lat <*> lon diff --git a/examples/Demo/TriangulateWorld.hs b/examples/Demo/TriangulateWorld.hs new file mode 100644 --- /dev/null +++ b/examples/Demo/TriangulateWorld.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Demo.TriangulateWorld where + +import Algorithms.Geometry.LineSegmentIntersection (hasSelfIntersections) +import Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate) +import Algorithms.Geometry.PolygonTriangulation.MakeMonotone (makeMonotone) +import Data.Maybe(mapMaybe) +import Control.Lens +import Data.Data +import Data.Ext +import Data.Geometry.Ipe +import Data.Geometry.Polygon +import Data.Geometry.PlanarSubdivision +import Data.Semigroup +import Options.Applicative +import qualified Data.Foldable as F + + +-------------------------------------------------------------------------------- + +data Options = Options { _inPath :: FilePath + , _outFile :: FilePath + } + deriving Data + +options :: ParserInfo Options +options = info (helper <*> parser) + ( progDesc "Triangulate all polygons in the input file." + <> header "trianguldateWorld" + ) + where + parser = Options + <$> strOption (help "Input file (in ipe7 xml format)" + <> short 'i' + ) + <*> strOption (help "Output File (in ipe7 xml format)" + <> short 'o' + ) + + + +-- runExcept' :: (Show e) => ExceptT e IO () -> IO () +-- runExcept' m = runExceptT m >>= \case +-- Left e -> print e +-- Right () -> pure () + +-- mainWith :: Options -> IO () +-- mainWith (Options inFile outFile) = runExcept' $ do +-- (page :: IpePage Rational) <- readSinglePageFile inFile +-- let polies = page^..content.traverse._withAttrs _IpePath _asSimplePolygon +-- let out = undefinedL +-- lift $ writeIpeFile outFile . singlePageFromContent $ out + +data PX = PX + +mainWith :: Options -> IO () +mainWith (Options inFile outFile) = do + ePage <- readSinglePageFile inFile + case ePage of + Left err -> print err + Right (page :: IpePage Rational) -> runPage page + where + runPage page = do + let polies = page^..content.to flattenGroups.traverse._withAttrs _IpePath _asSimplePolygon + polies' = filter (not . hasSelfIntersections . (^.core)) polies + subdivs = map (\(pg :+ _) -> triangulate (Identity PX) pg) polies' + yMonotones = tail . mapMaybe (^?_2.core._Left) + . concatMap (F.toList.rawFacePolygons) $ subdivs + ofs = map (\s -> rawFaceBoundary (outerFaceId s) s) subdivs + segs = map (^._2.core) . concatMap (F.toList . edgeSegments) $ subdivs + out = [ asIpeObject pg a + | pg :+ a <- polies + ] <> + [ asIpeObject s mempty + | s <- segs + ] <> + [ asIpeObject pg mempty + | pg <- yMonotones ] + mapM_ print . map (\pg -> pg^.core.to polygonVertices.to length) $ polies' + writeIpeFile outFile . singlePageFromContent $ out + + +-- mainWith :: Options -> IO () +-- mainWith (Options inFile outFile) = do +-- ePage <- readSinglePageFile inFile +-- case ePage of +-- Left err -> print err +-- Right (page :: IpePage Rational) -> runPage page +-- where +-- runPage page = do +-- let orig = page^.content +-- all' = page^.content.to flattenGroups +-- writeIpeFile outFile . singlePageFromContent $ orig <> all' + + +-- type ValT = EitherT IO + +-- flattenGroups :: [IpeObject r] -> [IpeObject r] +-- flattenGroups = concatMap flattenGroups' + +-- flattenGroups' :: IpeObject r -> [IpeObject r] +-- flattenGroups' (IpeGroup (Group gs :+ ats)) = +-- map (applyAts ats) . concatMap flattenGroups' $ gs +-- where +-- applyAts ats = id +-- flattenGroups' o = [o] diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -12,6 +12,7 @@ import qualified Demo.MinDisk as MinDisk import qualified Demo.Delaunay as Delaunay import qualified Demo.ExpectedPairwiseDistance as ExpPWD +import qualified Demo.TriangulateWorld as TriangulateWorld @@ -24,6 +25,7 @@ | MinDisk MinDisk.Options | Delaunay Delaunay.Options | ExpectedPairwiseDistance ExpPWD.Options + | TriangulateWorld TriangulateWorld.Options deriving Data parser :: Parser Options @@ -33,6 +35,7 @@ <> command' MinDisk MinDisk.options <> command' Delaunay Delaunay.options <> command' ExpectedPairwiseDistance ExpPWD.options + <> command' TriangulateWorld TriangulateWorld.options ) @@ -44,6 +47,7 @@ MinDisk opts -> MinDisk.mainWith opts Delaunay opts -> Delaunay.mainWith opts ExpectedPairwiseDistance opts -> ExpPWD.mainWith opts + TriangulateWorld opts -> TriangulateWorld.mainWith opts -------------------------------------------------------------------------------- diff --git a/hgeometry.cabal b/hgeometry.cabal --- a/hgeometry.cabal +++ b/hgeometry.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hgeometry -version: 0.6.0.0 +version: 0.7.0.0 synopsis: Geometric Algorithms, Data structures, and Data types. description: HGeometry provides some basic geometry types, and geometric algorithms and @@ -17,17 +17,20 @@ maintainer: frank@fstaals.net -- copyright: -tested-with: GHC >= 7.10.2 +tested-with: GHC >= 8.2 category: Geometry build-type: Simple -extra-source-files: README.md - resources/basic.isy +data-files: resources/basic.isy + test/Algorithms/Geometry/LineSegmentIntersection/manual.ipe + test/Algorithms/Geometry/LineSegmentIntersection/selfIntersections.ipe + test/Algorithms/Geometry/LowerEnvelope/manual.ipe + test/Algorithms/Geometry/PolygonTriangulation/monotone.ipe + test/Algorithms/Geometry/PolygonTriangulation/simplepolygon6.ipe + test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe test/Data/Geometry/pointInPolygon.ipe test/Data/Geometry/Polygon/Convex/convexTests.ipe - test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe - test/Algorithms/Geometry/LineSegmentIntersection/manual.ipe examples/BAPC2014/sample.in examples/BAPC2014/sample.out examples/BAPC2014/testdata.in @@ -38,7 +41,11 @@ examples/BAPC2012/sampleG.out -cabal-version: >=1.10 + +extra-source-files: README.md + changelog.md + +cabal-version: 2.0 source-repository head type: git location: https://github.com/noinia/hgeometry @@ -49,8 +56,18 @@ default: False manual: True +flag with-quickcheck + description: Include QuickCheck instances + default: True + manual: False + +flag interactive + description: Build interactive parts + default: False + manual: True + library - ghc-options: -Wall -fno-warn-unticked-promoted-constructors -fno-warn-type-defaults + ghc-options: -O2 -Wall -fno-warn-unticked-promoted-constructors -fno-warn-type-defaults exposed-modules: -- * Generic Geometry @@ -63,6 +80,9 @@ -- * Basic Geometry Types Data.Geometry.Vector Data.Geometry.Vector.VectorFixed + Data.Geometry.Vector.VectorFamily + Data.Geometry.Vector.VectorFamilyPeano + -- Data.Geometry.Vector.Vinyl Data.Geometry.Interval Data.Geometry.Interval.Util @@ -89,6 +109,8 @@ Data.Geometry.KDTree Data.Geometry.PlanarSubdivision + Data.Geometry.PlanarSubdivision.Basic + Data.Geometry.PlanarSubdivision.Draw -- * Algorithms Algorithms.Util @@ -97,6 +119,8 @@ Algorithms.Geometry.ConvexHull.GrahamScan Algorithms.Geometry.ConvexHull.DivideAndConqueror + Algorithms.Geometry.LowerEnvelope.DualCH + Algorithms.Geometry.SmallestEnclosingBall.Types Algorithms.Geometry.SmallestEnclosingBall.RandomizedIncrementalConstruction Algorithms.Geometry.SmallestEnclosingBall.Naive @@ -114,6 +138,14 @@ Algorithms.Geometry.Diameter + Algorithms.Geometry.Sweep + + Algorithms.Geometry.PolygonTriangulation.Types + Algorithms.Geometry.PolygonTriangulation.Triangulate + Algorithms.Geometry.PolygonTriangulation.MakeMonotone + Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone + + Algorithms.Geometry.LineSegmentIntersection Algorithms.Geometry.LineSegmentIntersection.Naive Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann Algorithms.Geometry.LineSegmentIntersection.Types @@ -146,16 +178,20 @@ Data.CircularList.Util Data.BalBST + Data.OrdSeq + Data.SlowSeq Data.Util -- * Planar Graphs Data.Permutation Data.PlanarGraph Data.PlaneGraph + Data.PlaneGraph.Draw -- * Other System.Random.Shuffle Control.Monad.State.Persistent + Data.Yaml.Util @@ -167,12 +203,11 @@ -- other-extensions: build-depends: - - Frames >= 0.1.3.0 - , base >= 4.8 && < 5 + base >= 4.9 && < 5 , bifunctors >= 4.1 , bytestring >= 0.10 , containers >= 0.5.5 + , dlist >= 0.7 , contravariant >= 1.4 , lens >= 4.2 , linear >= 1.10 @@ -180,8 +215,11 @@ , semigroups >= 0.18 , singletons >= 2.0 , text >= 1.1.1.0 - , vinyl >= 0.5 && < 0.6 + , vinyl >= 0.6 , deepseq >= 1.1 + , fingertree >= 0.1 + , colour >= 2.3.3 + , reflection >= 2.1 -- , validation >= 0.4 @@ -189,18 +227,22 @@ -- , tranformers > 0.3 , vector >= 0.11 - , fixed-vector >= 0.6.4.0 + , fixed-vector >= 1.0 , data-clist >= 0.0.7.2 , hexpat >= 0.20.9 + , aeson >= 1.0 + , yaml >= 0.8 + + , mtl , random , template-haskell - - , time - , directory - , optparse-applicative + if flag(with-quickcheck) + build-depends: QuickCheck >= 2.5 + , quickcheck-instances >= 0.3 + exposed-modules: Test.QuickCheck.HGeometryInstances hs-source-dirs: src @@ -235,6 +277,80 @@ , FlexibleContexts , MultiParamTypeClasses +executable hgeometry-viewer + if !flag(interactive) + buildable: False + main-is: Viewer.hs + + if flag(interactive) + build-depends: base + , hgeometry + , lens + , containers + , vinyl + , semigroups + , optparse-applicative >= 0.13.0.0 + , text + , hexpat + , bytestring + , directory + , time + , random + , vector + , colour + , cairo-canvas >= 0.1.0.0 + -- , sdl2 >= 2.2.0 + , gi-gtk >= 3.0.15 + , reactive-banana-gi-gtk >= 0.2.0.0 + , cairo >= 0.13.3.1 + -- , gi-glib + , gi-cairo + , gi-gdk + -- , gi-gdkpixbuf + , gi-gtk + , transformers + , linear + , haskell-gi-base + , reactive-banana >= 1.1.0.1 + + + + hs-source-dirs: interactive + + other-modules: RenderCanvas + RenderUtil + -- ConvexHull + + default-language: Haskell2010 + + default-extensions: TypeFamilies + , GADTs + , KindSignatures + , DataKinds + , TypeOperators + , ConstraintKinds + , PolyKinds + , RankNTypes + + , PatternSynonyms + , ViewPatterns + + , StandaloneDeriving + , GeneralizedNewtypeDeriving + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + + , DeriveDataTypeable + , AutoDeriveTypeable + + , FlexibleInstances + , FlexibleContexts + , MultiParamTypeClasses + + + + executable hgeometry-examples if !flag(examples) buildable: False @@ -246,7 +362,6 @@ , lens , containers , vinyl - , Frames , semigroups , optparse-applicative >= 0.13.0.0 , text @@ -255,7 +370,7 @@ , directory , time , random - + , QuickCheck hs-source-dirs: examples @@ -264,7 +379,7 @@ Demo.MinDisk Demo.Delaunay Demo.ExpectedPairwiseDistance - + Demo.TriangulateWorld Demo.GPXParser default-language: Haskell2010 @@ -300,7 +415,8 @@ type: exitcode-stdio-1.0 ghc-options: -threaded main-is: doctests.hs - build-depends: base, doctest >= 0.8 + build-depends: base + , doctest >= 0.8 default-language: Haskell2010 @@ -311,32 +427,43 @@ main-is: Spec.hs ghc-options: -O2 -fno-warn-unticked-promoted-constructors + build-tool-depends: hspec-discover:hspec-discover + + other-modules: Data.RangeSpec Data.EdgeOracleSpec Data.PlanarGraphSpec + Data.OrdSeqSpec Data.Geometry.Ipe.ReaderSpec Data.Geometry.PolygonSpec + Data.Geometry.LineSegmentSpec Data.Geometry.PointSpec Data.Geometry.Polygon.Convex.ConvexSpec Data.Geometry.KDTreeSpec Data.Geometry.IntervalSpec Data.Geometry.BoxSpec - + Data.Geometry.LineSpec + Data.Geometry.SubLineSpec + Data.Geometry.PlanarSubdivisionSpec Algorithms.Geometry.SmallestEnclosingDisk.RISpec Algorithms.Geometry.DelaunayTriangulation.DTSpec Algorithms.Geometry.WellSeparatedPairDecomposition.WSPDSpec Algorithms.Geometry.LineSegmentIntersection.BentleyOttmannSpec + Algorithms.Geometry.PolygonTriangulation.MakeMonotoneSpec + Algorithms.Geometry.PolygonTriangulation.TriangulateMonotoneSpec + Algorithms.Geometry.LowerEnvelope.LowerEnvSpec + Algorithms.Geometry.ConvexHull.ConvexHullSpec - QuickCheck.Instances Util build-depends: base - , hspec >= 2.1 - , QuickCheck >= 2.5 + , hspec >= 2.1 + , QuickCheck >= 2.5 + , quickcheck-instances >= 0.3 + , approximate-equality >= 1.1.0.2 , hgeometry - , Frames , lens , data-clist , linear @@ -346,6 +473,8 @@ , vector , containers , random + , singletons + , colour default-extensions: TypeFamilies , GADTs @@ -405,23 +534,38 @@ benchmark benchmarks - hs-source-dirs: benchmark test + hs-source-dirs: benchmark test examples main-is: Benchmarks.hs type: exitcode-stdio-1.0 - other-modules: + other-modules: Benchmark.Util + Algorithms.Geometry.ConvexHull.Bench + Algorithms.Geometry.ConvexHull.GrahamV2 + Algorithms.Geometry.ConvexHull.GrahamFam + Algorithms.Geometry.ConvexHull.GrahamFamPeano + Algorithms.Geometry.ConvexHull.GrahamFixed + Data.Geometry.Vector.VectorFamily6 + Algorithms.Geometry.ConvexHull.GrahamFam6 + Data.Geometry.IntervalTreeBench + Demo.ExpectedPairwiseDistance + Demo.TriangulateWorld + WSPDBench build-depends: base - , criterion >= 1.1.4.0 && < 1.2 + , criterion >= 1.1.4.0 + , fixed-vector + , linear , semigroups , deepseq , deepseq-generics , hgeometry - , Frames , lens , QuickCheck + , bytestring + , containers + , optparse-applicative ghc-options: -Wall -O2 -rtsopts -fno-warn-unticked-promoted-constructors diff --git a/interactive/RenderCanvas.hs b/interactive/RenderCanvas.hs new file mode 100644 --- /dev/null +++ b/interactive/RenderCanvas.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module RenderCanvas where + +import Control.Lens +import Data.Colour.SRGB(RGB(..), toSRGB24) +import Data.Colour.Names(readColourName) +import Data.Ext +import Data.Geometry +import Data.Geometry.Box +import Data.Geometry.Ipe.Attributes +import Data.Geometry.Ipe.Types hiding (ipeObject', width) +import qualified Data.Geometry.Ipe.Attributes as A +import Data.Proxy +import Data.Vinyl +import Linear.V4 (V4(..)) +import Graphics.Rendering.Cairo.Canvas (Canvas) +import qualified Graphics.Rendering.Cairo.Canvas as Canvas +import qualified Data.Text as T + + +rectangle :: (Real r, Ord r, Num r) => Rectangle p r -> Canvas () +rectangle r' = let r = bimap id realToFrac r' + (Point2 x y :+ _,_,_,_) = corners r + in Canvas.rect $ Canvas.D x y (width r) (height r) + +polygon :: Real r => SimplePolygon p r -> Canvas () +polygon pg' = let pg = bimap id realToFrac pg' + in Canvas.polygon $ pg^..outerBoundary.traverse.core.vector.to toV2 + +lineSegment :: Real r => LineSegment 2 p r -> Canvas () +lineSegment s' = let s = bimap id realToFrac s' + in Canvas.line (s^.start.core.vector.to toV2) (s^.end.core.vector.to toV2) + +polyLine :: Real r => PolyLine 2 p r -> Canvas () +polyLine p' = let p = bimap id realToFrac p' + in Canvas.shape Canvas.ShapeLines $ p^..points.traverse.core.vector.to toV2 + +-- | draw a point as a small disk +point :: Real r => Point 2 r -> Canvas () +point p = Canvas.circle' (realToFrac <$> (p^.vector.to toV2)) 5 + +-- | draw as a point +point' :: Real r => Point 2 r -> Canvas () +point' p = Canvas.point . fmap realToFrac $ p^.vector.to toV2 + +pathSegment :: Real r => PathSegment r -> Canvas () +pathSegment (PolyLineSegment p) = polyLine p +pathSegment (PolygonPath p) = polygon p +pathSegment _ = error "pathSegment: Not implemented yet" + + +ipeUse :: Real r => IpeSymbol r -> Canvas () +ipeUse (Symbol p _) = Canvas.circle' (realToFrac <$> p^.vector.to toV2) 10 + +ipePath :: Real r => Path r -> Canvas () +ipePath (Path p) = mapM_ pathSegment p + +ipeGroup :: RealFrac r => Group r -> Canvas () +ipeGroup = mapM_ ipeObject . _groupItems + +ipeObject' :: forall g r. (RealFrac r, AllSatisfy ApplyAttr (AttributesOf g)) + => (g r -> Canvas ()) + -> g r :+ IpeAttributes g r + -> Canvas () +ipeObject' f (i :+ ats) = do + Canvas.pushMatrix + applyAttributes (Proxy :: Proxy g) ats + f i + Canvas.popMatrix + +ipeObject :: RealFrac r + => IpeObject r -> Canvas () +ipeObject (IpeGroup g) = ipeObject' ipeGroup g +ipeObject (IpeImage _) = undefined +ipeObject (IpeTextLabel _) = undefined +ipeObject (IpeMiniPage _) = undefined +ipeObject (IpeUse p) = ipeObject' ipeUse p +ipeObject (IpePath p) = ipeObject' ipePath p + + +applyAttributes :: (RealFrac r, AllSatisfy ApplyAttr (AttributesOf g)) + => proxy g -> IpeAttributes g r -> Canvas () +applyAttributes _ (Attrs ats) = applyAttributes' ats + +applyAttributes' :: (RealFrac r, AllSatisfy ApplyAttr rs) + => Rec (Attr (AttrMapSym1 r)) rs + -> Canvas () +applyAttributes' RNil = pure () +applyAttributes' (a :& ats) = applyAttribute a >> applyAttributes' ats + + +newtype CanvasM = CanvasM { unCanvasM :: Canvas () } +instance Monoid CanvasM where + mempty = CanvasM $ pure () + (CanvasM a) `mappend` (CanvasM b) = CanvasM $ a >> b + + +applyAttribute' :: (RealFrac r, ApplyAttr label) + => Attr (AttrMapSym1 r) label -> CanvasM +applyAttribute' = CanvasM . applyAttribute + + +class ApplyAttr (label :: AttributeUniverse) where + applyAttribute :: RealFrac r => Attr (AttrMapSym1 r) label -> Canvas () + + +instance ApplyAttr Stroke where + applyAttribute NoAttr = pure () + applyAttribute (Attr c) = maybe (pure ()) Canvas.stroke $ toCanvasColor c + +instance ApplyAttr Fill where + applyAttribute NoAttr = pure () + applyAttribute (Attr c) = maybe (pure ()) Canvas.fill $ toCanvasColor c + +instance ApplyAttr Pen where + applyAttribute NoAttr = pure () + applyAttribute (Attr (IpePen p)) = case p of + Named _ -> pure () -- TODO + Valued v -> Canvas.strokeWeight (realToFrac v) + +instance ApplyAttr Clip where + applyAttribute _ = pure () + +instance ApplyAttr Size where + applyAttribute _ = pure () + +instance ApplyAttr Dash where + applyAttribute _ = pure () + + +instance ApplyAttr Layer where + applyAttribute _ = pure () + +instance ApplyAttr LineCap where + applyAttribute _ = pure () + +instance ApplyAttr LineJoin where + applyAttribute _ = pure () + +instance ApplyAttr A.Matrix where + applyAttribute _ = pure () + +instance ApplyAttr Pin where + applyAttribute _ = pure () + +instance ApplyAttr FillRule where + applyAttribute _ = pure () + +instance ApplyAttr Arrow where + applyAttribute _ = pure () + +instance ApplyAttr RArrow where + applyAttribute _ = pure () + +instance ApplyAttr Opacity where + applyAttribute _ = pure () + +instance ApplyAttr Tiling where + applyAttribute _ = pure () + +instance ApplyAttr Gradient where + applyAttribute _ = pure () + +instance ApplyAttr Transformations where + applyAttribute _ = pure () + + + + +-- | Looks up the colorname in the SVG colors if it is a name. +toCanvasColor :: RealFrac r => IpeColor r -> Maybe Canvas.Color +toCanvasColor (IpeColor c) = case c of + Named t -> h . toSRGB24 <$> readColourName (T.unpack $ T.toLower t) + Valued v -> Just $ f v + where + f (RGB r g b) = floor <$> V4 (255 *r) (255*g) (255*b) 255 + h (RGB r g b) = V4 r g b 255 diff --git a/interactive/RenderUtil.hs b/interactive/RenderUtil.hs new file mode 100644 --- /dev/null +++ b/interactive/RenderUtil.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedLabels #-} +module RenderUtil where + +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Reader (runReaderT) +import Data.GI.Base +import Data.GI.Base.Signals (SignalInfo, HaskellCallbackType) +import Data.IORef +import qualified Data.Text as T +import Foreign.Ptr (castPtr) +import qualified GI.Cairo as GI.Cairo +import qualified GI.Gtk as Gtk +import Graphics.Rendering.Cairo +import Graphics.Rendering.Cairo.Canvas (Canvas) +import qualified Graphics.Rendering.Cairo.Canvas as Canvas +import qualified Graphics.Rendering.Cairo.Internal as Cairo.Internal +import Graphics.Rendering.Cairo.Types (Cairo(Cairo)) +import Linear.V2 (V2(..)) +import Reactive.Banana +import Reactive.Banana.Frameworks +import Reactive.Banana.GI.Gtk + + + + +-- | This function bridges gi-cairo with the hand-written cairo +-- package. It takes a `GI.Cairo.Context` (as it appears in gi-cairo), +-- and a `Render` action (as in the cairo lib), and renders the +-- `Render` action into the given context. +renderWithContext :: MonadIO m => GI.Cairo.Context -> Render a -> m a +renderWithContext ct r = liftIO $ withManagedPtr ct $ \p -> + runReaderT (Cairo.Internal.runRender r) (Cairo (castPtr p)) + + +renderCanvas :: MonadIO m => GI.Cairo.Context -> V2 Double -> Canvas a -> m a +renderCanvas ct size c = liftIO $ Canvas.withRenderer (renderWithContext ct) size c + + +showT :: Show a => a -> T.Text +showT = T.pack . show + +-- | Get an 'Reactive.Banana.Event' from +-- a 'Data.GI.Base.Signals.SignalProxy' that produces one argument. +signalE1' + :: + ( HaskellCallbackType info ~ (a -> IO Bool) + , SignalInfo info + , Gtk.GObject self + ) + => self + -> SignalProxy self info + -> (a -> IO b) -- ^ function to transform the Event with + -> MomentIO (Event b) +signalE1' self signal h = signalEN self signal f >>= mapEventIO h + where + f g = \a -> g a >> return True -- we return True because the event has been + -- handled, don't want to propagate it + -- further + + +draw :: Gtk.DrawingArea -> Behavior (Canvas ()) -> MomentIO () +draw drawingArea bc = do + canvasRef <- liftIO . newIORef =<< valueB bc -- gets the initial canvas + + -- set up reactive-banana to update the canvasRef on changes, and triger a + -- redraw + c <- valueBLater bc + liftIOLater $ writeIORef canvasRef c + e <- changes bc + reactimate' $ (fmap $ \c' -> do liftIO $ writeIORef canvasRef c' + #queueDraw drawingArea + ) <$> e + + -- registers drawing event handler + _ <- on drawingArea #draw $ \context -> do + w <- realToFrac . fromIntegral <$> #getAllocatedWidth drawingArea + h <- realToFrac . fromIntegral <$> #getAllocatedHeight drawingArea + canvas <- readIORef canvasRef + renderCanvas context (V2 w h) canvas + pure True + pure () diff --git a/interactive/Viewer.hs b/interactive/Viewer.hs new file mode 100644 --- /dev/null +++ b/interactive/Viewer.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Control.Exception (catch) +import Control.Lens +import Control.Monad (forM_) +import Data.Ext +import Data.GI.Base +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text as T +import qualified GI.Gdk as Gdk +import qualified GI.Gtk as Gtk +import Graphics.Rendering.Cairo.Canvas (Canvas) +import qualified Graphics.Rendering.Cairo.Canvas as Canvas +import Linear.Affine ((.-.),(.+^)) +import Linear.V2 +import Linear.Vector ((*^)) +import Reactive.Banana +import Reactive.Banana.Frameworks +import Reactive.Banana.GI.Gtk +import qualified RenderCanvas as Render +import RenderUtil + +main :: IO () +main = runGtk `catch` (\(e::Gtk.GError) -> Gtk.gerrorMessage e >>= putStrLn . T.unpack) + where + runGtk = do + _ <- Gtk.init Nothing + compile networkDescription >>= actuate + Gtk.main + +data ArrowKey = UpKey | DownKey | LeftKey | RightKey deriving (Show,Read,Eq,Bounded,Enum) + +toArrowKey :: T.Text -> Maybe ArrowKey +toArrowKey "Up" = Just UpKey +toArrowKey "Down" = Just DownKey +toArrowKey "Left" = Just LeftKey +toArrowKey "Right" = Just RightKey +toArrowKey _ = Nothing + + + + +toDirection :: Num a => ArrowKey -> V2 a +toDirection UpKey = V2 0 1 +toDirection DownKey = V2 0 (-1) +toDirection LeftKey = V2 (-1) 0 +toDirection RightKey = V2 1 0 + + +networkDescription :: MomentIO () +networkDescription = do + b <- Gtk.builderNew + _ <- Gtk.builderAddFromFile b "interactive/viewport.glade" + + window <- castB b "window" Gtk.Window + destroyE <- signalE0 window #destroy + reactimate $ Gtk.mainQuit <$ destroyE + + -- mouseLabel <- castB b "mouseLabel" Gtk.Label + + drawingArea <- castB b "canvas" Gtk.DrawingArea + drawingAreaH <- realToFrac . fromIntegral . snd <$> #getPreferredHeight drawingArea + drawingAreaW <- realToFrac . fromIntegral . snd <$> #getPreferredWidth drawingArea + + Gtk.widgetAddEvents drawingArea (gflagsToWord [ Gdk.EventMaskPointerMotionMask + , Gdk.EventMaskButtonPressMask + , Gdk.EventMaskSmoothScrollMask + , Gdk.EventMaskKeyPressMask + ]) + + -- scroll Events + scrollE <- signalE1' drawingArea #scrollEvent $ \e -> + Gdk.getEventScrollDeltaY e + + -- events when we press a key + keyPressedE <- signalE1' drawingArea #keyPressEvent $ \e -> do + v <- Gdk.getEventKeyKeyval e + Gdk.keyvalName v + -- events where we press an arrow key + let arrowKeyE = filterJust . fmap (>>= toArrowKey) $ keyPressedE + + -- handle mouse clicks + mousePressedE <- signalE1' drawingArea #buttonPressEvent $ \e -> do + x <- Gdk.getEventButtonX e + y <- Gdk.getEventButtonY e + return $! V2 x ((-1*y) + drawingAreaH) + + lastMousePressB <- stepper undefined mousePressedE + + -- mouse release + -- mouseReleasedE <- signalE1' drawingArea #buttonReleaseEvent $ \e -> do + -- x <- Gdk.getEventButtonX e + -- y <- Gdk.getEventButtonY e + -- return $! V2 x ((-1*y) + drawingAreaH) + + -- mouse coordinates + mouseMotionE <- signalE1' drawingArea #motionNotifyEvent $ \e -> do + x <- Gdk.getEventMotionX e + y <- Gdk.getEventMotionY e + st <- Gdk.getEventMotionState e + let !p = V2 x ((-1*y) + drawingAreaH) + return (p,st) + mouseMotionB <- stepper undefined mouseMotionE + + -- difference between the current mouse position and where we clicked last + let dragOffsetB = (\p (q,_) -> p .-. q) <$> lastMousePressB <*> mouseMotionB + + -- sample the displacement vector whenever we are have a move event + -- and the moude button is still on + dragOffsetE = dragOffsetB + <@ filterE ((Gdk.ModifierTypeButton1Mask `elem`) . snd) mouseMotionE + + + zoomLevelB <- accumB 1 $ (\dy -> (+0.1*dy)) <$> scrollE + + + let lastPosE = unions [ (\k -> (.+^ 2 *^ toDirection k)) <$> arrowKeyE -- key event + , (\v -> (.+^ v)) <$> dragOffsetE -- drag event + ] + viewPortPosB <- accumB (V2 (drawingAreaW/2) (drawingAreaH/2)) $ lastPosE + + let viewPortB = ViewPort <$> pure drawWorld' + <*> pure (V2 drawingAreaW drawingAreaH) + <*> viewPortPosB + <*> zoomLevelB + <*> pure 0 + + -- draw everything + draw drawingArea (mirrored drawingAreaH render <$> viewPortB) + #showAll window + +data ViewPort a = ViewPort { drawWorld :: Canvas a + , screenSize :: V2 Double + , clippwingWindowCenter :: V2 Double + , zoomLevel :: Double + , rotation :: Double + } + +clippingWindow :: ViewPort a -> Canvas.Dim +clippingWindow (ViewPort _ (V2 w h) (V2 cx cy) z _) = let x = cx - z*w/2 + y = cy - z*h/2 + in Canvas.D x y (z*w) (z*h) + +-- some drawing +drawWorld' :: Canvas () +drawWorld' = do + Canvas.background $ Canvas.gray 255 + Canvas.stroke $ Canvas.gray 0 + forM_ [1..20] $ \i -> + forM_ [1..16] $ \j -> do + Canvas.rect (Canvas.D (100*i) (100*j) 20 20) + +-- | Mirror the canvas s.t. the bottom-left corner is the origin +mirrored :: Double -> (a -> Canvas ()) -> a -> Canvas () +mirrored h d x = do Canvas.scale $ V2 1 (-1) + Canvas.translate $ V2 0 (-1*h) + d x + +-- | Render the view +render :: ViewPort a -> Canvas a +render vp = do + let (Canvas.D x y _ _) = clippingWindow vp + + Canvas.scale $ V2 (1/zoomLevel vp) (1/zoomLevel vp) -- scale everything s.t. the + -- cippingWindow equals + -- the window size + Canvas.translate $ V2 (-1*x) (-1*y) -- move screen to the origin + drawWorld vp diff --git a/src/Algorithms/Geometry/ConvexHull/DivideAndConqueror.hs b/src/Algorithms/Geometry/ConvexHull/DivideAndConqueror.hs --- a/src/Algorithms/Geometry/ConvexHull/DivideAndConqueror.hs +++ b/src/Algorithms/Geometry/ConvexHull/DivideAndConqueror.hs @@ -12,7 +12,8 @@ import Data.Semigroup import Data.Semigroup.Foldable --- | \(O(n \log n)\) time ConvexHull using divide and conqueror. +-- | \(O(n \log n)\) time ConvexHull using divide and conqueror. The resulting polygon is +-- given in clockwise order. convexHull :: (Ord r, Num r) => NonEmpty.NonEmpty (Point 2 r :+ p) -> ConvexPolygon p r convexHull = unMerge diff --git a/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs b/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs --- a/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs +++ b/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs @@ -49,8 +49,8 @@ hull' :: (Ord r, Num r) => [Point 2 r :+ p] -> NonEmpty (Point 2 r :+ p) hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps where - hull'' h [] = h - hull'' h (p:ps) = hull'' (cleanMiddle (p:h)) ps + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' cleanMiddle h@[_,_] = h cleanMiddle h@(z:y:x:rest) diff --git a/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs b/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs --- a/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs +++ b/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs @@ -11,9 +11,11 @@ import qualified Data.IntMap.Strict as IM import qualified Data.Map as M import qualified Data.Map.Strict as SM -import Data.PlaneGraph +import qualified Data.PlaneGraph as PG +import qualified Data.PlanarGraph as PPG import qualified Data.Vector as V + -------------------------------------------------------------------------------- -- We store all adjacency lists in clockwise order @@ -80,47 +82,18 @@ -- | convert the triangulation into a planarsubdivision -- --- running time: \(O(n\log n)\). -toPlanarSubdivision :: proxy s -> Triangulation p r -> PlanarSubdivision s p () () r -toPlanarSubdivision px tr = PlanarSubdivision g - where - g = toPlaneGraph px tr & vertexData.traverse %~ (\(v :+ e) -> VertexData v e) - & dartData.traverse._2 %~ EdgeData Visible - & faceData.traverse %~ FaceData [] +-- running time: \(O(n)\). +toPlanarSubdivision :: (Ord r, Fractional r) + => proxy s -> Triangulation p r -> PlanarSubdivision s p () () r +toPlanarSubdivision px = fromPlaneGraph . toPlaneGraph px -- | convert the triangulation into a plane graph -- --- running time: \(O(n\log n)\). +-- running time: \(O(n)\). toPlaneGraph :: forall proxy s p r. - proxy s -> Triangulation p r -> PlaneGraph s Primal_ p () () r -toPlaneGraph _ tr = g & vertexData .~ tr^.positions + proxy s -> Triangulation p r -> PG.PlaneGraph s p () () r +toPlaneGraph _ tr = PG.PlaneGraph $ g&PPG.vertexData .~ vtxData where - g = fromAdjacencyLists . V.toList . V.imap f $ tr^.neighbours + g = PG.fromAdjacencyLists . V.toList . V.imap f $ tr^.neighbours f i adj = (VertexId i, VertexId <$> adj) - - - -- (planarGraph' . P.toCycleRep n $ perm)&vertexData .~ tr^.positions - -- where - -- neighs = C.rightElements <$> tr^.neighbours - -- n = sum . fmap length $ neighs - - -- vtxIDs = [0..] - -- perm = trd' . foldr toOrbit (ST mempty 0 mempty) $ zip vtxIDs (V.toList neighs) - - -- -- | Given a vertex with its adjacent vertices (u,vs) (in CCW order) convert this - -- -- vertex with its adjacent vertices into an Orbit - -- toOrbit :: (VertexID,[VertexID]) -> ST' [[Dart s]] - -- -> ST' [[Dart s]] - -- toOrbit (u,vs) (ST m a dss) = - -- let (ST m' a' ds') = foldr (toDart . (u,)) (ST m a mempty) vs - -- in ST m' a' (ds':dss) - - - -- -- | Given an edge (u,v) and a triplet (m,a,ds) we construct a new dart - -- -- representing this edge. - -- toDart :: (VertexID,VertexID) -> ST' [Dart s] -> ST' [Dart s] - -- toDart (u,v) (ST m a ds) = let dir = if u < v then Positive else Negative - -- t' = (min u v, max u v) - -- in case M.lookup t' m of - -- Just a' -> ST m a (Dart (Arc a') dir : ds) - -- Nothing -> ST (SM.insert t' a m) (a+1) (Dart (Arc a) dir : ds) + vtxData = (\(loc :+ p) -> VertexData loc p) <$> tr^.positions diff --git a/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs b/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs --- a/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs +++ b/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs @@ -25,14 +25,14 @@ -- running time: \(O(n \log n)\) euclideanMST :: (Ord r, Fractional r) => NonEmpty.NonEmpty (Point 2 r :+ p) -> Tree (Point 2 r :+ p) -euclideanMST pts = (\v -> g^.vDataOf v) <$> t +euclideanMST pts = (\v -> g^.locationOf v :+ g^.dataOf v) <$> t where -- since we care only about the relative order of the edges we can use the -- squared Euclidean distance rather than the Euclidean distance, thus -- avoiding the Floating constraint g = withEdgeDistances squaredEuclideanDist . toPlaneGraph (Proxy :: Proxy MSTW) . delaunayTriangulation $ pts - t = mst g + t = mst $ g^.graph data MSTW diff --git a/src/Algorithms/Geometry/LineSegmentIntersection.hs b/src/Algorithms/Geometry/LineSegmentIntersection.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/LineSegmentIntersection.hs @@ -0,0 +1,16 @@ +module Algorithms.Geometry.LineSegmentIntersection where + +import qualified Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann as BO +import Data.Geometry.LineSegment +import Data.Geometry.Polygon + +-- Tests if there are any interior intersections. +-- +-- | \(O(n \log n)\) +hasInteriorIntersections :: (Ord r, Fractional r) + => [LineSegment 2 p r] -> Bool +hasInteriorIntersections = not . null . BO.interiorIntersections + +-- | \(O(n \log n)\) +hasSelfIntersections :: (Ord r, Fractional r) => Polygon t p r -> Bool +hasSelfIntersections = hasInteriorIntersections . listEdges diff --git a/src/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmann.hs b/src/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmann.hs --- a/src/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmann.hs +++ b/src/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmann.hs @@ -1,12 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann where import Algorithms.Geometry.LineSegmentIntersection.Types import Control.Lens hiding (contains) -import qualified Data.BalBST as SS -- status struct import Data.Ext -import Data.Function (on) +import qualified Data.Foldable as F import Data.Geometry.Interval -import Data.Geometry.Line import Data.Geometry.LineSegment import Data.Geometry.Point import Data.Geometry.Properties @@ -16,12 +15,12 @@ import qualified Data.Map as M import Data.Maybe import Data.Ord (Down(..), comparing) +import Data.OrdSeq (Compare) +import qualified Data.OrdSeq as SS -- status struct import Data.Semigroup import qualified Data.Set as EQ -- event queue import Data.Vinyl -import Frames.CoRec - -import Debug.Trace +import Data.Vinyl.CoRec -------------------------------------------------------------------------------- @@ -30,12 +29,23 @@ -- \(O((n+k)\log n)\), where \(k\) is the number of intersections. intersections :: (Ord r, Fractional r) => [LineSegment 2 p r] -> Intersections p r -intersections ss = merge $ sweep pts (SS.empty $ ordAtNav undefined) +intersections ss = merge $ sweep pts mempty where - pts = EQ.fromAscList . groupStarts . L.sort . concatMap f $ ss - f s = let [p,q] = L.sortBy ordPoints [s^.start.core,s^.end.core] - in [Event p (Start $ s :| []), Event q (End s)] + pts = EQ.fromAscList . groupStarts . L.sort . concatMap asEventPts $ ss +-- | Computes all intersection points p s.t. p lies in the interior of at least +-- one of the segments. +-- +-- \(O((n+k)\log n)\), where \(k\) is the number of intersections. +interiorIntersections :: (Ord r, Fractional r) + => [LineSegment 2 p r] -> Intersections p r +interiorIntersections = M.filter (not . isEndPointIntersection) . intersections + +-- | Computes the event points for a given line segment +asEventPts :: Ord r => LineSegment 2 p r -> [Event p r] +asEventPts s = let [p,q] = L.sortBy ordPoints [s^.start.core,s^.end.core] + in [Event p (Start $ s :| []), Event q (End s)] + -- | Group the segments with the intersection points merge :: Ord r => [IntersectionPoint p r] -> Intersections p r merge = foldr (\(IntersectionPoint p a) -> M.insertWith (<>) p a) M.empty @@ -47,14 +57,12 @@ groupStarts (Event p (Start s) : es) = Event p (Start ss) : groupStarts rest where (ss',rest) = L.span sameStart es - -- sort the segs on lower endpoint ss = let (x:|xs) = s in x :| (xs ++ concatMap startSegs ss') sameStart (Event q (Start _)) = p == q sameStart _ = False -groupStarts (e : es) = e : groupStarts es - +groupStarts (e : es) = e : groupStarts es -------------------------------------------------------------------------------- -- * Data type for Events @@ -89,7 +97,6 @@ ordPoints :: Ord r => Point 2 r -> Point 2 r -> Ordering ordPoints a b = let f p = (Down $ p^.yCoord, p^.xCoord) in comparing f a b - -- | Get the segments that start at the given event point startSegs :: Event p r -> [LineSegment 2 p r] startSegs e = case eventType e of @@ -98,24 +105,30 @@ -------------------------------------------------------------------------------- --- | The navigator that we use that orders the segments that intersect at a --- horizontal line (from left to right) -ordAtNav :: (Ord r, Fractional r) => r -> SS.TreeNavigator r (LineSegment 2 p r) -ordAtNav y = SS.Nav (\s x -> h s <= x) (min `on` h) - where - h s = match (s `intersect` horizontalLine y) $ - (H $ \NoIntersection -> error "ordAtNav: No intersection") - :& (H $ \p -> p^.xCoord) - :& (H $ \_ -> rightEndpoint s) -- the intersection is s itself - :& RNil +-- | Compare based on the x-coordinate of the intersection with the horizontal +-- line through y +ordAt :: (Fractional r, Ord r) => r -> Compare (LineSegment 2 p r) +ordAt y = comparing (xCoordAt y) +-- | Given a y coord and a line segment that intersects the horizontal line +-- through y, compute the x-coordinate of this intersection point. +-- +-- note that we will pretend that the line segment is closed, even if it is not +xCoordAt :: (Fractional r, Ord r) => r -> LineSegment 2 p r -> r +xCoordAt y (LineSegment' (Point2 px py :+ _) (Point2 qx qy :+ _)) + | py == qy = px `max` qx -- s is horizontal, and since it by the + -- precondition it intersects the sweep + -- line, we return the x-coord of the + -- rightmost endpoint. + | otherwise = px + alpha * (qx - px) + where + alpha = (y - py) / (qy - py) -------------------------------------------------------------------------------- -- * The Main Sweep -type EventQueue p r = EQ.Set (Event p r) - -type StatusStructure p r = SS.BalBST r (LineSegment 2 p r) +type EventQueue p r = EQ.Set (Event p r) +type StatusStructure p r = SS.OrdSeq (LineSegment 2 p r) -- | Run the sweep handling all events sweep :: (Ord r, Fractional r) @@ -124,8 +137,13 @@ Nothing -> [] Just (e,eq') -> handle e eq' ss +isClosedStart :: Eq r => Point 2 r -> LineSegment 2 p r -> Bool +isClosedStart p (LineSegment s e) + | p == s^.unEndPoint.core = isClosed s + | otherwise = isClosed e + -- | Handle an event point -handle :: (Ord r, Fractional r) +handle :: forall r p. (Ord r, Fractional r) => Event p r -> EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r] handle e@(eventPoint -> p) eq ss = toReport <> sweep eq' ss' @@ -133,22 +151,20 @@ starts = startSegs e (before,contains',after) = extractContains p ss (ends,contains) = L.partition (endsAt p) contains' - - - toReport = case starts ++ contains' of - (_:_:_) -> [IntersectionPoint p $ associated (starts <> ends) contains] + -- starting segments, exluding those that have an open starting point + starts' = filter (isClosedStart p) starts + toReport = case starts' ++ contains' of + (_:_:_) -> [IntersectionPoint p $ associated (starts' <> ends) contains] _ -> [] -- new status structure - ss' = before `SS.join` newSegs `SS.join` after - + ss' = before <> newSegs <> after newSegs = toStatusStruct p $ starts ++ contains -- the new eeventqueue eq' = foldr EQ.insert eq es - -- the new events: - es | SS.null newSegs = maybeToList $ app (findNewEvent p) sl sr + es | F.null newSegs = maybeToList $ app (findNewEvent p) sl sr | otherwise = let s' = fst <$> SS.minView newSegs s'' = fst <$> SS.maxView newSegs in catMaybes [ app (findNewEvent p) sl s' @@ -164,24 +180,22 @@ extractContains :: (Fractional r, Ord r) => Point 2 r -> StatusStructure p r -> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r) -extractContains p ss = (before, mid1 ++ mid2, after) +extractContains p ss = (before, F.toList $ mid1 <> mid2, after) where - n = ordAtNav (p^.yCoord) - SS.Split before (mid1,mid2) after = SS.splitExtract pred' sel $ ss { SS.nav = n} - - pred' s = not $ SS.goLeft n s (p^.xCoord) - sel s = p `onSegment` s - + (before, mid1, after') = SS.splitOn (xCoordAt $ p^.yCoord) (p^.xCoord) ss + -- Make sure to also select the horizontal segments containing p + (mid2, after) = SS.splitMonotonic (\s -> not $ p `onSegment` s) after' -- | Given a point and the linesegements that contain it. Create a piece of -- status structure for it. toStatusStruct :: (Fractional r, Ord r) => Point 2 r -> [LineSegment 2 p r] -> StatusStructure p r -toStatusStruct p xs = ss { SS.nav = ordAtNav $ p^.yCoord } `SS.join` hors +toStatusStruct p xs = ss <> hors + -- ss { SS.nav = ordAtNav $ p^.yCoord } `SS.join` hors where (hors',rest) = L.partition isHorizontal xs - ss = SS.fromList (ordAtNav $ maxY xs) rest - hors = SS.fromList (SS.ordNavBy rightEndpoint) hors' + ss = SS.fromListBy (ordAt $ maxY xs) rest + hors = SS.fromListBy (comparing rightEndpoint) hors' isHorizontal s = s^.start.core.yCoord == s^.end.core.yCoord diff --git a/src/Algorithms/Geometry/LineSegmentIntersection/Naive.hs b/src/Algorithms/Geometry/LineSegmentIntersection/Naive.hs --- a/src/Algorithms/Geometry/LineSegmentIntersection/Naive.hs +++ b/src/Algorithms/Geometry/LineSegmentIntersection/Naive.hs @@ -11,7 +11,7 @@ import qualified Data.Map as M import Data.Semigroup import Data.Vinyl -import Frames.CoRec +import Data.Vinyl.CoRec -- | Compute all intersections (naively) diff --git a/src/Algorithms/Geometry/LineSegmentIntersection/Types.hs b/src/Algorithms/Geometry/LineSegmentIntersection/Types.hs --- a/src/Algorithms/Geometry/LineSegmentIntersection/Types.hs +++ b/src/Algorithms/Geometry/LineSegmentIntersection/Types.hs @@ -26,6 +26,7 @@ , _interiorTo :: Set' (LineSegment 2 p r) } deriving (Show) + instance (Eq p, Eq r) => Eq (Associated p r) where (Associated es is) == (Associated es' is') = f es es' && f is is' where @@ -65,6 +66,13 @@ } deriving (Show,Eq) makeLenses ''IntersectionPoint + +-- | reports true if there is at least one segment for which this intersection +-- point is interior. +-- +-- \(O(1)\) +isEndPointIntersection :: Associated p r -> Bool +isEndPointIntersection = Map.null . _interiorTo -- newtype E a b = E (a -> b) diff --git a/src/Algorithms/Geometry/LowerEnvelope/DualCH.hs b/src/Algorithms/Geometry/LowerEnvelope/DualCH.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/LowerEnvelope/DualCH.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Algorithms.Geometry.LowerEnvelope.DualCH where + +import Data.Maybe(fromJust) +import Control.Lens((^.)) +import Data.Ext +import Data.Geometry +import Algorithms.Geometry.ConvexHull.GrahamScan +import Data.List.NonEmpty(NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Geometry.Duality +import Data.Proxy +import Data.Vinyl.CoRec + +type Envelope a r = NonEmpty (Line 2 r :+ a) + +-- | Given a list of non-vertical lines, computes the lower envelope using +-- duality. +-- +-- \(O(n\log n)\) +lowerEnvelope :: (Ord r, Fractional r) => NonEmpty (Line 2 r :+ a) -> Envelope a r +lowerEnvelope = lowerEnvelopeWith upperHull + + +type UpperHullAlgorithm a r = NonEmpty (Point 2 r :+ a) -> NonEmpty (Point 2 r :+ a) + +-- | Given a list of non-vertical lines, computes the lower envelope by computing +-- the upper convex hull. It uses the given algorithm to do so +-- +-- running time: O(time required by the given upper hull algorithm) +lowerEnvelopeWith :: (Fractional r, Eq r) + => UpperHullAlgorithm (Line 2 r :+ a) r + -> NonEmpty (Line 2 r :+ a) -> Envelope a r +lowerEnvelopeWith chAlgo = fromPts . chAlgo . toPts + where + toPts = fmap (\l -> dualPoint' (l^.core) :+ l) + fromPts = fmap (^.extra) + +-- | Computes the vertices of the envelope, in left to right order +vertices :: (Ord r, Fractional r) => Envelope a r -> [Point 2 r :+ (a,a)] +vertices e = zipWith intersect' (NonEmpty.toList e) (NonEmpty.tail e) + + +-- | Given two non-parallel lines, compute the intersection point and +-- return the pair of a's associated with the lines +intersect' :: forall r a. (Ord r, Fractional r) + => Line 2 r :+ a -> Line 2 r :+ a -> Point 2 r :+ (a,a) +intersect' (l :+ le) (r :+ re) = (:+ (le,re)) . fromJust + . asA (Proxy :: Proxy (Point 2 r)) $ l `intersect` r diff --git a/src/Algorithms/Geometry/PolygonTriangulation/MakeMonotone.hs b/src/Algorithms/Geometry/PolygonTriangulation/MakeMonotone.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/PolygonTriangulation/MakeMonotone.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Algorithms.Geometry.PolygonTriangulation.MakeMonotone where + +import Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann ( xCoordAt + , ordAt) +import Algorithms.Geometry.PolygonTriangulation.Types +import Control.Lens +import Control.Monad (forM_, when) +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Writer (WriterT, execWriterT,tell) +import Data.Bifunctor +import Data.CircularSeq (rotateL, rotateR, zip3LWith) +import qualified Data.DList as DList +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.LineSegment +import Data.Geometry.PlanarSubdivision.Basic +import Data.Geometry.Point +import Data.Geometry.Polygon +import qualified Data.IntMap as IntMap +import qualified Data.List.NonEmpty as NonEmpty +import Data.Ord (comparing, Down(..)) +import Data.OrdSeq (OrdSeq) +import qualified Data.OrdSeq as SS +import Data.Semigroup +import Data.Util +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV + + +---------------------------------------------------------------------------------- + +data VertexType = Start | Merge | Split | End | Regular deriving (Show,Read,Eq) + + +-- How about the hole vertices? + +-- | assigns a vertex type to each vertex +-- +-- pre: the polygon is given in CCW order +-- +-- running time: \(O(n)\). +classifyVertices :: (Num r, Ord r) + => Polygon t p r + -> Polygon t (p :+ VertexType) r +classifyVertices p@(SimplePolygon _) = classifyVertices' p +classifyVertices (MultiPolygon vs h) = MultiPolygon vs' h' + where + (SimplePolygon vs') = classifyVertices' $ SimplePolygon vs + h' = map (first (&extra %~ onHole) . classifyVertices') h + + -- the roles on hole vertices are slightly different + onHole Start = Split + onHole Merge = End + onHole Split = Start + onHole End = Merge + onHole Regular = Regular + +-- | assigns a vertex type to each vertex +-- +-- pre: the polygon is given in CCW order +-- +-- running time: \(O(n)\). +classifyVertices' :: (Num r, Ord r) + => SimplePolygon p r + -> SimplePolygon (p :+ VertexType) r +classifyVertices' (SimplePolygon vs) = + SimplePolygon $ zip3LWith f (rotateL vs) vs (rotateR vs) + where + -- is the angle larger than > 180 degrees + largeInteriorAngle p c n = case ccw (p^.core) (c^.core) (n^.core) of + CCW -> False + CW -> True + _ -> error "classifyVertices -> largeInteriorAngle: colinear points" + + f p c n = c&extra %~ (:+ vt) + where + vt = case (p `cmpSweep` c, n `cmpSweep` c, largeInteriorAngle p c n) of + (LT, LT, False) -> Start + (LT, LT, True) -> Split + (GT, GT, False) -> End + (GT, GT, True) -> Merge + _ -> Regular + + + +-- | p < q = p.y < q.y || p.y == q.y && p.x > q.y +cmpSweep :: Ord r => Point 2 r :+ e -> Point 2 r :+ e -> Ordering +p `cmpSweep` q = + comparing (^.core.yCoord) p q <> comparing (Down . (^.core.xCoord)) p q + + +-------------------------------------------------------------------------------- + +type Event r = Point 2 r :+ (Two (LineSegment 2 Int r)) + +data StatusStruct r = SS { _statusStruct :: !(SS.OrdSeq (LineSegment 2 Int r)) + , _helper :: !(IntMap.IntMap Int) + -- ^ for every e_i, the id of the helper vertex + } deriving (Show) +makeLenses ''StatusStruct + +ix' :: Int -> Lens' (V.Vector a) a +ix' i = singular (ix i) + +-- | Given a polygon, find a set of non-intersecting diagonals that partition +-- the polygon into y-monotone pieces. +-- +-- running time: \(O(n\log n)\) +computeDiagonals :: forall t r p. (Fractional r, Ord r) + => Polygon t p r -> [LineSegment 2 p r] +computeDiagonals p' = map f . sweep + . NonEmpty.sortBy (flip cmpSweep) + . polygonVertices . withIncidentEdges + . first (^._1) $ pg + where + -- remaps to get the p value rather than the vertexId + f = first (\i -> vertexInfo^.ix' i._2) + + pg :: Polygon t (SP Int (p :+ VertexType)) r + pg = numberVertices . classifyVertices . toCounterClockWiseOrder $ p' + vertexInfo :: V.Vector (STR (Point 2 r) p VertexType) + vertexInfo = let vs = polygonVertices pg + n = F.length vs + in V.create $ do + v <- MV.new n + forM_ vs $ \(pt :+ SP i (p :+ vt)) -> + MV.write v i (STR pt p vt) + return v + + initialSS = SS mempty mempty + + sweep es = flip runReader vertexInfo $ evalStateT (sweep' es) initialSS + sweep' es = DList.toList <$> execWriterT (sweep'' es) + + sweep'' :: NonEmpty.NonEmpty (Event r) -> Sweep p r () + sweep'' = mapM_ handle + +-- | Computes a set of diagionals that decompose the polygon into y-monotone +-- pieces. +-- +-- running time: \(O(n\log n)\) +makeMonotone :: (Fractional r, Ord r) + => proxy s -> Polygon t p r + -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r +makeMonotone px pg = let (e:es) = listEdges pg + in constructSubdivision px e es (computeDiagonals pg) + +type Sweep p r = WriterT (DList.DList (LineSegment 2 Int r)) + (StateT (StatusStruct r) + (Reader (V.Vector (VertexInfo p r)))) + +type VertexInfo p r = STR (Point 2 r) p VertexType + + +tell' :: LineSegment 2 Int r -> Sweep p r () +tell' = tell . DList.singleton + +getIdx :: Event r -> Int +getIdx = view (extra._1.end.extra) + +getVertexType :: Int -> Sweep p r VertexType +getVertexType v = asks (^.ix' v._3) + +getEventType :: Event r -> Sweep p r VertexType +getEventType = getVertexType . getIdx + +handle :: (Fractional r, Ord r) => Event r -> Sweep p r () +handle e = let i = getIdx e in getEventType e >>= \case + Start -> handleStart i e + End -> handleEnd i e + Split -> handleSplit i e + Merge -> handleMerge i e + Regular | isLeftVertex i e -> handleRegularL i e + | otherwise -> handleRegularR i e + + +insertAt :: (Ord r, Fractional r) => Point 2 r -> LineSegment 2 q r + -> OrdSeq (LineSegment 2 q r) -> OrdSeq (LineSegment 2 q r) +insertAt v = SS.insertBy (ordAt $ v^.yCoord) + +deleteAt :: (Fractional r, Ord r) => Point 2 r -> LineSegment 2 p r + -> OrdSeq (LineSegment 2 p r) -> OrdSeq (LineSegment 2 p r) +deleteAt v = SS.deleteAllBy (ordAt $ v^.yCoord) + + +handleStart :: (Fractional r, Ord r) + => Int -> Event r -> Sweep p r () +handleStart i (v :+ adj) = modify $ \(SS t h) -> + SS (insertAt v (adj^._2) t) + (IntMap.insert i i h) + +handleEnd :: (Fractional r, Ord r) + => Int -> Event r -> Sweep p r () +handleEnd i (v :+ adj) = do let iPred = adj^._1.start.extra -- i-1 + -- lookup p's helper; if it is a merge vertex + -- we insert a new segment + tellIfMerge i v iPred + -- delete e_{i-1} from the status struct + modify $ \ss -> + ss&statusStruct %~ deleteAt v (adj^._1) + +-- | Adds edge (i,j) if e_j's helper is a merge vertex +tellIfMerge :: Int -> Point 2 r -> Int -> Sweep p r () +tellIfMerge i v j = do SP u ut <- getHelper j + when (ut == Merge) (tell' $ ClosedLineSegment (v :+ i) u) + +-- | Get the helper of edge i, and its vertex type +getHelper :: Int -> Sweep p r (SP (Point 2 r :+ Int) VertexType) +getHelper i = do Just ui <- gets (^.helper.at i) + STR u _ ut <- asks (^.ix' ui) + pure $ SP (u :+ ui) ut + + +lookupLE :: (Ord r, Fractional r) + => Point 2 r -> OrdSeq (LineSegment 2 Int r) + -> Maybe (LineSegment 2 Int r) +lookupLE v s = let (l,m,_) = SS.splitOn (xCoordAt $ v^.yCoord) (v^.xCoord) s + in SS.lookupMax (l <> m) + + +handleSplit :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r () +handleSplit i (v :+ adj) = do Just ej <- gets $ \ss -> ss^.statusStruct.to (lookupLE v) + let j = ej^.start.extra + SP u _ <- getHelper j + -- update the status struct: + -- insert the new edge into the status Struct and + -- set the helper of e_j to be v_i + modify $ \(SS t h) -> + SS (insertAt v (adj^._2) t) + (IntMap.insert i i . IntMap.insert j i $ h) + -- return the diagonal + tell' $ ClosedLineSegment (v :+ i) u + +handleMerge :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r () +handleMerge i (v :+ adj) = do let ePred = adj^._1.start.extra -- i-1 + tellIfMerge i v ePred + -- delete e_{i-1} from the status struct + modify $ \ss -> ss&statusStruct %~ deleteAt v (adj^._1) + connectToLeft i v + +-- | finds the edge j to the left of v_i, and connect v_i to it if the helper +-- of j is a merge vertex +connectToLeft :: (Fractional r, Ord r) => Int -> Point 2 r -> Sweep p r () +connectToLeft i v = do Just ej <- gets $ \ss -> ss^.statusStruct.to (lookupLE v) + let j = ej^.start.extra + tellIfMerge i v j + modify $ \ss -> ss&helper %~ IntMap.insert j i + +-- | returns True if v the interior of the polygon is to the right of v +isLeftVertex :: Ord r => Int -> Event r -> Bool +isLeftVertex i (v :+ adj) = case (adj^._1.start) `cmpSweep` (v :+ i) of + GT -> True + _ -> False + -- if the predecessor occurs before the sweep, this must be a left vertex + +handleRegularL :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r () +handleRegularL i (v :+ adj) = do let ePred = adj^._1.start.extra -- i-1 + tellIfMerge i v ePred + -- delete e_{i-1} from the status struct + modify $ \ss -> + ss&statusStruct %~ deleteAt v (adj^._1) + -- insert a e_i in the status struct, and set its helper + -- to be v_i + modify $ \(SS t h) -> + SS (insertAt v (adj^._2) t) + (IntMap.insert i i h) + +handleRegularR :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r () +handleRegularR i (v :+ _) = connectToLeft i v + + + + +-------------------------------------------------------------------------------- + + +-- testPolygon :: SimplePolygon Int Rational +-- testPolygon = fromPoints [ point2 20 20 :+ 1 +-- , point2 18 19 :+ 2 +-- , point2 16 25 :+ 3 +-- , point2 13 23 :+ 4 +-- , point2 10 24 :+ 5 +-- , point2 6 22 :+ 6 +-- , point2 8 21 :+ 7 +-- , point2 7 18 :+ 8 +-- , point2 2 19 :+ 9 +-- , point2 1 10 :+ 10 +-- , point2 3 5 :+ 11 +-- , point2 11 7 :+ 12 +-- , point2 15 1 :+ 13 +-- , point2 12 15 :+ 14 +-- , point2 15 12 :+ 15 +-- ] + +-- vertexTypes = [Start,Merge,Start,Merge,Start,Regular,Regular,Merge,Start,Regular,End,Split,End,Split,End] + + +-- loadT = do pgs <- readAllFrom "/Users/frank/tmp/testPoly.ipe" +-- :: IO [SimplePolygon () Rational :+ IpeAttributes Path Rational] +-- mapM_ print pgs +-- let diags = map (computeDiagonals . (^.core)) pgs +-- f = asIpeGroup . map (asIpeObject' mempty) +-- out = [ asIpeGroup $ map (\(pg :+ a) -> asIpeObject pg a) pgs +-- , asIpeGroup $ map f diags +-- ] +-- outFile = "/Users/frank/tmp/out.ipe" +-- writeIpeFile outFile . singlePageFromContent $ out diff --git a/src/Algorithms/Geometry/PolygonTriangulation/Triangulate.hs b/src/Algorithms/Geometry/PolygonTriangulation/Triangulate.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/PolygonTriangulation/Triangulate.hs @@ -0,0 +1,70 @@ +module Algorithms.Geometry.PolygonTriangulation.Triangulate where + + +import qualified Algorithms.Geometry.PolygonTriangulation.MakeMonotone as MM +import qualified Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone as TM +import Algorithms.Geometry.PolygonTriangulation.Types +import Control.Lens +import Data.Either (lefts) +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.LineSegment +import Data.Geometry.PlanarSubdivision.Basic +import Data.Geometry.Polygon +import Data.PlaneGraph (PlaneGraph) +import Data.Semigroup + +-- | Triangulates a polygon of \(n\) vertices +-- +-- running time: \(O(n \log n)\) +triangulate :: (Ord r, Fractional r) + => proxy s -> Polygon t p r + -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r +triangulate px pg' = constructSubdivision px e es diags + where + (pg, diags) = computeDiagonals' pg' + (e:es) = listEdges pg + + +-- | Triangulates a polygon of \(n\) vertices +-- +-- running time: \(O(n \log n)\) +triangulate' :: (Ord r, Fractional r) + => proxy s -> Polygon t p r + -> PlaneGraph s p PolygonEdgeType PolygonFaceData r +triangulate' px pg' = constructGraph px e es diags + where + (pg, diags) = computeDiagonals' pg' + (e:es) = listEdges pg + + +-- | Computes a set of diagaonals that together triangulate the input polygon +-- of \(n\) vertices. +-- +-- running time: \(O(n \log n)\) +computeDiagonals :: (Ord r, Fractional r) => Polygon t p r -> [LineSegment 2 p r] +computeDiagonals = snd . computeDiagonals' + +-- | Computes a set of diagaonals that together triangulate the input polygon +-- of \(n\) vertices. Returns a copy of the input polygon, whose boundaries are +-- oriented in counter clockwise order, as well. +-- +-- running time: \(O(n \log n)\) +computeDiagonals' :: (Ord r, Fractional r) + => Polygon t p r -> (Polygon t p r, [LineSegment 2 p r]) +computeDiagonals' pg' = (pg, monotoneDiags <> extraDiags) + where + pg = toCounterClockWiseOrder pg' + monotoneP = MM.makeMonotone (Identity pg') pg -- use some arbitrary proxy type + -- outerFaceId' = outerFaceId monotoneP + + monotoneDiags = map (^._2.core) . filter (\e' -> e'^._2.extra == Diagonal) + . F.toList . edgeSegments $ monotoneP + extraDiags = concatMap (TM.computeDiagonals . toCounterClockWiseOrder') + . lefts . map (^._2.core) + -- . filter (\f -> f^._1 /= outerFaceId') + . F.toList . rawFacePolygons $ monotoneP + + -- we alredy know we get the polgyons in *clockwise* order, so skip the + -- check if it is counter clockwise + toCounterClockWiseOrder' = reverseOuterBoundary diff --git a/src/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotone.hs b/src/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotone.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotone.hs @@ -0,0 +1,178 @@ +module Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone where + +import Control.Lens +import Data.Bifunctor +import qualified Data.CircularSeq as C +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Polygon +import qualified Data.List as L +import Data.Ord (comparing, Down(..)) +import Data.Semigroup +import Data.Util +import Algorithms.Geometry.PolygonTriangulation.Types +import Data.PlaneGraph (PlaneGraph) +import Data.Geometry.PlanarSubdivision.Basic(PolygonFaceData, PlanarSubdivision) + +-------------------------------------------------------------------------------- + +-- +type MonotonePolygon p r = SimplePolygon p r + +data LR = L | R deriving (Show,Eq) + +-- | Triangulates a polygon of \(n\) vertices +-- +-- running time: \(O(n \log n)\) +triangulate :: (Ord r, Fractional r) + => proxy s -> MonotonePolygon p r + -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r +triangulate px pg' = constructSubdivision px e es (computeDiagonals pg) + where + pg = toCounterClockWiseOrder pg' + (e:es) = listEdges pg + -- TODO: Find a way to construct the graph in O(n) time. + +-- | Triangulates a polygon of \(n\) vertices +-- +-- running time: \(O(n \log n)\) +triangulate' :: (Ord r, Fractional r) + => proxy s -> MonotonePolygon p r + -> PlaneGraph s p PolygonEdgeType PolygonFaceData r +triangulate' px pg' = constructGraph px e es (computeDiagonals pg) + where + pg = toCounterClockWiseOrder pg' + (e:es) = listEdges pg + -- TODO: Find a way to construct the graph in O(n) time. + + +-- | Given a y-monotone polygon in counter clockwise order computes the diagonals +-- to add to triangulate the polygon +-- +-- pre: the input polygon is y-monotone and has \(n \geq 3\) vertices +-- +-- running time: \(O(n)\) +computeDiagonals :: (Ord r, Num r) + => MonotonePolygon p r -> [LineSegment 2 p r] +computeDiagonals pg = diags'' <> diags' + where + -- | run the stack computation + SP (_:stack') diags' = L.foldl' (\(SP stack acc) v' -> (<> acc) <$> process v' stack) + (SP [v,u] []) vs' + -- add vertices from the last guy w to all 'middle' guys of the final stack + diags'' = map (seg w) $ init stack' + -- extract the last vertex + Just (vs',w) = unsnoc vs + -- merge the two lists into one list for procerssing + (u:v:vs) = uncurry (mergeBy $ comparing (\(Point2 x y :+ _) -> (Down y, x))) + $ splitPolygon pg + + +type P p r = Point 2 r :+ (LR :+ p) + +type Stack a = [a] + + + + +-- type Scan p r = State (Stack (P p r)) + +chainOf :: P p r -> LR +chainOf = (^.extra.core) + +toVtx :: P p r -> Point 2 r :+ p +toVtx = (&extra %~ (^.extra)) + +seg :: P p r -> P p r -> LineSegment 2 p r +seg u v = ClosedLineSegment (toVtx u) (toVtx v) + +process :: (Ord r, Num r) + => P p r -> Stack (P p r) + -> SP (Stack (P p r)) [LineSegment 2 p r] +process _ [] = error "TriangulateMonotone.process: absurd. empty stack" +process v stack@(u:ws) + | chainOf v /= chainOf u = SP [v,u] (map (seg v) . init $ stack) + | otherwise = SP (v:w:rest) (map (seg v) popped) + where + (popped,rest) = bimap (map fst) (map fst) . L.span (isInside v) $ zip ws stack + w = last $ u:popped + + +-- | test if m does not block the line segment from v to u +isInside :: (Ord r, Num r) => P p r -> (P p r, P p r) -> Bool +isInside v (u, m) = case ccw' v m u of + CoLinear -> False + CCW -> chainOf v == R + CW -> chainOf v == L + +-- | given a comparison function, merge the two ordered lists +mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +mergeBy cmp = go + where + go [] ys = ys + go xs [] = xs + go (x:xs) (y:ys) = case x `cmp` y of + GT -> y : go (x:xs) ys + _ -> x : go xs (y:ys) + + +-- | When the polygon is in counter clockwise order we return (leftChain,rightChain) +-- ordered from the top-down. +-- +-- if there are multiple points with the maximum yCoord we pick the rightmost one, +-- if there are multiple point with the minimum yCoord we pick the leftmost one. +-- +-- running time: \(O(n)\) +splitPolygon :: Ord r => MonotonePolygon p r + -> ([Point 2 r :+ (LR :+ p)], [Point 2 r :+ (LR :+ p)]) +splitPolygon pg = bimap (f L) (f R) + . second reverse + . L.break (\v -> v^.core == vMinY) + . F.toList . C.rightElements $ vs' + where + f x = map (&extra %~ (x :+)) + -- rotates the list to the vtx with max ycoord + Just vs' = C.findRotateTo (\v -> v^.core == vMaxY) + $ pg^.outerBoundary + vMaxY = getY F.maximumBy + vMinY = getY F.minimumBy + swap' (Point2 x y) = Point2 y x + getY ff = let p = ff (comparing (^.core.to swap')) $ pg^.outerBoundary + in p^.core + + + +-------------------------------------------------------------------------------- + +-- testPolygon = fromPoints . map ext $ [ point2 10 10 +-- , point2 5 20 +-- , point2 3 14 +-- , point2 1 1 +-- , point2 8 8 ] + + + + + + +testPoly5 :: SimplePolygon () Rational +testPoly5 = toCounterClockWiseOrder . fromPoints $ map ext $ [ Point2 176 736 + , Point2 240 688 + , Point2 240 608 + , Point2 128 576 + , Point2 64 640 + , Point2 80 720 + , Point2 128 752 + ] + + +-- testPoly5 :: SimplePolygon () Rational +-- testPoly5 = toCounterClockWiseOrder . fromPoints $ map ext $ [ Point2 320 320 +-- , Point2 256 320 +-- , Point2 224 320 +-- , Point2 128 240 +-- , Point2 64 224 +-- , Point2 256 192 +-- ] diff --git a/src/Algorithms/Geometry/PolygonTriangulation/Types.hs b/src/Algorithms/Geometry/PolygonTriangulation/Types.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/PolygonTriangulation/Types.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Algorithms.Geometry.PolygonTriangulation.Types where + +import Control.Lens +import Control.Monad (forM_) +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.LineSegment +import Data.Geometry.PlanarSubdivision.Basic +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.PlaneGraph as PG +import Data.Semigroup +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +-------------------------------------------------------------------------------- + +data PolygonEdgeType = Original | Diagonal + deriving (Show,Read,Eq) + +-- | Given a list of original edges and a list of diagonals, creates a +-- planar-subdivision +-- +-- +-- running time: \(O(n\log n)\) +constructSubdivision :: forall proxy r s p. (Fractional r, Ord r) + => proxy s + -> LineSegment 2 p r -- ^ A counter-clockwise + -- edge along the outer + -- boundary + -> [LineSegment 2 p r] -- ^ remaining original edges + -> [LineSegment 2 p r] -- ^ diagonals + -> PlanarSubdivision s + p PolygonEdgeType PolygonFaceData r +constructSubdivision px e origs diags = fromPlaneGraph $ constructGraph px e origs diags + +-- constructSubdivision px e origs diags = +-- subdiv & rawVertexData.traverse.dataVal %~ NonEmpty.head +-- & rawFaceData %~ V.zipWith zipF faceData' +-- & rawDartData.traverse.dataVal %~ snd +-- where +-- subdiv :: PlanarSubdivision s (NonEmpty p) (Bool,PolygonEdgeType) () r +-- subdiv = fromConnectedSegments px $ e' : origs' <> diags' + +-- diags' = (:+ (True, Diagonal)) <$> diags +-- origs' = (:+ (False,Original)) <$> origs +-- e' = e :+ (True, Original) + +-- -- the darts incident to internal faces +-- queryDarts = concatMap shouldQuery . F.toList . edges' $ subdiv +-- shouldQuery d = case subdiv^.dataOf d of +-- (True, Original) -> [d] +-- (True, Diagonal) -> [d, twin d] +-- _ -> [] + +-- -- the interior faces +-- intFaces = flip leftFace subdiv <$> queryDarts +-- faceData' = V.create $ do +-- v' <- MV.replicate (numFaces subdiv) Outside +-- forM_ intFaces $ \(PG.FaceId (PG.VertexId f)) -> +-- MV.write v' f Inside +-- pure v' + +-- -- set the inside/outside data value +-- zipF x rfd = rfd&dataVal .~ x +-- -- TODO: Idea: generalize the face data assignment into a function +-- -- that does something like: [(Dart, fLeft, fRight] -> FaceData + + +-- | Given a list of original edges and a list of diagonals, creates a +-- planar-subdivision +-- +-- +-- running time: \(O(n\log n)\) +constructGraph :: forall proxy r s p. (Fractional r, Ord r) + => proxy s + -> LineSegment 2 p r -- ^ A counter-clockwise + -- edge along the outer + -- boundary + -> [LineSegment 2 p r] -- ^ remaining original edges + -> [LineSegment 2 p r] -- ^ diagonals + -> PG.PlaneGraph s + p PolygonEdgeType PolygonFaceData r +constructGraph px e origs diags = + subdiv & PG.vertexData.traverse %~ NonEmpty.head + & PG.faceData .~ faceData' + & PG.rawDartData.traverse %~ snd + where + subdiv :: PG.PlaneGraph s (NonEmpty p) (Bool,PolygonEdgeType) () r + subdiv = PG.fromConnectedSegments px $ e' : origs' <> diags' + + diags' = (:+ (True, Diagonal)) <$> diags + origs' = (:+ (False,Original)) <$> origs + e' = e :+ (True, Original) + + -- the darts incident to internal faces + queryDarts = concatMap shouldQuery . F.toList . PG.edges' $ subdiv + shouldQuery d = case subdiv^.dataOf d of + (True, Original) -> [d] + (True, Diagonal) -> [d, twin d] + _ -> [] + + -- the interior faces + intFaces = flip PG.leftFace subdiv <$> queryDarts + faceData' :: V.Vector PolygonFaceData + faceData' = V.create $ do + v' <- MV.replicate (PG.numFaces subdiv) Outside + forM_ intFaces $ \(PG.FaceId (PG.VertexId f)) -> + MV.write v' f Inside + pure v' + +-- -constructSubdivision px e origs diags = +-- - subdiv & planeGraph.PG.vertexData.traverse %~ NonEmpty.head +-- - & planeGraph.PG.faceData .~ faceData' +-- - & planeGraph.PG.rawDartData.traverse.eData %~ snd +-- - where +-- - subdiv = fromConnectedSegments px $ e' : origs' <> diags' +-- - +-- - diags' = (:+ EdgeData Visible (True, Diagonal)) <$> diags +-- - origs' = (:+ EdgeData Visible (False,Original)) <$> origs +-- - e' = e :+ EdgeData Visible (True, Original) +-- - +-- - g = subdiv^.planeGraph +-- - +-- - -- the darts incident to internal faces +-- - queryDarts = concatMap shouldQuery . F.toList . PG.edges' $ g +-- - shouldQuery d = case g^.dataOf d.eData of +-- - (True, Original) -> [d] +-- - (True, Diagonal) -> [d, twin d] +-- - _ -> [] +-- - +-- - -- the interior faces +-- - intFaces = flip PG.leftFace g <$> queryDarts +-- - faceData' = V.create $ do +-- - v' <- MV.replicate (PG.numFaces g) (FaceData [] Outside) +-- - forM_ intFaces $ \(PG.FaceId (PG.VertexId f)) -> +-- - MV.write v' f (FaceData [] Inside) +-- - pure v' diff --git a/src/Algorithms/Geometry/Sweep.hs b/src/Algorithms/Geometry/Sweep.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/Sweep.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +module Algorithms.Geometry.Sweep where + +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Proxy +import Data.Reflection +import Unsafe.Coerce + + + +newtype Tagged (s :: *) a = Tagged { unTag :: a} deriving (Show,Eq,Ord) + +tag :: proxy s -> a -> Tagged s a +tag _ = Tagged + +newtype Timed s t a = Timed {atTime :: (Tagged s t) -> a } + + +instance (Reifies s t, Ord k) => Ord (Timed s t k) where + compare = compare_ + +instance (Reifies s t, Ord k) => Eq (Timed s t k) where + a == b = a `compare` b == EQ + +compare_ :: forall s t k. (Ord k, Reifies s t) + => Timed s t k -> Timed s t k + -> Ordering +(Timed f) `compare_` (Timed g) = let t = reflect (Proxy :: Proxy s) + in f (Tagged t) `compare` g (Tagged t) + + +coerceTo :: proxy s -> f (Timed s' t k) v -> f (Timed s t k) v +coerceTo _ = unsafeCoerce + +unTagged :: f (Timed s t k) v -> f (Timed () t k) v +unTagged = coerceTo (Proxy :: Proxy ()) + + +-- | Runs a computation at a given time. +runAt :: forall s0 t k r f v. Ord k + => t + -> f (Timed s0 t k) v + -> (forall s. Reifies s t => f (Timed s t k) v -> r) + -> r +runAt t m f = reify t $ \prx -> f (coerceTo prx m) + +getTime :: Timed s Int Int +getTime = Timed unTag + +constT :: proxy s -> Int -> Timed s Int Int +constT _ i = Timed (const i) + + +test1 i = reify 5 $ \prx -> getTime < constT prx i + + + + + +test2M :: Reifies s Int => proxy s -> Map (Timed s Int Int) String +test2M p = Map.fromList [ (constT p 10, "ten") + , (getTime, "timed") + ] + + +query :: forall s v. Ord (Timed s Int Int) + => Map (Timed s Int Int) v -> Maybe v +query = fmap snd . Map.lookupGE (constT (Proxy :: Proxy s) 4) + + +test2 :: Int -> Maybe String +test2 t = runAt t m query + where + m :: Map (Timed () Int Int) String + m = reify 0 $ \p -> unTagged $ test2M p + + + + + +-- test2 = reify 0 $ \p0 -> +-- let m = unTagged $ test2M p0 +-- in runAt 10 m Map.lookup + + + +-- newtype Key s a b = Key { getKey :: a -> b } + +-- instance (Eq b, Reifies s a) => Eq (Key s a b) where +-- (Key f) == (Key g) = let x = reflect (Proxy :: Proxy s) +-- in f x == g x + +-- instance (Ord b, Reifies s a) => Ord (Key s a b) where +-- Key f `compare` Key g = let x = reflect (Proxy :: Proxy s) +-- in f x `compare` g x + + +-- -- | Query the sweep +-- queryAt :: a +-- -> (forall (s :: *). Reifies s a => Map (Key s a b) v -> res) +-- -> Map (a -> b) v -> res +-- queryAt x f m = reify x (\p -> f . coerceKeys p $ m) + +-- updateAt :: a +-- -> (forall (s :: *). Reifies s a => +-- Map (Key s a b) v -> Map (Key s a b) v') +-- -> Map (a -> b) v +-- -> Map (a -> b) v' +-- updateAt x f m = reify x (\p -> uncoerceKeys . f . coerceKeys p $ m) + + +-- combineAt :: a +-- -> (forall (s :: *). Reifies s a => +-- Map (Key s a b) v -> Map (Key s a b) v +-- -> Map (Key s a b) v) +-- -> Map (a -> b) v +-- -> Map (a -> b) v +-- -> Map (a -> b) v +-- combineAt x uF m1 m2 = reify x (\p -> uncoerceKeys $ +-- coerceKeys p m1 `uF` coerceKeys p m2) + + +-- splitLookupAt :: Ord b +-- => a +-- -> (a -> b) +-- -> Map (a -> b) v +-- -> (Map (a -> b) v, Maybe v, Map (a -> b) v) +-- splitLookupAt x k m = reify x (\p -> let (l,mv,r) = Map.splitLookup (Key k) +-- $ coerceKeys p m +-- in (uncoerceKeys l, mv, uncoerceKeys r)) + + +-- -------------------------------------------------------------------------------- + +-- coerceKeys :: proxy s -> Map (a -> b) v -> Map (Key s a b) v +-- coerceKeys _ = unsafeCoerce + +-- uncoerceKeys :: Map (Key s a b) v -> Map (a -> b) v +-- uncoerceKeys = unsafeCoerce + + +-- -------------------------------------------------------------------------------- + + +-- data Node a = Node2 a a +-- | Node3 a a a + +-- data FT a = Single a +-- | Deep (FT (Node a)) a (FT (Node a)) diff --git a/src/Algorithms/Geometry/WellSeparatedPairDecomposition/Types.hs b/src/Algorithms/Geometry/WellSeparatedPairDecomposition/Types.hs --- a/src/Algorithms/Geometry/WellSeparatedPairDecomposition/Types.hs +++ b/src/Algorithms/Geometry/WellSeparatedPairDecomposition/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} module Algorithms.Geometry.WellSeparatedPairDecomposition.Types where import Control.Lens hiding (Level) diff --git a/src/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPD.hs b/src/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPD.hs --- a/src/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPD.hs +++ b/src/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPD.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase #-} module Algorithms.Geometry.WellSeparatedPairDecomposition.WSPD where @@ -36,10 +35,8 @@ -- | Construct a split tree -- -- running time: \(O(n \log n)\) -fairSplitTree :: (Fractional r, Ord r, Arity d, Index' 0 d, - KnownNat d - , Show r, Show p - +fairSplitTree :: (Fractional r, Ord r, Arity d, 1 <= d + , Show r, Show p ) => NonEmpty.NonEmpty (Point d r :+ p) -> SplitTree d p r () fairSplitTree pts = foldUp node' Leaf $ fairSplitTree' n pts' @@ -62,7 +59,7 @@ -- | Given a split tree, generate the Well separated pairs -- -- running time: \(O(s^d n)\) -wellSeparatedPairs :: (Floating r, Ord r, AlwaysTrueWSPD d) +wellSeparatedPairs :: (Floating r, Ord r, Arity d, Arity (d + 1)) => r -> SplitTree d p r a -> [WSP d p r a] wellSeparatedPairs s = f where @@ -107,7 +104,7 @@ -- (PointSeq))'s. Since we have the level assignment, we can compute these -- lists by traversing each original input list (i.e. one for every dimension) -- once, and partition the points based on their level assignment. -fairSplitTree' :: (Fractional r, Ord r, Arity d, Index' 0 d, KnownNat d +fairSplitTree' :: (Fractional r, Ord r, Arity d, 1 <= d , Show r, Show p ) => Int -> GV.Vector d (PointSeq d (Idx :+ p) r) @@ -187,7 +184,7 @@ -- time. -- -- so, basically, run reIndex points in ST as well. -reIndexPoints :: (Arity d, Index' 0 d) +reIndexPoints :: (Arity d, 1 <= d) => GV.Vector d (PointSeq d (Idx :+ p) r) -> GV.Vector d (PointSeq d (Idx :+ p) r) reIndexPoints ptsV = fmap reIndex ptsV @@ -357,10 +354,10 @@ -------------------------------------------------------------------------------- -- * Finding Well Separated Pairs -type AlwaysTrueWSPD d = ( Arity d, KnownNat d - , AlwaysTruePFT d, AlwaysTrueTransformation d) +-- type AlwaysTrueWSPD d = ( Arity d, KnownNat d +-- , AlwaysTruePFT d, AlwaysTrueTransformation d) -findPairs :: (Floating r, Ord r, AlwaysTrueWSPD d) +findPairs :: (Floating r, Ord r, Arity d, Arity (d + 1)) => r -> SplitTree d p r a -> SplitTree d p r a -> [WSP d p r a] findPairs s l r @@ -370,7 +367,7 @@ -- | Test if the two sets are well separated with param s -areWellSeparated :: ( AlwaysTrueWSPD d, Fractional r, Ord r) +areWellSeparated :: (Arity d, Arity (d + 1), Fractional r, Ord r) => r -- ^ separation factor -> SplitTree d p r a -> SplitTree d p r a -> Bool @@ -392,7 +389,7 @@ -- b' = translateBy v . scaleUniformlyBy s . translateBy ((-1) *^ v) $ b -- | Test if the two boxes are sufficiently far appart -boxBox :: (Fractional r, Ord r, AlwaysTruePFT d, AlwaysTrueTransformation d) +boxBox :: (Fractional r, Ord r, Arity d, Arity (d + 1)) => r -> Box d p r -> Box d p r -> Bool boxBox s lb rb = boxBox' lb rb && boxBox' rb lb where diff --git a/src/Control/Monad/State/Persistent.hs b/src/Control/Monad/State/Persistent.hs --- a/src/Control/Monad/State/Persistent.hs +++ b/src/Control/Monad/State/Persistent.hs @@ -13,7 +13,7 @@ -- | A State monad that can store earlier versions of the state. newtype PersistentStateT s m a = - PersistentStateT { runPersistentStateT' :: StateT (NonEmpty s) m a } + PersistentStateT (StateT (NonEmpty s) m a) deriving (Functor,Applicative,Monad) -- We store all the versions in reverse order diff --git a/src/Data/BalBST.hs b/src/Data/BalBST.hs --- a/src/Data/BalBST.hs +++ b/src/Data/BalBST.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} module Data.BalBST where +import Control.Applicative((<|>)) import Data.Bifunctor import Data.Function (on) import Data.Functor.Contravariant @@ -93,8 +94,16 @@ member :: Eq a => a -> BalBST k a -> Bool member x = isJust . lookup x - - +-- | Search for the Predecessor +-- \(O(\log n)\) +lookupLE :: Ord k => k -> BalBST k a -> Maybe a +lookupLE kx (BalBST n@Nav{..} t) = lookup' t + where + lookup' Empty = Nothing + lookup' (Leaf y) = if goLeft y kx then Just y else Nothing + lookup' (Node _ _ l k r) + | kx <= k = lookup' l + | otherwise = lookup' r <|> lookupMax (BalBST n l) -- | Insert an element in the BST. @@ -115,8 +124,15 @@ -- delete = undefined --- delete :: Eq a => a -> BalBST k a -> BalBST k a --- delete x (BalBST n@Nav{..} t) = delete' t +-- | Delete (one occurance of) an element. +-- \(O(\log n)\) +delete :: Eq a => a -> BalBST k a -> BalBST k a +delete x t = let Split l _ r = split x t + n = nav t + in BalBST n $ joinWith n l r + + +-- (BalBST n@Nav{..} t) = delete' t -- where -- delete' Empty = Empty -- delete' l@(Leaf y) = if x == y then Empty else l @@ -136,6 +152,9 @@ minView' (Leaf x) = Just (x,Empty) minView' (Node _ _ l _ r) = fmap (flip (joinWith n) r) <$> minView' l +lookupMin :: BalBST k b -> Maybe b +lookupMin = fmap fst . maxView + -- | Extract the maximum from the tree -- \(O(\log n)\) maxView :: BalBST k a -> Maybe (a, Tree k a) @@ -144,6 +163,10 @@ maxView' Empty = Nothing maxView' (Leaf x) = Just (x,Empty) maxView' (Node _ _ l _ r) = fmap (joinWith n l) <$> maxView' r + +lookupMax :: BalBST k b -> Maybe b +lookupMax = fmap fst . maxView + -- | Joins two BSTs. Assumes that the ranges are disjoint. It takes the left Tree nav -- diff --git a/src/Data/CircularSeq.hs b/src/Data/CircularSeq.hs --- a/src/Data/CircularSeq.hs +++ b/src/Data/CircularSeq.hs @@ -32,17 +32,19 @@ , isShiftOf ) where +import Control.DeepSeq import Control.Lens (lens, Lens', bimap) import qualified Data.Foldable as F import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (listToMaybe) import Data.Semigroup -import Data.Semigroup.Foldable +import Data.Semigroup.Foldable hiding (toNonEmpty) import Data.Sequence ((|>),(<|),ViewL(..),ViewR(..),Seq) import qualified Data.Sequence as S import qualified Data.Traversable as T import Data.Tuple (swap) +import GHC.Generics (Generic) -------------------------------------------------------------------------------- @@ -52,7 +54,10 @@ -- | Nonempty circular sequence data CSeq a = CSeq !(Seq a) !a !(Seq a) + deriving (Generic) -- we keep the seq balanced, i.e. size left >= size right + +instance NFData a => NFData (CSeq a) instance Eq a => Eq (CSeq a) where a == b = asSeq a == asSeq b diff --git a/src/Data/Ext.hs b/src/Data/Ext.hs --- a/src/Data/Ext.hs +++ b/src/Data/Ext.hs @@ -1,7 +1,14 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Data.Ext +Description: A pair-like data type to represent a 'core' type that has extra information as well. +Copyright : (c) Frank Staals +License : See LICENCE file +-} module Data.Ext where -import Control.Lens +import Control.Lens hiding ((.=)) import Data.Biapplicative import Data.Bifoldable import Data.Bifunctor.Apply @@ -12,9 +19,12 @@ import Data.Semigroup.Bitraversable import GHC.Generics (Generic) import Control.DeepSeq - +import Data.Aeson +import Data.Aeson.Types(typeMismatch) -------------------------------------------------------------------------------- +-- | Our Ext type that represents the core datatype core extended with extra +-- information of type 'extra'. data core :+ extra = core :+ extra deriving (Show,Read,Eq,Ord,Bounded,Generic,NFData) infixr 1 :+ @@ -43,6 +53,17 @@ instance (Semigroup core, Semigroup extra) => Semigroup (core :+ extra) where (c :+ e) <> (c' :+ e') = c <> c' :+ e <> e' + +instance (ToJSON core, ToJSON extra) => ToJSON (core :+ extra) where + -- toJSON (c :+ e) = toJSON (c,e) + -- toEncoding (c :+ e) = toEncoding (c,e) + toJSON (c :+ e) = object ["core" .= c, "extra" .= e] + toEncoding (c :+ e) = pairs ("core" .= c <> "extra" .= e) + +instance (FromJSON core, FromJSON extra) => FromJSON (core :+ extra) where + -- parseJSON = fmap (\(c,e) -> c :+ e) . parseJSON + parseJSON (Object v) = (:+) <$> v .: "core" <*> v .: "extra" + parseJSON invalid = typeMismatch "Ext (:+)" invalid _core :: (core :+ extra) -> core _core (c :+ _) = c diff --git a/src/Data/Geometry.hs b/src/Data/Geometry.hs --- a/src/Data/Geometry.hs +++ b/src/Data/Geometry.hs @@ -7,16 +7,16 @@ module Data.Geometry( module Data.Geometry.Properties , module Data.Geometry.Transformation , module Data.Geometry.Point - , module Data.Geometry.Vector + , module V , module Data.Geometry.Line , module Data.Geometry.LineSegment , module Data.Geometry.PolyLine , module Data.Geometry.Polygon - , module Linear.Affine - , module Linear.Vector + -- , module Linear.Affine + -- , module Linear.Vector ) where - +import Data.Geometry.Vector as V hiding (last) import Data.Geometry.Line import Data.Geometry.LineSegment import Data.Geometry.Point @@ -24,6 +24,5 @@ import Data.Geometry.Polygon hiding (fromPoints) import Data.Geometry.Properties import Data.Geometry.Transformation -import Data.Geometry.Vector -import Linear.Affine hiding (Point, Vector, origin) -import Linear.Vector +-- import Linear.Affine hiding (Point, Vector, origin) +-- import Linear.Vector diff --git a/src/Data/Geometry/Ball.hs b/src/Data/Geometry/Ball.hs --- a/src/Data/Geometry/Ball.hs +++ b/src/Data/Geometry/Ball.hs @@ -1,5 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} +{-| +Module : Data.Geometry.Ball +Description: \(d\)-dimensional Balls and Spheres +Copyright : (c) Frank Staals +License : See LICENCE file +-} module Data.Geometry.Ball where import Control.DeepSeq @@ -16,7 +22,7 @@ import qualified Data.List as L import qualified Data.Traversable as T import Data.Vinyl -import Frames.CoRec +import Data.Vinyl.CoRec import GHC.Generics (Generic) import Linear.Matrix import Linear.V3 (V3(..)) @@ -36,7 +42,7 @@ deriving instance (Show r, Show p, Arity d) => Show (Ball d p r) --- deriving instance (NFData p, NFData r, Arity d) => NFData (Ball d p r) +instance (NFData p, NFData r, Arity d) => NFData (Ball d p r) deriving instance (Eq r, Eq p, Arity d) => Eq (Ball d p r) type instance NumType (Ball d p r) = r @@ -111,6 +117,7 @@ pattern Sphere :: Point d r :+ p -> r -> Sphere d p r pattern Sphere c r = Boundary (Ball c r) +{-# COMPLETE Sphere #-} @@ -122,12 +129,14 @@ pattern Disk :: Point 2 r :+ p -> r -> Disk p r pattern Disk c r = Ball c r +{-# COMPLETE Disk #-} type Circle p r = Sphere 2 p r pattern Circle :: Point 2 r :+ p -> r -> Circle p r pattern Circle c r = Sphere c r +{-# COMPLETE Circle #-} -- | Given three points, get the disk through the three points. If the three -- input points are colinear we return Nothing diff --git a/src/Data/Geometry/Boundary.hs b/src/Data/Geometry/Boundary.hs --- a/src/Data/Geometry/Boundary.hs +++ b/src/Data/Geometry/Boundary.hs @@ -7,8 +7,8 @@ -- | The boundary of a geometric object. newtype Boundary g = Boundary g - deriving (Show,Eq,Ord,Read,IsTransformable) - + deriving (Show,Eq,Ord,Read,IsTransformable + ,Functor,Foldable,Traversable) type instance NumType (Boundary g) = NumType g type instance Dimension (Boundary g) = Dimension g diff --git a/src/Data/Geometry/Box.hs b/src/Data/Geometry/Box.hs --- a/src/Data/Geometry/Box.hs +++ b/src/Data/Geometry/Box.hs @@ -1,7 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveAnyClass #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module : Data.Geometry.Box +Description: Orthogonal \(d\)-dimensiontal boxes (e.g. rectangles) +Copyright : (c) Frank Staals +License : See LICENCE file +-} module Data.Geometry.Box( module Data.Geometry.Box.Internal , topSide, leftSide, bottomSide, rightSide , sides, sides' diff --git a/src/Data/Geometry/Box/Internal.hs b/src/Data/Geometry/Box/Internal.hs --- a/src/Data/Geometry/Box/Internal.hs +++ b/src/Data/Geometry/Box/Internal.hs @@ -1,16 +1,17 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE InstanceSigs #-} module Data.Geometry.Box.Internal where import Control.DeepSeq import Control.Lens import Data.Bifunctor import Data.Ext -import Frames.CoRec (asA) import Data.Geometry.Point import Data.Geometry.Properties import Data.Geometry.Transformation -import Data.Geometry.Vector (Vector, Arity, Index',C(..)) +import Data.Geometry.Vector (Vector, Arity, C(..)) import qualified Data.Geometry.Vector as V import qualified Data.List.NonEmpty as NE import Data.Proxy @@ -18,8 +19,9 @@ import Data.Semigroup import qualified Data.Semigroup.Foldable as F import qualified Data.Vector.Fixed as FV -import GHC.TypeLits +import Data.Vinyl.CoRec (asA) import GHC.Generics (Generic) +import GHC.TypeLits -------------------------------------------------------------------------------- @@ -61,6 +63,12 @@ (CWMax (Point $ fmap (^.R.upper.R.unEndPoint) rs) :+ mempty) +-- | Given a center point and a vector specifying the box width's, construct a box. +fromCenter :: (Arity d, Fractional r) => Point d r -> Vector d r -> Box d () r +fromCenter c ws = let f x r = R.ClosedRange (x-r) (x+r) + in fromExtent $ FV.zipWith f (toVec c) ((/2) <$> ws) + + -- | Center of the box centerPoint :: (Arity d, Fractional r) => Box d p r -> Point d r centerPoint b = Point $ w V.^/ 2 @@ -85,7 +93,12 @@ f = maybe (coRec NoIntersection) (coRec . fromExtent) r `intersect'` s = asA (Proxy :: Proxy (R.Range r)) $ r `intersect` s - +instance Arity d => Bifunctor (Box d) where + bimap :: forall p q r s. (p -> q) -> (r -> s) -> Box d p r -> Box d q s + bimap f g (Box mi ma) = Box (bimap g' f mi) (bimap g' f ma) + where + g' :: Functor g => g (Point d r) -> g (Point d s) + g' = fmap (fmap g) -- -- In principle this should also just work for Boxes in higher dimensions. It is just -- -- that we need a better way to compute their corners @@ -119,7 +132,8 @@ pmap f (Box mi ma) = Box (first (fmap f) mi) (first (fmap f) ma) -instance (Num r, AlwaysTruePFT d) => IsTransformable (Box d p r) where +instance (Fractional r, Arity d, Arity (d + 1)) + => IsTransformable (Box d p r) where -- Note that this does not guarantee the box is still a proper box Only use -- this to do translations and scalings. Other transformations may produce -- unexpected results. @@ -171,7 +185,8 @@ -- 1 -- >>> widthIn (C :: C 3) (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int) -- 3 -widthIn :: forall proxy p i d r. (Arity d, Num r, Index' (i-1) d) => proxy i -> Box d p r -> r +widthIn :: forall proxy p i d r. (Arity d, Arity (i - 1), Num r, ((i-1)+1) <= d) + => proxy i -> Box d p r -> r widthIn _ = view (V.element (C :: C (i - 1))) . size diff --git a/src/Data/Geometry/HalfLine.hs b/src/Data/Geometry/HalfLine.hs --- a/src/Data/Geometry/HalfLine.hs +++ b/src/Data/Geometry/HalfLine.hs @@ -4,6 +4,7 @@ module Data.Geometry.HalfLine where +import Control.DeepSeq import Control.Lens import Data.Ext import qualified Data.Foldable as F @@ -18,7 +19,7 @@ import qualified Data.Traversable as T import Data.UnBounded import GHC.Generics (Generic) -import Control.DeepSeq +import GHC.TypeLits -------------------------------------------------------------------------------- -- * d-dimensional Half-Lines @@ -50,7 +51,7 @@ supportingLine ~(HalfLine p v) = Line p v -- Half-Lines are transformable -instance (Num r, AlwaysTruePFT d) => IsTransformable (HalfLine d r) where +instance (Fractional r, Arity d, Arity (d + 1)) => IsTransformable (HalfLine d r) where transformBy t = toHalfLine . transformPointFunctor t . toLineSegment' where toLineSegment' :: (Num r, Arity d) => HalfLine d r -> LineSegment d () r diff --git a/src/Data/Geometry/Interval.hs b/src/Data/Geometry/Interval.hs --- a/src/Data/Geometry/Interval.hs +++ b/src/Data/Geometry/Interval.hs @@ -27,7 +27,7 @@ import Data.Semigroup import qualified Data.Traversable as T import Data.Vinyl -import Frames.CoRec +import Data.Vinyl.CoRec import GHC.Generics (Generic) -------------------------------------------------------------------------------- @@ -74,7 +74,7 @@ pattern Interval :: EndPoint (r :+ a) -> EndPoint (r :+ a) -> Interval a r pattern Interval l u = GInterval (Range l u) - +{-# COMPLETE Interval #-} -------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/Ipe.hs b/src/Data/Geometry/Ipe.hs --- a/src/Data/Geometry/Ipe.hs +++ b/src/Data/Geometry/Ipe.hs @@ -1,3 +1,9 @@ +{-| +Module : Data.Geometry.Ipe +Description: Reexports the functionality for reading and writing Ipe files. +Copyright : (c) Frank Staals +License : See LICENCE file +-} module Data.Geometry.Ipe( module Data.Geometry.Ipe.Types , module Data.Geometry.Ipe.Writer , module Data.Geometry.Ipe.Reader diff --git a/src/Data/Geometry/Ipe/Attributes.hs b/src/Data/Geometry/Ipe/Attributes.hs --- a/src/Data/Geometry/Ipe/Attributes.hs +++ b/src/Data/Geometry/Ipe/Attributes.hs @@ -5,15 +5,16 @@ {-# LANGUAGE UndecidableInstances #-} module Data.Geometry.Ipe.Attributes where -import Control.Lens hiding (rmap, Const) -import Data.Semigroup -import Data.Singletons -import Data.Singletons.TH -import Data.Text(Text) -import Data.Vinyl -import Data.Vinyl.Functor -import Data.Vinyl.TypeLevel -import GHC.Exts +import Control.Lens hiding (rmap, Const) +import Data.Colour.SRGB +import Data.Semigroup +import Data.Singletons +import Data.Singletons.TH +import Data.Text (Text) +import Data.Vinyl +import Data.Vinyl.Functor +import Data.Vinyl.TypeLevel +import GHC.Exts -------------------------------------------------------------------------------- @@ -68,15 +69,20 @@ makeLenses ''Attr +pattern Attr :: Apply f label -> Attr f label pattern Attr x = GAttr (Just x) + +pattern NoAttr :: Attr f label pattern NoAttr = GAttr Nothing -- | Give pref. to the *RIGHT* -instance Monoid (Attr f l) where - mempty = NoAttr - _ `mappend` b@(Attr _) = b - a `mappend` _ = a +instance Semigroup (Attr f l) where + _ <> b@(Attr _) = b + a <> _ = a +instance Monoid (Attr f l) where + mempty = NoAttr + mappend = (<>) newtype Attributes (f :: TyFun u * -> *) (ats :: [u]) = Attrs { _unAttrs :: Rec (Attr f) ats } @@ -187,16 +193,19 @@ -- | Many types either consist of a symbolc value, or a value of type v -data IpeValue v = Named Text | Valued v deriving (Show,Eq,Ord) +data IpeValue v = Named Text | Valued v deriving (Show,Eq,Ord,Functor,Foldable,Traversable) instance IsString (IpeValue v) where fromString = Named . fromString -type Colour = Text -- TODO: Make this a Colour.Colour +newtype IpeSize r = IpeSize (IpeValue r) deriving (Show,Eq,Ord) +newtype IpePen r = IpePen (IpeValue r) deriving (Show,Eq,Ord) +newtype IpeColor r = IpeColor (IpeValue (RGB r)) deriving (Show,Eq) -newtype IpeSize r = IpeSize (IpeValue r) deriving (Show,Eq,Ord) -newtype IpePen r = IpePen (IpeValue r) deriving (Show,Eq,Ord) -newtype IpeColor = IpeColor (IpeValue Colour) deriving (Show,Eq,Ord) +instance Ord r => Ord (IpeColor r) where + (IpeColor c) `compare` (IpeColor c') = fmap f c `compare` fmap f c' + where + f (RGB r g b) = (r,g,b) -- -- | And the corresponding types @@ -317,26 +326,6 @@ -- GroupAttributeUniverse instance IpeAttrName Clip where attrName _ = "clip" - --- | Wrap up a value with a capability given by its type -data GDict (c :: k -> Constraint) (a :: k) where - GDict :: c a => Proxy a -> GDict c a - --- -- | Sometimes we may know something for /all/ fields of a record, but when --- -- you expect to be able to /each/ of the fields, you are then out of luck. --- -- Surely given @∀x:u.φ(x)@ we should be able to recover @x:u ⊢ φ(x)@! Sadly, --- -- the constraint solver is not quite smart enough to realize this and we must --- -- make it patently obvious by reifying the constraint pointwise with proof. --- gReifyConstraint --- :: RecAll f rs c --- => proxy c --- -> Rec f rs --- -> Rec (GDict c :. f) rs --- gReifyConstraint prx RNil = RNil --- gReifyConstraint prx (x :& xs) = Compose (mkDict x) :& reifyConstraint prx xs --- where --- mkDict :: f l -> (GDict c l) --- mkDict _ = GDict (Proxy :: Proxy l) -- | Function that states that all elements in xs satisfy a given constraint c type family AllSatisfy (c :: k -> Constraint) (xs :: [k]) :: Constraint where diff --git a/src/Data/Geometry/Ipe/FromIpe.hs b/src/Data/Geometry/Ipe/FromIpe.hs --- a/src/Data/Geometry/Ipe/FromIpe.hs +++ b/src/Data/Geometry/Ipe/FromIpe.hs @@ -1,49 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} module Data.Geometry.Ipe.FromIpe where -import Control.Lens +import Control.Lens hiding (Simple) import Data.Ext +import Data.Geometry.Ipe.Reader import Data.Geometry.Ipe.Types -import Data.Geometry.Line import Data.Geometry.LineSegment import qualified Data.Geometry.PolyLine as PolyLine import Data.Geometry.Polygon +import Data.Geometry.Properties import qualified Data.Seq2 as S2 -import qualified Data.Traversable as Tr +import qualified Data.List.NonEmpty as NonEmpty +-------------------------------------------------------------------------------- +-- $setup +-- >>> :{ +-- import Data.Geometry.Ipe.Attributes +-- +-- let testPath :: Path Int +-- testPath = Path . S2.l1Singleton . PolyLineSegment . PolyLine.fromPoints . map ext +-- $ [ origin, point2 10 10, point2 200 100 ] +-- +-- testPathAttrs :: IpeAttributes Path Int +-- testPathAttrs = attr SStroke (IpeColor (Named "red")) +-- testObject :: IpeObject Int +-- testObject = IpePath (testPath :+ testPathAttrs) +-- :} + + -- | Try to convert a path into a line segment, fails if the path is not a line -- segment or a polyline with more than two points. +-- +-- _asLineSegment :: Prism' (Path r) (LineSegment 2 () r) _asLineSegment = prism' seg2path path2seg where seg2path = review _asPolyLine . PolyLine.fromLineSegment path2seg p = PolyLine.asLineSegment' =<< preview _asPolyLine p - -- | Convert to a polyline. Ignores all non-polyline parts +-- +-- >>> testPath ^? _asPolyLine +-- Just (PolyLine {_points = Seq2 (Point2 [0,0] :+ ()) (fromList [Point2 [10,10] :+ ()]) (Point2 [200,100] :+ ())}) _asPolyLine :: Prism' (Path r) (PolyLine.PolyLine 2 () r) _asPolyLine = prism' poly2path path2poly where poly2path = Path . S2.l1Singleton . PolyLineSegment - path2poly = preview (pathSegments.Tr.traverse._PolyLineSegment) + path2poly = preview (pathSegments.traverse._PolyLineSegment) -- TODO: Check that the path actually is a polyline, rather -- than ignoring everything that does not fit --- | Convert to a simple polygon: simply takes the first closed path -_asSimplePolygon :: Prism' (Path r) (SimplePolygon () r) -_asSimplePolygon = prism' poly2path path2poly +-- | Convert to a simple polygon +_asSimplePolygon :: Prism' (Path r) (Polygon Simple () r) +_asSimplePolygon = prism' polygonToPath path2poly where - poly2path = Path . S2.l1Singleton . PolygonPath - path2poly = preview (pathSegments.Tr.traverse._PolygonPath) - -- TODO: Check that the path actually is a simple polygon, rather - -- than ignoring everything that does not fit + path2poly p = pathToPolygon p >>= either pure (const Nothing) +-- | Convert to a multipolygon +_asMultiPolygon :: Prism' (Path r) (MultiPolygon () r) +_asMultiPolygon = prism' polygonToPath path2poly + where + path2poly p = pathToPolygon p >>= either (const Nothing) pure + +polygonToPath :: Polygon t () r -> Path r +polygonToPath pg@(SimplePolygon _) = Path . S2.l1Singleton . PolygonPath $ pg +polygonToPath (MultiPolygon vs hs) = Path . S2.viewL1FromNonEmpty . fmap PolygonPath + $ SimplePolygon vs NonEmpty.:| hs + + +pathToPolygon :: Path r -> Maybe (Either (SimplePolygon () r) (MultiPolygon () r)) +pathToPolygon p = case p^..pathSegments.traverse._PolygonPath of + [] -> Nothing + [pg] -> Just . Left $ pg + SimplePolygon vs: hs -> Just . Right $ MultiPolygon vs hs + + + -- | use the first prism to select the ipe object to depicle with, and the second -- how to select the geometry object from there on. Then we can select the geometry -- object, directly with its attributes here. +-- +-- >>> testObject ^? _withAttrs _IpePath _asPolyLine +-- Just (PolyLine {_points = Seq2 (Point2 [0,0] :+ ()) (fromList [Point2 [10,10] :+ ()]) (Point2 [200,100] :+ ())} :+ Attrs {_unAttrs = {GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Just (IpeColor (Named "red"))}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}}}) _withAttrs :: Prism' (IpeObject r) (i r :+ IpeAttributes i r) -> Prism' (i r) g -> Prism' (IpeObject r) (g :+ IpeAttributes i r) _withAttrs po pg = prism' g2o o2g where g2o = review po . over core (review pg) o2g o = preview po o >>= \(i :+ ats) -> (:+ ats) <$> preview pg i + + + + + +-- instance HasDefaultIpeObject Path where +-- defaultIpeObject' = _IpePath + + +-- class HasDefaultFromIpe g where +-- type DefaultFromIpe g :: * -> * +-- defaultIpeObject :: proxy g -> Prism' (IpeObject r) (DefaultFromIpe g r :+ IpeAttributes (DefaultFromIpe g) r) +-- defaultFromIpe :: proxy g -> Prism' (DefaultFromIpe g (NumType g)) g + + +class HasDefaultFromIpe g where + type DefaultFromIpe g :: * -> * + defaultFromIpe :: (r ~ NumType g) + => Prism' (IpeObject r) (g :+ IpeAttributes (DefaultFromIpe g) r) + +-- instance HasDefaultFromIpe (Point 2 r) where +-- type DefaultFromIpe (Point 2 r) = IpeSymbol +-- defaultFromIpe = _withAttrs _IpeUse symbolPoint + + +instance HasDefaultFromIpe (LineSegment 2 () r) where + type DefaultFromIpe (LineSegment 2 () r) = Path + defaultFromIpe = _withAttrs _IpePath _asLineSegment + +instance HasDefaultFromIpe (PolyLine.PolyLine 2 () r) where + type DefaultFromIpe (PolyLine.PolyLine 2 () r) = Path + defaultFromIpe = _withAttrs _IpePath _asPolyLine + + +instance HasDefaultFromIpe (SimplePolygon () r) where + type DefaultFromIpe (SimplePolygon () r) = Path + defaultFromIpe = _withAttrs _IpePath _asSimplePolygon + +instance HasDefaultFromIpe (MultiPolygon () r) where + type DefaultFromIpe (MultiPolygon () r) = Path + defaultFromIpe = _withAttrs _IpePath _asMultiPolygon + + +-- | Read all g's from some ipe page(s). +readAll :: (HasDefaultFromIpe g, r ~ NumType g, Foldable f) + => f (IpePage r) -> [g :+ IpeAttributes (DefaultFromIpe g) r] +readAll = foldMap (^..content.traverse.defaultFromIpe) + + +-- | Convenience function from reading all g's from an ipe file. If there +-- is an error reading or parsing the file the error is "thrown away". +readAllFrom :: (HasDefaultFromIpe g, r ~ NumType g, Coordinate r, Eq r) + => FilePath -> IO [g :+ IpeAttributes (DefaultFromIpe g) r] +readAllFrom fp = readAll <$> readSinglePageFile fp + diff --git a/src/Data/Geometry/Ipe/IpeOut.hs b/src/Data/Geometry/Ipe/IpeOut.hs --- a/src/Data/Geometry/Ipe/IpeOut.hs +++ b/src/Data/Geometry/Ipe/IpeOut.hs @@ -1,14 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.Geometry.Ipe.IpeOut where -import Control.Lens +import Control.Lens hiding (Simple) import Data.Bifunctor import Data.Ext import Data.Geometry.Ball import Data.Geometry.Boundary import Data.Geometry.Box import Data.Geometry.Ipe.Attributes +import Data.Geometry.Ipe.FromIpe import Data.Geometry.Ipe.Types +import Data.Geometry.Line import Data.Geometry.LineSegment import Data.Geometry.Point import Data.Geometry.PolyLine @@ -16,9 +19,12 @@ import Data.Geometry.Polygon.Convex import Data.Geometry.Properties import Data.Geometry.Transformation +import Data.Maybe (fromMaybe) +import Data.Proxy import Data.Semigroup import qualified Data.Seq2 as S2 import Data.Text (Text) +import Data.Vinyl.CoRec -------------------------------------------------------------------------------- @@ -44,7 +50,8 @@ -- ipe geometry object, the geometry object, and a record with its attributes, -- construct an ipe Object representing it. asIpeObjectWith :: (ToObject i, NumType g ~ r) - => IpeOut g (IpeObject' i r) -> g -> IpeAttributes i r -> IpeObject r + => IpeOut g (IpeObject' i r) -> g -> IpeAttributes i r + -> IpeObject r asIpeObjectWith io g ats = asIpe (ipeObject io ats) g @@ -83,6 +90,10 @@ -- => IpeOut g (IpeObject (NumType g)) -- defaultIpeObject = IpeOut $ flip asIpeObject mempty +-- instance HasDefaultIpeOut g => HasDefaultIpeOut [g] where +-- type DefaultIpeOut [g] = Group +-- defaultIpeOut = IpeOut $ asIpeGroup . map (asIpeObject' mempty) + instance HasDefaultIpeOut (Point 2 r) where type DefaultIpeOut (Point 2 r) = IpeSymbol defaultIpeOut = ipeDiskMark @@ -99,11 +110,15 @@ type DefaultIpeOut (PolyLine 2 p r) = Path defaultIpeOut = noAttrs ipePolyLine -instance HasDefaultIpeOut (SimplePolygon p r) where - type DefaultIpeOut (SimplePolygon p r) = Path - defaultIpeOut = flip addAttributes ipeSimplePolygon $ - mempty <> attr SFill (IpeColor "red") +instance HasDefaultIpeOut (Polygon t p r) where + type DefaultIpeOut (Polygon t p r) = Path + defaultIpeOut = flip addAttributes ipePolygon $ + mempty <> attr SFill (IpeColor "0.722 0.145 0.137") +instance HasDefaultIpeOut (SomePolygon p r) where + type DefaultIpeOut (SomePolygon p r) = Path + defaultIpeOut = IpeOut $ either (asIpe defaultIpeOut) (asIpe defaultIpeOut) + instance HasDefaultIpeOut (ConvexPolygon p r) where type DefaultIpeOut (ConvexPolygon p r) = Path defaultIpeOut = IpeOut $ asIpe defaultIpeOut . view simplePolygon @@ -132,15 +147,22 @@ defaultClipRectangle = boundingBox (point2 (-200) (-200)) <> boundingBox (point2 1000 1000) --- -- | An ipe out to draw a line, by clipping it to stay within a rectangle of --- -- default size. --- line :: IpeOut (Line 2 r) (IpeObject' Path r) --- line = line' defaultClipRectangle - --- -- | An ipe out to draw a line, by clipping it to stay within the rectangle --- line' :: Rectangle p r -> IpeOut (Line 2 r) (IpeObject' Path r) --- line' r = IpeOut $ \l -> error "not implemented yet" +-- | An ipe out to draw a line, by clipping it to stay within a rectangle of +-- default size. +line :: (Fractional r, Ord r) => IpeOut (Line 2 r) (IpeObject' Path r) +line = lineWith defaultClipRectangle +-- | An ipe out to draw a line, by clipping it to stay within the rectangle. +-- +-- pre: intersection of the line and the rectangle is a line segment +-- (otherwise it arbitrarily inserts the bottom of the rectangle as the path) +lineWith :: forall p r. (Ord r, Fractional r) + => Rectangle p r -> IpeOut (Line 2 r) (IpeObject' Path r) +lineWith r = IpeOut (asIpe defaultIpeOut . clip) + where + def = bimap (const ()) id $ bottomSide r + clip l = fromMaybe def . asA (Proxy :: Proxy (LineSegment 2 () r)) + $ l `intersect` r ipeLineSegment :: IpeOut (LineSegment 2 p r) (IpeObject' Path r) ipeLineSegment = noAttrs $ fromPathSegment ipeLineSegment' @@ -175,11 +197,17 @@ fromPathSegment :: IpeOut g (PathSegment r) -> IpeOut g (Path r) fromPathSegment io = IpeOut $ Path . S2.l1Singleton . asIpe io -ipeSimplePolygon :: IpeOut (SimplePolygon p r) (Path r) -ipeSimplePolygon = fromPathSegment . IpeOut $ PolygonPath . dropExt + +ipePolygon :: IpeOut (Polygon t p r) (Path r) +ipePolygon = IpeOut $ io . first (const ()) where - dropExt :: SimplePolygon p r -> SimplePolygon () r - dropExt (SimplePolygon vs) = SimplePolygon $ fmap (&extra .~ ()) vs + io :: forall t r. Polygon t () r -> Path r + io pg@(SimplePolygon _) = pg^.re _asSimplePolygon + io pg@(MultiPolygon _ _) = pg^.re _asMultiPolygon + + + + diff --git a/src/Data/Geometry/Ipe/ParserPrimitives.hs b/src/Data/Geometry/Ipe/ParserPrimitives.hs --- a/src/Data/Geometry/Ipe/ParserPrimitives.hs +++ b/src/Data/Geometry/Ipe/ParserPrimitives.hs @@ -2,7 +2,8 @@ {-# Language OverloadedStrings #-} module Data.Geometry.Ipe.ParserPrimitives( runP, runP' , pMany, pMany1, pChoice - , pChar, pSpace, pWhiteSpace, pInteger, pNatural + , pChar, pSpace, pWhiteSpace, pInteger + , pNatural, pPaddedNatural , (<*><>) , (<*><) , (<***>) , (<***) , (***>) , pMaybe , pCount , pSepBy @@ -43,6 +44,11 @@ pNatural :: Parser Integer pNatural = read <$> pMany1 digit + +-- | parses an integer with a prefix of zeros. Returns the total length of the +-- string parced (i.e. number of digits) and the resulting antural number. +pPaddedNatural :: Parser (Int, Integer) +pPaddedNatural = (\s -> (length s, read s)) <$> pMany1 digit pInteger :: Parser Integer pInteger = pNatural diff --git a/src/Data/Geometry/Ipe/PathParser.hs b/src/Data/Geometry/Ipe/PathParser.hs --- a/src/Data/Geometry/Ipe/PathParser.hs +++ b/src/Data/Geometry/Ipe/PathParser.hs @@ -1,4 +1,5 @@ {-# Language OverloadedStrings #-} +{-# Language DefaultSignatures #-} module Data.Geometry.Ipe.PathParser where import Data.Bifunctor @@ -14,29 +15,31 @@ import Data.Semigroup import Data.Text (Text) import qualified Data.Text as T -import Numeric import Text.Parsec.Error (messageString, errorMessages) ----------------------------------------------------------------------- -- | Represent stuff that can be used as a coordinate in ipe. (similar to show/read) -class Num r => Coordinate r where - fromSeq :: Integer -> Maybe Integer -> r - -defaultFromSeq :: (Ord r, Fractional r) => Integer -> Maybe Integer -> r -defaultFromSeq x Nothing = fromInteger x -defaultFromSeq x (Just y) = let x' = fromInteger x - y' = fromInteger y - asDecimal = head . dropWhile (>= 1) . iterate (* 0.1) - in signum x' * (abs x' + asDecimal y') +class Fractional r => Coordinate r where + -- reads a coordinate. The input is an integer representing the + -- part before the decimal point, and a length and an integer + -- representing the part after the decimal point + fromSeq :: Integer -> Maybe (Int, Integer) -> r + default fromSeq :: (Ord r, Fractional r) => Integer -> Maybe (Int, Integer) -> r + fromSeq = defaultFromSeq -instance Coordinate Double where - fromSeq = defaultFromSeq +defaultFromSeq :: (Ord r, Fractional r) + => Integer -> Maybe (Int, Integer) -> r +defaultFromSeq x Nothing = fromInteger x +defaultFromSeq x (Just (l,y)) = let x' = fromInteger x + y' = fromInteger y + asDecimal a = a * (0.1 ^ l) + z = if x' < 0 then (-1) else 1 + in z * (abs x' + asDecimal y') -instance Coordinate (Ratio Integer) where - fromSeq x Nothing = fromInteger x - fromSeq x (Just y) = fst . head $ readSigned readFloat (show x ++ "." ++ show y) +instance Coordinate Double +instance Coordinate (Ratio Integer) ----------------------------------------------------------------------- -- | Running the parsers @@ -52,13 +55,16 @@ -- Collect errors data Either' l r = Left' l | Right' r deriving (Show,Eq) + +instance (Semigroup l, Semigroup r) => Semigroup (Either' l r) where + (Left' l) <> (Left' l') = Left' $ l <> l' + (Left' l) <> _ = Left' l + _ <> (Left' l') = Left' l' + (Right' r) <> (Right' r') = Right' $ r <> r' + instance (Semigroup l, Semigroup r, Monoid r) => Monoid (Either' l r) where mempty = Right' mempty - (Left' l) `mappend` (Left' l') = Left' $ l <> l' - (Left' l) `mappend` _ = Left' l - _ `mappend` (Left' l') = Left' l' - (Right' r) `mappend` (Right' r') = Right' $ r <> r' - + mappend = (<>) either' :: (l -> a) -> (r -> a) -> Either' l r -> a either' lf _ (Left' l) = lf l either' _ rf (Right' r) = rf r @@ -130,8 +136,9 @@ pCoordinate :: Coordinate r => Parser r pCoordinate = fromSeq <$> pInteger <*> pDecimal where - pDecimal = pMaybe (pChar '.' *> pInteger) + pDecimal = pMaybe (pChar '.' *> pPaddedNatural) + pRectangle :: Coordinate r => Parser (Rectangle () r) pRectangle = (\p q -> box (ext p) (ext q)) <$> pPoint <* pWhiteSpace @@ -144,9 +151,9 @@ -- | Generate a matrix from a list of 6 coordinates. mkMatrix :: Coordinate r => [r] -> Matrix 3 3 r -mkMatrix [a,b,c,d,e,f] = Matrix $ v3 (v3 a c e) - (v3 b d f) - (v3 0 0 1) +mkMatrix [a,b,c,d,e,f] = Matrix $ Vector3 (Vector3 a c e) + (Vector3 b d f) + (Vector3 0 0 1) -- We need the matrix in the following order: -- 012 -- 345 diff --git a/src/Data/Geometry/Ipe/Reader.hs b/src/Data/Geometry/Ipe/Reader.hs --- a/src/Data/Geometry/Ipe/Reader.hs +++ b/src/Data/Geometry/Ipe/Reader.hs @@ -22,15 +22,19 @@ , ipeReadObject , ipeReadAttrs , ipeReadRec + + , Coordinate(..) ) where +import Control.Applicative((<|>)) import Control.Lens hiding (Const, rmap) import qualified Data.ByteString as B +import Data.Colour.SRGB (RGB(..)) import Data.Either (rights) import Data.Ext import Data.Geometry.Box import Data.Geometry.Ipe.Attributes -import Data.Geometry.Ipe.ParserPrimitives (pInteger) +import Data.Geometry.Ipe.ParserPrimitives (pInteger, pWhiteSpace) import Data.Geometry.Ipe.PathParser import Data.Geometry.Ipe.Types import Data.Geometry.Point @@ -40,14 +44,14 @@ import qualified Data.List as L import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe, mapMaybe) -import Data.Monoid import Data.Proxy import qualified Data.Seq2 as S2 +import Data.Semigroup ((<>)) import Data.Singletons -import qualified Data.Text as T import Data.Text (Text) +import qualified Data.Text as T import qualified Data.Traversable as Tr -import Data.Vinyl +import Data.Vinyl hiding (Label) import Data.Vinyl.Functor import Data.Vinyl.TypeLevel import Text.XML.Expat.Tree @@ -59,19 +63,22 @@ -- | Given a file path, tries to read an ipe file -readRawIpeFile :: Coordinate r => FilePath -> IO (Either ConversionError (IpeFile r)) +readRawIpeFile :: (Coordinate r, Eq r) + => FilePath -> IO (Either ConversionError (IpeFile r)) readRawIpeFile = fmap fromIpeXML . B.readFile -- | Given a file path, tries to read an ipe file. This function applies all -- matrices to objects. -readIpeFile :: Coordinate r => FilePath -> IO (Either ConversionError (IpeFile r)) +readIpeFile :: (Coordinate r, Eq r) + => FilePath -> IO (Either ConversionError (IpeFile r)) readIpeFile = fmap (bimap id applyMatrices) . readRawIpeFile -- | Since most Ipe file contain only one page, we provide a shortcut for that -- as well. This function applies all matrices. -readSinglePageFile :: Coordinate r => FilePath -> IO (Either ConversionError (IpePage r)) +readSinglePageFile :: (Coordinate r, Eq r) + => FilePath -> IO (Either ConversionError (IpePage r)) readSinglePageFile = fmap f . readIpeFile where f (Left e) = Left e @@ -151,9 +158,17 @@ instance Coordinate r => IpeReadText (Rectangle () r) where ipeReadText = readRectangle -instance IpeReadText IpeColor where - ipeReadText = fmap IpeColor . ipeReadTextWith Right +instance Coordinate r => IpeReadText (RGB r) where + ipeReadText = runParser (pRGB <|> pGrey) + where + pGrey = (\c -> RGB c c c) <$> pCoordinate + pRGB = RGB <$> pCoordinate <* pWhiteSpace + <*> pCoordinate <* pWhiteSpace + <*> pCoordinate +instance Coordinate r => IpeReadText (IpeColor r) where + ipeReadText = fmap IpeColor . ipeReadTextWith ipeReadText + instance Coordinate r => IpeReadText (IpePen r) where ipeReadText = fmap IpePen . ipeReadTextWith readCoordinate @@ -164,7 +179,7 @@ instance Coordinate r => IpeReadText [Operation r] where ipeReadText = readPathOperations -instance Coordinate r => IpeReadText (NE.NonEmpty (PathSegment r)) where +instance (Coordinate r, Eq r) => IpeReadText (NE.NonEmpty (PathSegment r)) where ipeReadText t = ipeReadText t >>= fromOpsN where fromOpsN xs = case fromOps xs of @@ -179,7 +194,7 @@ fromOps' _ [] = Left "Found only a MoveTo operation" fromOps' s (LineTo q:ops) = let (ls,xs) = span' _LineTo ops pts = map ext $ s:q:mapMaybe (^?_LineTo) ls - poly = Polygon.fromPoints pts + poly = Polygon.fromPoints . dropRepeats $ pts pl = fromPoints pts in case xs of (ClosePath : xs') -> PolygonPath poly <<| xs' @@ -190,7 +205,11 @@ x <<| xs = (x:) <$> fromOps xs -instance Coordinate r => IpeReadText (Path r) where + +dropRepeats :: Eq a => [a] -> [a] +dropRepeats = map head . L.group + +instance (Coordinate r, Eq r) => IpeReadText (Path r) where ipeReadText = fmap (Path . S2.viewL1FromNonEmpty) . ipeReadText -------------------------------------------------------------------------------- @@ -253,17 +272,17 @@ ipeReadAttrs _ _ = fmap Attrs . ipeReadRec (Proxy :: Proxy f) (Proxy :: Proxy ats) -testSym :: B.ByteString -testSym = "" +-- testSym :: B.ByteString +-- testSym = "" -- readAttrsFromXML :: B.ByteString -> Either -readSymAttrs :: Either ConversionError (IpeAttributes IpeSymbol Double) -readSymAttrs = readXML testSym - >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double) +-- readSymAttrs :: Either ConversionError (IpeAttributes IpeSymbol Double) +-- readSymAttrs = readXML testSym +-- >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double) @@ -301,7 +320,7 @@ unT (Text t) = Right t unT _ = Left "allText: Expected Text, found an Element" -instance Coordinate r => IpeRead (Path r) where +instance (Coordinate r, Eq r) => IpeRead (Path r) where ipeRead (Element "path" _ chs) = allText chs >>= ipeReadText ipeRead _ = Left "path: expected element, found text" @@ -333,7 +352,7 @@ ipeRead (Element "image" ats _) = Image () <$> (lookup' "rect" ats >>= ipeReadText) ipeRead _ = Left "Image: Element expected, text found" -instance Coordinate r => IpeRead (IpeObject r) where +instance (Coordinate r, Eq r) => IpeRead (IpeObject r) where ipeRead x = firstRight [ IpeUse <$> ipeReadObject (Proxy :: Proxy IpeSymbol) r x , IpePath <$> ipeReadObject (Proxy :: Proxy Path) r x , IpeGroup <$> ipeReadObject (Proxy :: Proxy Group) r x @@ -348,8 +367,8 @@ firstRight = maybe (Left "No matching object") Right . firstOf (traverse._Right) -instance Coordinate r => IpeRead (Group r) where - ipeRead (Element "group" _ chs) = Group <$> mapM ipeRead chs +instance (Coordinate r, Eq r) => IpeRead (Group r) where + ipeRead (Element "group" _ chs) = Right . Group . rights . map ipeRead $ chs ipeRead _ = Left "ipeRead Group: expected Element, found Text" @@ -366,7 +385,7 @@ -- TODO: this instance throws away all of our error collecting (and is pretty -- slow/stupid since it tries parsing all children with all parsers) -instance Coordinate r => IpeRead (IpePage r) where +instance (Coordinate r, Eq r) => IpeRead (IpePage r) where ipeRead (Element "page" _ chs) = Right $ IpePage (readAll chs) (readAll chs) (readAll chs) ipeRead _ = Left "page: Element expected, text found" -- withDef :: b -> Either a b -> Either c b @@ -381,7 +400,7 @@ readAll = rights . map ipeRead -instance Coordinate r => IpeRead (IpeFile r) where +instance (Coordinate r, Eq r) => IpeRead (IpeFile r) where ipeRead (Element "ipe" _ chs) = case readAll chs of [] -> Left "Ipe: no pages found" pgs -> Right $ IpeFile Nothing [] (NE.fromList pgs) @@ -389,59 +408,6 @@ -testz :: Either ConversionError (IpeObject Double) -testz = (bimap (T.pack . show) id $ parse' defaultParseOptions testSym) - >>= ipeRead -- Object (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double) - - - - - - - - - - - - - - - -- ipeReadAttrs (Element _ ats _) = - -instance Coordinate r => IpeReadText (PolyLine 2 () r) where - ipeReadText t = readPathOperations t >>= fromOps - where - fromOps (MoveTo p:LineTo q:ops) = (\ps -> fromPoints' $ [p,q] ++ ps) - <$> validateAll "Expected LineTo p" _LineTo ops - fromOps _ = Left "Expected MoveTo p:LineTo q:... " - -validateAll :: ConversionError -> Prism' (Operation r) (Point 2 r) -> [Operation r] - -> Either ConversionError [Point 2 r] -validateAll err fld = bimap T.unlines id . validateAll' err fld - - -validateAll' :: err -> Prism' (Operation r) (Point 2 r) -> [Operation r] - -> Either [err] [Point 2 r] -validateAll' err field = toEither . foldr (\op' res -> f op' <> res) (Right' []) - where - f op' = maybe (Left' [err]) (\p -> Right' [p]) $ op' ^? field - toEither = either' Left Right - --- This is a bit of a hack -instance Coordinate r => IpeRead (PolyLine 2 () r) where - ipeRead (Element "path" _ ts) = ipeReadText . T.unlines . map unText $ ts - -- apparently hexpat already splits the text into lines - ipeRead _ = Left "iperead: no polyline." - -unText :: Node t t1 -> t1 -unText (Text t) = t -unText _ = error "unText: element found, text expected" - -instance Coordinate r => IpeRead (PathSegment r) where - ipeRead = fmap PolyLineSegment . ipeRead - -testP :: B.ByteString -testP = "\n128 656 m\n224 768 l\n304 624 l\n432 752 l\n" -------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/Ipe/Types.hs b/src/Data/Geometry/Ipe/Types.hs --- a/src/Data/Geometry/Ipe/Types.hs +++ b/src/Data/Geometry/Ipe/Types.hs @@ -8,7 +8,7 @@ import Control.Lens import Data.Proxy -import Data.Vinyl +import Data.Vinyl hiding (Label) import Data.Ext import Data.Geometry.Box(Rectangle) @@ -50,7 +50,7 @@ type instance NumType (Image r) = r type instance Dimension (Image r) = 2 -instance Num r => IsTransformable (Image r) where +instance Fractional r => IsTransformable (Image r) where transformBy t = over rect (transformBy t) -------------------------------------------------------------------------------- @@ -68,10 +68,10 @@ type instance NumType (MiniPage r) = r type instance Dimension (MiniPage r) = 2 -instance Num r => IsTransformable (TextLabel r) where +instance Fractional r => IsTransformable (TextLabel r) where transformBy t (Label txt p) = Label txt (transformBy t p) -instance Num r => IsTransformable (MiniPage r) where +instance Fractional r => IsTransformable (MiniPage r) where transformBy t (MiniPage txt p w) = MiniPage txt (transformBy t p) w width :: MiniPage t -> t @@ -90,7 +90,7 @@ type instance NumType (IpeSymbol r) = r type instance Dimension (IpeSymbol r) = 2 -instance Num r => IsTransformable (IpeSymbol r) where +instance Fractional r => IsTransformable (IpeSymbol r) where transformBy t = over symbolPoint (transformBy t) @@ -118,7 +118,7 @@ type instance NumType (PathSegment r) = r type instance Dimension (PathSegment r) = 2 -instance Num r => IsTransformable (PathSegment r) where +instance Fractional r => IsTransformable (PathSegment r) where transformBy t (PolyLineSegment p) = PolyLineSegment $ transformBy t p transformBy t (PolygonPath p) = PolygonPath $ transformBy t p transformBy _ _ = error "transformBy: not implemented yet" @@ -132,7 +132,7 @@ type instance NumType (Path r) = r type instance Dimension (Path r) = 2 -instance Num r => IsTransformable (Path r) where +instance Fractional r => IsTransformable (Path r) where transformBy t (Path s) = Path $ fmap (transformBy t) s -- | type that represents a path in ipe. @@ -161,9 +161,9 @@ AttrMap r Pin = PinType AttrMap r Transformations = TransformationTypes - AttrMap r Stroke = IpeColor + AttrMap r Stroke = IpeColor r AttrMap r Pen = IpePen r - AttrMap r Fill = IpeColor + AttrMap r Fill = IpeColor r AttrMap r Size = IpeSize r AttrMap r Dash = IpeDash r @@ -203,7 +203,7 @@ type instance NumType (Group r) = r type instance Dimension (Group r) = 2 -instance Num r => IsTransformable (Group r) where +instance Fractional r => IsTransformable (Group r) where transformBy t (Group s) = Group $ fmap (transformBy t) s @@ -256,7 +256,7 @@ instance ToObject IpeSymbol where ipeObject' s a = IpeUse (s :+ a) instance ToObject Path where ipeObject' p a = IpePath (p :+ a) -instance Num r => IsTransformable (IpeObject r) where +instance Fractional r => IsTransformable (IpeObject r) where transformBy t (IpeGroup i) = IpeGroup $ i&core %~ transformBy t transformBy t (IpeImage i) = IpeImage $ i&core %~ transformBy t transformBy t (IpeTextLabel i) = IpeTextLabel $ i&core %~ transformBy t @@ -288,6 +288,17 @@ s (IpeUse i) a = IpeUse $ i&select .~ a s (IpePath i) a = IpePath $ i&select .~ a +-- | collect all non-group objects +flattenGroups :: [IpeObject r] -> [IpeObject r] +flattenGroups = concatMap flattenGroups' + where + flattenGroups' :: IpeObject r -> [IpeObject r] + flattenGroups' (IpeGroup (Group gs :+ ats)) = + map (applyAts ats) . concatMap flattenGroups' $ gs + where + applyAts _ = id + flattenGroups' o = [o] + -------------------------------------------------------------------------------- @@ -372,7 +383,7 @@ (mm,ats') = takeAttr (Proxy :: Proxy AT.Matrix) ats -- | Applies the matrix to an ipe object if it has one. -applyMatrix :: Num r => IpeObject r -> IpeObject r +applyMatrix :: Fractional r => IpeObject r -> IpeObject r applyMatrix (IpeGroup i) = IpeGroup . applyMatrix' $ i&core.groupItems.traverse %~ applyMatrix -- note that for a group we first (recursively) @@ -384,10 +395,10 @@ applyMatrix (IpeUse i) = IpeUse $ applyMatrix' i applyMatrix (IpePath i) = IpePath $ applyMatrix' i -applyMatrices :: Num r => IpeFile r -> IpeFile r +applyMatrices :: Fractional r => IpeFile r -> IpeFile r applyMatrices f = f&pages.traverse %~ applyMatricesPage -applyMatricesPage :: Num r => IpePage r -> IpePage r +applyMatricesPage :: Fractional r => IpePage r -> IpePage r applyMatricesPage p = p&content.traverse %~ applyMatrix diff --git a/src/Data/Geometry/Ipe/Writer.hs b/src/Data/Geometry/Ipe/Writer.hs --- a/src/Data/Geometry/Ipe/Writer.hs +++ b/src/Data/Geometry/Ipe/Writer.hs @@ -6,6 +6,7 @@ import Control.Lens ((^.),(^..),(.~),(&), to) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C +import Data.Colour.SRGB (RGB(..)) import Data.Ext import Data.Fixed import qualified Data.Foldable as F @@ -13,11 +14,10 @@ import Data.Geometry.Ipe.Attributes import qualified Data.Geometry.Ipe.Attributes as IA import Data.Geometry.Ipe.Types -import qualified Data.Geometry.Ipe.Types as IT import Data.Geometry.LineSegment import Data.Geometry.Point import Data.Geometry.PolyLine -import Data.Geometry.Polygon (SimplePolygon, outerBoundary) +import Data.Geometry.Polygon (Polygon, outerBoundary, holeList, asSimplePolygon) import qualified Data.Geometry.Transformation as GT import Data.Geometry.Vector import Data.Maybe (catMaybes, mapMaybe, fromMaybe) @@ -26,17 +26,15 @@ import Data.Semigroup import qualified Data.Seq2 as S2 import Data.Singletons +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text as Text -import Data.Text (Text) -import qualified Data.Traversable as Tr -import Data.Vinyl +import Data.Vinyl hiding (Label) import Data.Vinyl.Functor import Data.Vinyl.TypeLevel import System.IO (hPutStrLn,stderr) import Text.XML.Expat.Format (format') import Text.XML.Expat.Tree - -------------------------------------------------------------------------------- -- | Given a prism to convert something of type g into an ipe file, a file path, @@ -92,10 +90,16 @@ class IpeWrite t where ipeWrite :: t -> Maybe (Node Text Text) +instance (IpeWrite l, IpeWrite r) => IpeWrite (Either l r) where + ipeWrite = either ipeWrite ipeWrite instance IpeWriteText (Apply f at) => IpeWriteText (Attr f at) where ipeWriteText att = _getAttr att >>= ipeWriteText +instance (IpeWriteText l, IpeWriteText r) => IpeWriteText (Either l r) where + ipeWriteText = either ipeWriteText ipeWriteText + + -- | Functon to write all attributes in a Rec ipeWriteAttrs :: ( AllSatisfy IpeAttrName rs , RecAll (Attr f) rs IpeWriteText @@ -175,16 +179,19 @@ ipeWriteText Horizontal = Just "h" ipeWriteText Vertical = Just "v" +instance IpeWriteText r => IpeWriteText (RGB r) where + ipeWriteText (RGB r g b) = unwords' . map ipeWriteText $ [r,g,b] + deriving instance IpeWriteText r => IpeWriteText (IpeSize r) deriving instance IpeWriteText r => IpeWriteText (IpePen r) -deriving instance IpeWriteText IpeColor +deriving instance IpeWriteText r => IpeWriteText (IpeColor r) instance IpeWriteText r => IpeWriteText (IpeDash r) where ipeWriteText (DashNamed t) = Just t ipeWriteText (DashPattern xs x) = (\ts t -> mconcat [ "[" , Text.intercalate " " ts , "] ", t ]) - <$> Tr.mapM ipeWriteText xs + <$> mapM ipeWriteText xs <*> ipeWriteText x instance IpeWriteText FillType where @@ -196,7 +203,7 @@ <*> ipeWriteText s instance IpeWriteText r => IpeWriteText (Path r) where - ipeWriteText = fmap concat' . Tr.sequence . fmap ipeWriteText . _pathSegments + ipeWriteText = fmap concat' . sequence . fmap ipeWriteText . _pathSegments where concat' = F.foldr1 (\t t' -> t <> "\n" <> t') @@ -227,28 +234,37 @@ instance IpeWriteText r => IpeWriteText (Operation r) where - ipeWriteText (MoveTo p) = unwords' [ ipeWriteText p, Just "m"] - ipeWriteText (LineTo p) = unwords' [ ipeWriteText p, Just "l"] - ipeWriteText (CurveTo p q r) = unwords' [ ipeWriteText p - , ipeWriteText q - , ipeWriteText r, Just "m"] - ipeWriteText (Ellipse m) = unwords' [ ipeWriteText m, Just "e"] - -- TODO: The rest - ipeWriteText ClosePath = Just "h" + ipeWriteText (MoveTo p) = unwords' [ ipeWriteText p, Just "m"] + ipeWriteText (LineTo p) = unwords' [ ipeWriteText p, Just "l"] + ipeWriteText (CurveTo p q r) = unwords' [ ipeWriteText p + , ipeWriteText q + , ipeWriteText r, Just "c"] + ipeWriteText (QCurveTo p q) = unwords' [ ipeWriteText p + , ipeWriteText q, Just "q"] + ipeWriteText (Ellipse m) = unwords' [ ipeWriteText m, Just "e"] + ipeWriteText (ArcTo m p) = unwords' [ ipeWriteText m + , ipeWriteText p, Just "a"] + ipeWriteText (Spline pts) = unlines' $ map ipeWriteText pts <> [Just "s"] + ipeWriteText (ClosedSpline pts) = unlines' $ map ipeWriteText pts <> [Just "u"] + ipeWriteText ClosePath = Just "h" instance IpeWriteText r => IpeWriteText (PolyLine 2 () r) where - ipeWriteText pl = case pl^..points.Tr.traverse.core of + ipeWriteText pl = case pl^..points.traverse.core of (p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest -- the polyline type guarantees that there is at least one point -instance IpeWriteText r => IpeWriteText (SimplePolygon () r) where - ipeWriteText pg = case pg^..outerBoundary.to F.toList.Tr.traverse.core of - (p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest ++ [ClosePath] - _ -> Nothing +instance IpeWriteText r => IpeWriteText (Polygon t () r) where + ipeWriteText pg = fmap mconcat . traverse f $ asSimplePolygon pg : holeList pg + where + f pg' = case pg'^..outerBoundary.traverse.core of + (p : rest) -> unlines' . map ipeWriteText + $ MoveTo p : map LineTo rest ++ [ClosePath] + _ -> Nothing -- TODO: We are not really guaranteed that there is at least one point, it would -- be nice if the type could guarantee that. + instance IpeWriteText r => IpeWriteText (PathSegment r) where ipeWriteText (PolyLineSegment p) = ipeWriteText p ipeWriteText (PolygonPath p) = ipeWriteText p @@ -369,7 +385,7 @@ instance (IpeWriteText r, IpeWrite p) => IpeWrite (PolyLine 2 p r) where ipeWrite p = ipeWrite path where - path = fromPolyLine $ p & points.Tr.traverse.extra .~ () + path = fromPolyLine $ p & points.traverse.extra .~ () -- TODO: Do something with the p's fromPolyLine :: PolyLine 2 () r -> Path r diff --git a/src/Data/Geometry/KDTree.hs b/src/Data/Geometry/KDTree.hs --- a/src/Data/Geometry/KDTree.hs +++ b/src/Data/Geometry/KDTree.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.Geometry.KDTree where import Control.Lens hiding (imap, element, Empty, (:<)) import Data.BinaryTree -import Data.Coerce +import Unsafe.Coerce(unsafeCoerce) import Data.Ext import qualified Data.Foldable as F import Data.Geometry.Box @@ -70,11 +71,11 @@ -- | Expects the input to be a set, i.e. no duplicates -- -- running time: \(O(n \log n)\) -buildKDTree :: (Arity d, KnownNat d, Index' 0 d, Ord r) +buildKDTree :: (Arity d, 1 <= d, Ord r) => [Point d r :+ p] -> KDTree d p r buildKDTree = maybe Empty (Tree . buildKDTree') . NonEmpty.nonEmpty -buildKDTree' :: (Arity d, KnownNat d, Index' 0 d, Ord r) +buildKDTree' :: (Arity d, 1 <= d, Ord r) => NonEmpty.NonEmpty (Point d r :+ p) -> KDTree' d p r buildKDTree' = KDT . addBoxes . build (Coord 1) . toPointSet . Seq.fromNonEmpty where -- compute one tree with bounding boxes, then merge them together @@ -102,7 +103,7 @@ in (f p, p^.core) `compare` (f q, q^.core) -build :: (Index' 0 d, Arity d, KnownNat d, Ord r) +build :: (1 <= d, Arity d, Ord r) => Coord d -> PointSet (LSeq 1) d p r -> BinLeafTree (Split' d r) (Point d r :+ p) @@ -179,8 +180,8 @@ unzip' = bimap vectorFromListUnsafe vectorFromListUnsafe . unzip . F.toList -asSingleton :: (Index' 0 d, Arity d) => PointSet (LSeq 1) d p r +asSingleton :: (1 <= d, Arity d) => PointSet (LSeq 1) d p r -> Either (Point d r :+ p) (PointSet (LSeq 2) d p r) asSingleton v = case Seq.viewl $ v^.element (C :: C 0) of - _ :< _ Seq.:<< _ -> Right $ coerce v + _ :< _ Seq.:<< _ -> Right $ unsafeCoerce v p :< _ -> Left p -- only one element diff --git a/src/Data/Geometry/Line.hs b/src/Data/Geometry/Line.hs --- a/src/Data/Geometry/Line.hs +++ b/src/Data/Geometry/Line.hs @@ -1,18 +1,34 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UnicodeSyntax #-} module Data.Geometry.Line( module Data.Geometry.Line.Internal ) where -import Data.Geometry.Line.Internal -import Data.Geometry.LineSegment -import Data.Geometry.Box -import Data.Geometry.Properties -import Data.Geometry.Point -import Data.Geometry.Boundary -import Data.Geometry.Transformation -import Data.Geometry.Vector +import Control.Lens ((^.), re, bimap) +import Data.Ext +import Data.Geometry.Boundary +import Data.Geometry.Box +import Data.Geometry.Line.Internal +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Properties +import Data.Geometry.SubLine +import Data.Geometry.Transformation +import Data.Geometry.Vector +import qualified Data.List as L +import Data.Maybe (mapMaybe) +import Data.Proxy +import Data.UnBounded +import Data.Vinyl.CoRec +import Data.Vinyl.Core +import Data.Vinyl.Lens +import GHC.TypeLits +-------------------------------------------------------------------------------- + -- | Lines are transformable, via line segments -instance (Num r, AlwaysTruePFT d) => IsTransformable (Line d r) where +instance (Fractional r, Arity d, Arity (d + 1)) => IsTransformable (Line d r) where transformBy t = supportingLine . transformPointFunctor t . toLineSegment' where toLineSegment' :: (Num r, Arity d) => Line d r -> LineSegment d () r @@ -23,17 +39,50 @@ [ NoIntersection, Point 2 r, (Point 2 r, Point 2 r) , LineSegment 2 () r] --- instance (Eq r, Fractional r) --- => (Line 2 r) `IsIntersectableWith` (Boundary (Rectangle p r)) where --- nonEmptyIntersection = defaultNonEmptyIntersection +instance (Ord r, Fractional r) + => (Line 2 r) `IsIntersectableWith` (Boundary (Rectangle p r)) where + nonEmptyIntersection = defaultNonEmptyIntersection --- _ `intersect` (Boundary Empty) = coRec NoIntersection --- line `intersect` (Boundary rect) = error "TODO" --- where --- (t,r,b,l) = sides' rect + line' `intersect` (Boundary rect) = case asA' segP of + [sl'] -> coRec . bimap id unVal $ sl'^.re _SubLine + [] -> case nub' . map (fmap unVal) $ asA' pointP of + [p] -> coRec p + [p,q] -> coRec (p,q) + _ -> coRec NoIntersection + _ -> error "intersect; ine x boundary rect; absurd" + where + (t,r,b,l) = sides' rect + ints = map (\s -> sl `intersect` toSL s) [t,r,b,l] --- ints = map (line `intersect`) [t,r,b,l] + nub' = map head . L.group . L.sort + sl = fromLine line' + -- wrap a segment into an potentially unbounded subline + toSL s = bimap (const ()) Val $ s^._SubLine + unVal (Val x) = x + unVal _ = error "intersect; line x boundary rect: unVal Unbounded" + + asA' :: (t ∈ IntersectionOf (SubLine 2 () (UnBounded r)) + (SubLine 2 () (UnBounded r))) + => proxy t -> [t] + asA' px = mapMaybe (asA px) ints + + segP = Proxy :: Proxy (SubLine 2 () (UnBounded r)) + pointP = Proxy :: Proxy (Point 2 (UnBounded r)) + + type instance IntersectionOf (Line 2 r) (Rectangle p r) = [ NoIntersection, Point 2 r, LineSegment 2 () r] + + +instance (Ord r, Fractional r) + => (Line 2 r) `IsIntersectableWith` (Rectangle p r) where + nonEmptyIntersection = defaultNonEmptyIntersection + + line' `intersect` rect = match (line' `intersect` (Boundary rect)) $ + (H $ \NoIntersection -> coRec NoIntersection) + :& (H $ \p@(Point2 _ _) -> coRec p) + :& (H $ \(p,q) -> coRec $ ClosedLineSegment (ext p) (ext q)) + :& (H $ \s -> coRec s) + :& RNil diff --git a/src/Data/Geometry/Line/Internal.hs b/src/Data/Geometry/Line/Internal.hs --- a/src/Data/Geometry/Line/Internal.hs +++ b/src/Data/Geometry/Line/Internal.hs @@ -13,7 +13,7 @@ import Data.Ord (comparing) import qualified Data.Traversable as T import Data.Vinyl -import Frames.CoRec +import Data.Vinyl.CoRec import GHC.Generics (Generic) @@ -46,14 +46,14 @@ lineThrough p q = Line p (q .-. p) verticalLine :: Num r => r -> Line 2 r -verticalLine x = Line (point2 x 0) (v2 0 1) +verticalLine x = Line (point2 x 0) (Vector2 0 1) horizontalLine :: Num r => r -> Line 2 r -horizontalLine y = Line (point2 0 y) (v2 1 0) +horizontalLine y = Line (point2 0 y) (Vector2 1 0) -- | Given a line l with anchor point p, get the line perpendicular to l that also goes through p. perpendicularTo :: Num r => Line 2 r -> Line 2 r -perpendicularTo (Line p ~(Vector2 vx vy)) = Line p (v2 (-vy) vx) +perpendicularTo (Line p ~(Vector2 vx vy)) = Line p (Vector2 (-vy) vx) @@ -89,6 +89,11 @@ p `onLine` (Line q v) = p == q || (p .-. q) `isScalarMultipleOf` v +-- | Specific 2d version of testing if apoint lies on a line. +onLine2 :: (Ord r, Num r) => Point 2 r -> Line 2 r -> Bool +p `onLine2` (Line q v) = ccw p q (q .+^ v) == CoLinear + + -- | The intersection of two lines is either: NoIntersection, a point or a line. type instance IntersectionOf (Line 2 r) (Line 2 r) = [ NoIntersection , Point 2 r @@ -146,7 +151,7 @@ -- | Create a line from the linear function ax + b fromLinearFunction :: Num r => r -> r -> Line 2 r -fromLinearFunction a b = Line (point2 0 b) (v2 1 a) +fromLinearFunction a b = Line (point2 0 b) (Vector2 1 a) -- | get values a,b s.t. the input line is described by y = ax + b. -- returns Nothing if the line is vertical @@ -194,3 +199,25 @@ bisector p q = let v = q .-. p h = p .+^ (v ^/ 2) in perpendicularTo (Line h v) + + +-- | Compares the lines on slope. Vertical lines are considered larger than +-- anything else. +-- +-- >>> (Line origin (Vector2 5 1)) `cmpSlope` (Line origin (Vector2 3 3)) +-- LT +-- >>> (Line origin (Vector2 5 1)) `cmpSlope` (Line origin (Vector2 (-3) 3)) +-- GT +-- >>> (Line origin (Vector2 5 1)) `cmpSlope` (Line origin (Vector2 0 1)) +-- LT +cmpSlope :: (Num r, Ord r) => Line 2 r -> Line 2 r -> Ordering +(Line _ u) `cmpSlope` (Line _ v) = case ccw origin (f u) (f v) of + CCW -> LT + CW -> GT + CoLinear -> EQ + where + f w@(Vector2 x y) = Point $ case (x `compare` 0, y >= 0) of + (GT,_) -> w + (EQ,True) -> w + _ -> (-1) *^ w + -- x < 0, or (x==0 and y <0 ; i.e. a vertical line) diff --git a/src/Data/Geometry/LineSegment.hs b/src/Data/Geometry/LineSegment.hs --- a/src/Data/Geometry/LineSegment.hs +++ b/src/Data/Geometry/LineSegment.hs @@ -1,5 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} +{-| +Module : Data.Geometry.LineSegment +Description: Line segment data type and some basic functions on line segments +Copyright : (c) Frank Staals +License : See LICENCE file +-} module Data.Geometry.LineSegment( LineSegment , pattern LineSegment , pattern LineSegment' @@ -17,24 +23,25 @@ , flipSegment ) where -import Data.Ord(comparing) -import Control.Arrow((&&&)) +import Control.Arrow ((&&&)) import Control.Lens import Data.Bifunctor -import Data.Semigroup import Data.Ext +import qualified Data.Foldable as F import Data.Geometry.Box.Internal -import Data.Geometry.Interval +import Data.Geometry.Interval hiding (width, midPoint) import Data.Geometry.Line.Internal import Data.Geometry.Point import Data.Geometry.Properties import Data.Geometry.SubLine import Data.Geometry.Transformation import Data.Geometry.Vector -import Data.Vinyl +import Data.Ord (comparing) +import Data.Semigroup import Data.UnBounded -import Frames.CoRec -import qualified Data.Foldable as F +import Data.Vinyl +import Data.Vinyl.CoRec +import GHC.TypeLits -------------------------------------------------------------------------------- -- * d-dimensional LineSegments @@ -43,32 +50,33 @@ -- | Line segments. LineSegments have a start and end point, both of which may -- contain additional data of type p. We can think of a Line-Segment being defined as -- --- data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p)) --- (EndPoint (Point d r :+ p)) +-- +-- >>> data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p)) (EndPoint (Point d r :+ p)) newtype LineSegment d p r = GLineSegment { _unLineSeg :: Interval p (Point d r)} makeLenses ''LineSegment -- | Pattern that essentially models the line segment as a: -- --- data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p)) --- (EndPoint (Point d r :+ p)) +-- >>> data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p)) (EndPoint (Point d r :+ p)) pattern LineSegment :: EndPoint (Point d r :+ p) -> EndPoint (Point d r :+ p) -> LineSegment d p r pattern LineSegment s t = GLineSegment (Interval s t) +{-# COMPLETE LineSegment #-} -- | Gets the start and end point, but forgetting if they are open or closed. pattern LineSegment' :: Point d r :+ p -> Point d r :+ p -> LineSegment d p r pattern LineSegment' s t <- ((^.start) &&& (^.end) -> (s,t)) - +{-# COMPLETE LineSegment' #-} pattern ClosedLineSegment :: Point d r :+ p -> Point d r :+ p -> LineSegment d p r pattern ClosedLineSegment s t = GLineSegment (ClosedInterval s t) +{-# COMPLETE ClosedLineSegment #-} type instance Dimension (LineSegment d p r) = d type instance NumType (LineSegment d p r) = r @@ -86,6 +94,7 @@ _SubLine :: (Fractional r, Eq r, Arity d) => Iso' (LineSegment d p r) (SubLine d p r) _SubLine = iso segment2SubLine subLineToSegment +{-# INLINE _SubLine #-} segment2SubLine :: (Fractional r, Eq r, Arity d) => LineSegment d p r -> SubLine d p r @@ -107,6 +116,7 @@ instance (Num r, Arity d) => HasSupportingLine (LineSegment d p r) where supportingLine s = lineThrough (s^.start.core) (s^.end.core) + instance (Show r, Show p, Arity d) => Show (LineSegment d p r) where show ~(LineSegment p q) = concat ["LineSegment (", show p, ") (", show q, ")"] @@ -121,7 +131,7 @@ instance Arity d => IsBoxable (LineSegment d p r) where boundingBox l = boundingBox (l^.start.core) <> boundingBox (l^.end.core) -instance (Num r, AlwaysTruePFT d) => IsTransformable (LineSegment d p r) where +instance (Fractional r, Arity d, Arity (d + 1)) => IsTransformable (LineSegment d p r) where transformBy = transformPointFunctor instance Arity d => Bifunctor (LineSegment d) where @@ -207,7 +217,10 @@ p `onSegment` l = let s = l^.start.core t = l^.end.core inRange' x = 0 <= x && x <= 1 - in maybe False inRange' $ scalarMultiple (p .-. s) (t .-. s) + in + if s == t -- zero length segment + then p == s + else maybe False inRange' $ scalarMultiple (p .-. s) (t .-. s) -- | The left and right end point (or left below right if they have equal x-coords) diff --git a/src/Data/Geometry/PlanarSubdivision.hs b/src/Data/Geometry/PlanarSubdivision.hs --- a/src/Data/Geometry/PlanarSubdivision.hs +++ b/src/Data/Geometry/PlanarSubdivision.hs @@ -1,132 +1,107 @@ {-# LANGUAGE TemplateHaskell #-} -module Data.Geometry.PlanarSubdivision where +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Geometry.PlanarSubdivision( module Data.Geometry.PlanarSubdivision.Basic + , fromPolygon, fromPolygons + ) where -import Control.Lens -import qualified Data.BalBST as SS -import Data.Bifunctor.Apply -import qualified Data.CircularSeq as C +-- import Algorithms.Geometry.PolygonTriangulation.Triangulate +import Control.Lens hiding (holes, holesOf, (.=)) +import qualified Data.CircularSeq as CSeq import Data.Ext import qualified Data.Foldable as F -import Data.Geometry.Interval -import Data.Geometry.LineSegment -import Data.Geometry.Point +import Data.Geometry.Box +import Data.Geometry.PlanarSubdivision.Basic import Data.Geometry.Polygon -import Data.Geometry.Properties -import qualified Data.Map as M -import Data.PlanarGraph -import Data.PlaneGraph -import Data.Semigroup -import Data.Util +import Data.Geometry.Vector +import qualified Data.Geometry.Vector as Vec +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Vector as V +import qualified Data.PlaneGraph as PG +import Data.Proxy --- | Note that the functor instance is in v -data VertexData r v = VertexData { _location :: !(Point 2 r) - , _vData :: !v - } deriving (Show,Eq,Ord,Functor,Foldable,Traversable) -makeLenses ''VertexData +-- | Construct a planar subdivision from a polygon. Since our PlanarSubdivision +-- models only connected planar subdivisions, this may add dummy/invisible +-- edges. +-- +-- running time: \(O(n)\) for a simple polygon, \(O(n\log n)\) for a polygon +-- with holes. +fromPolygon :: forall proxy t p f r s. + (Ord r, Fractional r) => proxy s + -> Polygon t p r + -> f -- ^ data inside + -> f -- ^ data outside the polygon + -> PlanarSubdivision s p () f r +fromPolygon p pg@(SimplePolygon _) iD oD = fromSimplePolygon p pg iD oD +fromPolygon _ (MultiPolygon vs hs) iD oD = PlanarSubdivision cs vd dd fd + where + wp = Proxy :: Proxy (Wrap s) -instance Bifunctor VertexData where - bimap f g (VertexData p v) = VertexData (fmap f p) (g v) + -- the components + cs = undefined + cs' = PG.fromSimplePolygon wp (SimplePolygon vs) iD oD + : map (\h -> PG.fromSimplePolygon wp h oD iD) hs + vd = undefined + dd = undefined + fd = undefined -data EdgeType = Visible | Invisible deriving (Show,Read,Eq,Ord) -data EdgeData e = EdgeData { _edgeType :: !EdgeType - , _eData :: !e - } deriving (Show,Eq,Ord,Functor,Foldable,Traversable) -makeLenses ''EdgeData --- | The Face data consists of the data itself and a list of holes -data FaceData h f = FaceData { _holes :: [h] - , _fData :: !f - } deriving (Show,Eq,Ord,Functor,Foldable,Traversable) -makeLenses ''FaceData - - -newtype PlanarSubdivision s v e f r = PlanarSubdivision { _graph :: - PlanarGraph s Primal_ (VertexData r v) (EdgeData e) (FaceData (Dart s) f) } - deriving (Show,Eq) -makeLenses ''PlanarSubdivision - -instance Functor (PlanarSubdivision s v e f) where - fmap f s = s&graph.vertexData.traverse.location %~ fmap f +-- | Given a list of *disjoint* polygons, construct a planarsubdivsion +-- representing them. This may create dummy vertices which have no vertex data, +-- hence the 'Maybe p' data type for the vertices. +-- +-- running time: \(O(n\log n)\) +fromPolygons :: (Ord r, Fractional r) + => proxy s + -> NonEmpty (SimplePolygon p r :+ f) + -> f -- ^ data outside the polygons + -> PlanarSubdivision s (Maybe p) () f r +fromPolygons px pgs oD = undefined + -- subd&planeGraph.faceData .~ faceData' + -- &planeGraph.vertexData.traverse %~ getP + -- where + -- faceData' = fmap (\(fi, FaceData hs _) -> FaceData hs (getFData fi)) . faces $ subd + -- -- given a faceId lookup the + -- getFData fi = let v = boundaryVertices fi subd V.! 0 + -- in subd^.dataOf v.to holeData --------------------------------------------------------------------------------- + -- -- note that we intentionally reverse the order of iDd and oD in the call below, + -- -- as our holes are now outside + -- subd = fromPolygon px (MultiPolygon (CSeq.fromList [a,b,c,d]) holes') (Just oD) Nothing --- | Construct a planar subdivision from a polygon --- --- running time: \(O(n)\). -fromPolygon :: proxy s - -> SimplePolygon p r - -> f -- ^ data inside - -> f -- ^ data outside the polygon - -> PlanarSubdivision s p () f r -fromPolygon p (SimplePolygon vs) iD oD = PlanarSubdivision g' - where - g = fromVertices p vs - fData' = V.fromList [FaceData [] iD, FaceData [] oD] + -- -- for every polygon, construct a hole. + -- holes' = map withF . F.toList $ pgs + -- -- add the facedata to the vertex data + -- withF (pg :+ f) = bimap (\p -> Hole f p) id pg - g' = g & faceData .~ fData' - & dartData.traverse._2 .~ EdgeData Visible () --- The following does not really work anymore --- frompolygon p (MultiPolygon vs hs) iD oD = PlanarSubdivision g' --- where --- g = fromVertices p vs --- hs' = map (\h -> fromPolygon p h oD iD) hs --- -- note that oD and iD are exchanged --- fData' = V.fromList [FaceData iD hs', FaceData oD []] + -- -- corners of the slightly enlarged boundingbox + -- (a,b,c,d) = corners . bimap (const $ Outer oD) id + -- . grow 1 . boundingBoxList . fmap (^.core) $ pgs + --TODO: We need to mark the edges of the outer square as invisible. -fromVertices :: proxy s - -> C.CSeq (Point 2 r :+ p) - -> PlanarGraph s Primal_ (VertexData r p) () () -fromVertices _ vs = g&vertexData .~ vData' - where - n = length vs - g = planarGraph [ [ (Dart (Arc i) Positive, ()) - , (Dart (Arc $ (i+1) `mod` n) Negative, ()) - ] - | i <- [0..(n-1)]] - vData' = V.fromList . map (\(p :+ e) -> VertexData p e) . F.toList $ vs + -- Main Idea: Assign the vertices the hole-number on which they occur. For + -- each face we then find an incident vertex to find the data corresponding + -- to that face. +data HoleData f p = Outer !f | Hole !f !p deriving (Show,Eq) --- | Constructs a connected planar subdivision. --- --- pre: the segments form a single connected component --- running time: \(O(n\log n)\) -fromConnectedSegments :: (Foldable f, Ord r, Num r) - => proxy s - -> f (LineSegment 2 p r :+ EdgeData e) - -> PlanarSubdivision s [p] e () r -fromConnectedSegments px ss = PlanarSubdivision $ - fromConnectedSegments' px ss & faceData.traverse %~ FaceData [] +holeData :: HoleData f p -> f +holeData (Outer f) = f +holeData (Hole f _) = f --- | Constructs a planar graph --- --- pre: The segments form a single connected component --- --- running time: \(O(n\log n)\) -fromConnectedSegments' :: (Foldable f, Ord r, Num r) - => proxy s - -> f (LineSegment 2 p r :+ e) - -> PlanarGraph s Primal_ (VertexData r [p]) e () -fromConnectedSegments' _ ss = planarGraph dts & vertexData .~ vxData - where - pts = M.fromListWith (<>) . concatMap f . zipWith g [0..] . F.toList $ ss - f (s :+ e) = [ ( s^.start.core - , SP [s^.start.extra] [(s^.end.core) :+ h Positive e]) - , ( s^.end.core - , SP [s^.end.extra] [(s^.start.core) :+ h Negative e]) - ] - g i (s :+ e) = s :+ (Arc i :+ e) - h d (a :+ e) = (Dart a d, e) +getP :: HoleData f p -> Maybe p +getP (Outer _) = Nothing +getP (Hole _ p) = Just p - vts = map (\(p,sp) -> (p,map (^.extra) . sortArround (ext p) <$> sp)) - . M.assocs $ pts - -- vertex Data - vxData = V.fromList . map (\(p,sp) -> VertexData p (sp^._1)) $ vts - -- The darts - dts = map (^._2._2) vts +-- | grows the box by x on all sides +grow :: (Num r, Arity d) => r -> Box d p r -> Box d p r +grow x b = let mi = minPoint b + ma = maxPoint b + v = Vec.replicate x + in box (mi&core %~ (.+^ ((-1) *^ v))) (ma&core %~ (.+^ v)) diff --git a/src/Data/Geometry/PlanarSubdivision/Basic.hs b/src/Data/Geometry/PlanarSubdivision/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/PlanarSubdivision/Basic.hs @@ -0,0 +1,598 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Geometry.PlanarSubdivision.Basic( VertexId', FaceId' + , VertexData(VertexData), PG.vData, PG.location + + , FaceData(FaceData), holes, fData + + , PlanarSubdivision(PlanarSubdivision) + , Wrap + + , Component, ComponentId + + , PolygonFaceData(..) + , PlanarGraph + , PlaneGraph + , fromSimplePolygon + , fromConnectedSegments + , fromPlaneGraph, fromPlaneGraph' + + , numVertices, numEdges, numFaces, numDarts + , dual + + , components, component + , vertices', vertices + , edges', edges + , faces', faces, internalFaces + , darts' + + , headOf, tailOf, twin, endPoints + + , incidentEdges, incomingEdges, outgoingEdges + , nextIncidentEdge + , neighboursOf + + , leftFace, rightFace + , outerBoundaryDarts, boundaryVertices, holesOf + , outerFaceId + , boundary' + + , locationOf + , HasDataOf(..) + + , endPointsOf, endPointData + + , edgeSegment, edgeSegments + , rawFacePolygon, rawFaceBoundary + , rawFacePolygons + + , VertexId(..), FaceId(..), Dart, World(..) + + + , rawVertexData, rawDartData, rawFaceData + , dataVal + + , dartMapping, Raw(..) + ) where + +import Control.Lens hiding (holes, holesOf, (.=)) +import Data.Aeson +import Data.Coerce +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.Box +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Polygon +import Data.Geometry.Properties +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Permutation (ix') +import Data.PlanarGraph (toAdjacencyLists,buildFromJSON, isPositive, allDarts) +import qualified Data.PlaneGraph as PG +import Data.PlaneGraph( PlaneGraph, PlanarGraph, dual + , Dart, VertexId(..), FaceId(..), twin + , World(..) + , VertexId', FaceId' + , VertexData, location, vData + , HasDataOf(..) + ) +import qualified Data.Sequence as Seq +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import GHC.Generics (Generic) + +-------------------------------------------------------------------------------- + +-- | The Face data consists of the data itself and a list of holes +data FaceData h f = FaceData { _holes :: (Seq.Seq h) + , _fData :: !f + } deriving (Show,Eq,Ord,Functor,Foldable,Traversable,Generic) +makeLenses ''FaceData + +instance Bifunctor FaceData where + bimap f g (FaceData hs x) = FaceData (fmap f hs) (g x) + + +instance (FromJSON h, FromJSON f) => FromJSON (FaceData h f) +instance (ToJSON h, ToJSON f) => ToJSON (FaceData h f) where + toEncoding = genericToEncoding defaultOptions + + +-------------------------------------------------------------------------------- + + +data Wrap' s +type family Wrap (s :: k) :: k where + Wrap s = Wrap' s + +newtype ComponentId s = ComponentId { unCI :: Int } + deriving (Show,Eq,Ord,Generic,Bounded,Enum) + + +data Raw s ia a = Raw { _compId :: {-# UNPACK #-} !(ComponentId s) + , _idxVal :: {-# UNPACK #-} !ia + , _dataVal :: !a + } deriving (Eq,Show,Functor,Foldable,Traversable) +makeLenses ''Raw + + + +-------------------------------------------------------------------------------- + +-- | A connected component. +-- +-- For every face f, and every hole in this face, the facedata points to a dart +-- d on the hole s.t. this dart has the face f on its left. i.e. +-- leftFace d = f +type Component s r = PlaneGraph (Wrap s) + (VertexId' s) (Dart s) (FaceData (Dart s) (FaceId' s)) + r + + +-- | A planarsubdivision is essentially a bunch of plane-graphs; one for every +-- connected component. These graphs store the global ID's (darts, vertexId's, faceId's) +-- in their data values. This essentially gives us a mapping between the two. +-- +-- note that a face may actually occur in multiple graphs, hence when we store +-- the edges to the the holes, we store the global edgeId's rather than the +-- 'local' edgeId (dart)'s. +-- +-- invariant: the outerface has faceId 0 +data PlanarSubdivision s v e f r = + PlanarSubdivision { _components :: V.Vector (Component s r) + , _rawVertexData :: V.Vector (Raw s (VertexId' (Wrap s)) v) + , _rawDartData :: V.Vector (Raw s (Dart (Wrap s)) e) + , _rawFaceData :: V.Vector (Raw s (FaceId' (Wrap s)) f) + } deriving (Show,Eq,Functor) +makeLenses ''PlanarSubdivision + + +type instance NumType (PlanarSubdivision s v e f r) = r +type instance Dimension (PlanarSubdivision s v e f r) = 2 + +instance IsBoxable (PlanarSubdivision s v e f r) where + boundingBox = boundingBoxList' . V.toList . _components + + +component :: ComponentId s -> Lens' (PlanarSubdivision s v e f r) + (Component s r) +component ci = components.ix' (unCI ci) + +-------------------------------------------------------------------------------- + +-- | Constructs a planarsubdivision from a PlaneGraph +-- +-- runningTime: \(O(n)\) +fromPlaneGraph :: forall s v e f r. (Ord r, Fractional r) + => PlaneGraph s v e f r -> PlanarSubdivision s v e f r +fromPlaneGraph g = fromPlaneGraph' g (PG.outerFaceDart g) + +-- | Given a (connected) PlaneGraph and a dart that has the outerface on its left +-- | Constructs a planarsubdivision +-- +-- runningTime: \(O(n)\) +fromPlaneGraph' :: forall s v e f r. PlaneGraph s v e f r -> Dart s + -> PlanarSubdivision s v e f r +fromPlaneGraph' g ofD = PlanarSubdivision (V.singleton . coerce $ g') vd ed fd + where + c = ComponentId 0 + vd = V.imap (\i v -> Raw c (VertexId i) v) $ g^.PG.vertexData + ed = V.zipWith (\d dd -> Raw c d dd) allDarts'' $ g^.PG.rawDartData + fd = V.imap (\i f -> Raw c (mkFaceId i) f) . swapOf $ g^.PG.faceData + + g' :: PlaneGraph s (VertexId' s) (Dart s) (FaceData (Dart s) (FaceId' s)) r + g' = g&PG.faceData %~ V.imap (\i _ -> mkFaceData i) + &PG.vertexData %~ V.imap (\i _ -> VertexId i) + &PG.rawDartData .~ allDarts'' + + allDarts'' :: forall s'. V.Vector (Dart s') + allDarts'' = allDarts' (PG.numDarts g) + + -- make sure the outerFaceId is 0 + (FaceId (VertexId of')) = PG.leftFace ofD g + + -- at index i we are storing the outerface + mkFaceData i | i == of' = faceData (Seq.singleton ofD) 0 + | i == 0 = faceData mempty of' + | otherwise = faceData mempty i + faceData xs i = FaceData xs (FaceId . VertexId $ i) + + + mkFaceId :: forall s'. Int -> FaceId' s' + mkFaceId = FaceId . VertexId . mkFaceId' + mkFaceId' i | i == 0 = of' + | i == of' = 0 + | otherwise = i + swapOf = V.modify (\v -> MV.swap v 0 of') + + + + + +-- | Construct a planar subdivision from a simple polygon +-- +-- running time: \(O(n)\). +fromSimplePolygon :: (Ord r, Fractional r) + => proxy s + -> SimplePolygon p r + -> f -- ^ data inside + -> f -- ^ data outside the polygon + -> PlanarSubdivision s p () f r +fromSimplePolygon p pg iD oD = + fromPlaneGraph (PG.fromSimplePolygon p pg iD oD) + +-- | Constructs a connected planar subdivision. +-- +-- pre: the segments form a single connected component +-- running time: \(O(n\log n)\) +fromConnectedSegments :: (Foldable f, Ord r, Fractional r) + => proxy s + -> f (LineSegment 2 p r :+ e) + -> PlanarSubdivision s (NonEmpty p) e () r +fromConnectedSegments px = fromPlaneGraph . PG.fromConnectedSegments px + +-------------------------------------------------------------------------------- + +-- | Data type that expresses whether or not we are inside or outside the +-- polygon. +data PolygonFaceData = Inside | Outside deriving (Show,Read,Eq) + + +-------------------------------------------------------------------------------- +-- * Basic Graph information + +-- | Get the number of vertices +-- +-- >>> numVertices myGraph +-- 4 +numVertices :: PlanarSubdivision s v e f r -> Int +numVertices = V.length . _rawVertexData + +-- | Get the number of Darts +-- +-- >>> numDarts myGraph +-- 12 +numDarts :: PlanarSubdivision s v e f r -> Int +numDarts = V.length . _rawDartData + +-- | Get the number of Edges +-- +-- >>> numEdges myGraph +-- 6 +numEdges :: PlanarSubdivision s v e f r -> Int +numEdges = (`div` 2) . V.length . _rawDartData + +-- | Get the number of faces +-- +-- >>> numFaces myGraph +-- 4 +numFaces :: PlanarSubdivision s v e f r -> Int +numFaces = V.length . _rawFaceData + +-- | Enumerate all vertices +-- +-- >>> vertices' myGraph +-- [VertexId 0,VertexId 1,VertexId 2,VertexId 3] +vertices' :: PlanarSubdivision s v e f r -> V.Vector (VertexId' s) +vertices' ps = let n = numVertices ps + in V.fromList $ map VertexId [0..n-1] + +-- | Enumerate all vertices, together with their vertex data + +-- >>> vertices myGraph +-- [(VertexId 0,()),(VertexId 1,()),(VertexId 2,()),(VertexId 3,())] +vertices :: PlanarSubdivision s v e f r -> V.Vector (VertexId' s, VertexData r v) +vertices ps = (\vi -> (vi,ps^.vertexDataOf vi)) <$> vertices' ps + +-- | Enumerate all darts +darts' :: PlanarSubdivision s v e f r -> V.Vector (Dart s) +darts' = allDarts' . numDarts + +allDarts' :: forall s'. Int -> V.Vector (Dart s') +allDarts' n = V.fromList $ take n allDarts + + +-- | Enumerate all edges. We report only the Positive darts +edges' :: PlanarSubdivision s v e f r -> V.Vector (Dart s) +edges' = V.filter isPositive . darts' + +-- | Enumerate all edges with their edge data. We report only the Positive +-- darts. +-- +-- >>> mapM_ print $ edges myGraph +-- (Dart (Arc 2) +1,"c+") +-- (Dart (Arc 1) +1,"b+") +-- (Dart (Arc 0) +1,"a+") +-- (Dart (Arc 5) +1,"g+") +-- (Dart (Arc 4) +1,"e+") +-- (Dart (Arc 3) +1,"d+") +edges :: PlanarSubdivision s v e f r -> V.Vector (Dart s, e) +edges ps = (\e -> (e,ps^.dataOf e)) <$> edges' ps + + +faces' :: PlanarSubdivision s v e f r -> V.Vector (FaceId' s) +faces' ps = let n = numFaces ps + in V.fromList $ map (FaceId . VertexId) [0..n-1] + +faces :: PlanarSubdivision s v e f r -> V.Vector (FaceId' s, FaceData (Dart s) f) +faces ps = (\fi -> (fi,ps^.faceDataOf fi)) <$> faces' ps + +-- | Enumerates all faces with their face data exlcluding the outer face +internalFaces :: (Ord r, Fractional r) + => PlanarSubdivision s v e f r + -> V.Vector (FaceId' s, FaceData (Dart s) f) +internalFaces ps = let i = outerFaceId ps + in V.filter (\(j,_) -> i /= j) $ faces ps + + +-- -- | lens to access the Dart Data +-- dartData :: Lens (PlanarSubdivision s v e f r) (PlanarSubdivision s v e' f r) +-- (V.Vector (Dart s, e)) (V.Vector (Dart s, e')) +-- dartData = graph.PG.dartData + + + + + +-- | The tail of a dart, i.e. the vertex this dart is leaving from +-- +-- running time: \(O(1)\) +tailOf :: Dart s -> PlanarSubdivision s v e f r -> VertexId' s +tailOf d ps = let (_,d',g) = asLocalD d ps + in g^.dataOf (PG.tailOf d' g) + + +-- | The vertex this dart is heading in to +-- +-- running time: \(O(1)\) +headOf :: Dart s -> PlanarSubdivision s v e f r -> VertexId' s +headOf d ps = let (_,d',g) = asLocalD d ps + in g^.dataOf (PG.headOf d' g) + + +-- | endPoints d g = (tailOf d g, headOf d g) +-- +-- running time: \(O(1)\) +endPoints :: Dart s -> PlanarSubdivision s v e f r + -> (VertexId' s, VertexId' s) +endPoints d ps = (tailOf d ps, headOf d ps) + + +-- | All edges incident to vertex v, in counterclockwise order around v. +-- +-- running time: \(O(k)\), where \(k\) is the number of edges reported. +incidentEdges :: VertexId' s -> PlanarSubdivision s v e f r + -> V.Vector (Dart s) +incidentEdges v ps= let (_,v',g) = asLocalV v ps + ds = PG.incidentEdges v' g + in (\d -> g^.dataOf d) <$> ds + + +-- | Given a dart d that points into some vertex v, report the next +-- dart e in the cyclic order around v. +-- +-- running time: \(O(1)\) +nextIncidentEdge :: Dart s -> PlanarSubdivision s v e f r -> Dart s +nextIncidentEdge d ps = let (_,d',g) = asLocalD d ps + d'' = PG.nextIncidentEdge d' g + in g^.dataOf d'' + +-- | All incoming edges incident to vertex v, in counterclockwise order around v. +incomingEdges :: VertexId' s -> PlanarSubdivision s v e f r -> V.Vector (Dart s) +incomingEdges v ps = V.filter (not . isPositive) $ incidentEdges v ps + +-- | All outgoing edges incident to vertex v, in counterclockwise order around v. +outgoingEdges :: VertexId' s -> PlanarSubdivision s v e f r -> V.Vector (Dart s) +outgoingEdges v ps = V.filter isPositive $ incidentEdges v ps + + +-- | Gets the neighbours of a particular vertex, in counterclockwise order +-- around the vertex. +-- +-- running time: \(O(k)\), where \(k\) is the output size +neighboursOf :: VertexId' s -> PlanarSubdivision s v e f r -> V.Vector (VertexId' s) +neighboursOf v ps = otherVtx <$> incidentEdges v ps + where + otherVtx d = let u = tailOf d ps in if u == v then headOf d ps else u + + +-- | The face to the left of the dart +-- +-- running time: \(O(1)\). +leftFace :: Dart s -> PlanarSubdivision s v e f r -> FaceId' s +leftFace d ps = let (_,d',g) = asLocalD d ps + fi = PG.leftFace d' g + in g^.dataOf fi.fData + +-- | The face to the right of the dart +-- +-- running time: \(O(1)\). +rightFace :: Dart s -> PlanarSubdivision s v e f r -> FaceId' s +rightFace d ps = let (_,d',g) = asLocalD d ps + fi = PG.rightFace d' g + in g^.dataOf fi.fData + +-- | The darts on the outer boundary of the face, for internal faces in +-- clockwise order, for the outer face in counter clockwise order. +-- +-- +-- running time: \(O(k)\), where \(k\) is the output size. +outerBoundaryDarts :: FaceId' s -> PlanarSubdivision s v e f r -> V.Vector (Dart s) +outerBoundaryDarts f ps = let (_,f',g) = asLocalF f ps + ds = PG.boundary f' g + in (\d -> g^.dataOf d) <$> ds + + + +-- | The vertices of the outer boundary of the face, for internal faces in +-- clockwise order, for the outer face in counter clockwise order. +-- +-- +-- running time: \(O(k)\), where \(k\) is the output size. +boundaryVertices :: FaceId' s -> PlanarSubdivision s v e f r + -> V.Vector (VertexId' s) +boundaryVertices f ps = (\d -> headOf d ps) <$> outerBoundaryDarts f ps + + +-- | Lists the holes in this face, given as a list of darts to arbitrary darts +-- on those faces. +-- +-- running time: \(O(k)\), where \(k\) is the number of darts returned. +holesOf :: FaceId' s -> PlanarSubdivision s v e f r -> Seq.Seq (Dart s) +holesOf f ps = ps^.faceDataOf f.holes + + +-------------------------------------------------------------------------------- +-- * Access data + + + +asLocalD :: Dart s -> PlanarSubdivision s v e f r + -> (ComponentId s, Dart (Wrap s), Component s r) +asLocalD d ps = let (Raw ci d' _) = ps^.rawDartData.ix' (fromEnum d) + in (ci,d',ps^.component ci) + + + + +asLocalV :: VertexId' s -> PlanarSubdivision s v e f r + -> (ComponentId s, VertexId' (Wrap s), Component s r) +asLocalV (VertexId v) ps = let (Raw ci v' _) = ps^.rawVertexData.ix' v + in (ci,v',ps^.component ci) + +asLocalF :: FaceId' s -> PlanarSubdivision s v e f r + -> (ComponentId s, FaceId' (Wrap s), Component s r) +asLocalF (FaceId (VertexId f)) ps = let (Raw ci f' _) = ps^.rawFaceData.ix' f + in (ci,f',ps^.component ci) + + + +-- | Note that using the setting part of this lens may be very expensive!! +vertexDataOf :: VertexId' s + -> Lens' (PlanarSubdivision s v e f r ) (VertexData r v) +vertexDataOf (VertexId vi) = lens get' set'' + where + get' ps = let (Raw ci wvdi x) = ps^.rawVertexData.ix' vi + vd = ps^.component ci.PG.vertexDataOf wvdi + in vd&vData .~ x + set'' ps x = let (Raw ci wvdi _) = ps^.rawVertexData.ix' vi + in ps&rawVertexData.ix' vi.dataVal .~ (x^.vData) + &component ci.PG.vertexDataOf wvdi.location .~ (x^.location) + +locationOf :: VertexId' s -> Lens' (PlanarSubdivision s v e f r ) (Point 2 r) +locationOf v = vertexDataOf v.location + + +faceDataOf :: FaceId' s -> Lens' (PlanarSubdivision s v e f r) + (FaceData (Dart s) f) +faceDataOf fi = lens getF setF + where + (FaceId (VertexId i)) = fi + getF ps = let (Raw ci wfi x) = ps^.rawFaceData.ix' i + fd = ps^.component ci.dataOf wfi + in fd&fData .~ x + + setF ps fd = let (Raw ci wfi _) = ps^.rawFaceData.ix' i + fd' = fd&fData .~ fi + x = fd^.fData + in ps&component ci.dataOf wfi .~ fd' + &rawFaceData.ix' i.dataVal .~ x + +instance HasDataOf (PlanarSubdivision s v e f r) (VertexId' s) where + type DataOf (PlanarSubdivision s v e f r) (VertexId' s) = v + dataOf v = vertexDataOf v.vData + +instance HasDataOf (PlanarSubdivision s v e f r) (Dart s) where + type DataOf (PlanarSubdivision s v e f r) (Dart s) = e + dataOf d = rawDartData.ix' (fromEnum d).dataVal + +instance HasDataOf (PlanarSubdivision s v e f r) (FaceId' s) where + type DataOf (PlanarSubdivision s v e f r) (FaceId' s) = f + dataOf f = faceDataOf f.fData + + + +-- | Getter for the data at the endpoints of a dart +-- +-- running time: \(O(1)\) +endPointsOf :: Dart s -> Getter (PlanarSubdivision s v e f r ) + (VertexData r v, VertexData r v) +endPointsOf d = to (endPointData d) + +-- | data corresponding to the endpoints of the dart +-- +-- running time: \(O(1)\) +endPointData :: Dart s -> PlanarSubdivision s v e f r + -> (VertexData r v, VertexData r v) +endPointData d ps = let (u,v) = endPoints d ps + in (ps^.vertexDataOf u, ps^.vertexDataOf v) + + +-------------------------------------------------------------------------------- + +-- | gets the id of the outer face +-- +-- running time: \(O(1)\) +outerFaceId :: PlanarSubdivision s v e f r -> FaceId' s +outerFaceId = const . FaceId . VertexId $ 0 + -- our invariant tells us the outerface is always at faceId 0 + +-------------------------------------------------------------------------------- + +-- | Reports all edges as line segments +edgeSegments :: PlanarSubdivision s v e f r -> V.Vector (Dart s, LineSegment 2 v r :+ e) +edgeSegments ps = (\d -> (d,edgeSegment d ps)) <$> edges' ps + + +-- | Given a dart and the subdivision constructs the line segment representing it +-- +-- \(O(1)\) +edgeSegment :: Dart s -> PlanarSubdivision s v e f r -> LineSegment 2 v r :+ e +edgeSegment d ps = let (p,q) = bimap PG.vtxDataToExt PG.vtxDataToExt $ ps^.endPointsOf d + in ClosedLineSegment p q :+ ps^.dataOf d + + +-- | Generates the darts incident to a face, starting with the given dart. +-- +-- +-- \(O(k)\), where \(k\) is the number of darts reported +boundary' :: Dart s -> PlanarSubdivision s v e f r -> V.Vector (Dart s) +boundary' d ps = let (_,d',g) = asLocalD d ps + in (\d'' -> g^.dataOf d'') <$> PG.boundary' d' g + + +-- | Constructs the outer boundary of the face +-- +-- \(O(k)\), where \(k\) is the complexity of the outer boundary of the face +rawFaceBoundary :: FaceId' s -> PlanarSubdivision s v e f r -> SimplePolygon v r :+ f +rawFaceBoundary i ps = fromPoints pts :+ (ps^.dataOf i) + where + d = V.head $ outerBoundaryDarts i ps + pts = (\d' -> PG.vtxDataToExt $ ps^.vertexDataOf (headOf d' ps)) + <$> V.toList (boundary' d ps) + + +-- | Constructs the boundary of the given face +-- +-- \(O(k)\), where \(k\) is the complexity of the face +rawFacePolygon :: FaceId' s -> PlanarSubdivision s v e f r + -> SomePolygon v r :+ f +rawFacePolygon i ps = case F.toList $ holesOf i ps of + [] -> Left res :+ x + hs -> Right (MultiPolygon vs $ map toHole hs) :+ x + where + res@(SimplePolygon vs) :+ x = rawFaceBoundary i ps + toHole d = (rawFaceBoundary (leftFace d ps) ps)^.core + +-- | Lists all faces of the planar subdivision. +rawFacePolygons :: PlanarSubdivision s v e f r + -> V.Vector (FaceId' s, SomePolygon v r :+ f) +rawFacePolygons ps = fmap (\i -> (i,rawFacePolygon i ps)) . faces' $ ps + + + +dartMapping ps = ps^.component (ComponentId 0).PG.dartData diff --git a/src/Data/Geometry/PlanarSubdivision/Draw.hs b/src/Data/Geometry/PlanarSubdivision/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/PlanarSubdivision/Draw.hs @@ -0,0 +1,17 @@ +module Data.Geometry.PlanarSubdivision.Draw where + +import Data.Geometry.Ipe +import Data.Ext +import Control.Lens +import qualified Data.Vector as V +import Data.Geometry.PlanarSubdivision + +drawPlanarSubdivision :: forall s v e f r. IpeOut (PlanarSubdivision s v e f r) (IpeObject r) +drawPlanarSubdivision = IpeOut draw + where + draw :: PlanarSubdivision s v e f r -> IpeObject r + draw g = asIpeGroup $ concatMap V.toList [vs, es, fs] + where + vs = (\(_,VertexData p _) -> asIpeObject p mempty) <$> vertices g + es = (\(_,s :+ _) -> asIpeObject s mempty) <$> edgeSegments g + fs = (\(_,f :+ _) -> asIpeObject f mempty) <$> rawFacePolygons g diff --git a/src/Data/Geometry/Point.hs b/src/Data/Geometry/Point.hs --- a/src/Data/Geometry/Point.hs +++ b/src/Data/Geometry/Point.hs @@ -1,9 +1,16 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} +{-| +Module : Data.Geometry.Point +Description: \(d\)-dimensional points +Copyright : (c) Frank Staals +License : See LICENCE file +-} module Data.Geometry.Point where import Control.DeepSeq import Control.Lens +import Data.Aeson import qualified Data.CircularList as C import qualified Data.CircularList.Util as CU import Data.Ext @@ -13,8 +20,6 @@ import qualified Data.Geometry.Vector as Vec import qualified Data.List as L import Data.Proxy -import qualified Data.Traversable as T -import qualified Data.Vector.Fixed as FV import GHC.Generics (Generic) import GHC.TypeLits -------------------------------------------------------------------------------- @@ -23,7 +28,7 @@ -- $setup -- >>> :{ -- let myVector :: Vector 3 Int --- myVector = v3 1 2 3 +-- myVector = Vector3 1 2 3 -- myPoint = Point myVector -- :} @@ -35,20 +40,17 @@ newtype Point d r = Point { toVec :: Vector d r } deriving (Generic) instance (Show r, Arity d) => Show (Point d r) where - show (Point (Vector v)) = mconcat [ "Point", show $ FV.length v , " " - , show $ F.toList v - ] - - + show (Point v) = mconcat [ "Point", show $ F.length v , " " + , show $ F.toList v + ] deriving instance (Eq r, Arity d) => Eq (Point d r) deriving instance (Ord r, Arity d) => Ord (Point d r) deriving instance Arity d => Functor (Point d) -deriving instance Arity d => F.Foldable (Point d) -deriving instance Arity d => T.Traversable (Point d) +deriving instance Arity d => Foldable (Point d) +deriving instance Arity d => Traversable (Point d) deriving instance (Arity d, NFData r) => NFData (Point d r) - type instance NumType (Point d r) = r type instance Dimension (Point d r) = d @@ -58,7 +60,13 @@ p .-. q = toVec p ^-^ toVec q p .+^ v = Point $ toVec p ^+^ v +instance (FromJSON r, Arity d, KnownNat d) => FromJSON (Point d r) where + parseJSON = fmap Point . parseJSON +instance (ToJSON r, Arity d) => ToJSON (Point d r) where + toJSON = toJSON . toVec + toEncoding = toEncoding . toVec + -- | Point representing the origin in d dimensions -- -- >>> origin :: Point 4 Int @@ -73,7 +81,7 @@ -- -- >>> (point3 1 2 3) ^. vector -- Vector3 [1,2,3] --- >>> origin & vector .~ v3 1 2 3 +-- >>> origin & vector .~ Vector3 1 2 3 -- Point3 [1,2,3] vector :: Lens' (Point d r) (Vector d r) vector = lens toVec (const Point) @@ -86,7 +94,7 @@ -- >>> point3 1 2 3 ^. unsafeCoord 2 -- 2 unsafeCoord :: Arity d => Int -> Lens' (Point d r) r -unsafeCoord i = vector . FV.element (i-1) +unsafeCoord i = vector . singular (ix (i-1)) -- Points are 1 indexed, vectors are 0 indexed -- | Get the coordinate in a given dimension @@ -97,9 +105,18 @@ -- Point3 [10,2,3] -- >>> point3 1 2 3 & coord (C :: C 3) %~ (+1) -- Point3 [1,2,4] -coord :: forall proxy i d r. (Index' (i-1) d, Arity d) => proxy i -> Lens' (Point d r) r +coord :: forall proxy i d r. (1 <= i, i <= d, ((i - 1) + 1) ~ i + , Arity (i - 1), Arity d + ) => proxy i -> Lens' (Point d r) r coord _ = vector . Vec.element (Proxy :: Proxy (i-1)) +{-# INLINABLE coord #-} + +-- somehow these rules don't fire +-- {-# SPECIALIZE coord :: C 1 -> Lens' (Point 2 r) r#-} +-- {-# SPECIALIZE coord :: C 2 -> Lens' (Point 2 r) r#-} + + -- | Constructs a point from a list of coordinates -- -- >>> pointFromList [1,2,3] :: Maybe (Point 3 Int) @@ -108,6 +125,10 @@ pointFromList = fmap Point . Vec.vectorFromList +-- | Project a point down into a lower dimension. +projectPoint :: (Arity i, Arity d, i <= d) => Point d r -> Point i r +projectPoint = Point . prefix . toVec + -------------------------------------------------------------------------------- -- * Convenience functions to construct 2 and 3 dimensional points @@ -128,6 +149,7 @@ pattern Point2 x y <- (_point2 -> (x,y)) where Point2 x y = point2 x y +{-# COMPLETE Point2 #-} -- | Similarly, we can write: -- @@ -142,47 +164,48 @@ pattern Point3 x y z <- (_point3 -> (x,y,z)) where Point3 x y z = point3 x y z +{-# COMPLETE Point3 #-} -- | Construct a 2 dimensional point -- -- >>> point2 1 2 -- Point2 [1,2] point2 :: r -> r -> Point 2 r -point2 x y = Point $ v2 x y +point2 x y = Point $ Vector2 x y -- | Destruct a 2 dimensional point -- -- >>> _point2 $ point2 1 2 -- (1,2) -_point2 :: Point 2 r -> (r,r) -_point2 p = (p^.xCoord, p^.yCoord) +_point2 :: Point 2 r -> (r,r) +_point2 = (\(Vector2 x y) -> (x,y)) . toVec + -- | Construct a 3 dimensional point -- -- >>> point3 1 2 3 -- Point3 [1,2,3] point3 :: r -> r -> r -> Point 3 r -point3 x y z = Point $ v3 x y z +point3 x y z = Point $ Vector3 x y z -- | Destruct a 3 dimensional point -- -- >>> _point3 $ point3 1 2 3 -- (1,2,3) -_point3 :: Point 3 r -> (r,r,r) -_point3 p = (p^.xCoord, p^.yCoord, p^.zCoord) +_point3 :: Point 3 r -> (r,r,r) +_point3 = (\(Vector3 x y z) -> (x,y,z)) . toVec -type i <=. d = (Index' (i-1) d, Arity d) - -- | Shorthand to access the first coordinate C 1 -- -- >>> point3 1 2 3 ^. xCoord -- 1 -- >>> point2 1 2 & xCoord .~ 10 -- Point2 [10,2] -xCoord :: (1 <=. d) => Lens' (Point d r) r +xCoord :: (1 <= d, Arity d) => Lens' (Point d r) r xCoord = coord (C :: C 1) +{-# INLINABLE xCoord #-} -- | Shorthand to access the second coordinate C 2 -- @@ -190,8 +213,9 @@ -- 2 -- >>> point3 1 2 3 & yCoord %~ (+1) -- Point3 [1,3,3] -yCoord :: (2 <=. d) => Lens' (Point d r) r +yCoord :: (2 <= d, Arity d) => Lens' (Point d r) r yCoord = coord (C :: C 2) +{-# INLINABLE yCoord #-} -- | Shorthand to access the third coordinate C 3 -- @@ -199,9 +223,9 @@ -- 3 -- >>> point3 1 2 3 & zCoord %~ (+1) -- Point3 [1,2,4] -zCoord :: (3 <=. d) => Lens' (Point d r) r +zCoord :: (3 <= d, Arity d) => Lens' (Point d r) r zCoord = coord (C :: C 3) - +{-# INLINABLE zCoord #-} -------------------------------------------------------------------------------- @@ -235,6 +259,10 @@ Vector2 vx vy = r .-. p z = ux * vy - uy * vx +-- | Given three points p q and r determine the orientation when going from p to r via q. +ccw' :: (Ord r, Num r) => Point 2 r :+ a -> Point 2 r :+ b -> Point 2 r :+ c -> CCW +ccw' p q r = ccw (p^.core) (q^.core) (r^.core) + -- | Sort the points arround the given point p in counter clockwise order with -- respect to the rightward horizontal ray starting from p. If two points q -- and r are colinear with p, the closest one to p is reported first. @@ -251,7 +279,7 @@ -- | Quadrants around point c; quadrants are closed on their "previous" -- boundary (i..e the boundary with the previous quadrant in the CCW order), -- open on next boundary. The origin itself is assigned the topRight quadrant -quadrantWith :: (Ord r, 1 <=. d, 2 <=. d) +quadrantWith :: (Ord r, 1 <= d, 2 <= d, Arity d) => Point d r :+ q -> Point d r :+ p -> Quadrant quadrantWith (c :+ _) (p :+ _) = case ( (c^.xCoord) `compare` (p^.xCoord) , (c^.yCoord) `compare` (p^.yCoord) ) of @@ -266,7 +294,7 @@ (LT, GT) -> BottomRight -- | Quadrants with respect to the origin -quadrant :: (Ord r, Num r, 1 <=. d, 2 <=. d) => Point d r :+ p -> Quadrant +quadrant :: (Ord r, Num r, 1 <= d, 2 <= d, Arity d) => Point d r :+ p -> Quadrant quadrant = quadrantWith (ext origin) -- | Given a center point c, and a set of points, partition the points into @@ -274,7 +302,7 @@ -- reported in the order topLeft, topRight, bottomLeft, bottomRight. The points -- are in the same order as they were in the original input lists. -- Points with the same x-or y coordinate as p, are "rounded" to above. -partitionIntoQuadrants :: (Ord r, 1 <=. d, 2 <=. d) +partitionIntoQuadrants :: (Ord r, 1 <= d, 2 <= d, Arity d) => Point d r :+ q -> [Point d r :+ p] -> ( [Point d r :+ p], [Point d r :+ p] diff --git a/src/Data/Geometry/PolyLine.hs b/src/Data/Geometry/PolyLine.hs --- a/src/Data/Geometry/PolyLine.hs +++ b/src/Data/Geometry/PolyLine.hs @@ -16,6 +16,7 @@ import Data.Semigroup import qualified Data.Seq2 as S2 import qualified Data.Sequence as Seq +import GHC.TypeLits -------------------------------------------------------------------------------- -- * d-dimensional Polygonal Lines (PolyLines) @@ -40,7 +41,7 @@ instance Arity d => IsBoxable (PolyLine d p r) where boundingBox = boundingBoxList . NE.fromList . toListOf (points.traverse.core) -instance (Num r, AlwaysTruePFT d) => IsTransformable (PolyLine d p r) where +instance (Fractional r, Arity d, Arity (d + 1)) => IsTransformable (PolyLine d p r) where transformBy = transformPointFunctor instance PointFunctor (PolyLine d p) where @@ -77,3 +78,7 @@ asLineSegment' (PolyLine (S2.Seq2 p m q)) | Seq.null m = Just $ ClosedLineSegment p q | otherwise = Nothing + + +-- polylineEdges :: Polyline d p r -> NonEmpty.NonEmpty (LineSegment d p r) +-- polylineEdges (Polyline ) diff --git a/src/Data/Geometry/Polygon.hs b/src/Data/Geometry/Polygon.hs --- a/src/Data/Geometry/Polygon.hs +++ b/src/Data/Geometry/Polygon.hs @@ -1,11 +1,19 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : Data.Geometry.Polygon +Description: A Polygon data type and some basic functions to interact with them. +Copyright : (c) Frank Staals +License : See LICENCE file +-} module Data.Geometry.Polygon where +import Control.DeepSeq import Control.Lens hiding (Simple) +import Data.Bifoldable import Data.Bifunctor +import Data.Bitraversable import qualified Data.CircularSeq as C import Data.Ext -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Foldable as F import Data.Geometry.Boundary import Data.Geometry.Box @@ -15,12 +23,13 @@ import Data.Geometry.Properties import Data.Geometry.Transformation import Data.Geometry.Vector +import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (mapMaybe) import Data.Proxy import Data.Semigroup +import qualified Data.Sequence as Seq import Data.Util -import Frames.CoRec (asA) - +import Data.Vinyl.CoRec (asA) -------------------------------------------------------------------------------- -- * Polygons @@ -44,10 +53,36 @@ SimplePolygon :: C.CSeq (Point 2 r :+ p) -> Polygon Simple p r MultiPolygon :: C.CSeq (Point 2 r :+ p) -> [Polygon Simple p r] -> Polygon Multi p r +instance Bifunctor (Polygon t) where + bimap = bimapDefault + +instance Bifoldable (Polygon t) where + bifoldMap = bifoldMapDefault + +instance Bitraversable (Polygon t) where + bitraverse f g p = case p of + SimplePolygon vs -> SimplePolygon <$> bitraverseVertices f g vs + MultiPolygon vs hs -> MultiPolygon <$> bitraverseVertices f g vs + <*> traverse (bitraverse f g) hs + +instance (NFData p, NFData r) => NFData (Polygon t p r) where + rnf (SimplePolygon vs) = rnf vs + rnf (MultiPolygon vs hs) = rnf (vs,hs) + +bitraverseVertices :: (Applicative f, Traversable t) => (p -> f q) -> (r -> f s) + -> t (Point 2 r :+ p) -> f (t (Point 2 s :+ q)) +bitraverseVertices f g = traverse (bitraverse (traverse g) f) + type SimplePolygon = Polygon Simple type MultiPolygon = Polygon Multi +-- | Either a simple or multipolygon +type SomePolygon p r = Either (Polygon Simple p r) (Polygon Multi p r) + +type instance Dimension (SomePolygon p r) = 2 +type instance NumType (SomePolygon p r) = r + -- | Polygons are per definition 2 dimensional type instance Dimension (Polygon t p r) = 2 type instance NumType (Polygon t p r) = r @@ -64,12 +99,30 @@ pmap f (SimplePolygon vs) = SimplePolygon (fmap (first f) vs) pmap f (MultiPolygon vs hs) = MultiPolygon (fmap (first f) vs) (map (pmap f) hs) -instance Num r => IsTransformable (Polygon t p r) where +instance Fractional r => IsTransformable (Polygon t p r) where transformBy = transformPointFunctor instance IsBoxable (Polygon t p r) where boundingBox = boundingBoxList' . toListOf (outerBoundary.traverse.core) +type instance IntersectionOf (Line 2 r) (Boundary (Polygon t p r)) = + '[Seq.Seq (Either (Point 2 r) (LineSegment 2 () r))] + +-- instance IsIntersectableWith (Line 2 r) (Boundary (Polygon t p r)) where +-- nonEmptyIntersection _ _ (CoRec xs) = null xs +-- l `intersect` (Boundary (SimplePolygon vs)) = +-- undefined + -- l `intersect` (Boundary (MultiPolygon vs hs)) = coRec . + -- Seq.sortBy f . Seq.fromList + -- . concatMap (unpack . (l `intersect`) . Boundary) + -- $ SimplePolygon vs : hs + -- where + -- unpack (CoRec x) = x + -- f = undefined + + + + -- * Functions on Polygons outerBoundary :: forall t p r. Lens' (Polygon t p r) (C.CSeq (Point 2 r :+ p)) @@ -84,8 +137,8 @@ s (SimplePolygon _) vs = SimplePolygon vs s (MultiPolygon _ hs) vs = MultiPolygon vs hs -holes :: forall p r. Lens' (Polygon Multi p r) [Polygon Simple p r] -holes = lens g s +polygonHoles :: forall p r. Lens' (Polygon Multi p r) [Polygon Simple p r] +polygonHoles = lens g s where g :: Polygon Multi p r -> [Polygon Simple p r] g (MultiPolygon _ hs) = hs @@ -120,15 +173,47 @@ sconcat $ C.toNonEmpty vs NonEmpty.:| map polygonVertices hs - +-- | Creates a simple polygon from the given list of vertices. +-- +-- pre: the input list constains no repeated vertices. fromPoints :: [Point 2 r :+ p] -> SimplePolygon p r fromPoints = SimplePolygon . C.fromList + -- | The edges along the outer boundary of the polygon. The edges are half open. +-- +-- running time: \(O(n)\) outerBoundaryEdges :: Polygon t p r -> C.CSeq (LineSegment 2 p r) outerBoundaryEdges = toEdges . (^.outerBoundary) +-- | Lists all edges. The edges on the outer boundary are given before the ones +-- on the holes. However, no other guarantees are given on the order. +-- +-- running time: \(O(n)\) +listEdges :: Polygon t p r -> [LineSegment 2 p r] +listEdges pg = let f = F.toList . outerBoundaryEdges + in f pg <> concatMap f (holeList pg) +-- | Pairs every vertex with its incident edges. The first one is its +-- predecessor edge, the second one its successor edge. +-- +-- >>> mapM_ print . polygonVertices $ withIncidentEdges simplePoly +-- Point2 [0 % 1,0 % 1] :+ SP LineSegment (Closed (Point2 [1 % 1,11 % 1] :+ ())) (Closed (Point2 [0 % 1,0 % 1] :+ ())) LineSegment (Closed (Point2 [0 % 1,0 % 1] :+ ())) (Closed (Point2 [10 % 1,0 % 1] :+ ())) +-- Point2 [10 % 1,0 % 1] :+ SP LineSegment (Closed (Point2 [0 % 1,0 % 1] :+ ())) (Closed (Point2 [10 % 1,0 % 1] :+ ())) LineSegment (Closed (Point2 [10 % 1,0 % 1] :+ ())) (Closed (Point2 [10 % 1,10 % 1] :+ ())) +-- Point2 [10 % 1,10 % 1] :+ SP LineSegment (Closed (Point2 [10 % 1,0 % 1] :+ ())) (Closed (Point2 [10 % 1,10 % 1] :+ ())) LineSegment (Closed (Point2 [10 % 1,10 % 1] :+ ())) (Closed (Point2 [5 % 1,15 % 1] :+ ())) +-- Point2 [5 % 1,15 % 1] :+ SP LineSegment (Closed (Point2 [10 % 1,10 % 1] :+ ())) (Closed (Point2 [5 % 1,15 % 1] :+ ())) LineSegment (Closed (Point2 [5 % 1,15 % 1] :+ ())) (Closed (Point2 [1 % 1,11 % 1] :+ ())) +-- Point2 [1 % 1,11 % 1] :+ SP LineSegment (Closed (Point2 [5 % 1,15 % 1] :+ ())) (Closed (Point2 [1 % 1,11 % 1] :+ ())) LineSegment (Closed (Point2 [1 % 1,11 % 1] :+ ())) (Closed (Point2 [0 % 1,0 % 1] :+ ())) +withIncidentEdges :: Polygon t p r + -> Polygon t (Two (LineSegment 2 p r)) r +withIncidentEdges (SimplePolygon vs) = + SimplePolygon $ C.zip3LWith f (C.rotateL vs) vs (C.rotateR vs) + where + f p c n = c&extra .~ SP (ClosedLineSegment p c) (ClosedLineSegment c n) +withIncidentEdges (MultiPolygon vs hs) = MultiPolygon vs' hs' + where + (SimplePolygon vs') = withIncidentEdges $ SimplePolygon vs + hs' = map withIncidentEdges hs + -- -- | Gets the i^th edge on the outer boundary of the polygon, that is the edge ---- with vertices i and i+1 with respect to the current focus. All indices -- -- modulo n. @@ -284,25 +369,29 @@ -- | Test if the outer boundary of the polygon is in clockwise or counter -- clockwise order. -- --- running time: \(O(1)\) +-- running time: \(O(n)\) -- isCounterClockwise :: (Eq r, Fractional r) => Polygon t p r -> Bool isCounterClockwise = (\x -> x == abs x) . signedArea - . fromPoints . take 3 . F.toList . (^.outerBoundary) + . fromPoints . F.toList . (^.outerBoundary) -- | Orient the outer boundary to clockwise order toClockwiseOrder :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r toClockwiseOrder p - | isCounterClockwise p = p&outerBoundary %~ C.reverseDirection + | isCounterClockwise p = reverseOuterBoundary p | otherwise = p -- | Orient the outer boundary to counter clockwise order toCounterClockWiseOrder :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r toCounterClockWiseOrder p - | not $ isCounterClockwise p = p&outerBoundary %~ C.reverseDirection + | not $ isCounterClockwise p = reverseOuterBoundary p | otherwise = p +reverseOuterBoundary :: Polygon t p r -> Polygon t p r +reverseOuterBoundary p = p&outerBoundary %~ C.reverseDirection + + -- | Convert a Polygon to a simple polygon by forgetting about any holes. asSimplePolygon :: Polygon t p r -> SimplePolygon p r asSimplePolygon poly@(SimplePolygon _) = poly @@ -324,3 +413,14 @@ extremesLinear u p = let vs = p^.outerBoundary f = cmpExtreme u in (F.minimumBy f vs, F.maximumBy f vs) + + +-- | assigns unique integer numbers to all vertices. Numbers start from 0, and +-- are increasing along the outer boundary. The vertices of holes +-- will be numbered last, in the same order. +-- +-- >>> numberVertices simplePoly +-- SimplePolygon CSeq [Point2 [0 % 1,0 % 1] :+ SP 0 (),Point2 [10 % 1,0 % 1] :+ SP 1 (),Point2 [10 % 1,10 % 1] :+ SP 2 (),Point2 [5 % 1,15 % 1] :+ SP 3 (),Point2 [1 % 1,11 % 1] :+ SP 4 ()] +numberVertices :: Polygon t p r -> Polygon t (SP Int p) r +numberVertices = snd . bimapAccumL (\a p -> (a+1,SP a p)) (\a r -> (a,r)) 0 + -- TODO: Make sure that this does not have the same issues as foldl vs foldl' diff --git a/src/Data/Geometry/Polygon/Convex.hs b/src/Data/Geometry/Polygon/Convex.hs --- a/src/Data/Geometry/Polygon/Convex.hs +++ b/src/Data/Geometry/Polygon/Convex.hs @@ -20,35 +20,42 @@ , bottomMost ) where +import Control.DeepSeq import Control.Lens hiding ((:<), (:>)) import Data.CircularSeq (focus,CSeq) import qualified Data.CircularSeq as C import Data.Ext import qualified Data.Foldable as F import Data.Function (on, ) -import Data.Geometry import Data.Geometry.Box (IsBoxable(..)) -import Data.Geometry.Polygon (fromPoints, cmpExtreme) +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Polygon (fromPoints, SimplePolygon, cmpExtreme, outerBoundary) import Data.Geometry.Properties +import Data.Geometry.Transformation +import Data.Geometry.Vector import Data.Maybe (fromJust) import Data.Ord (comparing) import Data.Sequence (viewl,viewr, ViewL(..), ViewR(..)) import qualified Data.Sequence as S -- import Data.Geometry.Ipe -import Debug.Trace +-- import Debug.Trace -------------------------------------------------------------------------------- newtype ConvexPolygon p r = ConvexPolygon {_simplePolygon :: SimplePolygon p r } - deriving (Show,Eq,PointFunctor) + deriving (Show,Eq,NFData) makeLenses ''ConvexPolygon +instance PointFunctor (ConvexPolygon p) where + pmap f (ConvexPolygon p) = ConvexPolygon $ pmap f p + -- | Polygons are per definition 2 dimensional type instance Dimension (ConvexPolygon p r) = 2 type instance NumType (ConvexPolygon p r) = r -instance Num r => IsTransformable (ConvexPolygon p r) where +instance Fractional r => IsTransformable (ConvexPolygon p r) where transformBy = transformPointFunctor instance IsBoxable (ConvexPolygon p r) where @@ -349,14 +356,14 @@ -- nxt = focus' xs' -- in if p cur nxt then go xs' else xs -test1 :: Num r => ConvexPolygon () r -test1 = ConvexPolygon . fromPoints . map ext . reverse $ [origin, point2 1 4, point2 5 6, point2 10 3] +-- test1 :: Num r => ConvexPolygon () r +-- test1 = ConvexPolygon . fromPoints . map ext . reverse $ [origin, point2 1 4, point2 5 6, point2 10 3] -test2 :: Num r => ConvexPolygon () r -test2 = ConvexPolygon . fromPoints . map ext . reverse $ [point2 11 6, point2 10 10, point2 15 18, point2 12 5] +-- test2 :: Num r => ConvexPolygon () r +-- test2 = ConvexPolygon . fromPoints . map ext . reverse $ [point2 11 6, point2 10 10, point2 15 18, point2 12 5] -testA :: Num r => ConvexPolygon () r -testA = ConvexPolygon . fromPoints . map ext $ [origin, point2 5 1, point2 2 2] +-- testA :: Num r => ConvexPolygon () r +-- testA = ConvexPolygon . fromPoints . map ext $ [origin, point2 5 1, point2 2 2] -testB :: Num r => ConvexPolygon () r -testB = ConvexPolygon . fromPoints . map ext $ [origin, point2 5 3, point2 (-2) 2, point2 (-2) 1] +-- testB :: Num r => ConvexPolygon () r +-- testB = ConvexPolygon . fromPoints . map ext $ [origin, point2 5 3, point2 (-2) 2, point2 (-2) 1] diff --git a/src/Data/Geometry/Properties.hs b/src/Data/Geometry/Properties.hs --- a/src/Data/Geometry/Properties.hs +++ b/src/Data/Geometry/Properties.hs @@ -2,19 +2,23 @@ {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE DefaultSignatures #-} +{-| +Module : Data.Geometry.Properties +Description: Defines some generic geometric properties e.g. Dimensions, NumType, and Intersection types. +Copyright : (c) Frank Staals +License : See LICENCE file +-} module Data.Geometry.Properties where -import Data.Maybe(isNothing) -import Data.Proxy -import Data.Vinyl.Core -import Data.Vinyl.Functor -import Data.Vinyl.Lens -import Frames.CoRec -import GHC.TypeLits - - +import Data.Maybe (isNothing) +import Data.Proxy +import Data.Vinyl.CoRec +import Data.Vinyl.Core +import Data.Vinyl.Functor +import Data.Vinyl.Lens +import GHC.TypeLits --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- | A type family for types that are associated with a dimension. The -- dimension is the dimension of the geometry they are embedded in. @@ -35,7 +39,7 @@ -- | Helper to produce a corec coRec :: (a ∈ as) => a -> CoRec Identity as -coRec = Col . Identity +coRec = CoRec . Identity class IsIntersectableWith g h where @@ -51,7 +55,7 @@ -- | Helper to implement `intersects`. nonEmptyIntersection :: proxy g -> proxy h -> Intersection g h -> Bool - {-# MINIMAL intersect , nonEmptyIntersection #-} + {-# MINIMAL intersect, nonEmptyIntersection #-} default nonEmptyIntersection :: ( NoIntersection ∈ IntersectionOf g h , RecApplicative (IntersectionOf g h) diff --git a/src/Data/Geometry/SegmentTree/Generic.hs b/src/Data/Geometry/SegmentTree/Generic.hs --- a/src/Data/Geometry/SegmentTree/Generic.hs +++ b/src/Data/Geometry/SegmentTree/Generic.hs @@ -21,13 +21,11 @@ import Data.BinaryTree import Data.Ext import Data.Geometry.Interval -import Data.Geometry.Interval.Util import Data.Geometry.IntervalTree (IntervalLike(..)) import Data.Geometry.Properties import qualified Data.List as List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty -import Data.Range import Data.Semigroup import GHC.Generics (Generic) diff --git a/src/Data/Geometry/Slab.hs b/src/Data/Geometry/Slab.hs --- a/src/Data/Geometry/Slab.hs +++ b/src/Data/Geometry/Slab.hs @@ -2,7 +2,7 @@ {-# Language TemplateHaskell #-} module Data.Geometry.Slab where -import Control.Lens (makeLenses, (^.),(%~),(.~),(&), both) +import Control.Lens (makeLenses, (^.),(%~),(.~),(&), both, from) import Data.Bifunctor import Data.Ext import qualified Data.Foldable as F @@ -15,7 +15,7 @@ import Data.Geometry.SubLine import qualified Data.Traversable as T import Data.Vinyl -import Frames.CoRec +import Data.Vinyl.CoRec -------------------------------------------------------------------------------- @@ -141,6 +141,21 @@ where dropExtra sub = sub&subRange %~ bimap (const ()) id singleton p = let x = ext $ toOffset p l in SubLine l (ClosedInterval x x) + + +type instance IntersectionOf (LineSegment 2 p r) (Slab o a r) = + [NoIntersection, LineSegment 2 () r] + +instance (Fractional r, Ord r, HasBoundingLines o) => + LineSegment 2 a r `IsIntersectableWith` (Slab o a r) where + nonEmptyIntersection = defaultNonEmptyIntersection + + seg `intersect` slab = match ((seg^._SubLine) `intersect` slab) $ + (H $ \NoIntersection -> coRec NoIntersection) + :& (H $ \sl -> coRec $ sl^. from _SubLine) + :& RNil + + test :: SubLine 2 () Double diff --git a/src/Data/Geometry/SubLine.hs b/src/Data/Geometry/SubLine.hs --- a/src/Data/Geometry/SubLine.hs +++ b/src/Data/Geometry/SubLine.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} module Data.Geometry.SubLine where import Control.Lens @@ -12,11 +13,11 @@ import qualified Data.Traversable as T import Data.UnBounded import Data.Vinyl -import Frames.CoRec +import Data.Vinyl.CoRec -------------------------------------------------------------------------------- --- | Part of a line. The interval is ranged based on the unit-vector of the +-- | Part of a line. The interval is ranged based on the vector of the -- line l, and s.t.t zero is the anchorPoint of l. data SubLine d p r = SubLine { _line :: Line d r , _subRange :: Interval p r @@ -34,12 +35,17 @@ deriving instance Arity d => F.Foldable (SubLine d p) deriving instance Arity d => T.Traversable (SubLine d p) +instance Arity d => Bifunctor (SubLine d) where + bimap f g (SubLine l r) = SubLine (g <$> l) (bimap f g r) + -- | Get the point at the given position along line, where 0 corresponds to the -- anchorPoint of the line, and 1 to the point anchorPoint .+^ directionVector pointAt :: (Num r, Arity d) => r -> Line d r -> Point d r pointAt a (Line p v) = p .+^ (a *^ v) + + -- | Annotate the subRange with the actual ending points fixEndPoints :: (Num r, Arity d) => SubLine d p r -> SubLine d (Point d r :+ p) r fixEndPoints sl = sl&subRange %~ f @@ -63,31 +69,52 @@ , SubLine 2 p r ] +-- | given point p, and a Subline l r such that p lies on line l, test if it +-- lies on the subline, i.e. in the interval r +onSubLine :: (Ord r, Fractional r, Arity d) + => Point d r -> SubLine d p r -> Bool +onSubLine p (SubLine l r) = toOffset p l `inInterval` r +-- | given point p, and a Subline l r such that p lies on line l, test if it +-- lies on the subline, i.e. in the interval r +onSubLine2 :: (Ord r, Num r) => Point 2 r -> SubLine 2 p r -> Bool +p `onSubLine2` sl = d `inInterval` r + where + -- get the endpoints (a,b) of the subline + SubLine _ (Interval s e) = fixEndPoints sl + a = s^.unEndPoint.extra.core + b = e^.unEndPoint.extra.core + d = (p .-. a) `dot` (b .-. a) + -- map to an interval corresponding to the length of the segment + r = Interval (s&unEndPoint.core .~ 0) (e&unEndPoint.core .~ squaredEuclideanDist b a) + -- note that we take the dist between b and a, so if these are infinity + -- we get maxInfinity as well + instance (Ord r, Fractional r) => (SubLine 2 p r) `IsIntersectableWith` (SubLine 2 p r) where nonEmptyIntersection = defaultNonEmptyIntersection - (SubLine l r) `intersect` (SubLine m s) = match (l `intersect` m) $ + sl@(SubLine l r) `intersect` sm@(SubLine m _) = match (l `intersect` m) $ (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \p@(Point _) -> if (toOffset p l) `inInterval` r - && - (toOffset p m) `inInterval` s + :& (H $ \p@(Point _) -> if onSubLine2 p sl && onSubLine2 p sm then coRec p else coRec NoIntersection) - :& (H $ \_ -> match (r `intersect` s') $ + :& (H $ \_ -> match (r `intersect` s'') $ (H $ \NoIntersection -> coRec NoIntersection) :& (H $ \i -> coRec $ SubLine l i) :& RNil ) :& RNil where - s' = shiftLeft' (toOffset (m^.anchorPoint) l) s - + -- s' = shiftLeft' (toOffset (m^.anchorPoint) l) $ s + s' = (fixEndPoints sm)^.subRange + s'' = bimap (^.extra) id + $ s'&start.core .~ toOffset (s'^.start.extra.core) l + &end.core .~ toOffset (s'^.end.extra.core) l fromLine :: Arity d => Line d r -> SubLine d () (UnBounded r) -fromLine l = SubLine (fmap Val l) (OpenInterval (ext MinInfinity) (ext MaxInfinity)) +fromLine l = SubLine (fmap Val l) (ClosedInterval (ext MinInfinity) (ext MaxInfinity)) -- testL :: SubLine 2 () (UnBounded Rational) diff --git a/src/Data/Geometry/Transformation.hs b/src/Data/Geometry/Transformation.hs --- a/src/Data/Geometry/Transformation.hs +++ b/src/Data/Geometry/Transformation.hs @@ -38,21 +38,21 @@ -- * Transformations -- | A type representing a Transformation for d dimensional objects -newtype Transformation d r = Transformation { _transformationMatrix :: Matrix (1 + d) (1 + d) r } +newtype Transformation d r = Transformation { _transformationMatrix :: Matrix (d + 1) (d + 1) r } -transformationMatrix :: Lens' (Transformation d r) (Matrix (1 + d) (1 + d) r) +transformationMatrix :: Lens' (Transformation d r) (Matrix (d + 1) (d + 1) r) transformationMatrix = lens _transformationMatrix (const Transformation) -deriving instance (Show r, Arity (1 + d)) => Show (Transformation d r) -deriving instance (Eq r, Arity (1 + d)) => Eq (Transformation d r) -deriving instance (Ord r, Arity (1 + d)) => Ord (Transformation d r) -deriving instance Arity (1 + d) => Functor (Transformation d) +deriving instance (Show r, Arity (d + 1)) => Show (Transformation d r) +deriving instance (Eq r, Arity (d + 1)) => Eq (Transformation d r) +deriving instance (Ord r, Arity (d + 1)) => Ord (Transformation d r) +deriving instance Arity (d + 1) => Functor (Transformation d) type instance NumType (Transformation d r) = r -- | Compose transformations (right to left) -(|.|) :: (Num r, Arity (1 + d)) => Transformation d r -> Transformation d r -> Transformation d r +(|.|) :: (Num r, Arity (d + 1)) => Transformation d r -> Transformation d r -> Transformation d r (Transformation f) |.| (Transformation g) = Transformation $ f `multM` g -------------------------------------------------------------------------------- @@ -67,55 +67,55 @@ transformAllBy t = fmap (transformBy t) -type AlwaysTruePFT d = AlwaysTrueDestruct d (1 + d) - - -transformPointFunctor :: ( PointFunctor g, Num r, d ~ Dimension (g r) - , AlwaysTruePFT d +transformPointFunctor :: ( PointFunctor g, Fractional r, d ~ Dimension (g r) + , Arity d, Arity (d + 1) ) => Transformation d r -> g r -> g r transformPointFunctor t = pmap (transformBy t) -instance ( Num r - , Arity d, AlwaysTrueDestruct d (1 + d) - ) => IsTransformable (Point d r) where - transformBy (Transformation m) (Point v) = Point . V.init $ m `mult` v' +instance (Fractional r, Arity d, Arity (d + 1)) + => IsTransformable (Point d r) where + transformBy t = Point . transformBy t . toVec + +instance (Fractional r, Arity d, Arity (d + 1)) + => IsTransformable (Vector d r) where + transformBy (Transformation m) v = f $ m `mult` snoc v 1 where - v' = snoc v 1 + f u = (/ V.last u) <$> V.init u -------------------------------------------------------------------------------- -- * Common transformations -translation :: ( Num r, Arity (1 + d) - , AlwaysTrueSnoc d, Arity d, Index' (1+d-1) (1+d)) +translation :: (Num r, Arity d, Arity (d + 1)) => Vector d r -> Transformation d r translation v = Transformation . Matrix $ V.imap transRow (snoc v 1) -scaling :: (Num r, Arity (1 + d), AlwaysTrueSnoc d, Arity d) => Vector d r -> Transformation d r +scaling :: (Num r, Arity d, Arity (d + 1)) + => Vector d r -> Transformation d r scaling v = Transformation . Matrix $ V.imap mkRow (snoc v 1) -uniformScaling :: (Num r, Arity (1 + d), AlwaysTrueSnoc d, Arity d) => r -> Transformation d r +uniformScaling :: (Num r, Arity d, Arity (d + 1)) => r -> Transformation d r uniformScaling = scaling . pure -------------------------------------------------------------------------------- -- * Functions that execute transformations -type AlwaysTrueTransformation d = (Arity (1 + d), AlwaysTrueSnoc d, Arity d, Index' (1+d-1) (1+d)) +-- type AlwaysTrueTransformation d = (Arity (1 + d), AlwaysTrueSnoc d, Arity d, Index' (1+d-1) (1+d)) translateBy :: ( IsTransformable g, Num (NumType g) - , AlwaysTrueTransformation (Dimension g) + , Arity (Dimension g), Arity (Dimension g + 1) ) => Vector (Dimension g) (NumType g) -> g -> g translateBy = transformBy . translation scaleBy :: ( IsTransformable g, Num (NumType g) - , AlwaysTrueTransformation (Dimension g) + , Arity (Dimension g), Arity (Dimension g + 1) ) => Vector (Dimension g) (NumType g) -> g -> g scaleBy = transformBy . scaling scaleUniformlyBy :: ( IsTransformable g, Num (NumType g) - , AlwaysTrueTransformation (Dimension g) + , Arity (Dimension g), Arity (Dimension g + 1) ) => NumType g -> g -> g scaleUniformlyBy = transformBy . uniformScaling @@ -129,5 +129,10 @@ mkRow i x = set (FV.element i) x zero -- | Row in a translation matrix -transRow :: forall n r. (Arity n, Index' (n-1) n, Num r) => Int -> r -> Vector n r -transRow i x = set (V.element (Proxy :: Proxy (n-1))) x $ mkRow i 1 +-- transRow :: forall n r. ( Arity n, Arity (n- 1), ((n - 1) + 1) ~ n +-- , Num r) => Int -> r -> Vector n r +-- transRow i x = set (V.element (Proxy :: Proxy (n-1))) x $ mkRow i 1 + +transRow :: forall n r. (Arity n, Arity (n + 1), Num r) + => Int -> r -> Vector (n + 1) r +transRow i x = set (V.element (Proxy :: Proxy n)) x $ mkRow i 1 diff --git a/src/Data/Geometry/Triangle.hs b/src/Data/Geometry/Triangle.hs --- a/src/Data/Geometry/Triangle.hs +++ b/src/Data/Geometry/Triangle.hs @@ -1,39 +1,43 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UndecidableInstances #-} module Data.Geometry.Triangle where import Data.Bifunctor import Control.Lens import Data.Ext import Data.Geometry.Point +import Data.Geometry.Vector import Data.Geometry.Ball import Data.Geometry.Properties import Data.Geometry.Transformation +import GHC.TypeLits -data Triangle p r = Triangle (Point 2 r :+ p) - (Point 2 r :+ p) - (Point 2 r :+ p) - deriving (Show,Eq) +data Triangle d p r = Triangle (Point d r :+ p) + (Point d r :+ p) + (Point d r :+ p) -instance Functor (Triangle p) where +deriving instance (Arity d, Show r, Show p) => Show (Triangle d p r) + +instance Arity d => Functor (Triangle d p) where fmap f (Triangle p q r) = let f' = first (fmap f) in Triangle (f' p) (f' q) (f' r) -type instance NumType (Triangle p r) = r -type instance Dimension (Triangle p r) = 2 +type instance NumType (Triangle d p r) = r +type instance Dimension (Triangle d p r) = d -instance PointFunctor (Triangle p) where +instance PointFunctor (Triangle d p) where pmap f (Triangle p q r) = Triangle (p&core %~ f) (q&core %~ f) (r&core %~ f) -instance Num r => IsTransformable (Triangle d r) where +instance (Fractional r, Arity d, Arity (d + 1)) => IsTransformable (Triangle d p r) where transformBy = transformPointFunctor -- | Compute the area of a triangle -area :: Fractional r => Triangle p r -> r +area :: Fractional r => Triangle 2 p r -> r area t = doubleArea t / 2 -- | 2*the area of a triangle. -doubleArea :: Num r => Triangle p r -> r +doubleArea :: Num r => Triangle 2 p r -> r doubleArea (Triangle a b c) = abs $ ax*by - ax*cy + bx*cy - bx*ay + cx*ay - cx*by @@ -46,5 +50,6 @@ -- | get the inscribed disk. Returns Nothing if the triangle is degenerate, -- i.e. if the points are colinear. -inscribedDisk :: (Eq r, Fractional r) => Triangle p r -> Maybe (Disk () r) +inscribedDisk :: (Eq r, Fractional r) + => Triangle 2 p r -> Maybe (Disk () r) inscribedDisk (Triangle p q r) = disk (p^.core) (q^.core) (r^.core) diff --git a/src/Data/Geometry/Vector.hs b/src/Data/Geometry/Vector.hs --- a/src/Data/Geometry/Vector.hs +++ b/src/Data/Geometry/Vector.hs @@ -1,46 +1,55 @@ -module Data.Geometry.Vector( module Data.Geometry.Vector.VectorFixed +module Data.Geometry.Vector( module Data.Geometry.Vector.VectorFamily , module LV + , C(..) , Affine(..) , qdA, distanceA - , dot, norm + , dot, norm, signorm , isScalarMultipleOf , scalarMultiple + -- reexports + , FV.replicate + , FV.imap, ) where +import Control.Applicative (liftA2) import qualified Data.Foldable as F -import Data.Geometry.Vector.VectorFixed -import Data.Geometry.Vector.VectorFixed as GV +import Data.Geometry.Properties +import Data.Geometry.Vector.VectorFamily +import Data.Geometry.Vector.VectorFixed(C(..)) import Data.Maybe +import Data.Semigroup import qualified Data.Vector.Fixed as FV import Linear.Affine (Affine(..), qdA, distanceA) -import Linear.Metric (dot,norm) +import Linear.Metric (dot,norm,signorm) import Linear.Vector as LV -------------------------------------------------------------------------------- +type instance Dimension (Vector d r) = d +type instance NumType (Vector d r) =r -- | Test if v is a scalar multiple of u. -- --- >>> v2 1 1 `isScalarMultipleOf` v2 10 10 +-- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 10 10 -- True --- >>> v2 1 1 `isScalarMultipleOf` v2 10 1 +-- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 10 1 -- False --- >>> v2 1 1 `isScalarMultipleOf` v2 11.1 11.1 +-- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 11.1 11.1 -- True --- >>> v2 1 1 `isScalarMultipleOf` v2 11.1 11.2 +-- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 11.1 11.2 -- False --- >>> v2 2 1 `isScalarMultipleOf` v2 11.1 11.2 +-- >>> Vector2 2 1 `isScalarMultipleOf` Vector2 11.1 11.2 -- False --- >>> v2 2 1 `isScalarMultipleOf` v2 4 2 +-- >>> Vector2 2 1 `isScalarMultipleOf` Vector2 4 2 -- True --- >>> v2 2 1 `isScalarMultipleOf` v2 4 0 +-- >>> Vector2 2 1 `isScalarMultipleOf` Vector2 4 0 -- False -isScalarMultipleOf :: (Eq r, Fractional r, GV.Arity d) +isScalarMultipleOf :: (Eq r, Fractional r, Arity d) => Vector d r -> Vector d r -> Bool u `isScalarMultipleOf` v = isJust $ scalarMultiple u v -- | Get the scalar labmda s.t. v = lambda * u (if it exists) -scalarMultiple :: (Eq r, Fractional r, GV.Arity d) +scalarMultiple :: (Eq r, Fractional r, Arity d) => Vector d r -> Vector d r -> Maybe r scalarMultiple u v | allZero u || allZero v = Just 0 @@ -60,27 +69,30 @@ -- allLambda (_, myLambda) (b,Just lambda) = (myLambda == lambda && b, Just lambda) -allZero :: (GV.Arity d, Eq r, Num r) => Vector d r -> Bool +allZero :: (Arity d, Eq r, Num r) => Vector d r -> Bool allZero = F.all (== 0) data ScalarMultiple r = No | Maybe | Yes r deriving (Eq,Show) -instance Eq r => Monoid (ScalarMultiple r) where - mempty = Maybe - - No `mappend` _ = No - _ `mappend` No = No - Maybe `mappend` x = x - x `mappend` Maybe = x - (Yes x) `mappend` (Yes y) +instance Eq r => Semigroup (ScalarMultiple r) where + No <> _ = No + _ <> No = No + Maybe <> x = x + x <> Maybe = x + (Yes x) <> (Yes y) | x == y = Yes x | otherwise = No -scalarMultiple' :: (Eq r, Fractional r, GV.Arity d) +instance Eq r => Monoid (ScalarMultiple r) where + mempty = Maybe + mappend = (<>) + +-- | Actual implementation of scalarMultiple +scalarMultiple' :: (Eq r, Fractional r, Arity d) => Vector d r -> Vector d r -> Maybe r -scalarMultiple' u v = g . F.foldr mappend mempty $ FV.zipWith f u v +scalarMultiple' u v = g . F.foldr mappend mempty $ liftA2 f u v where f 0 0 = Maybe -- we don't know lambda yet, but it may still be a scalar mult. f _ 0 = No -- Not a scalar multiple diff --git a/src/Data/Geometry/Vector/VectorFamily.hs b/src/Data/Geometry/Vector/VectorFamily.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Vector/VectorFamily.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Geometry.Vector.VectorFamily where + +import Control.DeepSeq +import Control.Lens hiding (element) +import Data.Aeson +-- import Data.Aeson (ToJSON(..),FromJSON(..)) +import qualified Data.Foldable as F +import qualified Data.List as L +import Data.Geometry.Vector.VectorFixed (C(..)) +import qualified Data.Geometry.Vector.VectorFamilyPeano as Fam +import Data.Geometry.Vector.VectorFamilyPeano ( VectorFamily(..) + , VectorFamilyF + , ImplicitArity + ) +import Data.Semigroup +import qualified Data.Vector.Fixed as V +import Data.Vector.Fixed.Cont (Peano) +import GHC.TypeLits +import Linear.Affine (Affine(..)) +import Linear.Metric +import qualified Linear.V2 as L2 +import qualified Linear.V3 as L3 +import qualified Linear.V4 as L4 +import Linear.Vector + + +-------------------------------------------------------------------------------- +-- * d dimensional Vectors + + +-- | Datatype representing d dimensional vectors. The default implementation is +-- based n VectorFixed. However, for small vectors we automatically select a +-- more efficient representation. +newtype Vector (d :: Nat) (r :: *) = MKVector { _unV :: VectorFamily (Peano d) r } + +type instance V.Dim (Vector d) = Fam.FromPeano (Peano d) +-- the above definition is a bit convoluted, but it allows us to make Vector an instance of +-- V.Vector having only an Arity constraint rather than an Arity2 constraint. +type instance Index (Vector d r) = Int +type instance IxValue (Vector d r) = r + +unV :: Lens (Vector d r) (Vector d s) (VectorFamily (Peano d) r) (VectorFamily (Peano d) s) +unV = lens _unV (const MKVector) +{-# INLINE unV #-} + +type Arity d = (ImplicitArity (Peano d), KnownNat d) + +deriving instance (Eq r, Arity d) => Eq (Vector d r) +deriving instance (Ord r, Arity d) => Ord (Vector d r) + +deriving instance Arity d => Functor (Vector d) +deriving instance Arity d => Foldable (Vector d) +deriving instance Arity d => Traversable (Vector d) +deriving instance Arity d => Applicative (Vector d) + +deriving instance Arity d => Additive (Vector d) +deriving instance Arity d => Metric (Vector d) +deriving instance Arity d => Affine (Vector d) + +instance Arity d => Ixed (Vector d r) where + ix = element' + +instance Arity d => V.Vector (Vector d) r where + construct = MKVector <$> V.construct + inspect = V.inspect . _unV + basicIndex = V.basicIndex . _unV + +instance (Arity d, Show r) => Show (Vector d r) where + show v = mconcat [ "Vector", show $ F.length v , " " + , show $ F.toList v ] + +deriving instance (FromJSON r, Arity d) => FromJSON (Vector d r) +instance (ToJSON r, Arity d) => ToJSON (Vector d r) where + toJSON = toJSON . _unV + toEncoding = toEncoding . _unV + +deriving instance (NFData r, Arity d) => NFData (Vector d r) + +-------------------------------------------------------------------------------- +-- * Convenience "constructors" + +pattern Vector :: VectorFamilyF (Peano d) r -> Vector d r +pattern Vector v = MKVector (VectorFamily v) + +pattern Vector1 :: r -> Vector 1 r +pattern Vector1 x = (Vector (Identity x)) + +pattern Vector2 :: r -> r -> Vector 2 r +pattern Vector2 x y = (Vector (L2.V2 x y)) + +pattern Vector3 :: r -> r -> r -> Vector 3 r +pattern Vector3 x y z = (Vector (L3.V3 x y z)) + +pattern Vector4 :: r -> r -> r -> r -> Vector 4 r +pattern Vector4 x y z w = (Vector (L4.V4 x y z w)) + +-------------------------------------------------------------------------------- + +vectorFromList :: Arity d => [r] -> Maybe (Vector d r) +vectorFromList = V.fromListM + +vectorFromListUnsafe :: Arity d => [r] -> Vector d r +vectorFromListUnsafe = V.fromList + +destruct :: (Arity d, Arity (d + 1)) + => Vector (d + 1) r -> (r, Vector d r) +destruct v = (head $ F.toList v, vectorFromListUnsafe . tail $ F.toList v) + -- FIXME: this implementaion of tail is not particularly nice + +-------------------------------------------------------------------------------- +-- * Indexing vectors + +-- | Lens into the i th element +element :: forall proxy i d r. (Arity d, KnownNat i, (i + 1) <= d) + => proxy i -> Lens' (Vector d r) r +element _ = singular . element' . fromInteger $ natVal (C :: C i) +{-# INLINE element #-} + + +-- | Similar to 'element' above. Except that we don't have a static guarantee +-- that the index is in bounds. Hence, we can only return a Traversal +element' :: forall d r. Arity d => Int -> Traversal' (Vector d r) r +element' i = unV.(e (C :: C d) i) + where + e :: Arity d => proxy d -> Int -> Traversal' (VectorFamily (Peano d) r) r + e _ = Fam.element' +{-# INLINE element' #-} + +-------------------------------------------------------------------------------- +-- * Snoccing and consindg + +-- | Add an element at the back of the vector +snoc :: (Arity (d + 1), Arity d) => Vector d r -> r -> Vector (d + 1) r +snoc v x = vectorFromListUnsafe . (++ [x]) $ F.toList v + -- FIXME: horrible implementation here as well + +-- | Get a vector of the first d - 1 elements. +init :: (Arity d, Arity (d + 1)) => Vector (d + 1) r -> Vector d r +init = vectorFromListUnsafe . L.init . F.toList + +last :: forall d r. (KnownNat d, Arity (d + 1)) => Vector (d + 1) r -> r +last = view $ element (C :: C d) + +-- | Get a prefix of i elements of a vector +prefix :: forall i d r. (Arity d, Arity i, i <= d) + => Vector d r -> Vector i r +prefix = let i = fromInteger . natVal $ (C :: C i) + in vectorFromListUnsafe . take i . F.toList + +-------------------------------------------------------------------------------- +-- * Specific on 3-dimensional vectors +-- | Cross product of two three-dimensional vectors +cross :: Num r => Vector 3 r -> Vector 3 r -> Vector 3 r +(Vector u) `cross` (Vector v) = Vector $ u `L3.cross` v diff --git a/src/Data/Geometry/Vector/VectorFamilyPeano.hs b/src/Data/Geometry/Vector/VectorFamilyPeano.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Vector/VectorFamilyPeano.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Geometry.Vector.VectorFamilyPeano where + +import Control.Applicative (liftA2) +import Control.DeepSeq +import Control.Lens hiding (element) +import Data.Aeson(FromJSON(..),ToJSON(..)) +-- import Data.Aeson (ToJSON(..),FromJSON(..)) +import qualified Data.Foldable as F +import qualified Data.Geometry.Vector.VectorFixed as FV +import Data.Maybe (fromMaybe) +import Data.Proxy +import Data.Semigroup +import Data.Traversable (foldMapDefault,fmapDefault) +import qualified Data.Vector.Fixed as V +import qualified Data.Vector.Fixed.Cont as Cont +import Data.Vector.Fixed.Cont (Peano(..), PeanoNum(..), Fun(..)) +import GHC.TypeLits +import Linear.Affine (Affine(..)) +import Linear.Metric +import qualified Linear.V2 as L2 +import qualified Linear.V3 as L3 +import qualified Linear.V4 as L4 +import Linear.Vector + +-------------------------------------------------------------------------------- +-- * Natural number stuff + +type One = S Z +type Two = S One +type Three = S Two +type Four = S Three +type Many d = S (S (S (S (S d)))) + + +type family FromPeano (d :: PeanoNum) :: Nat where + FromPeano Z = 0 + FromPeano (S d) = 1 + FromPeano d + + +data SingPeano (d :: PeanoNum) where + SZ :: SingPeano Z + SS :: !(SingPeano d) -> SingPeano (S d) + +class ImplicitPeano (d :: PeanoNum) where + implicitPeano :: SingPeano d +instance ImplicitPeano Z where + implicitPeano = SZ +instance ImplicitPeano d => ImplicitPeano (S d) where + implicitPeano = SS implicitPeano + +-------------------------------------------------------------------------------- +-- * d dimensional Vectors + +-- | Datatype representing d dimensional vectors. The default implementation is +-- based n VectorFixed. However, for small vectors we automatically select a +-- more efficient representation. +newtype VectorFamily (d :: PeanoNum) (r :: *) = + VectorFamily { _unVF :: VectorFamilyF d r } + +-- | Mapping between the implementation type, and the actual implementation. +type family VectorFamilyF (d :: PeanoNum) :: * -> * where + VectorFamilyF Z = Const () + VectorFamilyF One = Identity + VectorFamilyF Two = L2.V2 + VectorFamilyF Three = L3.V3 + VectorFamilyF Four = L4.V4 + VectorFamilyF (Many d) = FV.Vector (FromPeano (Many d)) + +type instance V.Dim (VectorFamily d) = FromPeano d +type instance Index (VectorFamily d r) = Int +type instance IxValue (VectorFamily d r) = r + +type instance V.Dim L2.V2 = 2 +type instance V.Dim L3.V3 = 3 +type instance V.Dim L4.V4 = 4 + +unVF :: Lens (VectorFamily d r) (VectorFamily d t) + (VectorFamilyF d r) (VectorFamilyF d t) +unVF = lens _unVF (const VectorFamily) +{-# INLINE unVF #-} + +type ImplicitArity d = (ImplicitPeano d, V.Arity (FromPeano d)) + +instance (Eq r, ImplicitArity d) => Eq (VectorFamily d r) where + (VectorFamily u) == (VectorFamily v) = case (implicitPeano :: SingPeano d) of + SZ -> u == v + (SS SZ) -> u == v + (SS (SS SZ)) -> u == v + (SS (SS (SS SZ))) -> u == v + (SS (SS (SS (SS SZ)))) -> u == v + (SS (SS (SS (SS (SS _))))) -> u == v + {-# INLINE (==) #-} + +instance (Ord r, ImplicitArity d) => Ord (VectorFamily d r) where + (VectorFamily u) `compare` (VectorFamily v) = case (implicitPeano :: SingPeano d) of + SZ -> u `compare` v + (SS SZ) -> u `compare` v + (SS (SS SZ)) -> u `compare` v + (SS (SS (SS SZ))) -> u `compare` v + (SS (SS (SS (SS SZ)))) -> u `compare` v + (SS (SS (SS (SS (SS _))))) -> u `compare` v + {-# INLINE compare #-} + + +instance ImplicitArity d => Functor (VectorFamily d) where + fmap f = VectorFamily . g f . _unVF + where g = case (implicitPeano :: SingPeano d) of + SZ -> fmap + (SS SZ) -> fmap + (SS (SS SZ)) -> fmap + (SS (SS (SS SZ))) -> fmap + (SS (SS (SS (SS SZ)))) -> fmap + (SS (SS (SS (SS (SS _))))) -> fmap + {-# INLINE fmap #-} + + +instance ImplicitArity d => Foldable (VectorFamily d) where + foldMap f = g f . _unVF + where g = case (implicitPeano :: SingPeano d) of + SZ -> foldMap + (SS SZ) -> foldMap + (SS (SS SZ)) -> foldMap + (SS (SS (SS SZ))) -> foldMap + (SS (SS (SS (SS SZ)))) -> foldMap + (SS (SS (SS (SS (SS _))))) -> foldMap + {-# INLINE foldMap #-} + +instance ImplicitArity d => Traversable (VectorFamily d) where + traverse f = fmap VectorFamily . g f . _unVF + where g = case (implicitPeano :: SingPeano d) of + SZ -> traverse + (SS SZ) -> traverse + (SS (SS SZ)) -> traverse + (SS (SS (SS SZ))) -> traverse + (SS (SS (SS (SS SZ)))) -> traverse + (SS (SS (SS (SS (SS _))))) -> traverse + {-# INLINE traverse #-} + +instance ImplicitArity d => Applicative (VectorFamily d) where + pure = VectorFamily . case (implicitPeano :: SingPeano d) of + SZ -> pure + (SS SZ) -> pure + (SS (SS SZ)) -> pure + (SS (SS (SS SZ))) -> pure + (SS (SS (SS (SS SZ)))) -> pure + (SS (SS (SS (SS (SS _))))) -> pure + {-# INLINE pure #-} + liftA2 f (VectorFamily u) (VectorFamily v) = VectorFamily $ + case (implicitPeano :: SingPeano d) of + SZ -> liftA2 f u v + (SS SZ) -> liftA2 f u v + (SS (SS SZ)) -> liftA2 f u v + (SS (SS (SS SZ))) -> liftA2 f u v + (SS (SS (SS (SS SZ)))) -> liftA2 f u v + (SS (SS (SS (SS (SS _))))) -> liftA2 f u v + {-# INLINE liftA2 #-} + + +instance ImplicitArity d => V.Vector (VectorFamily d) r where + construct = fmap VectorFamily $ case (implicitPeano :: SingPeano d) of + SZ -> Fun $ Const () + (SS SZ) -> V.construct + (SS (SS SZ)) -> Fun L2.V2 + (SS (SS (SS SZ))) -> Fun L3.V3 + (SS (SS (SS (SS SZ)))) -> Fun L4.V4 + (SS (SS (SS (SS (SS _))))) -> V.construct + {-# INLINE construct #-} + inspect (VectorFamily v) ff@(Fun f) = case (implicitPeano :: SingPeano d) of + SZ -> f + (SS SZ) -> V.inspect v ff + (SS (SS SZ)) -> let (L2.V2 x y) = v in f x y + (SS (SS (SS SZ))) -> let (L3.V3 x y z) = v in f x y z + (SS (SS (SS (SS SZ)))) -> let (L4.V4 x y z w) = v in f x y z w + (SS (SS (SS (SS (SS _))))) -> V.inspect v ff + {-# INLINE inspect #-} + basicIndex v i = v^.singular (element' i) + {-# INLINE basicIndex #-} + +instance (ImplicitArity d, Show r) => Show (VectorFamily d r) where + show v = mconcat [ "Vector", show $ F.length v , " " + , show $ F.toList v ] + +instance (NFData r, ImplicitArity d) => NFData (VectorFamily d r) where + rnf (VectorFamily v) = case (implicitPeano :: SingPeano d) of + SZ -> rnf v + (SS SZ) -> rnf v + (SS (SS SZ)) -> rnf v + (SS (SS (SS SZ))) -> rnf v + (SS (SS (SS (SS SZ)))) -> rnf v + (SS (SS (SS (SS (SS _))))) -> rnf v + {-# INLINE rnf #-} + +instance ImplicitArity d => Ixed (VectorFamily d r) where + ix = element' + +element' :: forall d r. ImplicitArity d => Int -> Traversal' (VectorFamily d r) r +element' = case (implicitPeano :: SingPeano d) of + SZ -> elem0 + (SS SZ) -> elem1 + (SS (SS SZ)) -> elem2 + (SS (SS (SS SZ))) -> elem3 + (SS (SS (SS (SS SZ)))) -> elem4 + (SS (SS (SS (SS (SS _))))) -> elemD +{-# INLINE element' #-} + +elem0 :: Int -> Traversal' (VectorFamily Z r) r +elem0 _ = \_ v -> pure v +{-# INLINE elem0 #-} +-- zero length vectors don't store any elements + +elem1 :: Int -> Traversal' (VectorFamily One r) r +elem1 = \case + 0 -> unVF.(lens runIdentity (\_ -> Identity)) + _ -> \_ v -> pure v +{-# INLINE elem1 #-} + +elem2 :: Int -> Traversal' (VectorFamily Two r) r +elem2 = \case + 0 -> unVF.L2._x + 1 -> unVF.L2._y + _ -> \_ v -> pure v +{-# INLINE elem2 #-} + +elem3 :: Int -> Traversal' (VectorFamily Three r) r +elem3 = \case + 0 -> unVF.L3._x + 1 -> unVF.L3._y + 2 -> unVF.L3._z + _ -> \_ v -> pure v +{-# INLINE elem3 #-} + +elem4 :: Int -> Traversal' (VectorFamily Four r) r +elem4 = \case + 0 -> unVF.L4._x + 1 -> unVF.L4._y + 2 -> unVF.L4._z + 3 -> unVF.L4._w + _ -> \_ v -> pure v +{-# INLINE elem4 #-} + +elemD :: V.Arity (FromPeano (Many d)) => Int -> Traversal' (VectorFamily (Many d) r) r +elemD i = unVF.FV.element' i +{-# INLINE elemD #-} + + +instance ImplicitArity d => Metric (VectorFamily d) + +instance ImplicitArity d => Additive (VectorFamily d) where + zero = pure 0 + u ^+^ v = liftA2 (+) u v + +instance ImplicitArity d => Affine (VectorFamily d) where + type Diff (VectorFamily d) = VectorFamily d + + u .-. v = u ^-^ v + p .+^ v = p ^+^ v + +instance (FromJSON r, ImplicitArity d) => FromJSON (VectorFamily d r) where + parseJSON y = parseJSON y >>= \xs -> case vectorFromList xs of + Nothing -> fail . mconcat $ + [ "FromJSON (Vector d a), wrong number of elements. Expected " + , show $ natVal (Proxy :: Proxy (FromPeano d)) + , " elements but found " + , show $ length xs + , "." + ] + Just v -> pure v + +instance (ToJSON r, ImplicitArity d) => ToJSON (VectorFamily d r) where + toJSON = toJSON . F.toList + toEncoding = toEncoding . F.toList + +-------------------------------------------------------------------------------- + +vectorFromList :: ImplicitArity d => [r] -> Maybe (VectorFamily d r) +vectorFromList = V.fromListM + +vectorFromListUnsafe :: ImplicitArity d => [r] -> VectorFamily d r +vectorFromListUnsafe = V.fromList + +-- | Get the head and tail of a vector +destruct :: (ImplicitArity d, ImplicitArity (S d)) + => VectorFamily (S d) r -> (r, VectorFamily d r) +destruct v = (head $ F.toList v, vectorFromListUnsafe . tail $ F.toList v) + -- FIXME: this implementaion of tail is not particularly nice + +snoc :: (ImplicitArity d, ImplicitArity (S d), (1 + FromPeano d) ~ (FromPeano d + 1)) + => VectorFamily d r -> r -> VectorFamily (S d) r +snoc = flip V.snoc diff --git a/src/Data/Geometry/Vector/VectorFixed.hs b/src/Data/Geometry/Vector/VectorFixed.hs --- a/src/Data/Geometry/Vector/VectorFixed.hs +++ b/src/Data/Geometry/Vector/VectorFixed.hs @@ -3,15 +3,19 @@ module Data.Geometry.Vector.VectorFixed where import Control.DeepSeq -import Control.Lens +import Control.Lens hiding (element) +import Data.Aeson import qualified Data.Foldable as F +import Data.Proxy import qualified Data.Vector.Fixed as V +import Data.Vector.Fixed (Arity) import Data.Vector.Fixed.Boxed -import Data.Vector.Fixed.Cont (Z, S, ToPeano) +import Data.Vector.Fixed.Cont (Peano, PeanoNum(..)) import GHC.Generics (Generic) import GHC.TypeLits import Linear.Affine (Affine(..)) import Linear.Metric +import qualified Linear.V2 as L2 import qualified Linear.V3 as L3 import Linear.Vector @@ -25,25 +29,22 @@ -- | Datatype representing d dimensional vectors. Our implementation wraps the -- implementation provided by fixed-vector. -newtype Vector (d :: Nat) (r :: *) = Vector { _unV :: Vec (ToPeano d) r } +newtype Vector (d :: Nat) (r :: *) = Vector { _unV :: Vec d r } deriving (Generic) -unV :: Lens' (Vector d r) (Vec (ToPeano d) r) +unV :: Lens' (Vector d r) (Vec d r) unV = lens _unV (const Vector) ---------------------------------------- -type Arity (n :: Nat) = V.Arity (ToPeano n) -type Index' i d = V.Index (ToPeano i) (ToPeano d) - - -- | Lens into the i th element -element :: forall proxy i d r. (Arity d, Index' i d) => proxy i -> Lens' (Vector d r) r -element _ = V.elementTy (undefined :: (ToPeano i)) +element :: forall proxy i d r. (Arity d, Arity i, (i + 1) <= d) + => proxy i -> Lens' (Vector d r) r +element _ = V.elementTy (Proxy :: Proxy i) -- | Similar to 'element' above. Except that we don't have a static guarantee -- that the index is in bounds. Hence, we can only return a Traversal -element' :: forall d r. (KnownNat d, Arity d) => Int -> Traversal' (Vector d r) r +element' :: forall d r. Arity d => Int -> Traversal' (Vector d r) r element' i f v | 0 <= i && i < fromInteger (natVal (C :: C d)) = f (v V.! i) <&> \a -> (v&V.element i .~ a) @@ -65,8 +66,12 @@ deriving instance (Eq r, Arity d) => Eq (Vector d r) deriving instance (Ord r, Arity d) => Ord (Vector d r) -deriving instance Arity d => Functor (Vector d) +-- deriving instance Arity d => Functor (Vector d) +-- for some weird reason, implemeting this myself yields is faster code +instance Arity d => Functor (Vector d) where + fmap f (Vector v) = Vector $ fmap f v + deriving instance Arity d => Foldable (Vector d) deriving instance Arity d => Applicative (Vector d) @@ -89,21 +94,33 @@ instance Arity d => Metric (Vector d) -type instance V.Dim (Vector d) = ToPeano d +type instance V.Dim (Vector d) = d instance Arity d => V.Vector (Vector d) r where - construct = Vector <$> V.construct - inspect v = V.inspect (_unV v) - basicIndex v = V.basicIndex (_unV v) + construct = Vector <$> V.construct + inspect = V.inspect . _unV + basicIndex = V.basicIndex . _unV --- ---------------------------------------- +instance (FromJSON r, Arity d, KnownNat d) => FromJSON (Vector d r) where + parseJSON y = parseJSON y >>= \xs -> case vectorFromList xs of + Nothing -> fail . mconcat $ + [ "FromJSON (Vector d a), wrong number of elements. Expected " + , show $ natVal (Proxy :: Proxy d) + , " elements but found " + , show $ length xs + , "." + ] + Just v -> pure v -type AlwaysTrueDestruct pd d = (Arity pd, ToPeano d ~ S (ToPeano pd)) +instance (ToJSON r, Arity d) => ToJSON (Vector d r) where + toJSON = toJSON . F.toList + toEncoding = toEncoding . F.toList +------------------------------------------ -- | Get the head and tail of a vector -destruct :: AlwaysTrueDestruct predD d - => Vector d r -> (r, Vector predD r) +destruct :: (Arity d, Arity (d + 1), 1 <= (d + 1)) + => Vector (d + 1) r -> (r, Vector d r) destruct (Vector v) = (V.head v, Vector $ V.tail v) @@ -114,6 +131,10 @@ -------------------------------------------------------------------------------- +-- | Vonversion to a Linear.V2 +toV2 :: Vector 2 a -> L2.V2 a +toV2 ~(Vector2 a b) = L2.V2 a b + -- | Conversion to a Linear.V3 toV3 :: Vector 3 a -> L3.V3 a toV3 ~(Vector3 a b c) = L3.V3 a b c @@ -124,34 +145,22 @@ ---------------------------------------------------------------------------------- - -type AlwaysTrueSnoc d = ToPeano (1 + d) ~ S (ToPeano d) - -- | Add an element at the back of the vector -snoc :: (AlwaysTrueSnoc d, Arity d) => Vector d r -> r -> Vector (1 + d) r +snoc :: (Arity (d + 1), Arity d) => Vector d r -> r -> Vector (d + 1) r snoc = flip V.snoc -- | Get a vector of the first d - 1 elements. -init :: AlwaysTrueDestruct predD d => Vector d r -> Vector predD r +init :: (Arity d, Arity (d + 1)) => Vector (d + 1) r -> Vector d r init = Vector . V.reverse . V.tail . V.reverse . _unV --- | Get a prefix of i elements of a vector -prefix :: (Prefix (ToPeano i) (ToPeano d)) => Vector d r -> Vector i r -prefix (Vector v) = Vector $ prefix' v - -class Prefix i d where - prefix' :: Vec d r -> Vec i r - -instance Prefix Z d where - prefix' _ = V.vector V.empty - -instance (V.Arity i, V.Arity d, Prefix i d) => Prefix (S i) (S d) where - prefix' v = V.vector $ V.head v `V.cons` (prefix' $ V.tail v) - +last :: forall d r. (Arity d, Arity (d + 1)) => Vector (d + 1) r -> r +last = view $ element (Proxy :: Proxy d) --- | Map with indices -imap :: Arity d => (Int -> r -> s ) -> Vector d r -> Vector d s -imap = V.imap +-- | Get a prefix of i elements of a vector +prefix :: forall i d r. (Arity d, Arity i, i <= d) + => Vector d r -> Vector i r +prefix = let i = fromInteger . natVal $ (Proxy :: Proxy i) + in V.fromList . take i . V.toList -------------------------------------------------------------------------------- -- * Functions specific to two and three dimensional vectors. @@ -164,7 +173,6 @@ v3 :: r -> r -> r -> Vector 3 r v3 a b c = Vector $ V.mk3 a b c - -- | Destruct a 2 dim vector into a pair _unV2 :: Vector 2 r -> (r,r) _unV2 v = let [x,y] = V.toList v in (x,y) @@ -172,10 +180,22 @@ _unV3 :: Vector 3 r -> (r,r,r) _unV3 v = let [x,y,z] = V.toList v in (x,y,z) - -- | Pattern synonym for two and three dim vectors pattern Vector2 :: r -> r -> Vector 2 r pattern Vector2 x y <- (_unV2 -> (x,y)) + where + Vector2 x y = v2 x y +{-# COMPLETE Vector2 #-} pattern Vector3 :: r -> r -> r -> Vector 3 r pattern Vector3 x y z <- (_unV3 -> (x,y,z)) + where + Vector3 x y z = v3 x y z +{-# COMPLETE Vector3 #-} + + +pattern Vector4 :: r -> r -> r -> r -> Vector 4 r +pattern Vector4 x y z a <- (V.toList -> [x,y,z,a]) + where + Vector4 x y z a = V.mk4 x y z a +{-# COMPLETE Vector4 #-} diff --git a/src/Data/OrdSeq.hs b/src/Data/OrdSeq.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrdSeq.hs @@ -0,0 +1,190 @@ +module Data.OrdSeq where + + +import Control.Lens (bimap) +import qualified Data.FingerTree as FT +import Data.FingerTree hiding (null, viewl, viewr) +import qualified Data.Foldable as F +import Data.Maybe +import Data.Semigroup + +-------------------------------------------------------------------------------- + +data Key a = NoKey | Key { getKey :: !a } deriving (Show,Eq,Ord) + +instance Semigroup (Key a) where + k <> NoKey = k + _ <> k = k + +instance Monoid (Key a) where + mempty = NoKey + k `mappend` k' = k <> k' + +liftCmp :: (a -> a -> Ordering) -> Key a -> Key a -> Ordering +liftCmp _ NoKey NoKey = EQ +liftCmp _ NoKey (Key _) = LT +liftCmp _ (Key _) NoKey = GT +liftCmp cmp (Key x) (Key y) = x `cmp` y + + + +newtype Elem a = Elem { getElem :: a } deriving (Eq,Ord,Traversable,Foldable,Functor) + +instance Show a => Show (Elem a) where + show (Elem x) = "Elem " <> show x + + +newtype OrdSeq a = OrdSeq { _asFingerTree :: FingerTree (Key a) (Elem a) } + deriving (Show,Eq) + +instance Semigroup (OrdSeq a) where + (OrdSeq s) <> (OrdSeq t) = OrdSeq $ s `mappend` t + +instance Monoid (OrdSeq a) where + mempty = OrdSeq mempty + mappend = (<>) + +instance Foldable OrdSeq where + foldMap f = foldMap (foldMap f) . _asFingerTree + null = null . _asFingerTree + length = length . _asFingerTree + minimum = fromJust . lookupMin + maximum = fromJust . lookupMax + +instance Measured (Key a) (Elem a) where + measure (Elem x) = Key x + + +type Compare a = a -> a -> Ordering + +-- | Insert into a monotone OrdSeq. +-- +-- pre: the comparator maintains monotonicity +-- +-- \(O(\log n)\) +insertBy :: Compare a -> a -> OrdSeq a -> OrdSeq a +insertBy cmp x (OrdSeq s) = OrdSeq $ l `mappend` (Elem x <| r) + where + (l,r) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ, GT]) s + +-- | Insert into a sorted OrdSeq +-- +-- \(O(\log n)\) +insert :: Ord a => a -> OrdSeq a -> OrdSeq a +insert = insertBy compare + +deleteAllBy :: Compare a -> a -> OrdSeq a -> OrdSeq a +deleteAllBy cmp x s = l <> r + where + (l,_,r) = splitBy cmp x s + + -- (l,m) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ,GT]) s + -- (_,r) = split (\v -> liftCmp cmp v (Key x) == GT) m + + +-- | \(O(\log n)\) +splitBy :: Compare a -> a -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a) +splitBy cmp x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r) + where + (l, m) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ,GT]) s + (m',r) = split (\v -> liftCmp cmp v (Key x) == GT) m + + +-- | Given a monotonic function f that maps a to b, split the sequence s +-- depending on the b values. I.e. the result (l,m,r) is such that +-- * all (< x) . fmap f $ l +-- * all (== x) . fmap f $ m +-- * all (> x) . fmap f $ r +-- +-- >>> splitOn id 3 $ fromAscList' [1..5] +-- (OrdSeq {_asFingerTree = fromList [Elem 1,Elem 2]},OrdSeq {_asFingerTree = fromList [Elem 3]},OrdSeq {_asFingerTree = fromList [Elem 4,Elem 5]}) +-- >>> splitOn fst 2 $ fromAscList' [(0,"-"),(1,"A"),(2,"B"),(2,"C"),(3,"D"),(4,"E")] +-- (OrdSeq {_asFingerTree = fromList [Elem (0,"-"),Elem (1,"A")]},OrdSeq {_asFingerTree = fromList [Elem (2,"B"),Elem (2,"C")]},OrdSeq {_asFingerTree = fromList [Elem (3,"D"),Elem (4,"E")]}) +-- +-- \(O(\log n)\) +splitOn :: Ord b => (a -> b) -> b -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a) +splitOn f x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r) + where + (l, m) = split (\(Key v) -> compare (f v) x `elem` [EQ,GT]) s + (m',r) = split (\(Key v) -> compare (f v) x == GT) m + +-- | Given a monotonic predicate p, splits the sequence s into two sequences +-- (as,bs) such that all (not p) as and all p bs +-- +-- \(O(\log n)\) +splitMonotonic :: (a -> Bool) -> OrdSeq a -> (OrdSeq a, OrdSeq a) +splitMonotonic p = bimap OrdSeq OrdSeq . split (p . getKey) . _asFingerTree + + +-- Deletes all elements from the OrdDeq +-- +-- \(O(n\log n)\) +deleteAll :: Ord a => a -> OrdSeq a -> OrdSeq a +deleteAll = deleteAllBy compare + + +-- | inserts all eleements in order +-- \(O(n\log n)\) +fromListBy :: Compare a -> [a] -> OrdSeq a +fromListBy cmp = foldr (insertBy cmp) mempty + +-- | inserts all eleements in order +-- \(O(n\log n)\) +fromListByOrd :: Ord a => [a] -> OrdSeq a +fromListByOrd = fromListBy compare + +-- | O(n) +fromAscList' :: [a] -> OrdSeq a +fromAscList' = OrdSeq . fromList . fmap Elem + + +-- | \(O(\log n)\) +lookupBy :: Compare a -> a -> OrdSeq a -> Maybe a +lookupBy cmp x s = let (_,m,_) = splitBy cmp x s in listToMaybe . F.toList $ m + +memberBy :: Compare a -> a -> OrdSeq a -> Bool +memberBy cmp x = isJust . lookupBy cmp x + + +-- | Fmap, assumes the order does not change +-- O(n) +mapMonotonic :: (a -> b) -> OrdSeq a -> OrdSeq b +mapMonotonic f = fromAscList' . map f . F.toList + + +-- | Gets the first element from the sequence +-- \(O(1)\) +viewl :: OrdSeq a -> ViewL OrdSeq a +viewl = f . FT.viewl . _asFingerTree + where + f EmptyL = EmptyL + f (Elem x :< s) = x :< OrdSeq s + +-- Last element +-- \(O(1)\) +viewr :: OrdSeq a -> ViewR OrdSeq a +viewr = f . FT.viewr . _asFingerTree + where + f EmptyR = EmptyR + f (s :> Elem x) = OrdSeq s :> x + + +-- \(O(1)\) +minView :: OrdSeq a -> Maybe (a, OrdSeq a) +minView s = case viewl s of + EmptyL -> Nothing + (x :< t) -> Just (x,t) + +-- \(O(1)\) +lookupMin :: OrdSeq a -> Maybe a +lookupMin = fmap fst . minView + +-- \(O(1)\) +maxView :: OrdSeq a -> Maybe (a, OrdSeq a) +maxView s = case viewr s of + EmptyR -> Nothing + (t :> x) -> Just (x,t) + +-- \(O(1)\) +lookupMax :: OrdSeq a -> Maybe a +lookupMax = fmap fst . maxView diff --git a/src/Data/Permutation.hs b/src/Data/Permutation.hs --- a/src/Data/Permutation.hs +++ b/src/Data/Permutation.hs @@ -52,6 +52,10 @@ next :: GV.Vector v a => v a -> Int -> a next v i = let n = GV.length v in v GV.! ((i+1) `mod` n) +-- | Previous item in a cyclic permutation +previous :: GV.Vector v a => v a -> Int -> a +previous v i = let n = GV.length v in v GV.! ((i-1) `mod` n) + -- | Lookup the indices of an element, i.e. in which orbit the item is, and the -- index within the orbit. -- diff --git a/src/Data/PlanarGraph.hs b/src/Data/PlanarGraph.hs --- a/src/Data/PlanarGraph.hs +++ b/src/Data/PlanarGraph.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module Data.PlanarGraph( Arc(..) , Direction(..), rev @@ -8,60 +9,68 @@ , World(..) - , Dual + , DualOf - , VertexId(..) + , VertexId(..), VertexId' , PlanarGraph - , embedding, vertexData, dartData, faceData + , embedding, vertexData, dartData, faceData, rawDartData , edgeData , planarGraph, planarGraph', fromAdjacencyLists + , toAdjacencyLists + , buildFromJSON , numVertices, numDarts, numEdges, numFaces , darts', darts, edges', edges, vertices', vertices, faces', faces , tailOf, headOf, endPoints , incidentEdges, incomingEdges, outgoingEdges, neighboursOf - - , vDataOf, eDataOf, fDataOf, endPointDataOf, endPointData + , nextIncidentEdge, prevIncidentEdge + , HasDataOf(..), endPointDataOf, endPointData , dual - , FaceId(..) - , leftFace, rightFace, boundary, boundaryVertices - + , FaceId(..), FaceId' + , leftFace, rightFace, boundary, boundary', boundaryVertices + , nextEdge, prevEdge , EdgeOracle , edgeOracle, buildEdgeOracle , findEdge - , hasEdge + , hasEdge, findDart + + , allDarts ) where + import Control.Applicative (Alternative(..)) -import Control.Lens -import Control.Monad (forM_) +import Control.Lens hiding ((.=)) import Control.Monad.ST (ST) import Control.Monad.State.Strict +import Data.Aeson import Data.Bifunctor import Data.Bitraversable import Data.Ext import qualified Data.Foldable as F -import Data.Maybe (catMaybes, isJust) +import Data.Maybe (catMaybes, isJust, fromJust, fromMaybe) import Data.Permutation import Data.Semigroup (Semigroup(..)) import Data.Traversable (fmapDefault,foldMapDefault) -import Data.Util +import Data.Type.Equality (gcastWith, (:~:)(..)) import qualified Data.Vector as V import qualified Data.Vector.Generic as GV import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Unboxed as UV import qualified Data.Vector.Unboxed.Mutable as UMV +import Unsafe.Coerce (unsafeCoerce) -import Debug.Trace +-- import Data.Yaml.Util +-- import Debug.Trace + -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- @@ -69,7 +78,7 @@ -- >>> :{ -- let dart i s = Dart (Arc i) (read s) -- (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..] --- myGraph :: PlanarGraph Test Primal_ () String () +-- myGraph :: PlanarGraph Test Primal () String () -- myGraph = planarGraph [ [ (Dart aA Negative, "a-") -- , (Dart aC Positive, "c+") -- , (Dart aB Positive, "b+") @@ -89,8 +98,8 @@ -- ] -- :} --- TODO: Add a fig. of the Graph - +-- This represents the following graph: +-- ![myGraph](docs/Data/PlanarGraph/testG.png) -------------------------------------------------------------------------------- @@ -121,13 +130,14 @@ -- | A dart represents a bi-directed edge. I.e. a dart has a direction, however -- the dart of the oposite direction is always present in the planar graph as -- well. -data Dart s = Dart { _arc :: !(Arc s) - , _direction :: !Direction +data Dart s = Dart { _arc :: {-#UNPACK #-} !(Arc s) + , _direction :: {-#UNPACK #-} !Direction } deriving (Eq,Ord) makeLenses ''Dart + instance Show (Dart s) where show (Dart a d) = "Dart (" ++ show a ++ ") " ++ show d @@ -156,24 +166,39 @@ Negative -> 2*i + 1 +-- | Enumerates all darts such that +-- allDarts !! i = d <=> i == fromEnum d +allDarts :: [Dart s] +allDarts = concatMap (\a -> [Dart a Positive, Dart a Negative]) [Arc 0..] + -- | The world in which the graph lives -data World = Primal_ | Dual_ deriving (Show,Eq) +data World = Primal | Dual deriving (Show,Eq) -type family Dual (sp :: World) where - Dual Primal_ = Dual_ - Dual Dual_ = Primal_ +type family DualOf (sp :: World) where + DualOf Primal = Dual + DualOf Dual = Primal +dualDualIdentity :: forall w. DualOf (DualOf w) :~: w +dualDualIdentity = unsafeCoerce Refl + -- manual proof: + -- DualOf (DualOf Primal) = Primal + -- DualOf (DualOf Dual) = Dual + -- | A vertex in a planar graph. A vertex is tied to a particular planar graph -- by the phantom type s, and to a particular world w. -newtype VertexId s (w :: World) = VertexId { _unVertexId :: Int } deriving (Eq,Ord,Enum) +newtype VertexId s (w :: World) = VertexId { _unVertexId :: Int } + deriving (Eq,Ord,Enum,ToJSON,FromJSON) -- VertexId's are in the range 0...|orbits|-1 -makeLenses ''VertexId +type VertexId' s = VertexId s Primal + +unVertexId :: Getter (VertexId s w) Int +unVertexId = to _unVertexId + instance Show (VertexId s w) where show (VertexId i) = "VertexId " ++ show i - -------------------------------------------------------------------------------- -- * The graph type itself @@ -184,27 +209,144 @@ -- The types v, e, and f are the are the types of the data associated with the -- vertices, edges, and faces, respectively. -- --- The orbits in the embedding are assumed to be in counterclockwise order. -data PlanarGraph s (w :: World) v e f = PlanarGraph { _embedding :: Permutation (Dart s) - , _vertexData :: V.Vector v +-- The orbits in the embedding are assumed to be in counterclockwise +-- order. Therefore, every dart directly bounds the face to its right. +data PlanarGraph s (w :: World) v e f = PlanarGraph { _embedding :: Permutation (Dart s) + , _vertexData :: V.Vector v , _rawDartData :: V.Vector e , _faceData :: V.Vector f + , _dual :: PlanarGraph s (DualOf w) f e v } - deriving (Show,Eq) -makeLenses ''PlanarGraph +instance (Show v, Show e, Show f) => Show (PlanarGraph s w v e f) where + show (PlanarGraph e v r f _) = unwords [ "PlanarGraph" + , "embedding =", show e + , ", vertexData =", show v + , ", rawDartData =", show r + , ", faceData =", show f + ] +instance (Eq v, Eq e, Eq f) => Eq (PlanarGraph s w v e f) where + (PlanarGraph e v r f _) == (PlanarGraph e' v' r' f' _) = e == e' && v == v' + && r == r' && f == f' + + +instance (ToJSON v, ToJSON e, ToJSON f) + => ToJSON (PlanarGraph s w v e f) where + toJSON = object . encodeJSON + toEncoding = pairs . mconcat . encodeJSON + +encodeJSON :: (ToJSON f, ToJSON e, ToJSON v, KeyValue t) + => PlanarGraph s w v e f -> [t] +encodeJSON g = [ "vertices" .= ((\(v,d) -> v :+ d) <$> vertices g) + , "darts" .= ((\(e,d) -> endPoints e g :+ d) <$> darts g) + , "faces" .= ((\(f,d) -> f :+ d) <$> faces g) + , "adjacencies" .= toAdjacencyLists g + ] + + +instance (FromJSON v, FromJSON e, FromJSON f) + => FromJSON (PlanarGraph s Primal v e f) where + parseJSON = withObject "" $ \v -> buildFromJSON <$> v .: "vertices" + <*> v .: "darts" + <*> v .: "faces" + <*> v .: "adjacencies" + + +-- | Helper function to build the graph from JSON data +-- +-- running time: \(O(n)\) +buildFromJSON :: V.Vector (VertexId' s :+ v) + -> V.Vector ((VertexId' s, VertexId' s) :+ e) + -> V.Vector (FaceId' s :+ f) + -> [(VertexId' s, V.Vector (VertexId' s))] + -> PlanarGraph s Primal v e f +buildFromJSON vs es fs as = g&vertexData .~ reorder vs _unVertexId + &dartData .~ ds + &faceData .~ reorder fs (_unVertexId._unFaceId) + where + g = fromAdjacencyLists as + oracle = edgeOracle g + findEdge' (u,v) = fromJust $ findDart u v oracle + + ds = es&traverse %~ \(e:+x) -> (findEdge' e,x) + -- for the face data we don't really know enough to reconstruct them I think + -- i.e. we may not have the guarnatee that the faceId's are the same in the + -- old graph and the new one + + -- make sure we order the data values appropriately + reorder v f = V.create $ do + v' <- MV.new (V.length v) + forM_ v $ \(i :+ x) -> + MV.write v' (f i) x + pure v' + + + + + + +-- ** lenses and getters + +embedding :: Getter (PlanarGraph s w v e f) (Permutation (Dart s)) +embedding = to _embedding + +vertexData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v' e f) + (V.Vector v) (V.Vector v') +vertexData = lens _vertexData (\g vD -> updateData (const vD) id id g) + +rawDartData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v e' f) + (V.Vector e) (V.Vector e') +rawDartData = lens _rawDartData (\g dD -> updateData id (const dD) id g) + +faceData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v e f') + (V.Vector f) (V.Vector f') +faceData = lens _faceData (\g fD -> updateData id id (const fD) g) + +dual :: Getter (PlanarGraph s w v e f) (PlanarGraph s (DualOf w) f e v) +dual = to _dual + + -- | lens to access the Dart Data dartData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v e' f) - (V.Vector (Dart s, e)) (V.Vector (Dart s, e')) -dartData = lens darts (\g xs -> g&rawDartData .~ reorderEdgeData xs) + (V.Vector (Dart s, e)) (V.Vector (Dart s, e')) +dartData = lens darts (\g dD -> updateData id (const $ reorderEdgeData dD) id g) -- | edgeData is just an alias for 'dartData' edgeData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v e' f) (V.Vector (Dart s, e)) (V.Vector (Dart s, e')) edgeData = dartData +-- | Helper function to update the data in a planar graph. Takes care to update +-- both the data in the original graph as well as in the dual. +updateData :: forall s w v e f v' e' f' + . (V.Vector v -> V.Vector v') + -> (V.Vector e -> V.Vector e') + -> (V.Vector f -> V.Vector f') + -> PlanarGraph s w v e f + -> PlanarGraph s w v' e' f' +updateData = gcastWith proof updateData' + where + proof :: DualOf (DualOf w) :~: w + proof = dualDualIdentity +-- | The function that does the actual work for 'updateData' +updateData' :: (DualOf (DualOf w) ~ w) + => (V.Vector v -> V.Vector v') + -> (V.Vector e -> V.Vector e') + -> (V.Vector f -> V.Vector f') + -> PlanarGraph s w v e f + -> PlanarGraph s w v' e' f' +updateData' fv fe ff (PlanarGraph em vtxData dData fData dg) = g' + where + vtxData' = fv vtxData + dData' = fe dData + fData' = ff fData + + g' = PlanarGraph em vtxData' dData' fData' dg' + dg' = PlanarGraph (dg^.embedding) fData' dData' vtxData' g' + + -- | Reorders the edge data to be in the right order to set edgeData reorderEdgeData :: Foldable f => f (Dart s, e) -> V.Vector e reorderEdgeData ds = V.create $ do @@ -213,27 +355,31 @@ MV.write v (fromEnum d) x pure v +-------------------------------------------------------------------------------- +-- ** Constructing a Planar graph -- | Construct a planar graph +-- +-- running time: \(O(n)\). planarGraph' :: Permutation (Dart s) -> PlanarGraph s w () () () -planarGraph' perm = PlanarGraph perm vData eData fData +planarGraph' perm = pg where - d = size perm - e = d `div` 2 - v = V.length (perm^.orbits) - f = e - v + 2 + pg = PlanarGraph perm vData eData fData (computeDual pg) + -- note the lazy calculation of computeDual that refers to pg itself + d = size perm + e = d `div` 2 + v = V.length (perm^.orbits) + f = e - v + 2 vData = V.replicate v () eData = V.replicate d () fData = V.replicate f () - - -- | Construct a planar graph, given the darts in cyclic order around each -- vertex. -- -- running time: \(O(n)\). -planarGraph :: [[(Dart s,e)]] -> PlanarGraph s Primal_ () e () +planarGraph :: [[(Dart s,e)]] -> PlanarGraph s Primal () e () planarGraph ds = (planarGraph' perm)&dartData .~ (V.fromList . concat $ ds) where n = sum . map length $ ds @@ -244,9 +390,11 @@ -- | Construct a planar graph from a adjacency matrix. For every vertex, all -- vertices should be given in counter clockwise order. -- +-- pre: No self-loops, and no multi-edges +-- -- running time: \(O(n)\). -fromAdjacencyLists :: forall s w f. (Foldable f, Functor f) - => [(VertexId s w, f (VertexId s w))] +fromAdjacencyLists :: forall s w h. (Foldable h, Functor h) + => [(VertexId s w, h (VertexId s w))] -> PlanarGraph s w () () () fromAdjacencyLists adjM = planarGraph' . toCycleRep n $ perm where @@ -280,8 +428,17 @@ f :: e -> State Int (Int :+ e) f e = do i <- get ; put (i+1) ; pure (i :+ e) - - +-- | Produces the adjacencylists for all vertices in the graph. For every vertex, the +-- adjacent vertices are given in counter clockwise order. +-- +-- Note that in case a vertex u as a self loop, we have that this vertexId occurs +-- twice in the list of neighbours, i.e.: u : [...,u,..,u,...]. Similarly, if there are +-- multiple darts between a pair of edges they occur multiple times. +-- +-- running time: \(O(n)\) +toAdjacencyLists :: PlanarGraph s w v e f -> [(VertexId s w, V.Vector (VertexId s w))] +toAdjacencyLists pg = map (\u -> (u,neighboursOf u pg)) . V.toList . vertices' $ pg +-- TODO: something weird happens when we have self-loops here. -- -- Go through all of the edges we find an edge (u,v), with u <= v, -- -- assign an ArcId to this edge (and increment the next available arcId). @@ -311,15 +468,15 @@ -- -- u < v, to arcId's. -- -- - a: the next available unused arcID -- -- - x: the data value we are interested in computing --- type STR' s b = STR (SM.Map (VertexId s Primal_,VertexId s Primal_) Int) Int b +-- type STR' s b = STR (SM.Map (VertexId s Primal,VertexId s Primal) Int) Int b -- -- | Construct a planar graph from a adjacency matrix. For every vertex, all -- -- vertices should be given in counter clockwise order. -- -- -- -- running time: \(O(n \log n)\). -- fromAdjacencyLists :: forall s. --- [(VertexId s Primal_, C.CList (VertexId s Primal_))] --- -> PlanarGraph s Primal_ () () () +-- [(VertexId s Primal, C.CList (VertexId s Primal))] +-- -> PlanarGraph s Primal () () () -- fromAdjacencyLists adjM = planarGraph' . toCycleRep n $ perm -- where -- n = sum . fmap length $ adjM @@ -328,7 +485,7 @@ -- -- | Given a vertex with its adjacent vertices (u,vs) (in CCW order) convert this -- -- vertex with its adjacent vertices into an Orbit --- toOrbit :: (VertexId s Primal_, C.CList (VertexId s Primal_)) +-- toOrbit :: (VertexId s Primal, C.CList (VertexId s Primal)) -- -> STR' s [[Dart s]] -- -> STR' s [[Dart s]] -- toOrbit (u,vs) (STR m a dss) = @@ -338,7 +495,7 @@ -- -- | Given an edge (u,v) and a triplet (m,a,ds) we construct a new dart -- -- representing this edge. --- toDart :: (VertexId s Primal_,VertexId s Primal_) +-- toDart :: (VertexId s Primal,VertexId s Primal) -- -> STR' s [Dart s] -- -> STR' s [Dart s] -- toDart (u,v) (STR m a ds) = let dir = if u < v then Positive else Negative @@ -349,6 +506,7 @@ -------------------------------------------------------------------------------- +-- ** Convenience functions -- | Get the number of vertices -- @@ -414,7 +572,7 @@ -- (Dart (Arc 2) -1,"c-") -- (Dart (Arc 5) -1,"g-") darts :: PlanarGraph s w v e f -> V.Vector (Dart s, e) -darts g = (\d -> (d,g^.eDataOf d)) <$> darts' g +darts g = (\d -> (d,g^.dataOf d)) <$> darts' g -- | Enumerate all edges. We report only the Positive darts edges' :: PlanarGraph s w v e f -> V.Vector (Dart s) @@ -457,12 +615,15 @@ endPoints d g = (tailOf d g, headOf d g) + + -- | All edges incident to vertex v, in counterclockwise order around v. -- -- running time: \(O(k)\), where \(k\) is the output size incidentEdges :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (Dart s) incidentEdges (VertexId v) g = g^.embedding.orbits.ix' v + -- TODO: The Delaunay triang. stuff seems to produce these in clockwise order instead -- | All incoming edges incident to vertex v, in counterclockwise order around v. incomingEdges :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (Dart s) @@ -482,36 +643,50 @@ where otherVtx d = let u = tailOf d g in if u == v then headOf d g else u --- outgoingNeighbours :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w) --- outgoingNeighbours = undefined +-- | Given a dart d that points into some vertex v, report the next dart in the +-- cyclic order around v. +-- +-- running time: \(O(1)\) +nextIncidentEdge :: Dart s -> PlanarGraph s w v e f -> Dart s +nextIncidentEdge d g = let perm = g^.embedding + (i,j) = lookupIdx perm d + in next (perm^.orbits.ix' i) j --- incomingNeighbours :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w) --- incomingNeighbours = undefined +-- | Given a dart d that points into some vertex v, report the next dart in the +-- cyclic order around v. +-- +-- running time: \(O(1)\) +prevIncidentEdge :: Dart s -> PlanarGraph s w v e f -> Dart s +prevIncidentEdge d g = let perm = g^.embedding + (i,j) = lookupIdx perm d + in previous (perm^.orbits.ix' i) j + -------------------------------------------------------------------------------- -- * Access data --- | Get the vertex data associated with a node. Note that updating this data may be --- expensive!! --- --- running time: \(O(1)\) -vDataOf :: VertexId s w -> Lens' (PlanarGraph s w v e f) v -vDataOf (VertexId i) = vertexData.ix' i --- | Edge data of a given dart --- --- running time: \(O(1)\) -eDataOf :: Dart s -> Lens' (PlanarGraph s w v e f) e -eDataOf d = rawDartData.ix' (fromEnum d) +class HasDataOf g i where + type DataOf g i + -- | get the data associated with the value i. + -- + -- running time: \(O(1)\) to read the data, \(O(n)\) to write it. + dataOf :: i -> Lens' g (DataOf g i) --- | Data of a face of a given face --- --- running time: \(O(1)\) -fDataOf :: FaceId s w -> Lens' (PlanarGraph s w v e f) f -fDataOf (FaceId (VertexId i)) = faceData.ix' i +instance HasDataOf (PlanarGraph s w v e f) (VertexId s w) where + type DataOf (PlanarGraph s w v e f) (VertexId s w) = v + dataOf (VertexId i) = vertexData.ix' i +instance HasDataOf (PlanarGraph s w v e f) (Dart s) where + type DataOf (PlanarGraph s w v e f) (Dart s) = e + dataOf d = rawDartData.ix' (fromEnum d) +instance HasDataOf (PlanarGraph s w v e f) (FaceId s w) where + type DataOf (PlanarGraph s w v e f) (FaceId s w) = f + dataOf (FaceId (VertexId i)) = faceData.ix' i + + -- | Data corresponding to the endpoints of the dart endPointDataOf :: Dart s -> Getter (PlanarGraph s w v e f) (v,v) endPointDataOf d = to $ endPointData d @@ -521,7 +696,7 @@ -- -- running time: \(O(1)\) endPointData :: Dart s -> PlanarGraph s w v e f -> (v,v) -endPointData d g = let (u,v) = endPoints d g in (g^.vDataOf u, g^.vDataOf v) +endPointData d g = let (u,v) = endPoints d g in (g^.dataOf u, g^.dataOf v) -------------------------------------------------------------------------------- -- * The Dual graph @@ -535,27 +710,42 @@ -- , fromList [dart 1 "+1",dart 3 "-1",dart 2 "-1"] -- , fromList [dart 4 "-1",dart 3 "+1",dart 5 "+1",dart 5 "-1"] -- ] --- in (dual myGraph)^.embedding.orbits == answer +-- in (computeDual myGraph)^.embedding.orbits == answer -- :} -- True -- -- running time: \(O(n)\). -dual :: PlanarGraph s w v e f -> PlanarGraph s (Dual w) f e v -dual g = let perm = g^.embedding - in PlanarGraph (cycleRep (elems perm) (apply perm . twin)) +computeDual :: forall s w v e f. PlanarGraph s w v e f -> PlanarGraph s (DualOf w) f e v +computeDual = gcastWith proof computeDual' + where + proof :: DualOf (DualOf w) :~: w + proof = dualDualIdentity + +-- | Does the actual work for dualGraph +computeDual' :: (DualOf (DualOf w) ~ w) + => PlanarGraph s w v e f -> PlanarGraph s (DualOf w) f e v +computeDual' g = dualG + where + perm = g^.embedding + dualG = PlanarGraph (cycleRep (elems perm) (apply perm . twin)) (g^.faceData) (g^.rawDartData) (g^.vertexData) + g + -- | A face -newtype FaceId s w = FaceId { _unFaceId :: VertexId s (Dual w) } deriving (Eq,Ord) +newtype FaceId s w = FaceId { _unFaceId :: VertexId s (DualOf w) } + deriving (Eq,Ord,ToJSON,FromJSON) +type FaceId' s = FaceId s Primal + instance Show (FaceId s w) where show (FaceId (VertexId i)) = "FaceId " ++ show i -- | Enumerate all faces in the planar graph faces' :: PlanarGraph s w v e f -> V.Vector (FaceId s w) -faces' = fmap FaceId . vertices' . dual +faces' = fmap FaceId . vertices' . _dual -- | All faces with their face data. faces :: PlanarGraph s w v e f -> V.Vector (FaceId s w, f) @@ -574,7 +764,7 @@ -- -- running time: \(O(1)\). leftFace :: Dart s -> PlanarGraph s w v e f -> FaceId s w -leftFace d g = FaceId . headOf d $ dual g +leftFace d g = FaceId . headOf d $ _dual g -- | The face to the right of the dart @@ -590,18 +780,44 @@ -- -- running time: \(O(1)\). rightFace :: Dart s -> PlanarGraph s w v e f -> FaceId s w -rightFace d g = FaceId . tailOf d $ dual g +rightFace d g = FaceId . tailOf d $ _dual g +-- | Get the next edge along the face +-- +-- running time: \(O(1)\). +nextEdge :: Dart s -> PlanarGraph s w v e f -> Dart s +nextEdge d = nextIncidentEdge d . _dual + +-- | Get the previous edge along the face +-- +-- running time: \(O(1)\). +prevEdge :: Dart s -> PlanarGraph s w v e f -> Dart s +prevEdge d = prevIncidentEdge d . _dual + + -- | The darts bounding this face, for internal faces in clockwise order, for -- the outer face in counter clockwise order. -- -- -- running time: \(O(k)\), where \(k\) is the output size. boundary :: FaceId s w -> PlanarGraph s w v e f -> V.Vector (Dart s) -boundary (FaceId v) g = incidentEdges v $ dual g +boundary (FaceId v) g = incidentEdges v $ _dual g +-- | Generates the darts incident to a face, starting with the given dart. +-- +-- +-- \(O(k)\), where \(k\) is the number of darts reported +boundary' :: Dart s -> PlanarGraph s w v e f -> V.Vector (Dart s) +boundary' d g = fromMaybe (error "boundary'") . rotateTo d $ boundary (rightFace d g) g + where + rotateTo :: Eq a => a -> V.Vector a -> Maybe (V.Vector a) + rotateTo x v = f <$> V.elemIndex x v + where + f i = let (a,b) = V.splitAt i v in b <> a + + -- | The vertices bounding this face, for internal faces in clockwise order, for -- the outer face in counter clockwise order. -- @@ -610,6 +826,10 @@ boundaryVertices :: FaceId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w) boundaryVertices f g = fmap (flip tailOf g) $ boundary f g +-- -- | Gets the next dart along the face +-- nextDart :: Dart s -> PlanarGraph s w v e f -> Dart s +-- nextDart d g = f rightFace e + -------------------------------------------------------------------------------- -- Testing stuff @@ -635,41 +855,33 @@ data Test --- testG :: PlanarGraph Test Primal_ () String () --- testG = planarGraph' [ [ (Dart aA Negative, "a-") --- , (Dart aC Positive, "c+") --- , (Dart aB Positive, "b+") --- , (Dart aA Positive, "a+") --- ] --- , [ (Dart aE Negative, "e-") --- , (Dart aB Negative, "b-") --- , (Dart aD Negative, "d-") --- , (Dart aG Positive, "g+") --- ] --- , [ (Dart aE Positive, "e+") --- , (Dart aD Positive, "d+") --- , (Dart aC Negative, "c-") --- ] --- , [ (Dart aG Negative, "g-") --- ] --- ] --- where --- (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..] +testG :: PlanarGraph Test Primal () String () +testG = planarGraph [ [ (Dart aA Negative, "a-") + , (Dart aC Positive, "c+") + , (Dart aB Positive, "b+") + , (Dart aA Positive, "a+") + ] + , [ (Dart aE Negative, "e-") + , (Dart aB Negative, "b-") + , (Dart aD Negative, "d-") + , (Dart aG Positive, "g+") + ] + , [ (Dart aE Positive, "e+") + , (Dart aD Positive, "d+") + , (Dart aC Negative, "c-") + ] + , [ (Dart aG Negative, "g-") + ] + ] + where + (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..] --------------------------------------------------------------------------------- --- type ArcID = Int --- -- | ST' is a strict triple (m,a,x) containing: --- -- --- -- - m: a Map, mapping edges, represented by a pair of vertexId's (u,v) with --- -- u < v, to arcId's. --- -- - a: the next available unused arcID --- -- - x: the data value we are interested in computing --- type ST' a = ST (SM.Map (VertexID,VertexID) ArcID) ArcID a +-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- @@ -700,11 +912,23 @@ g = traverse (bitraverse pure f) -edgeOracle :: PlanarGraph s w v e f -> EdgeOracle s w () -edgeOracle g = buildEdgeOracle [ (v, ext <$> neighboursOf v g) +-- | Given a planar graph, construct an edge oracle. Given a pair of vertices +-- this allows us to efficiently find the dart representing this edge in the +-- graph. +-- +-- pre: No self-loops and no multi-edges!!! +-- +-- running time: \(O(n)\) +edgeOracle :: PlanarGraph s w v e f -> EdgeOracle s w (Dart s) +edgeOracle g = buildEdgeOracle [ (v, mkAdjacency v <$> incidentEdges v g) | v <- F.toList $ vertices' g ] + where + mkAdjacency v d = otherVtx v d :+ d + otherVtx v d = let u = tailOf d g in if u == v then headOf d g else u + + -- | Builds an edge oracle that can be used to efficiently test if two vertices -- are connected by an edge. -- @@ -780,14 +1004,24 @@ where find' j i = fmap (^.extra) . F.find (\(VertexId k :+ _) -> j == k) $ os V.! i - +-- | Given a pair of vertices (u,v) returns the dart, oriented from u to v, +-- corresponding to these vertices. +-- +-- running time: \(O(1)\) +findDart :: VertexId s w -> VertexId s w -> EdgeOracle s w (Dart s) -> Maybe (Dart s) +findDart (VertexId u) (VertexId v) (EdgeOracle os) = find' twin u v <|> find' id v u + -- looks up j in the adjacencylist of i and applies f to the result + where + find' f j i = fmap (f . (^.extra)) . F.find (\(VertexId k :+ _) -> j == k) $ os V.! i -------------------------------------------------------------------------------- data TestG -type Vertex = VertexId TestG Primal_ + +type Vertex = VertexId TestG Primal + testEdges :: [(Vertex,[Vertex])] testEdges = map (\(i,vs) -> (VertexId i, map VertexId vs)) [ (0, [1]) @@ -797,3 +1031,26 @@ , (4, [1,2,5]) , (5, [3,4]) ] + + +myGraph :: PlanarGraph Test Primal () String () +myGraph = planarGraph [ [ (Dart aA Negative, "a-") + , (Dart aC Positive, "c+") + , (Dart aB Positive, "b+") + , (Dart aA Positive, "a+") + ] + , [ (Dart aE Negative, "e-") + , (Dart aB Negative, "b-") + , (Dart aD Negative, "d-") + , (Dart aG Positive, "g+") + ] + , [ (Dart aE Positive, "e+") + , (Dart aD Positive, "d+") + , (Dart aC Negative, "c-") + ] + , [ (Dart aG Negative, "g-") + ] + ] + where + -- dart i s = Dart (Arc i) (read s) + (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..] diff --git a/src/Data/PlaneGraph.hs b/src/Data/PlaneGraph.hs --- a/src/Data/PlaneGraph.hs +++ b/src/Data/PlaneGraph.hs @@ -1,37 +1,548 @@ -module Data.PlaneGraph( module Data.PlanarGraph - , PlaneGraph +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.PlaneGraph( PlaneGraph(PlaneGraph), graph + , PlanarGraph + , VertexData(VertexData), vData, location, vtxDataToExt + , fromSimplePolygon, fromConnectedSegments + , PG.fromAdjacencyLists + , numVertices, numEdges, numFaces, numDarts + , dual + + , vertices', vertices + , edges', edges + , faces', faces, internalFaces, faces'' + , darts' + + , headOf, tailOf, twin, endPoints + + , incidentEdges, incomingEdges, outgoingEdges + , neighboursOf + , nextIncidentEdge, prevIncidentEdge + + + , leftFace, rightFace + , nextEdge, prevEdge + , boundary, boundary', boundaryVertices + , outerFaceId, outerFaceDart + + , vertexDataOf, locationOf, HasDataOf(..) + + , endPointsOf, endPointData + , vertexData, faceData, dartData, rawDartData + + , edgeSegment, edgeSegments + , rawFacePolygon, rawFaceBoundary + , rawFacePolygons + + , VertexId(..), FaceId(..), Dart, World(..), VertexId', FaceId' + + , withEdgeDistances - , faceToSimplePolygon ) where -import Data.Ext -import Control.Lens -import Data.PlanarGraph -import Data.Geometry.Point -import Data.Geometry.Polygon(fromPoints, SimplePolygon) -import Data.Geometry.Properties + +import Control.Lens hiding (holes, holesOf, (.=)) +import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.CircularSeq as C +import Data.Ext +import qualified Data.Foldable as F +import Data.Function (on) +import Data.Geometry.Interval +import Data.Geometry.Line (cmpSlope, supportingLine) +import Data.Geometry.LineSegment +import Data.Geometry.Box +import Data.Geometry.Properties +import Data.Geometry.Point +import Data.Geometry.Polygon +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as M +import Data.Ord (comparing) +import qualified Data.PlanarGraph as PG +import Data.PlanarGraph( PlanarGraph, planarGraph, dual + , Dart(..), VertexId(..), FaceId(..), Arc(..) + , Direction(..), twin + , World(..) + , FaceId', VertexId' + , HasDataOf(..) + ) +import Data.Semigroup +import Data.Util import qualified Data.Vector as V +import GHC.Generics (Generic) +import Debug.Trace +-------------------------------------------------------------------------------- +-- | Note that the functor instance is in v +data VertexData r v = VertexData { _location :: !(Point 2 r) + , _vData :: !v + } deriving (Show,Eq,Ord,Functor,Foldable,Traversable) +makeLenses ''VertexData + +vtxDataToExt :: VertexData r v -> Point 2 r :+ v +vtxDataToExt (VertexData p v) = p :+ v + +instance Bifunctor VertexData where + bimap f g (VertexData p v) = VertexData (fmap f p) (g v) + +instance (FromJSON r, FromJSON v) => FromJSON (VertexData r v) where + parseJSON = fmap (\(l :+ d) -> VertexData l d) . parseJSON + +instance (ToJSON r, ToJSON v) => ToJSON (VertexData r v) where + toJSON = toJSON . vtxDataToExt + toEncoding = toEncoding . vtxDataToExt + -------------------------------------------------------------------------------- -type PlaneGraph s w v e f r = PlanarGraph s w (Point 2 r :+ v) e f +-- | Embedded, *connected*, planar graph +newtype PlaneGraph s v e f r = + PlaneGraph { _graph :: PlanarGraph s Primal (VertexData r v) e f } + deriving (Show,Eq,ToJSON,FromJSON) +makeLenses ''PlaneGraph -type instance NumType (PlaneGraph s w v e f r) = r +type instance NumType (PlaneGraph s v e f r) = r +type instance Dimension (PlaneGraph s v e f r) = 2 +instance Functor (PlaneGraph s v e f) where + fmap f pg = pg&graph.PG.vertexData.traverse.location %~ fmap f --- | Labels the edges of a plane graph with their distances, as specified by --- the distance function. -withEdgeDistances :: (Point 2 r -> Point 2 r -> a) - -> PlaneGraph s w p e f r -> PlaneGraph s w p (a :+ e) f r -withEdgeDistances f g = g&dartData %~ fmap (\(d,x) -> (d,len d :+ x)) +instance IsBoxable (PlaneGraph s v e f r) where + boundingBox = boundingBoxList' . F.toList . fmap (^._2.location) . vertices + + + + +-------------------------------------------------------------------------------- +-- * Constructing a Plane Graph + +-- | Construct a plane graph from a simple polygon. It is assumed that the +-- polygon is given in counterclockwise order. +-- +-- the interior of the polygon will have faceId 0 +-- +-- pre: the input polygon is given in counterclockwise order +-- running time: \(O(n)\). +fromSimplePolygon :: proxy s + -> SimplePolygon p r + -> f -- ^ data inside + -> f -- ^ data outside the polygon + -> PlaneGraph s p () f r +fromSimplePolygon p (SimplePolygon vs) iD oD = PlaneGraph g' where - len d = uncurry f . over both (^.core) $ endPointData d g + g = fromVertices p vs + fData' = V.fromList [iD, oD] + g' = g & PG.faceData .~ fData' +-- | Constructs a planar from the given vertices +fromVertices :: proxy s + -> C.CSeq (Point 2 r :+ p) + -> PlanarGraph s Primal (VertexData r p) () () +fromVertices _ vs = g&PG.vertexData .~ vData' + where + n = length vs + g = planarGraph [ [ (Dart (Arc i) Positive, ()) + , (Dart (Arc $ (i+1) `mod` n) Negative, ()) + ] + | i <- [0..(n-1)]] + vData' = V.fromList . map (\(p :+ e) -> VertexData p e) . F.toList $ vs -faceToSimplePolygon :: FaceId s w -> PlaneGraph s w p e f r - -> SimplePolygon p r :+ f -faceToSimplePolygon i gr = poly (boundaryVertices i gr) :+ gr^.fDataOf i +-- | Constructs a connected plane graph +-- +-- pre: The segments form a single connected component +-- +-- running time: \(O(n\log n)\) +fromConnectedSegments :: (Foldable f, Ord r, Num r) + => proxy s + -> f (LineSegment 2 p r :+ e) + -> PlaneGraph s (NonEmpty.NonEmpty p) e () r +fromConnectedSegments _ ss = PlaneGraph $ planarGraph dts & PG.vertexData .~ vxData where - poly = fromPoints . V.toList . fmap (\j -> gr^.vDataOf j) + pts = M.fromListWith (<>) . concatMap f . zipWith g [0..] . F.toList $ ss + f (s :+ e) = [ ( s^.start.core + , SP (sing $ s^.start.extra) [(s^.end.core) :+ h Positive e]) + , ( s^.end.core + , SP (sing $ s^.end.extra) [(s^.start.core) :+ h Negative e]) + ] + g i (s :+ e) = s :+ (Arc i :+ e) + h d (a :+ e) = (Dart a d, e) + + sing x = x NonEmpty.:| [] + + vts = map (\(p,sp) -> (p,map (^.extra) . sortArround (ext p) <$> sp)) + . M.assocs $ pts + -- vertex Data + vxData = V.fromList . map (\(p,sp) -> VertexData p (sp^._1)) $ vts + -- The darts + dts = map (^._2._2) vts + +-------------------------------------------------------------------------------- +-- * Basic Graph information + +-- | Get the number of vertices +-- +-- >>> numVertices myGraph +-- 4 +numVertices :: PlaneGraph s v e f r -> Int +numVertices = PG.numVertices . _graph + +-- | Get the number of Darts +-- +-- >>> numDarts myGraph +-- 12 +numDarts :: PlaneGraph s v e f r -> Int +numDarts = PG.numDarts . _graph + +-- | Get the number of Edges +-- +-- >>> numEdges myGraph +-- 6 +numEdges :: PlaneGraph s v e f r -> Int +numEdges = PG.numEdges . _graph + +-- | Get the number of faces +-- +-- >>> numFaces myGraph +-- 4 +numFaces :: PlaneGraph s v e f r -> Int +numFaces = PG.numFaces . _graph + +-- | Enumerate all vertices +-- +-- >>> vertices' myGraph +-- [VertexId 0,VertexId 1,VertexId 2,VertexId 3] +vertices' :: PlaneGraph s v e f r -> V.Vector (VertexId' s) +vertices' = PG.vertices' . _graph + +-- | Enumerate all vertices, together with their vertex data + +-- >>> vertices myGraph +-- [(VertexId 0,()),(VertexId 1,()),(VertexId 2,()),(VertexId 3,())] +vertices :: PlaneGraph s v e f r -> V.Vector (VertexId' s, VertexData r v) +vertices = PG.vertices . _graph + +-- | Enumerate all darts +darts' :: PlaneGraph s v e f r -> V.Vector (Dart s) +darts' = PG.darts' . _graph + +-- | Enumerate all edges. We report only the Positive darts +edges' :: PlaneGraph s v e f r -> V.Vector (Dart s) +edges' = PG.edges' . _graph + +-- | Lens to access the raw dart data, use at your own risk +rawDartData :: Lens (PlaneGraph s v e f r) (PlaneGraph s v e' f r) + (V.Vector e) (V.Vector e') +rawDartData = graph.PG.rawDartData + +-- | lens to access the Dart Data +dartData :: Lens (PlaneGraph s v e f r) (PlaneGraph s v e' f r) + (V.Vector (Dart s, e)) (V.Vector (Dart s, e')) +dartData = graph.PG.dartData + +-- | Lens to access face data +faceData :: Lens (PlaneGraph s v e f r) (PlaneGraph s v e f' r) + (V.Vector f) (V.Vector f') +faceData = graph.PG.faceData + +vertexData :: Lens (PlaneGraph s v e f r) (PlaneGraph s v' e f r) + (V.Vector v) (V.Vector v') +vertexData = lens get'' set'' + where + get'' pg = let v = pg^.graph.PG.vertexData in (^.vData) <$> v + set'' pg v' = pg&graph.PG.vertexData %~ V.zipWith f v' + f x (VertexData l _) = VertexData l x + +-- | Enumerate all edges with their edge data. We report only the Positive +-- darts. +-- +-- >>> mapM_ print $ edges myGraph +-- (Dart (Arc 2) +1,"c+") +-- (Dart (Arc 1) +1,"b+") +-- (Dart (Arc 0) +1,"a+") +-- (Dart (Arc 5) +1,"g+") +-- (Dart (Arc 4) +1,"e+") +-- (Dart (Arc 3) +1,"d+") +edges :: PlaneGraph s v e f r -> V.Vector (Dart s, e) +edges = PG.edges . _graph + +-- | Enumerate all faces in the plane graph +faces' :: PlaneGraph s v e f r -> V.Vector (FaceId' s) +faces' = PG.faces' . _graph + +-- | All faces with their face data. +faces :: PlaneGraph s v e f r -> V.Vector (FaceId' s, f) +faces = PG.faces . _graph + + +-- | Reports the outerface and all internal faces separately. +-- running time: \(O(n)\) +faces'' :: (Ord r, Fractional r) + => PlaneGraph s v e f r -> ((FaceId' s, f), V.Vector (FaceId' s, f)) +faces'' g = let i = outerFaceId g + in ((i,g^.dataOf i), V.filter (\(j,_) -> i /= j) $ faces g) + +-- | Reports all internal faces. +-- running time: \(O(n)\) +internalFaces :: (Ord r, Fractional r) + => PlaneGraph s v e f r -> V.Vector (FaceId' s, f) +internalFaces = snd . faces'' + +-- | The tail of a dart, i.e. the vertex this dart is leaving from +-- +-- running time: \(O(1)\) +tailOf :: Dart s -> PlaneGraph s v e f r -> VertexId' s +tailOf d = PG.tailOf d . _graph + +-- | The vertex this dart is heading in to +-- +-- running time: \(O(1)\) +headOf :: Dart s -> PlaneGraph s v e f r -> VertexId' s +headOf d = PG.headOf d . _graph + +-- | endPoints d g = (tailOf d g, headOf d g) +-- +-- running time: \(O(1)\) +endPoints :: Dart s -> PlaneGraph s v e f r + -> (VertexId' s, VertexId' s) +endPoints d = PG.endPoints d . _graph + +-- | All edges incident to vertex v, in counterclockwise order around v. +-- +-- running time: \(O(k)\), where \(k\) is the output size +incidentEdges :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s) +incidentEdges v = PG.incidentEdges v . _graph + +-- | All incoming edges incident to vertex v, in counterclockwise order around v. +incomingEdges :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s) +incomingEdges v = PG.incomingEdges v . _graph + +-- | All outgoing edges incident to vertex v, in counterclockwise order around v. +outgoingEdges :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s) +outgoingEdges v = PG.outgoingEdges v . _graph + +-- | Gets the neighbours of a particular vertex, in counterclockwise order +-- around the vertex. +-- +-- running time: \(O(k)\), where \(k\) is the output size +neighboursOf :: VertexId' s -> PlaneGraph s v e f r + -> V.Vector (VertexId' s) +neighboursOf v = PG.neighboursOf v . _graph + +-- | Given a dart d that points into some vertex v, report the next dart in the +-- cyclic order around v. +-- +-- running time: \(O(1)\) +nextIncidentEdge :: Dart s -> PlaneGraph s v e f r -> Dart s +nextIncidentEdge d = PG.nextIncidentEdge d . _graph + +-- | Given a dart d that points into some vertex v, report the next dart in the +-- cyclic order around v. +-- +-- running time: \(O(1)\) +prevIncidentEdge :: Dart s -> PlaneGraph s v e f r -> Dart s +prevIncidentEdge d = PG.prevIncidentEdge d . _graph + + +-- | The face to the left of the dart +-- +-- >>> leftFace (dart 1 "+1") myGraph +-- FaceId 1 +-- >>> leftFace (dart 1 "-1") myGraph +-- FaceId 2 +-- >>> leftFace (dart 2 "+1") myGraph +-- FaceId 2 +-- >>> leftFace (dart 0 "+1") myGraph +-- FaceId 0 +-- +-- running time: \(O(1)\). +leftFace :: Dart s -> PlaneGraph s v e f r -> FaceId' s +leftFace d = PG.leftFace d . _graph + +-- | The face to the right of the dart +-- +-- >>> rightFace (dart 1 "+1") myGraph +-- FaceId 2 +-- >>> rightFace (dart 1 "-1") myGraph +-- FaceId 1 +-- >>> rightFace (dart 2 "+1") myGraph +-- FaceId 1 +-- >>> rightFace (dart 0 "+1") myGraph +-- FaceId 1 +-- +-- running time: \(O(1)\). +rightFace :: Dart s -> PlaneGraph s v e f r -> FaceId' s +rightFace d = PG.rightFace d . _graph + + +-- | Get the next edge along the face +-- +-- +-- running time: \(O(1)\). +nextEdge :: Dart s -> PlaneGraph s v e f r -> Dart s +nextEdge d = PG.nextEdge d . _graph + +-- | Get the previous edge along the face +-- +-- +-- running time: \(O(1)\). +prevEdge :: Dart s -> PlaneGraph s v e f r -> Dart s +prevEdge d = PG.prevEdge d . _graph + + +-- | The darts bounding this face, for internal faces in clockwise order, for +-- the outer face in counter clockwise order. +-- +-- +-- running time: \(O(k)\), where \(k\) is the output size. +boundary :: FaceId' s -> PlaneGraph s v e f r -> V.Vector (Dart s) +boundary f = PG.boundary f . _graph + +-- | Generates the darts incident to a face, starting with the given dart. +-- +-- +-- \(O(k)\), where \(k\) is the number of darts reported +boundary' :: Dart s -> PlaneGraph s v e f r -> V.Vector (Dart s) +boundary' d = PG.boundary' d . _graph + + +-- | The vertices bounding this face, for internal faces in clockwise order, for +-- the outer face in counter clockwise order. +-- +-- +-- running time: \(O(k)\), where \(k\) is the output size. +boundaryVertices :: FaceId' s -> PlaneGraph s v e f r + -> V.Vector (VertexId' s) +boundaryVertices f = PG.boundaryVertices f . _graph + +-------------------------------------------------------------------------------- +-- * Access data + +vertexDataOf :: VertexId' s -> Lens' (PlaneGraph s v e f r ) (VertexData r v) +vertexDataOf v = graph.PG.dataOf v + +locationOf :: VertexId' s -> Lens' (PlaneGraph s v e f r ) (Point 2 r) +locationOf v = vertexDataOf v.location + + +instance HasDataOf (PlaneGraph s v e f r) (VertexId' s) where + type DataOf (PlaneGraph s v e f r) (VertexId' s) = v + dataOf v = graph.dataOf v.vData + +instance HasDataOf (PlaneGraph s v e f r) (Dart s) where + type DataOf (PlaneGraph s v e f r) (Dart s) = e + dataOf d = graph.dataOf d + +instance HasDataOf (PlaneGraph s v e f r) (FaceId' s) where + type DataOf (PlaneGraph s v e f r) (FaceId' s) = f + dataOf f = graph.dataOf f + + +-- | Getter for the data at the endpoints of a dart +-- +-- running time: \(O(1)\) +endPointsOf :: Dart s -> Getter (PlaneGraph s v e f r ) + (VertexData r v, VertexData r v) +endPointsOf d = graph.PG.endPointDataOf d + +-- | Data corresponding to the endpoints of the dart +-- +-- running time: \(O(1)\) +endPointData :: Dart s -> PlaneGraph s v e f r + -> (VertexData r v, VertexData r v) +endPointData d = PG.endPointData d . _graph + +-------------------------------------------------------------------------------- + +-- | gets the id of the outer face +-- +-- running time: \(O(n)\) +outerFaceId :: (Ord r, Fractional r) => PlaneGraph s v e f r -> FaceId' s +outerFaceId ps = leftFace (outerFaceDart ps) ps + + +-- | gets a dart incident to the outer face (in particular, that has the +-- outerface on its left) +-- +-- running time: \(O(n)\) +outerFaceDart :: (Ord r, Fractional r) => PlaneGraph s v e f r -> Dart s +outerFaceDart ps = d + where + (v,_) = V.minimumBy (comparing (^._2.location.xCoord)) . vertices $ ps + d :+ _ = V.maximumBy (cmpSlope `on` (^.extra)) + . fmap (\d' -> d' :+ (edgeSegment d' ps)^.core.to supportingLine) + $ incidentEdges v ps + -- based on the approach sketched at https://cstheory.stackexchange.com/questions/27586/finding-outer-face-in-plane-graph-embedded-planar-graph + -- basically: find the leftmost vertex, find the incident edge with the largest slope + -- and take the face left of that edge. This is the outerface. + -- note that this requires that the edges are straight line segments + -- + + + +-------------------------------------------------------------------------------- + +-- | Reports all edges as line segments +edgeSegments :: PlaneGraph s v e f r -> V.Vector (Dart s, LineSegment 2 v r :+ e) +edgeSegments ps = fmap withSegment . edges $ ps + where + withSegment (d,e) = let (p,q) = bimap vtxDataToExt vtxDataToExt + $ ps^.endPointsOf d + seg = ClosedLineSegment p q + in (d, seg :+ e) + +-- | Given a dart and the graph constructs the line segment representing the dart +-- +-- \(O(1)\) +edgeSegment :: Dart s -> PlaneGraph s v e f r -> LineSegment 2 v r :+ e +edgeSegment d ps = seg :+ ps^.dataOf d + where + seg = let (p,q) = bimap vtxDataToExt vtxDataToExt $ ps^.endPointsOf d + in ClosedLineSegment p q + +-- | The polygon describing the face +-- +-- runningtime: \(O(k)\), where \(k\) is the size of the face. +rawFaceBoundary :: FaceId' s -> PlaneGraph s v e f r + -> SimplePolygon v r :+ f +rawFaceBoundary i ps = pg :+ (ps^.dataOf i) + where + pg = fromPoints . F.toList . fmap (\j -> ps^.graph.dataOf j.to vtxDataToExt) + . boundaryVertices i $ ps + +-- | Alias for rawFace Boundary +-- +-- runningtime: \(O(k)\), where \(k\) is the size of the face. +rawFacePolygon :: FaceId' s -> PlaneGraph s v e f r -> SimplePolygon v r :+ f +rawFacePolygon = rawFaceBoundary + +-- | Lists all faces of the plane graph. +rawFacePolygons :: PlaneGraph s v e f r + -> V.Vector (FaceId' s, SimplePolygon v r :+ f) +rawFacePolygons ps = fmap (\i -> (i,rawFacePolygon i ps)) . faces' $ ps + + +-------------------------------------------------------------------------------- +-- * Reading and Writing the Plane Graph + +-- +-- readPlaneGraph :: (FromJSON v, FromJSON e, FromJSON f, FromJSON r) +-- => proxy s -> ByteString +-- -> Either String (PlaneGraph s v e f r) +-- readPlaneGraph = undefined-- parseEither + + +-- writePlaneGraph :: (ToJSON v, ToJSON e, ToJSON f, ToJSON r) +-- => PlaneGraph s v e f r -> ByteString +-- writePlaneGraph = YamlP.encodePretty YamlP.defConfig + +-------------------------------------------------------------------------------- + +-- | Labels the edges of a plane graph with their distances, as specified by +-- the distance function. +withEdgeDistances :: (Point 2 r -> Point 2 r -> a) + -> PlaneGraph s p e f r -> PlaneGraph s p (a :+ e) f r +withEdgeDistances f g = g&graph.PG.dartData %~ fmap (\(d,x) -> (d,len d :+ x)) + where + len d = uncurry f . over both (^.location) $ endPointData d g diff --git a/src/Data/PlaneGraph/Draw.hs b/src/Data/PlaneGraph/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Data/PlaneGraph/Draw.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.PlaneGraph.Draw where + +import Data.PlaneGraph +import Data.Geometry.Ipe +import Data.Ext +import Control.Lens +import qualified Data.Vector as V + + + +drawPlaneGraph :: forall s v e f r. IpeOut (PlaneGraph s v e f r) (IpeObject r) +drawPlaneGraph = IpeOut draw + where + draw :: PlaneGraph s v e f r -> IpeObject r + draw g = asIpeGroup $ concatMap V.toList [vs, es, fs] + where + vs = (\(_,VertexData p _) -> asIpeObject p mempty) <$> vertices g + es = (\(_,s :+ _) -> asIpeObject s mempty) <$> edgeSegments g + fs = (\(_,f :+ _) -> asIpeObject f mempty) <$> rawFacePolygons g + + +-- drawPlaneGraphWith :: (VertexId' s :+ v -> IpeObject r) +-- -> (Dart s :+ e -> IpeObject r) +-- -> (FaceId' s :+ f -> IpeObject r) +-- -> IpeObject +-- drawPlaneGraphWith vertexF edgeF faceF g = asIpeGroup $ vs ++ es ++ fs +-- where +-- vs = map vertices () diff --git a/src/Data/Range.hs b/src/Data/Range.hs --- a/src/Data/Range.hs +++ b/src/Data/Range.hs @@ -1,5 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveAnyClass #-} +{-| +Module : Data.Range +Description: Generic Ranges (Intervals) +Copyright : (c) Frank Staals +License : See LICENCE file +-} module Data.Range( EndPoint(..) , isOpen, isClosed , unEndPoint @@ -15,14 +21,14 @@ import Control.Lens import Data.Geometry.Properties -import Frames.CoRec +import Data.Vinyl.CoRec import Text.Printf(printf) import GHC.Generics (Generic) import Control.DeepSeq -------------------------------------------------------------------------------- - +-- | Endpoints of a range may either be open or closed. data EndPoint a = Open !a | Closed !a deriving (Show,Read,Eq,Functor,Foldable,Traversable,Generic,NFData) @@ -55,6 +61,7 @@ -------------------------------------------------------------------------------- +-- | Data type for representing ranges. data Range a = Range { _lower :: !(EndPoint a) , _upper :: !(EndPoint a) } @@ -72,9 +79,10 @@ pattern ClosedRange :: a -> a -> Range a pattern ClosedRange l u = Range (Closed l) (Closed u) --- | A range from l to u, ignoring/forgetting the type of the enpoints +-- | A range from l to u, ignoring/forgetting the type of the endpoints pattern Range' :: a -> a -> Range a pattern Range' l u <- ((\r -> (r^.lower.unEndPoint,r^.upper.unEndPoint) -> (l,u))) +{-# COMPLETE Range' #-} prettyShow :: Show a => Range a -> String diff --git a/src/Data/Seq.hs b/src/Data/Seq.hs --- a/src/Data/Seq.hs +++ b/src/Data/Seq.hs @@ -34,12 +34,11 @@ , promise ) where -import Control.Lens ((%~), (&), (<&>), (^?), Lens', bimap) +import Control.Lens ((%~), (&), (<&>), (^?), bimap) import Control.Lens.At (Ixed(..), Index, IxValue) import qualified Data.Foldable as F import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromJust) -import Data.Proxy import Data.Semigroup import qualified Data.Sequence as S import qualified Data.Traversable as Tr @@ -174,15 +173,17 @@ infixr 5 :<| --- pattern (:<|) :: a -> LSeq n a -> LSeq (1 + n) a +-- pattern (:<|) :: a -> LSeq n a -> LSeq (1 + m) a pattern x :<| xs <- (viewl -> x :< xs) where x :<| xs = x <| xs infixr 5 :<< +pattern (:<<) :: a -> LSeq 0 a -> LSeq n a pattern x :<< xs <- (viewLSeq -> Just (x,xs)) +pattern EmptyL :: LSeq n a pattern EmptyL <- (viewLSeq -> Nothing) viewLSeq :: LSeq n a -> Maybe (a,LSeq 0 a) @@ -226,10 +227,10 @@ -------------------------------------------------------------------------------- -testL = (eval (Proxy :: Proxy 2) $ fromList [1..5]) +-- testL = (eval (Proxy :: Proxy 2) $ fromList [1..5]) -testL' :: LSeq 2 Integer -testL' = fromJust testL +-- testL' :: LSeq 2 Integer +-- testL' = fromJust testL -test :: Show a => LSeq (1 + n) a -> String -test (x :<| xs) = show x ++ show xs +-- test :: Show a => LSeq (1 + n) a -> String +-- test (x :<| xs) = show x ++ show xs diff --git a/src/Data/Sequence/Util.hs b/src/Data/Sequence/Util.hs --- a/src/Data/Sequence/Util.hs +++ b/src/Data/Sequence/Util.hs @@ -2,11 +2,12 @@ import Data.Sequence(Seq, ViewL(..),ViewR(..)) import qualified Data.Sequence as S +import qualified Data.Vector.Generic as V -------------------------------------------------------------------------------- --- | Get the index h such that everything strictly smaller than h has: p i = --- False, and all i >= h, we have p h = True +-- | Given a monotonic predicate, Get the index h such that everything strictly +-- smaller than h has: p i = False, and all i >= h, we have p h = True -- -- returns Nothing if no element satisfies p -- @@ -23,7 +24,24 @@ p' = p . S.index s u = S.length s - 1 +-- | Given a monotonic predicate, get the index h such that everything strictly +-- smaller than h has: p i = False, and all i >= h, we have p h = True +-- +-- returns Nothing if no element satisfies p +-- +-- running time: \(O(T*\log n)\), where \(T\) is the time to execute the +-- predicate. +binarySearchVec :: V.Vector v a + => (a -> Bool) -> v a -> Maybe Int +binarySearchVec p' v | V.null v = Nothing + | not $ p n' = Nothing + | otherwise = Just $ if p 0 then 0 + else binarySearch p 0 n' + where + n' = V.length v - 1 + p = p' . (v V.!) + -- | Partition the seq s given a monotone predicate p into (xs,ys) such that -- -- all elements in xs do *not* satisfy the predicate p @@ -49,6 +67,7 @@ -- -- running time: \(O(\log(u - l))\) {-# SPECIALIZE binarySearch :: (Int -> Bool) -> Int -> Int -> Int #-} +{-# SPECIALIZE binarySearch :: (Word -> Bool) -> Word -> Word -> Word #-} binarySearch :: Integral a => (a -> Bool) -> a -> a -> a binarySearch p l u = let d = u - l m = l + (d `div` 2) diff --git a/src/Data/SlowSeq.hs b/src/Data/SlowSeq.hs new file mode 100644 --- /dev/null +++ b/src/Data/SlowSeq.hs @@ -0,0 +1,206 @@ +module Data.SlowSeq where + + +import Control.Lens (bimap) +-- import qualified Data.FingerTree as FT +-- import Data.FingerTree hiding (null, viewl, viewr) +import Data.FingerTree(ViewL(..),ViewR(..)) +import qualified Data.Foldable as F +import Data.Maybe +import Data.Semigroup +import qualified Data.Sequence as S +import qualified Data.Sequence.Util as SU + + + +-------------------------------------------------------------------------------- + +data Key a = NoKey | Key { getKey :: a } deriving (Show,Eq,Ord) + +instance Semigroup (Key a) where + k <> NoKey = k + _ <> k = k + +instance Monoid (Key a) where + mempty = NoKey + k `mappend` k' = k <> k' + +liftCmp :: (a -> a -> Ordering) -> Key a -> Key a -> Ordering +liftCmp _ NoKey NoKey = EQ +liftCmp _ NoKey (Key _) = LT +liftCmp _ (Key _) NoKey = GT +liftCmp cmp (Key x) (Key y) = x `cmp` y + + + +-- newtype Elem a = Elem { getElem :: a } deriving (Eq,Ord,Traversable,Foldable,Functor) + +-- instance Show a => Show (Elem a) where +-- show (Elem x) = "Elem " <> show x + + +newtype OrdSeq a = OrdSeq { _asSeq :: S.Seq a } + deriving (Show,Eq) + +instance Semigroup (OrdSeq a) where + (OrdSeq s) <> (OrdSeq t) = OrdSeq $ s `mappend` t + +instance Monoid (OrdSeq a) where + mempty = OrdSeq mempty + mappend = (<>) + +instance Foldable OrdSeq where + foldMap f = foldMap f . _asSeq + null = null . _asSeq + length = length . _asSeq + minimum = fromJust . lookupMin + maximum = fromJust . lookupMax + +-- instance Measured (Key a) (Elem a) where +-- measure (Elem x) = Key x + + +type Compare a = a -> a -> Ordering + +-- | Insert into a monotone OrdSeq. +-- +-- pre: the comparator maintains monotonicity +-- +-- \(O(\log^2 n)\) +insertBy :: Compare a -> a -> OrdSeq a -> OrdSeq a +insertBy cmp x (OrdSeq s) = OrdSeq $ l `mappend` (x S.<| r) + where + (l,r) = split (\v -> cmp v x `elem` [EQ, GT]) s + + + + + + +-- | Insert into a sorted OrdSeq +-- +-- \(O(\log^2 n)\) +insert :: Ord a => a -> OrdSeq a -> OrdSeq a +insert = insertBy compare + +deleteAllBy :: Compare a -> a -> OrdSeq a -> OrdSeq a +deleteAllBy cmp x s = l <> r + where + (l,_,r) = splitBy cmp x s + + -- (l,m) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ,GT]) s + -- (_,r) = split (\v -> liftCmp cmp v (Key x) == GT) m + + +-- | \(O(\log^2 n)\) +splitBy :: Compare a -> a -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a) +splitBy cmp x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r) + where + (l, m) = split (\v -> cmp v x `elem` [EQ,GT]) s + (m',r) = split (\v -> cmp v x == GT) m + + +-- | Given a monotonic function f that maps a to b, split the sequence s +-- depending on the b values. I.e. the result (l,m,r) is such that +-- * all (< x) . fmap f $ l +-- * all (== x) . fmap f $ m +-- * all (> x) . fmap f $ r +-- +-- >>> splitOn id 3 $ fromAscList' [1..5] +-- (OrdSeq {_asSeq = fromList [Elem 1,Elem 2]},OrdSeq {_asSeq = fromList [Elem 3]},OrdSeq {_asSeq = fromList [Elem 4,Elem 5]}) +-- >>> splitOn fst 2 $ fromAscList' [(0,"-"),(1,"A"),(2,"B"),(2,"C"),(3,"D"),(4,"E")] +-- (OrdSeq {_asSeq = fromList [Elem (0,"-"),Elem (1,"A")]},OrdSeq {_asSeq = fromList [Elem (2,"B"),Elem (2,"C")]},OrdSeq {_asSeq = fromList [Elem (3,"D"),Elem (4,"E")]}) +-- +-- \(O(\log^2 n)\) +splitOn :: Ord b => (a -> b) -> b -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a) +splitOn f x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r) + where + (l, m) = split (\v -> compare (f v) x `elem` [EQ,GT]) s + (m',r) = split (\v -> compare (f v) x == GT) m + +-- | Given a monotonic predicate p, splits the sequence s into two sequences +-- (as,bs) such that all (not p) as and all p bs +-- +-- \(O(\log^2 n)\) +splitMonotonic :: (a -> Bool) -> OrdSeq a -> (OrdSeq a, OrdSeq a) +splitMonotonic p = bimap OrdSeq OrdSeq . split p . _asSeq + + +-- monotonic split for Sequences +-- +-- \(O(\log^2 n)\) +split :: (a -> Bool) -> S.Seq a -> (S.Seq a, S.Seq a) +split = SU.splitMonotone + +-- Deletes all elements from the OrdDeq +-- +-- \(O(\log^2 n)\) +deleteAll :: Ord a => a -> OrdSeq a -> OrdSeq a +deleteAll = deleteAllBy compare + + +-- | inserts all eleements in order +-- \(O(n\log n)\) +fromListBy :: Compare a -> [a] -> OrdSeq a +fromListBy cmp = foldr (insertBy cmp) mempty + +-- | inserts all eleements in order +-- \(O(n\log n)\) +fromListByOrd :: Ord a => [a] -> OrdSeq a +fromListByOrd = fromListBy compare + +-- | O(n) +fromAscList' :: [a] -> OrdSeq a +fromAscList' = OrdSeq . S.fromList + + +-- | \(O(\log^2 n)\) +lookupBy :: Compare a -> a -> OrdSeq a -> Maybe a +lookupBy cmp x s = let (_,m,_) = splitBy cmp x s in listToMaybe . F.toList $ m + +memberBy :: Compare a -> a -> OrdSeq a -> Bool +memberBy cmp x = isJust . lookupBy cmp x + + +-- | Fmap, assumes the order does not change +-- \(O(n)\) +mapMonotonic :: (a -> b) -> OrdSeq a -> OrdSeq b +mapMonotonic f = fromAscList' . map f . F.toList + + +-- | Gets the first element from the sequence +-- \(O(1)\) +viewl :: OrdSeq a -> ViewL OrdSeq a +viewl = f . S.viewl . _asSeq + where + f S.EmptyL = EmptyL + f (x S.:< s) = x :< OrdSeq s + +-- Last element +-- \(O(1)\) +viewr :: OrdSeq a -> ViewR OrdSeq a +viewr = f . S.viewr . _asSeq + where + f S.EmptyR = EmptyR + f (s S.:> x) = OrdSeq s :> x + + +-- \(O(1)\) +minView :: OrdSeq a -> Maybe (a, OrdSeq a) +minView s = case viewl s of + EmptyL -> Nothing + (x :< t) -> Just (x,t) + +-- \(O(1)\) +lookupMin :: OrdSeq a -> Maybe a +lookupMin = fmap fst . minView + +-- \(O(1)\) +maxView :: OrdSeq a -> Maybe (a, OrdSeq a) +maxView s = case viewr s of + EmptyR -> Nothing + (t :> x) -> Just (x,t) + +-- \(O(1)\) +lookupMax :: OrdSeq a -> Maybe a +lookupMax = fmap fst . maxView diff --git a/src/Data/Util.hs b/src/Data/Util.hs --- a/src/Data/Util.hs +++ b/src/Data/Util.hs @@ -1,7 +1,6 @@ module Data.Util where import Control.Lens -import Data.Bifunctor import Data.Semigroup -- | strict triple diff --git a/src/Data/Yaml/Util.hs b/src/Data/Yaml/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Util.hs @@ -0,0 +1,22 @@ +module Data.Yaml.Util where + +import qualified Data.Yaml.Pretty as YamlP +import Data.Yaml +import Data.ByteString (ByteString) +import Data.ByteString.Char8 as B + +-- | Write the output to yaml +encodeYaml :: ToJSON a => a -> ByteString +encodeYaml = YamlP.encodePretty YamlP.defConfig + +-- | Prints the yaml +printYaml :: ToJSON a => a -> IO () +printYaml = B.putStrLn . encodeYaml + +-- | alias for decodeEither' from the Yaml Package +decodeYaml :: FromJSON a => ByteString -> Either ParseException a +decodeYaml = decodeEither' + +-- | alias for reading a yaml file +decodeYamlFile :: FromJSON a => FilePath -> IO (Either ParseException a) +decodeYamlFile = decodeFileEither diff --git a/src/Test/QuickCheck/HGeometryInstances.hs b/src/Test/QuickCheck/HGeometryInstances.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/HGeometryInstances.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Test.QuickCheck.HGeometryInstances where + +import Control.Lens +import Data.BinaryTree +import Data.Ext +import Data.Geometry hiding (vector) +import Data.Geometry.Box +import Data.Geometry.SubLine +import Data.OrdSeq (OrdSeq, fromListByOrd) +import Data.Proxy +import Data.Semigroup +import qualified Data.Seq as Seq +import qualified Data.Seq2 as S2 +import GHC.TypeLits +import Test.QuickCheck + +-------------------------------------------------------------------------------- + +-- instance Arbitrary a => Arbitrary (NonEmpty.NonEmpty a) where +-- arbitrary = NonEmpty.fromList <$> listOf1 arbitrary + +instance (Arbitrary a, Ord a) => Arbitrary (OrdSeq a) where + arbitrary = fromListByOrd <$> arbitrary + +instance Arbitrary a => Arbitrary (S2.Seq2 a) where + arbitrary = S2.Seq2 <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary a => Arbitrary (BinaryTree a) where + arbitrary = sized f + where f n | n <= 0 = pure Nil + | otherwise = do + l <- choose (0,n-1) + Internal <$> f l <*> arbitrary <*> f (n-l-1) + +instance (Arbitrary a, Arbitrary v) => Arbitrary (BinLeafTree v a) where + arbitrary = sized f + where f n | n <= 0 = Leaf <$> arbitrary + | otherwise = do + l <- choose (0,n-1) + Node <$> f l <*> arbitrary <*> f (n-l-1) + + +instance (KnownNat n, Arbitrary a) => Arbitrary (Seq.LSeq n a) where + arbitrary = (\s s' -> Seq.promise . Seq.fromList $ s <> s') + <$> vector (fromInteger . natVal $ (Proxy :: Proxy n)) + <*> arbitrary + +instance (Arbitrary r, Arity d) => Arbitrary (Vector d r) where + arbitrary = vectorFromListUnsafe <$> infiniteList + +instance (Arbitrary r, Arity d) => Arbitrary (Point d r) where + arbitrary = Point <$> arbitrary + +instance (Arbitrary r, Arity d, Num r, Eq r) => Arbitrary (Line d r) where + arbitrary = do p <- arbitrary + q <- suchThat arbitrary (/= p) + return $ lineThrough p q + +instance (Arbitrary r, Arity d, Ord r) => Arbitrary (Box d () r) where + arbitrary = (\p (q :: Point d r) -> boundingBoxList' [p,q]) <$> arbitrary <*> arbitrary + + +instance Arbitrary r => Arbitrary (EndPoint r) where + arbitrary = frequency [ (1, Open <$> arbitrary) + , (9, Closed <$> arbitrary) + ] + +instance (Arbitrary r, Ord r) => Arbitrary (Range r) where + arbitrary = do + l <- arbitrary + r <- suchThat arbitrary (p l) + return $ Range l r + where + p (Open l) r = l < r^.unEndPoint + p (Closed l) r = l <= r^.unEndPoint + + +instance (Arbitrary c, Arbitrary e) => Arbitrary (c :+ e) where + arbitrary = (:+) <$> arbitrary <*> arbitrary + +instance (Arbitrary r, Arbitrary p, Ord r, Ord p) => Arbitrary (Interval p r) where + arbitrary = GInterval <$> arbitrary + + +instance (Arbitrary r, Arbitrary p, Arity d, Ord r, Ord p, Num r) + => Arbitrary (SubLine d p r) where + arbitrary = SubLine <$> arbitrary <*> arbitrary + + +instance (Arbitrary r, Arbitrary p, Arity d) => Arbitrary (LineSegment d p r) where + arbitrary = LineSegment <$> arbitrary <*> arbitrary diff --git a/test/Algorithms/Geometry/ConvexHull/ConvexHullSpec.hs b/test/Algorithms/Geometry/ConvexHull/ConvexHullSpec.hs new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/ConvexHull/ConvexHullSpec.hs @@ -0,0 +1,41 @@ +module Algorithms.Geometry.ConvexHull.ConvexHullSpec where + +import qualified Algorithms.Geometry.ConvexHull.DivideAndConqueror as DivideAndConqueror +import qualified Algorithms.Geometry.ConvexHull.GrahamScan as GrahamScan +import Control.Lens +import Data.CircularSeq (isShiftOf) +import Data.Ext +import Data.Geometry.Point +import Data.Geometry.Polygon +import Data.Geometry.Polygon.Convex +import qualified Data.List as L +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import Data.Proxy +import Data.Semigroup +import qualified Data.Set as Set +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.HGeometryInstances() +import Test.QuickCheck.Instances() +import Util + +import Debug.Trace + +spec :: Spec +spec = do + describe "ConvexHull Algorithms" $ do + modifyMaxSize (const 1000) . modifyMaxSuccess (const 1000) $ + it "GrahamScan and DivideAnd Conqueror are the same" $ + property $ \pts -> + (PG $ GrahamScan.convexHull pts) + == + (PG $ DivideAndConqueror.convexHull pts) + +newtype PG = PG (ConvexPolygon () Rational) deriving (Show) + +instance Eq PG where + (PG a) == (PG b) = let as = a^.simplePolygon.outerBoundary + bs = b^.simplePolygon.outerBoundary + in isShiftOf as bs diff --git a/test/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannSpec.hs b/test/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannSpec.hs --- a/test/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannSpec.hs +++ b/test/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannSpec.hs @@ -1,5 +1,6 @@ module Algorithms.Geometry.LineSegmentIntersection.BentleyOttmannSpec where +import Algorithms.Geometry.LineSegmentIntersection (hasSelfIntersections) import qualified Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann as Sweep import qualified Algorithms.Geometry.LineSegmentIntersection.Naive as Naive import Algorithms.Geometry.LineSegmentIntersection.Types @@ -9,23 +10,32 @@ import Data.Geometry.Ipe import Data.Geometry.LineSegment import Data.Geometry.Point +import Data.Geometry.Polygon import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map +import Data.Proxy +import Data.Semigroup import qualified Data.Set as Set import Test.Hspec import Test.QuickCheck import Util +import Debug.Trace + spec :: Spec spec = do describe "Testing Bentley Ottmann LineSegment Intersection" $ do -- toSpec (TestCase "myPoints" myPoints) -- toSpec (TestCase "myPoints'" myPoints') ipeSpec + describe "Self Intersecting Polygon Tests" $ do + siTestCases (testPath <> "selfIntersections.ipe") +testPath = "test/Algorithms/Geometry/LineSegmentIntersection/" + ipeSpec :: Spec -ipeSpec = testCases "test/Algorithms/Geometry/LineSegmentIntersection/manual.ipe" +ipeSpec = testCases (testPath <> "manual.ipe") testCases :: FilePath -> Spec testCases fp = (runIO $ readInput fp) >>= \case @@ -63,3 +73,44 @@ ) => [LineSegment 2 p r] -> Spec sameAsNaive segs = it "Same as Naive " $ do (Sweep.intersections segs) `shouldBe` (Naive.intersections segs) + + +data SelfIntersectionTestCase r = SITestCase { _siPolygon :: SimplePolygon () r + , _isSelfIntersectiong :: Bool + } deriving (Show,Eq) + + +siTestCases :: FilePath -> Spec +siTestCases fp = (runIO $ readSiInput fp) >>= \case + Left e -> it "reading SelfIntersection file" $ + expectationFailure $ "Failed to read ipe file " ++ show e + Right tcs -> mapM_ siToSpec tcs + +-- | polygons are considered self intersecting when they are red +readSiInput :: FilePath -> IO (Either ConversionError [SelfIntersectionTestCase Rational]) +readSiInput fp = fmap f <$> readSinglePageFile fp + where + f page = [ SITestCase pg (isRed a) + | pg :+ a <- polies + ] + where + polies = page^..content.to flattenGroups.traverse + ._withAttrs _IpePath _asSimplePolygon + isRed ats = lookupAttr (Proxy :: Proxy Stroke) ats == Just (IpeColor (Named "red")) + + +siToSpec :: SelfIntersectionTestCase Rational -> Spec +siToSpec (SITestCase pg b) = it ("SelfIntersecting?: " <> take 50 (show pg)) $ do + hasSelfIntersections pg `shouldBe` b + + + +-- flattenGroups :: [IpeObject r] -> [IpeObject r] +-- flattenGroups = concatMap flattenGroups' + +-- flattenGroups' :: IpeObject r -> [IpeObject r] +-- flattenGroups' (IpeGroup (Group gs :+ ats)) = +-- map (applyAts ats) . concatMap flattenGroups' $ gs +-- where +-- applyAts ats = id +-- flattenGroups' o = [o] diff --git a/test/Algorithms/Geometry/LineSegmentIntersection/selfIntersections.ipe b/test/Algorithms/Geometry/LineSegmentIntersection/selfIntersections.ipe new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/LineSegmentIntersection/selfIntersections.ipe @@ -0,0 +1,313 @@ + + + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + +0.6 0 0 0.6 0 0 e + + + + + +0.5 0 0 0.5 0 0 e + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h +-0.4 -0.4 m +0.4 -0.4 l +0.4 0.4 l +-0.4 0.4 l +h + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h + + + + + +-0.5 -0.5 m +0.5 -0.5 l +0.5 0.5 l +-0.5 0.5 l +h + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h +-0.4 -0.4 m +0.4 -0.4 l +0.4 0.4 l +-0.4 0.4 l +h + + + + + + +-0.43 -0.57 m +0.57 0.43 l +0.43 0.57 l +-0.57 -0.43 l +h + + +-0.43 0.57 m +0.57 -0.43 l +0.43 -0.57 l +-0.57 0.43 l +h + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +-1 0.333 m +0 0 l +-1 -0.333 l + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +96 704 m +192 816 l +352 656 l +208 640 l +336 784 l +h + + +144 592 m +336 624 l +320 544 l +240 624 l +h + + +80 624 m +32 576 l +128 576 l +h + + +64 784 m +32 752 l +32 688 l +64 672 l +144 672 l +96 688 l +80 768 l +128 768 l +112 800 l +h + + + diff --git a/test/Algorithms/Geometry/LowerEnvelope/LowerEnvSpec.hs b/test/Algorithms/Geometry/LowerEnvelope/LowerEnvSpec.hs new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/LowerEnvelope/LowerEnvSpec.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Algorithms.Geometry.LowerEnvelope.LowerEnvSpec where + +import qualified Algorithms.Geometry.LowerEnvelope.DualCH as DualCH +import Control.Lens +import Data.Eq.Approximate +import Data.Ext +import Data.Geometry +import Data.Geometry.Ipe +import Data.Geometry.Line +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (mapMaybe) +import Data.Proxy +import Data.Ratio +import Data.Semigroup +import Data.Vinyl.CoRec +import GHC.TypeLits +import Test.Hspec +import Util + +-- import Algorithms.Geometry.LowerEnvelope.Types + +spec :: Spec +spec = testCases "test/Algorithms/Geometry/LowerEnvelope/manual.ipe" + +testCases :: FilePath -> Spec +testCases fp = (runIO $ readInput fp) >>= \case + Left e -> it "reading Smallest enclosing disk file" $ + expectationFailure $ "Failed to read ipe file " ++ show e + Right tcs -> mapM_ toSpec tcs + + +type Approx r = AbsolutelyApproximateValue (Proxy 3) r + + + +data TestCase r = TestCase { _lines :: NonEmpty (Line 2 r :+ ()) + , _color :: Maybe (IpeColor r) + , _solution :: [Point 2 (Approx r)] + } + deriving (Show,Eq) + + +readInput :: FilePath -> IO (Either ConversionError [TestCase Rational]) +readInput fp = fmap f <$> readSinglePageFile fp + where + f page = [ let c = lookup' $ NonEmpty.head lSet + in TestCase ((\l -> l^.core.to supportingLine :+ ()) <$> lSet) + c + (solutionOf c) + | lSet <- mapMaybe NonEmpty.nonEmpty $ byStrokeColour segs + ] + where + segs :: [LineSegment 2 () Rational :+ IpeAttributes Path Rational] + segs = page^..content.traverse._withAttrs _IpePath _asLineSegment + pts = page^..content.traverse._IpeUse + + solutionOf c = [ AbsolutelyApproximateValue <$> p^.core.symbolPoint + | p <- pts, lookup' p == c + ] + + + +lookup' (_ :+ ats) = lookupAttr (Proxy :: Proxy Stroke) ats + + +toSpec :: (Fractional r, Ord r, Show r) => TestCase r -> Spec +toSpec (TestCase ls c sol) = it ("testing the " <> show c <> " set") $ + (map (approx . (^.core)) + . DualCH.vertices . DualCH.lowerEnvelope $ ls) `shouldBe` sol + + +approx = fmap AbsolutelyApproximateValue + +-- shouldApprox :: forall f r. ( Functor f, Eq (f (Approx r)) +-- , Show (f (Approx r)) +-- ) +-- => f r -> f r -> Expectation +-- a `shouldApprox` b = a' `shouldBe` b' +-- where +-- a' :: f (Approx r) +-- a' = AbsolutelyApproximateValue <$> a +-- b' :: f (Approx r) +-- b' = AbsolutelyApproximateValue <$> b + + + +instance KnownNat n => AbsoluteTolerance (Proxy n) where + absoluteToleranceOf = toleranceFromKnownNat . getAbsoluteTolerance + +toleranceFromKnownNat :: (Fractional r, KnownNat n) => proxy n -> r +toleranceFromKnownNat p = recip . fromInteger $ (10 :: Integer) ^ (natVal p) + +instance KnownNat n => RelativeTolerance (Proxy n) where + relativeToleranceOf = toleranceFromKnownNat . getRelativeTolerance + +instance KnownNat n => ZeroTolerance (Proxy n) where + zeroToleranceOf = toleranceFromKnownNat . getZeroTolerance + +-- where +-- f :: Fractional r => AbsolutelyApproximateValue (Proxy n) r -> r +-- f _ = recip $ (fromInteger 10) ^^ (natVal (Proxy :: Proxy n)) diff --git a/test/Algorithms/Geometry/LowerEnvelope/manual.ipe b/test/Algorithms/Geometry/LowerEnvelope/manual.ipe new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/LowerEnvelope/manual.ipe @@ -0,0 +1,299 @@ + + + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + +0.6 0 0 0.6 0 0 e + + + + + +0.5 0 0 0.5 0 0 e + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h +-0.4 -0.4 m +0.4 -0.4 l +0.4 0.4 l +-0.4 0.4 l +h + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h + + + + + +-0.5 -0.5 m +0.5 -0.5 l +0.5 0.5 l +-0.5 0.5 l +h + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h +-0.4 -0.4 m +0.4 -0.4 l +0.4 0.4 l +-0.4 0.4 l +h + + + + + + +-0.43 -0.57 m +0.57 0.43 l +0.43 0.57 l +-0.57 -0.43 l +h + + +-0.43 0.57 m +0.57 -0.43 l +0.43 -0.57 l +-0.57 0.43 l +h + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +-1 0.333 m +0 0 l +-1 -0.333 l + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +80 496 m +304 624 l + + +320 512 m +176 624 l + + +80 560 m +368 560 l + + +80 512 m +320 608 l + + + + + + diff --git a/test/Algorithms/Geometry/PolygonTriangulation/MakeMonotoneSpec.hs b/test/Algorithms/Geometry/PolygonTriangulation/MakeMonotoneSpec.hs new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/PolygonTriangulation/MakeMonotoneSpec.hs @@ -0,0 +1,58 @@ +module Algorithms.Geometry.PolygonTriangulation.MakeMonotoneSpec where + +import Algorithms.Geometry.PolygonTriangulation.MakeMonotone +import Data.Geometry.Polygon +import Data.Geometry +import Data.Ext +import Control.Lens +import Test.Hspec +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set +-- import Data.Geometry.Ipe + + +spec :: Spec +spec = describe "GeomBook Example" $ do + it "Classify Verticese" $ + (fmap (^.extra.extra) . polygonVertices $ classifyVertices geomBookPoly) + `shouldBe` geomBookVertexTypes + it "Diagonals" $ + (Set.fromList . map (\s -> sort' (s^.start.extra,s^.end.extra)) + $ computeDiagonals geomBookPoly) + `shouldBe` geomBookDiagonals + + + -- testCases "test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe" + +sort' :: Ord a => (a,a) -> (a,a) +sort' (x,y) = (min x y, max x y) + +geomBookPoly :: SimplePolygon Int Rational +geomBookPoly = fromPoints [ point2 20 20 :+ 1 + , point2 18 19 :+ 2 + , point2 16 25 :+ 3 + , point2 13 23 :+ 4 + , point2 10 24 :+ 5 + , point2 6 22 :+ 6 + , point2 8 21 :+ 7 + , point2 7 18 :+ 8 + , point2 2 19 :+ 9 + , point2 1 10 :+ 10 + , point2 3 5 :+ 11 + , point2 11 7 :+ 12 + , point2 15 1 :+ 13 + , point2 12 15 :+ 14 + , point2 15 12 :+ 15 + ] +geomBookVertexTypes = NonEmpty.fromList [Start,Merge,Start,Merge,Start,Regular,Regular,Merge,Start,Regular,End,Split,End,Split,End] +geomBookDiagonals = Set.fromList [(4,6),(2,8),(8,14),(10,12)] + + + + -- let f i = geomBookPoly !! (i-1) + -- seg i j = + -- in + + -- [Clo + + -- LineSegment (Closed (Point2 [6 % 1,22 % 1] :+ 6)) (Closed (Point2 [13 % 1,23 % 1] :+ 4)),LineSegment (Closed (Point2 [7 % 1,18 % 1] :+ 8)) (Closed (Point2 [18 % 1,19 % 1] :+ 2)),LineSegment (Closed (Point2 [12 % 1,15 % 1] :+ 14)) (Closed (Point2 [7 % 1,18 % 1] :+ 8)),LineSegment (Closed (Point2 [11 % 1,7 % 1] :+ 12)) (Closed (Point2 [1 % 1,10 % 1] :+ 10))] diff --git a/test/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotoneSpec.hs b/test/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotoneSpec.hs new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotoneSpec.hs @@ -0,0 +1,73 @@ +module Algorithms.Geometry.PolygonTriangulation.TriangulateMonotoneSpec where + +import Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone +import Control.Lens +import Data.Ext +import Data.Geometry +import Data.Geometry.Ipe +import Data.Geometry.Polygon +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe +import qualified Data.Set as Set +import Data.Vinyl +import Test.Hspec +import Util + + +spec :: Spec +spec = do testCases "test/Algorithms/Geometry/PolygonTriangulation/monotone.ipe" + testCases "test/Algorithms/Geometry/PolygonTriangulation/simplepolygon6.ipe" + +testCases :: FilePath -> Spec +testCases fp = (runIO $ readInput fp) >>= \case + Left e -> it "reading TriangulateMonotone file" $ + expectationFailure $ "Failed to read ipe file " ++ show e + Right tcs -> mapM_ toSpec tcs + + +data TestCase r = TestCase { _polygon :: MonotonePolygon () r :+ IpeColor r + , _solution :: [LineSegment 2 () r] + } + deriving (Show,Eq) + + +toSpec :: (Num r, Ord r, Show r) => TestCase r -> Spec +toSpec (TestCase (poly :+ c) sol) = + describe ("testing polygions of color " ++ show c) $ do + it "comparing with manual solution" $ + (naiveSet $ computeDiagonals poly) `shouldBe` naiveSet sol + where + naiveSet = NaiveSet . map S + +newtype S p r = S (LineSegment 2 p r) deriving (Show) + +instance (Eq p, Eq r) => Eq (S p r) where + (S s) == (S y) = (s^.start == y^.start && s^.end == y^.end) + || (s^.start == y^.end && s^.end == y^.start) + + + +-- | Point sets per color, Crosses form the solution +readInput :: FilePath -> IO (Either ConversionError [TestCase Rational]) +readInput fp = fmap f <$> readSinglePageFile fp + where + f page = [ TestCase pg (solutionOf pg segs) + | pg <- map g polies + ] + where + g x@(pg :+ _) = toCounterClockWiseOrder pg :+ lookupColor x + + polies = page^..content.traverse._withAttrs _IpePath _asSimplePolygon + segs = page^..content.traverse._withAttrs _IpePath _asLineSegment + + solutionOf (_ :+ c) = map (^.core) . filter ((== c) . lookupColor) + + + -- -- | Crosses form a solution + -- isInSolution s = s^.core.symbolName == "mark/cross(sx)" + + -- right = either (const Nothing) Just + -- solutionOf = right . fromList . map (^.core.symbolPoint) . filter isInSolution + +lookupColor :: i :+ IpeAttributes Path r -> IpeColor r +lookupColor (_ :+ ats) = fromMaybe (IpeColor $ Named "black") $ lookupAttr SStroke ats diff --git a/test/Algorithms/Geometry/PolygonTriangulation/monotone.ipe b/test/Algorithms/Geometry/PolygonTriangulation/monotone.ipe new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/PolygonTriangulation/monotone.ipe @@ -0,0 +1,364 @@ + + + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + +0.6 0 0 0.6 0 0 e + + + + + +0.5 0 0 0.5 0 0 e + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h +-0.4 -0.4 m +0.4 -0.4 l +0.4 0.4 l +-0.4 0.4 l +h + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h + + + + + +-0.5 -0.5 m +0.5 -0.5 l +0.5 0.5 l +-0.5 0.5 l +h + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h +-0.4 -0.4 m +0.4 -0.4 l +0.4 0.4 l +-0.4 0.4 l +h + + + + + + +-0.43 -0.57 m +0.57 0.43 l +0.43 0.57 l +-0.57 -0.43 l +h + + +-0.43 0.57 m +0.57 -0.43 l +0.43 -0.57 l +-0.57 0.43 l +h + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +-1 0.333 m +0 0 l +-1 -0.333 l + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +176 736 m +240 688 l +240 608 l +128 576 l +64 640 l +80 720 l +128 752 l +h + + +240 608 m +64 640 l + + +64 640 m +240 688 l + + +240 688 m +80 720 l + + +80 720 m +176 736 l + + +160 384 m +352 384 l +128 176 l +224 320 l +48 400 l +h + + +384 480 m +256 416 l + + +256 416 m +192 480 l + + +320 320 m +256 320 l +224 320 l +128 240 l +64 224 l +256 192 l +h + + +256 320 m +128 240 l + + +128 240 m +320 320 l + + +256 192 m +128 240 l + + +320 320 m +256 320 l +224 320 l +128 240 l +64 224 l +256 192 l +h + + +464 160 m +336 208 l + + +336 80 m +336 208 l + + +368 80 m +336 208 l + + + diff --git a/test/Algorithms/Geometry/PolygonTriangulation/simplepolygon6.ipe b/test/Algorithms/Geometry/PolygonTriangulation/simplepolygon6.ipe new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/PolygonTriangulation/simplepolygon6.ipe @@ -0,0 +1,297 @@ + + + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + +0.6 0 0 0.6 0 0 e + + + + + +0.5 0 0 0.5 0 0 e + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h +-0.4 -0.4 m +0.4 -0.4 l +0.4 0.4 l +-0.4 0.4 l +h + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h + + + + + +-0.5 -0.5 m +0.5 -0.5 l +0.5 0.5 l +-0.5 0.5 l +h + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h +-0.4 -0.4 m +0.4 -0.4 l +0.4 0.4 l +-0.4 0.4 l +h + + + + + + +-0.43 -0.57 m +0.57 0.43 l +0.43 0.57 l +-0.57 -0.43 l +h + + +-0.43 0.57 m +0.57 -0.43 l +0.43 -0.57 l +-0.57 0.43 l +h + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +-1 0.333 m +0 0 l +-1 -0.333 l + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +80 544 m +320 527 l +208 496 l +48 432 l +16 560 l +h + + +80 544 m +208 496 l + + +208 496 m +16 560 l + + + diff --git a/test/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPDSpec.hs b/test/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPDSpec.hs --- a/test/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPDSpec.hs +++ b/test/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPDSpec.hs @@ -13,6 +13,7 @@ import qualified Data.Vector as V import Test.Hspec import Util +import GHC.TypeLits -------------------------------------------------------------------------------- @@ -26,10 +27,10 @@ it "simple input reordering " $ do reIndexPoints input `shouldBe` output where - input = v2 (ptSeq [ origin :+ 1, point2 1 1 :+ 100, point2 5 5 :+ 101 ]) - (ptSeq [ point2 1 1 :+ 100, point2 5 5 :+ 101, origin :+ 1 ]) - output = v2 (ptSeq [ origin :+ 0, point2 1 1 :+ 1, point2 5 5 :+ 2 ]) - (ptSeq [ point2 1 1 :+ 1, point2 5 5 :+ 2, origin :+ 0 ]) + input = Vector2 (ptSeq [ origin :+ 1, point2 1 1 :+ 100, point2 5 5 :+ 101 ]) + (ptSeq [ point2 1 1 :+ 100, point2 5 5 :+ 101, origin :+ 1 ]) + output = Vector2 (ptSeq [ origin :+ 0, point2 1 1 :+ 1, point2 5 5 :+ 2 ]) + (ptSeq [ point2 1 1 :+ 1, point2 5 5 :+ 2, origin :+ 0 ]) @@ -41,7 +42,7 @@ it "distributePoints' on a single list " $ do distributePoints' 3 levels input `shouldBe` output it "distributePoints on multiple lists" $ do - distributePoints 3 levels (v2 input input) `shouldBe` output' + distributePoints 3 levels (Vector2 input input) `shouldBe` output' where levels = V.fromList [Just $ Level 0 (Just 2),Just $ Level 1 (Just 1), Nothing] @@ -50,7 +51,7 @@ , ptSeq [point2 1 1 :+ 1] , ptSeq [point2 2 2 :+ 2] ] - output' = fmap (\pts -> v2 pts pts) output + output' = fmap (\pts -> Vector2 pts pts) output -- input = v2 (f [ origin :+ 1, point2 1 1 :+ 100, point2 5 5 :+ 101 ]) -- (f [ point2 1 1 :+ 100, point2 5 5 :+ 101, origin :+ 1 ]) @@ -68,7 +69,7 @@ -- | Computes all pairs of points that are uncovered by the WSPD with separation s -uncovered :: (Floating r, Ord r, AlwaysTrueWSPD d, Ord p) +uncovered :: (Floating r, Ord r, Arity d, Arity (d+1), Ord p) => [Point d r :+ p] -> r -> SplitTree d p r a -> [(Point d r :+ p, Point d r :+ p)] uncovered pts s t = Set.toList $ allPairs `Set.difference` covered where diff --git a/test/Data/EdgeOracleSpec.hs b/test/Data/EdgeOracleSpec.hs --- a/test/Data/EdgeOracleSpec.hs +++ b/test/Data/EdgeOracleSpec.hs @@ -11,7 +11,7 @@ data TestG -type Vertex = VertexId TestG Primal_ +type Vertex = VertexId TestG Primal testEdges :: [(Vertex,[Vertex])] @@ -24,7 +24,7 @@ , (5, [3,4]) ] -buildEdgeOracle' :: [(Vertex,[Vertex])] -> EdgeOracle TestG Primal_ () +buildEdgeOracle' :: [(Vertex,[Vertex])] -> EdgeOracle TestG Primal () buildEdgeOracle' = buildEdgeOracle . map (second $ fmap ext) -- | Flattens an adjacencylist representation into a set of edges diff --git a/test/Data/Geometry/IntervalSpec.hs b/test/Data/Geometry/IntervalSpec.hs --- a/test/Data/Geometry/IntervalSpec.hs +++ b/test/Data/Geometry/IntervalSpec.hs @@ -1,24 +1,27 @@ {-# LANGUAGE ScopedTypeVariables #-} module Data.Geometry.IntervalSpec where +import Control.Lens import Data.Ext import qualified Data.Foldable as F import Data.Geometry import Data.Geometry.Box -import qualified Data.Geometry.IntervalTree as IntTree import Data.Geometry.IntervalTree (IntervalTree) -import qualified Data.Geometry.SegmentTree as SegTree +import qualified Data.Geometry.IntervalTree as IntTree import Data.Geometry.SegmentTree (SegmentTree, I(..)) +import qualified Data.Geometry.SegmentTree as SegTree import qualified Data.List.NonEmpty as NonEmpty +import Data.Range import qualified Data.Seq as Seq import qualified Data.Set as Set import GHC.TypeLits -import QuickCheck.Instances () import Test.Hspec +import Test.Hspec.QuickCheck import Test.QuickCheck +import Test.QuickCheck.HGeometryInstances () +import Test.QuickCheck.Instances () import Util - naive :: (Ord r, Foldable f) => r -> f (Interval p r) -> [Interval p r] naive q = filter (q `inInterval`) . F.toList @@ -46,19 +49,21 @@ , IntTree.fromIntervals $ F.toList is)) spec :: Spec -spec = do - describe "Same as Naive" $ do - it "quickcheck segmentTree" $ - property $ \(is :: NonEmpty.NonEmpty (Interval () Word)) -> allSameAsNaive is - it "quickcheck IntervalTree" $ - property $ \(Intervals is :: Intervals Word) -> allSameAsNaiveIT is +spec = modifyMaxSuccess (const 1000) $ do + describe "Same as Naive" $ do + it "quickcheck segmentTree" $ + property $ \(Intervals is :: Intervals Word) -> allSameAsNaive is + it "quickcheck IntervalTree" $ + property $ \(Intervals is :: Intervals Word) -> allSameAsNaiveIT is newtype Intervals r = Intervals (NonEmpty.NonEmpty (Interval () r)) deriving (Show,Eq) --- don't generate double open intervals +-- don't generate double open intervals, and don't generate intervals in which +-- one endpoint is open, the other is closed, but at the same point instance (Arbitrary r, Ord r) => Arbitrary (Intervals r) where arbitrary = Intervals . NonEmpty.fromList <$> listOf1 (suchThat arbitrary p) where p (OpenInterval _ _) = False - p _ = True + p (Interval s e) = not (isOpen s /= isOpen e + && s^.unEndPoint.core == e^.unEndPoint.core) diff --git a/test/Data/Geometry/Ipe/ReaderSpec.hs b/test/Data/Geometry/Ipe/ReaderSpec.hs --- a/test/Data/Geometry/Ipe/ReaderSpec.hs +++ b/test/Data/Geometry/Ipe/ReaderSpec.hs @@ -25,7 +25,7 @@ (show $ readXML useTxt >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double)) `shouldBe` - "Right (Attrs {_unAttrs = {GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Just (IpeColor (Valued \"black\"))}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Just (IpeSize (Named \"normal\"))}}})" + "Right (Attrs {_unAttrs = {GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Just (IpeColor (Named \"black\"))}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Just (IpeSize (Named \"normal\"))}}})" describe "IpeRead" $ do it "parses a Symbol" $ diff --git a/test/Data/Geometry/KDTreeSpec.hs b/test/Data/Geometry/KDTreeSpec.hs --- a/test/Data/Geometry/KDTreeSpec.hs +++ b/test/Data/Geometry/KDTreeSpec.hs @@ -9,7 +9,7 @@ import qualified Data.Seq as Seq import qualified Data.Set as Set import GHC.TypeLits -import QuickCheck.Instances() +import Test.QuickCheck.HGeometryInstances() import Test.Hspec import Test.QuickCheck @@ -22,7 +22,7 @@ => [Point d r :+ p] -> KDTree d p r -> Box d q r -> Bool sameAsNaive pts t q = Set.fromList (searchKDTree q t) == Set.fromList (naive q pts) -allSameAsNaive :: (Ord r, Ord p, Arity d, KnownNat d, Index' 0 d, Foldable f) +allSameAsNaive :: (Ord r, Ord p, Arity d, 1 <= d, Foldable f) => f (Point d r :+ p) -> [Box d () r] -> Bool allSameAsNaive pts = let pts' = F.toList pts in all (sameAsNaive pts' $ buildKDTree pts') diff --git a/test/Data/Geometry/LineSegmentSpec.hs b/test/Data/Geometry/LineSegmentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Geometry/LineSegmentSpec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Geometry.LineSegmentSpec where + +import Data.Ext +import Data.Geometry +import Test.Hspec +import Test.QuickCheck.HGeometryInstances () + +spec :: Spec +spec = + describe "onSegment" $ + it "handles zero length segments correctly" $ do + let zeroSegment :: LineSegment 2 () Rational + zeroSegment = ClosedLineSegment (Point2 0 0 :+ ()) (Point2 0 0 :+ ()) + (Point2 0 0 `onSegment` zeroSegment) `shouldBe` True + (Point2 1 0 `onSegment` zeroSegment) `shouldBe` False diff --git a/test/Data/Geometry/LineSpec.hs b/test/Data/Geometry/LineSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Geometry/LineSpec.hs @@ -0,0 +1,48 @@ +module Data.Geometry.LineSpec where + +import Data.Ext +import Control.Lens +import Data.Geometry +import Data.Geometry.Box +import Data.Vinyl.CoRec +import Test.Hspec +import Data.Ratio + + + + +spec :: Spec +spec = do + describe "Line x Box intersections" $ do + boxIntersections + +boxIntersections :: Spec +boxIntersections = do + it "proper intersection" $ + (lineThrough (Point2 1 5) (Point2 10 (7 :: Rational)) + `intersect` b + ) `shouldBe` + (coRec $ ClosedLineSegment (ext $ Point2 (0 :: Rational) (43 % 9)) + (ext $ Point2 14 (71 % 9)) + ) + it "boundary segment" $ + (lineThrough (Point2 0 0) (Point2 10 (0 :: Rational)) + `intersect` b + ) `shouldBe` + (coRec $ ClosedLineSegment (ext $ Point2 (0 :: Rational) 0) + (ext $ Point2 14 0) + ) + it "Touching in Point" $ + (lineThrough (Point2 0 0) (Point2 (-1) (1 :: Rational)) + `intersect` + boundingBoxList' [Point2 0 (0 :: Rational), Point2 14 9] + ) `shouldBe` + (coRec (origin :: Point 2 Rational)) + it "No Intersection" $ + (lineThrough (Point2 (-1) 0) (Point2 (-2) (2 :: Rational)) + `intersect` + boundingBoxList' [Point2 0 (0 :: Rational), Point2 14 9] + ) `shouldBe` + (coRec NoIntersection) + where + b = boundingBoxList' [Point2 0 (0 :: Rational), Point2 14 9] diff --git a/test/Data/Geometry/PlanarSubdivisionSpec.hs b/test/Data/Geometry/PlanarSubdivisionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Geometry/PlanarSubdivisionSpec.hs @@ -0,0 +1,221 @@ +module Data.Geometry.PlanarSubdivisionSpec where + + +import qualified Algorithms.Geometry.PolygonTriangulation.MakeMonotone as MM +import Data.Bifunctor (second) +import Data.Ext +import Data.Foldable (toList, forM_) +import Data.Geometry +import Data.Geometry.PlanarSubdivision +import qualified Data.Geometry.PlanarSubdivision as PS +import Data.Geometry.Polygon +import qualified Data.List.NonEmpty as NonEmpty +import Data.PlanarGraph (FaceId(..),VertexId(..)) +import qualified Data.PlaneGraph as PG +import Test.Hspec +import qualified Data.Vector as V +import qualified Data.List as L + +import qualified Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone as TM +import qualified Algorithms.Geometry.PolygonTriangulation.Triangulate as TR + +import Control.Lens hiding (holesOf) +import Data.Either (lefts) +import Data.Geometry.Ipe +import Data.Geometry.PlanarSubdivision.Draw +import Data.Maybe (fromJust) +import Data.PlaneGraph.Draw + + +data Test = Test +data Id a = Id a + + + + +simplePg = fromSimplePolygon (Id Test) simplePg' Inside Outside +simplePg' = toCounterClockWiseOrder . fromPoints $ map ext $ [ Point2 160 736 + , Point2 128 688 + , Point2 176 672 + , Point2 256 672 + , Point2 272 608 + , Point2 384 656 + , Point2 336 768 + , Point2 272 720 + ] + +triangle :: PlanarSubdivision Test () () PolygonFaceData Rational +triangle = (\pg -> fromSimplePolygon (Id Test) pg Inside Outside) + $ trianglePG + +trianglePG = fromPoints . map ext $ [origin, Point2 10 0, Point2 10 10] + + +toNonEmpty :: Foldable f => f a -> NonEmpty.NonEmpty a +toNonEmpty = NonEmpty.fromList . toList + +spec :: Spec +spec = do + describe "PlanarSubdivision" $ do + it "outerFaceId = 0 " $ + outerFaceId triangle `shouldBe` (FaceId $ VertexId 0) + it "outerFace tests" $ + let [d] = toList $ holesOf (outerFaceId triangle) triangle + in leftFace d triangle `shouldBe` (outerFaceId triangle) + testSpec testPoly + testSpec testPoly2 + testSpec testPoly3 + testSpec testPoly4 + + -- describe "incidentDarts" $ do + -- forM_ (darts' triangle) $ \d -> + -- it "incidentDarts indiv" $ + -- boundary' d triangle `shouldBe` (toNonEmpty $ edges' triangle) + -- this last test is nonsense + + +sameAsConnectedPG :: (Eq v, Eq e, Eq f, Eq r, Show v, Show e, Show f, Show r) + => PlaneGraph s v e f r -> PlanarSubdivision s v e f r + -> Spec +sameAsConnectedPG g ps = describe "connected planarsubdiv, same as PlaneGraph" $ do + it "same number of vertices" $ + PG.numVertices g `shouldBe` PS.numVertices ps + it "same number of darts" $ + PG.numDarts g `shouldBe` PS.numDarts ps + it "same number of edges" $ + PG.numEdges g `shouldBe` PS.numEdges ps + it "same number of faces" $ + PG.numFaces g `shouldBe` PS.numFaces ps + it "same vertices" $ + PG.vertices g `shouldBe` vertices ps + it "same dart data" $ + (g^.PG.rawDartData) `shouldBe` ((^.dataVal) <$> ps^.rawDartData) + -- it "same dart endpoints" $ do + describe "same darts" $ do + forM_ (darts' ps) $ \d -> + it ("sameDarts: " ++ (show d)) $ endPoints d ps `shouldBe` PG.endPoints d g + -- sameDarts g ps + it "same edges" $ + (V.fromList . L.sortOn fst . toList $ PG.edgeSegments g) `shouldBe` edgeSegments ps + it "same edges per vertex" $ + forM_ (PG.vertices' g) $ \v -> + PG.incidentEdges v g `shouldBe` PS.incidentEdges v ps + -- it "same face Id's" $ + -- PG.faces' g `shouldBe` faces' ps + -- it "same outerface boundary" $ + -- (second (FaceData mempty) + -- it "same faces" $ + -- (second (FaceData mempty) <$> PG.faces g) `shouldBe` faces ps + + +-- sameDart g ps d = + +-- sameDarts :: (Eq v, Eq e, Eq f, Eq r, Show v, Show e, Show f, Show r) +-- => PlaneGraph s v e f r -> PlanarSubdivision s v e f r +-- -> Spec +-- sameDarts g ps = +-- -- sameDart g ps + + +-- sort' = V.fromList . L.sortOn fst . toList + + + + +testSpec :: (Ord r, Eq p, Fractional r, Show r, Show p) + => SimplePolygon p r -> Spec +testSpec pg = do + sameAsConnectedPG (PG.fromSimplePolygon (Id Test) pg Inside Outside) + (PS.fromSimplePolygon (Id Test) pg Inside Outside) + -- sameAsConnectedPG (TM.triangulate' (Id Test) pg) + -- (TM.triangulate (Id Test) pg) + sameAsConnectedPG (TR.triangulate' (Id Test) pg) + (TR.triangulate (Id Test) pg) + + + +testPoly :: SimplePolygon () Rational +testPoly = toCounterClockWiseOrder . fromPoints $ map ext $ [ + Point2 128 720 + , Point2 192 752 + , Point2 224 720 + , Point2 240 672 + , Point2 128 624 + , Point2 176 672 + ] + + +testPoly2 :: SimplePolygon () Rational +testPoly2 = toCounterClockWiseOrder . fromPoints $ map ext $ [ Point2 160 736 + , Point2 128 688 + , Point2 176 672 + , Point2 256 672 + , Point2 272 608 + , Point2 384 656 + , Point2 336 768 + , Point2 272 720 + ] + + + +testPoly3 :: SimplePolygon () Rational +testPoly3 = toCounterClockWiseOrder . fromPoints $ map ext $ [ Point2 352 367 + , Point2 128 176 + , Point2 240 336 + , Point2 80 272 + , Point2 48 400 + , Point2 96 384 + , Point2 240 496 + ] + + + +testPoly4 :: SimplePolygon () Rational +testPoly4 = toCounterClockWiseOrder . fromPoints $ map ext $ [ Point2 64 544 + , Point2 320 527 + , Point2 208 496 + , Point2 48 432 + , Point2 16 560 + ] + +testPoly5 :: SimplePolygon () Rational +testPoly5 = toCounterClockWiseOrder . fromPoints $ map ext $ [ Point2 352 384 + , Point2 128 176 + , Point2 224 320 + , Point2 48 400 + , Point2 160 384 + , Point2 240 496 + ] + + +testPolyP = fromSimplePolygon (Id Test) testPoly5 Inside Outside +testPolygPlaneG = fromJust $ testPolyP^?components.ix 0 + +monotonePs = MM.makeMonotone (Id Test) testPoly5 +monotonePlaneG = fromJust $ monotonePs^?components.ix 0 + +test = TR.triangulate (Id Test) testPoly5 +test' = TR.triangulate' (Id Test) testPoly5 +-- test = asIpe drawPlaneGraph testPolygPlaneG mempty + +printMP = mapM_ printAsIpeSelection + . map (asIpeObject' mempty . (^.core) . snd) + . toList . rawFacePolygons $ monotonePs + + + +printP = mapM_ printAsIpeSelection + . map (asIpeObject' mempty . (^.core) . snd) + . toList . PG.rawFacePolygons $ test' + + +printPPX = mapM_ printAsIpeSelection + . map (asIpeObject' mempty . (^.core) . snd) + . toList . rawFacePolygons + +printPP = printPPX test + +parts' = map (\pg -> fromSimplePolygon (Id Test) pg Inside Outside) + . lefts . map ((^.core) . snd) . toList . rawFacePolygons $ monotonePs + +parts'' = lefts . map ((^.core) . snd) . toList . rawFacePolygons $ monotonePs diff --git a/test/Data/Geometry/Polygon/Convex/ConvexSpec.hs b/test/Data/Geometry/Polygon/Convex/ConvexSpec.hs --- a/test/Data/Geometry/Polygon/Convex/ConvexSpec.hs +++ b/test/Data/Geometry/Polygon/Convex/ConvexSpec.hs @@ -13,9 +13,10 @@ import Data.Geometry.Polygon.Convex import qualified Data.List.NonEmpty as NonEmpty import Data.Traversable (traverse) -import QuickCheck.Instances +import Test.QuickCheck.HGeometryInstances () import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Instances() @@ -46,7 +47,7 @@ -- | generates 360 vectors "equally" spaced/angled directions :: Num r => [Vector 2 r] -directions = map (fmap toRat . uncurry v2 . (cos &&& sin) . toRad) ([0..359] :: [Double]) +directions = map (fmap toRat . uncurry Vector2 . (cos &&& sin) . toRad) ([0..359] :: [Double]) where toRad i = i * (pi / 180) toRat x = fromIntegral . round $ 100000 * x diff --git a/test/Data/Geometry/SubLineSpec.hs b/test/Data/Geometry/SubLineSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Geometry/SubLineSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Geometry.SubLineSpec where + +import Control.Lens +import Data.Ext +import Data.Geometry +import Data.Geometry.Line +import Data.Geometry.LineSegment +import Data.Geometry.SubLine +import Data.Ratio +import Data.UnBounded +import Data.Vinyl.CoRec +import Test.QuickCheck.HGeometryInstances () +import Test.Hspec +import Test.QuickCheck + + +spec :: Spec +spec = do + describe "subLineTests" $ + it "subline specialization in R^2" $ + property $ \(alpha :: Rational) l@(Line p v) (i :: Interval () Rational) -> + let q = p .+^ alpha *^ v + sl = SubLine l i + in onSubLineOrig q sl `shouldBe` onSubLine2 q sl + + it "manual test " $ + ((Point2 (-1) (-1 :: Rational)) `onSubLine2` + (seg^._SubLine)) + `shouldBe` False + + it "Intersection test" $ + let mySeg = Val <$> ClosedLineSegment (ext origin) (ext $ Point2 (14 :: Rational) 0) + mySeg' = mySeg^._SubLine + myLine = fromLine $ lineThrough (Point2 0 0) (Point2 10 (0 :: Rational)) + in (myLine `intersect` mySeg') + `shouldBe` + coRec (myLine&subRange .~ ClosedInterval (ext $ Val 0) (ext . Val $ 7 % 5)) + + + +seg :: LineSegment 2 () Rational +seg = ClosedLineSegment (ext (Point2 1 1)) (ext (Point2 5 5)) + + + +-- | Original def of onSubline +onSubLineOrig :: (Ord r, Fractional r, Arity d) + => Point d r -> SubLine d p r -> Bool +onSubLineOrig p (SubLine l r) = toOffset p l `inInterval` r diff --git a/test/Data/OrdSeqSpec.hs b/test/Data/OrdSeqSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OrdSeqSpec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.OrdSeqSpec where + +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.OrdSeq (OrdSeq) +import qualified Data.OrdSeq as OrdSeq +import Data.Semigroup +import Test.QuickCheck.HGeometryInstances +import Test.Hspec +import Test.QuickCheck + +spec :: Spec +spec = do + describe "OrdSeq tests" $ do + it "fromListBy" $ + property $ \(xs :: [Int]) -> + F.toList (OrdSeq.fromListBy compare xs) `shouldBe` List.sort xs + it "splitOn, <" $ + property $ \x (xs :: OrdSeq Int) -> + let (l,_,_) = OrdSeq.splitOn id x xs + in all (< x) l + it "splitOn, ==" $ + property $ \x (xs :: OrdSeq Int) -> + let (_,m,_) = OrdSeq.splitOn id x xs + in all (== x) m + it "splitOn, >=" $ + property $ \x (xs :: OrdSeq Int) -> + let (_,_,r) = OrdSeq.splitOn id x xs + in all (> x) r + it "join" $ + property $ \x (xs :: [Int]) -> let (ys,zs) = List.partition (<= x) $ xs in + (F.toList $ OrdSeq.fromListByOrd ys <> OrdSeq.fromListByOrd zs) + `shouldBe` + List.sort (ys <> zs) + it "positive member" $ + property $ \(xs :: OrdSeq Int) -> + all (\x -> OrdSeq.memberBy compare x xs) xs + it "member" $ + property $ \x (xs :: OrdSeq Int) -> + OrdSeq.memberBy compare x xs + `shouldBe` + F.elem x (F.toList xs) + it "lookupMin" $ + property $ \(xs :: OrdSeq Int) -> + OrdSeq.lookupMin xs + `shouldBe` + (safe minimum $ F.toList xs) + it "lookupMax" $ + property $ \(xs :: OrdSeq Int) -> + OrdSeq.lookupMax xs + `shouldBe` + (safe maximum $ F.toList xs) + + +safe :: ([t] -> a) -> [t] -> Maybe a +safe _ [] = Nothing +safe f xs = Just . f $ xs diff --git a/test/Data/PlanarGraphSpec.hs b/test/Data/PlanarGraphSpec.hs --- a/test/Data/PlanarGraphSpec.hs +++ b/test/Data/PlanarGraphSpec.hs @@ -15,7 +15,7 @@ data TestG -type Vertex = VertexId TestG Primal_ +type Vertex = VertexId TestG Primal -- | Report all adjacnecies from g missing in h missingAdjacencies :: PlanarGraph s w v e f -> PlanarGraph s w v e f @@ -59,15 +59,15 @@ -- u < v, to arcId's. -- - a: the next available unused arcID -- - x: the data value we are interested in computing -type STR' s b = STR (SM.Map (VertexId s Primal_,VertexId s Primal_) Int) Int b +type STR' s b = STR (SM.Map (VertexId s Primal,VertexId s Primal) Int) Int b -- | Construct a planar graph from a adjacency matrix. For every vertex, all -- vertices should be given in counter clockwise order. -- -- running time: $O(n \log n)$. fromAdjacencyListsOld :: forall s f.(Foldable f, Functor f) - => [(VertexId s Primal_, f (VertexId s Primal_))] - -> PlanarGraph s Primal_ () () () + => [(VertexId s Primal, f (VertexId s Primal))] + -> PlanarGraph s Primal () () () fromAdjacencyListsOld adjM = planarGraph' . toCycleRep n $ perm where n = sum . fmap length $ perm @@ -77,7 +77,7 @@ -- | Given a vertex with its adjacent vertices (u,vs) (in CCW order) convert this -- vertex with its adjacent vertices into an Orbit toOrbit :: Foldable f - => (VertexId s Primal_, f (VertexId s Primal_)) + => (VertexId s Primal, f (VertexId s Primal)) -> STR' s [[Dart s]] -> STR' s [[Dart s]] toOrbit (u,vs) (STR m a dss) = @@ -87,7 +87,7 @@ -- | Given an edge (u,v) and a triplet (m,a,ds) we construct a new dart -- representing this edge. - toDart :: (VertexId s Primal_,VertexId s Primal_) + toDart :: (VertexId s Primal,VertexId s Primal) -> STR' s [Dart s] -> STR' s [Dart s] toDart (u,v) (STR m a ds) = let dir = if u < v then Positive else Negative diff --git a/test/Data/RangeSpec.hs b/test/Data/RangeSpec.hs --- a/test/Data/RangeSpec.hs +++ b/test/Data/RangeSpec.hs @@ -2,34 +2,31 @@ import Data.Geometry.Properties import Data.Range -import Frames.CoRec import Test.Hspec spec :: Spec spec = do describe "RangeRange Intersection" $ do - -- it "openRange cap openrange" $ do - -- ((OpenRange 1 (10 :: Int)) `intersect` (OpenRange 5 (10 :: Int))) - -- `shouldBe` (coRec $ OpenRange 5 (10 :: Int)) - -- it "disjoint open ranges" $ do - -- ((OpenRange 1 10) `intersect` (OpenRange 10 12)) - -- `shouldBe` (coRec NoIntersection) - -- it "closed cap open, disjoint" $ do - -- ((ClosedRange (1::Int) 10) `intersect` (OpenRange 50 (60 :: Int))) - -- `shouldBe` (coRec NoIntersection) + it "openRange cap openrange" $ do + ((OpenRange 1 (10 :: Int)) `intersect` (OpenRange 5 (10 :: Int))) + `shouldBe` (coRec $ OpenRange 5 (10 :: Int)) + it "disjoint open ranges" $ do + ((OpenRange 1 (10 :: Int)) `intersect` (OpenRange 10 (12 :: Int))) + `shouldBe` (coRec NoIntersection) + it "closed cap open, disjoint" $ do + ((ClosedRange (1::Int) 10) `intersect` (OpenRange 50 (60 :: Int))) + `shouldBe` (coRec NoIntersection) -- it "closed intersect open" $ - -- ((OpenRange 1 10) `intersect` (ClosedRange 10 12)) - -- `shouldBe` (coRec $ Range (Open 5) (Closed 10)) + -- ((OpenRange 1 (10 :: Int)) `intersect` (ClosedRange 10 (12 :: Int))) + -- `shouldBe` (coRec NoIntersection) - -- it "open rage intersect closed " $ - -- (OpenRange 1 10) `intersect` (ClosedRange 10 12) - -- `shouldBe` (coRec $ Range (Open 10) (Open 10)) + -- it "open rage intersect closed " $ do + -- ((OpenRange 1 (10 :: Int)) `intersect` (ClosedRange 10 (12 :: Int))) + -- `shouldBe` (coRec $ Range (Open 10) (Open (10 :: Int))) -- (Col Range {_lower = Closed 10, _upper = Open 10}) -- >>> (OpenRange 1 10) `intersect` (ClosedRange 10 12) - it "returns the first element of a list" $ do - head [23 ..] `shouldBe` (23 :: Int) -- it "closed open " $ do -- ((ClosedRange 1 10) `intersect` (OpenRange 5 10)) diff --git a/test/QuickCheck/Instances.hs b/test/QuickCheck/Instances.hs deleted file mode 100644 --- a/test/QuickCheck/Instances.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module QuickCheck.Instances where - -import Control.Lens -import Data.BinaryTree -import Data.Ext -import Data.Geometry hiding (vector) -import Data.Geometry.Box -import Data.Geometry.Interval -import Data.Geometry.SubLine -import Data.Geometry.Vector -import qualified Data.List.NonEmpty as NonEmpty -import Data.Proxy -import Data.Range -import Data.Semigroup -import qualified Data.Seq as Seq -import qualified Data.Seq2 as S2 -import GHC.TypeLits -import Test.QuickCheck - --------------------------------------------------------------------------------- - --- instance Arbitrary a => Arbitrary (NonEmpty.NonEmpty a) where --- arbitrary = NonEmpty.fromList <$> listOf1 arbitrary - -instance Arbitrary a => Arbitrary (S2.Seq2 a) where - arbitrary = S2.Seq2 <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary a => Arbitrary (BinaryTree a) where - arbitrary = sized f - where f n | n <= 0 = pure Nil - | otherwise = do - l <- choose (0,n-1) - Internal <$> f l <*> arbitrary <*> f (n-l-1) - -instance (Arbitrary a, Arbitrary v) => Arbitrary (BinLeafTree v a) where - arbitrary = sized f - where f n | n <= 0 = Leaf <$> arbitrary - | otherwise = do - l <- choose (0,n-1) - Node <$> f l <*> arbitrary <*> f (n-l-1) - - -instance (KnownNat n, Arbitrary a) => Arbitrary (Seq.LSeq n a) where - arbitrary = (\s s' -> Seq.promise . Seq.fromList $ s <> s') - <$> vector (fromInteger . natVal $ (Proxy :: Proxy n)) - <*> arbitrary - -instance (Arbitrary r, Arity d) => Arbitrary (Vector d r) where - arbitrary = vectorFromListUnsafe <$> infiniteList - -instance (Arbitrary r, Arity d) => Arbitrary (Point d r) where - arbitrary = Point <$> arbitrary - -instance (Arbitrary r, Arity d, Num r) => Arbitrary (Line d r) where - arbitrary = lineThrough <$> arbitrary <*> arbitrary - -instance (Arbitrary r, Arity d, Ord r) => Arbitrary (Box d () r) where - arbitrary = (\p (q :: Point d r) -> boundingBoxList' [p,q]) <$> arbitrary <*> arbitrary - - -instance Arbitrary r => Arbitrary (EndPoint r) where - arbitrary = frequency [ (1, Open <$> arbitrary) - , (9, Closed <$> arbitrary) - ] - -instance (Arbitrary r, Ord r) => Arbitrary (Range r) where - arbitrary = do - l <- arbitrary - r <- suchThat arbitrary (p l) - return $ Range l r - where - p (Open l) r = l < r^.unEndPoint - p (Closed l) r = l <= r^.unEndPoint - - -instance (Arbitrary c, Arbitrary e) => Arbitrary (c :+ e) where - arbitrary = (:+) <$> arbitrary <*> arbitrary - -instance (Arbitrary r, Arbitrary p, Ord r, Ord p) => Arbitrary (Interval p r) where - arbitrary = GInterval <$> arbitrary - - -instance (Arbitrary r, Arbitrary p, Arity d, Ord r, Ord p, Num r) - => Arbitrary (SubLine d p r) where - arbitrary = SubLine <$> arbitrary <*> arbitrary - - -instance (Arbitrary r, Arbitrary p, Arity d) => Arbitrary (LineSegment d p r) where - arbitrary = LineSegment <$> arbitrary <*> arbitrary diff --git a/test/Util.hs b/test/Util.hs --- a/test/Util.hs +++ b/test/Util.hs @@ -6,8 +6,10 @@ import Data.Ext import Data.Function(on) import qualified Data.List as L +import Data.Singletons(Apply) -byStrokeColour :: (Stroke ∈ AttributesOf g) => [IpeObject' g r] -> [[IpeObject' g r]] +byStrokeColour :: (Stroke ∈ ats, Ord (Apply f Stroke)) + => [a :+ Attributes f ats] -> [[a :+ Attributes f ats]] byStrokeColour = map (map fst) . L.groupBy ((==) `on` snd) . L.sortOn snd . map (\x -> (x,lookup' x)) where @@ -22,3 +24,9 @@ diffBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] diffBy p xs ys = foldr (L.deleteBy p) ys xs + +-- | \(O(n^2)\) set that ignores duplicates and order +newtype NaiveSet a = NaiveSet [a] deriving (Show) + +instance Eq a => Eq (NaiveSet a) where + (NaiveSet xs) == (NaiveSet ys) = L.null $ difference xs ys