diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -2,6 +2,16 @@ * Changelog +** 0.14 + +- Got rid of proxies to build planar graphs, use TypeApplication + instead. Also slightly changed some of the types to better reflect + what they need; in particular 'buildGraph' now takes only the + adjacency lists (no face information). And 'fromAdjRep' which + computes a PlanarGraph from its adjacencylists (including vertex and + edge info.) +- Cleaning up the public API by hiding several internal modules. + ** 0.13 - Moved 'intersects' from the HasIntersectionWith class into a new diff --git a/changelog.org b/changelog.org --- a/changelog.org +++ b/changelog.org @@ -2,6 +2,16 @@ * Changelog +** 0.14 + +- Got rid of proxies to build planar graphs, use TypeApplication + instead. Also slightly changed some of the types to better reflect + what they need; in particular 'buildGraph' now takes only the + adjacency lists (no face information). And 'fromAdjRep' which + computes a PlanarGraph from its adjacencylists (including vertex and + edge info.) +- Cleaning up the public API by hiding several internal modules. + ** 0.13 - Moved 'intersects' from the HasIntersectionWith class into a new diff --git a/hgeometry-combinatorial.cabal b/hgeometry-combinatorial.cabal --- a/hgeometry-combinatorial.cabal +++ b/hgeometry-combinatorial.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hgeometry-combinatorial -version: 0.13 +version: 0.14 synopsis: Data structures, and Data types. description: The Non-geometric data types and algorithms used in HGeometry. @@ -110,10 +110,8 @@ Data.PlanarGraph.Immutable Data.PlanarGraph.AdjRep Data.PlanarGraph.IO - Data.PlanarGraph.Dart - Data.PlanarGraph.Core - Data.PlanarGraph.Dual Data.PlanarGraph.EdgeOracle + Data.PlanarGraph.Dart -- * Other System.Random.Shuffle @@ -125,7 +123,10 @@ Data.Yaml.Util other-modules: Data.PlanarGraph.Internal + Data.PlanarGraph.Core + Data.PlanarGraph.Dual + -- other-extensions: build-depends: base >= 4.11 && < 5 @@ -154,7 +155,7 @@ , vector >= 0.11 , data-clist >= 0.1.2.3 - , vector-circular >= 0.1.2 + , vector-circular >= 0.1.4 , nonempty-vector >= 0.2.0.0 , vector-builder >= 0.3.7 , unordered-containers diff --git a/src/Algorithms/BinarySearch.hs b/src/Algorithms/BinarySearch.hs --- a/src/Algorithms/BinarySearch.hs +++ b/src/Algorithms/BinarySearch.hs @@ -9,12 +9,12 @@ module Algorithms.BinarySearch where import Control.Applicative ((<|>)) +import Data.Kind import Data.Sequence (Seq, ViewL(..),ViewR(..)) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set.Internal as Set import qualified Data.Vector.Generic as V - -------------------------------------------------------------------------------- -- | Given a monotonic predicate p, a lower bound l, and an upper bound u, with: @@ -69,8 +69,8 @@ class BinarySearch v where - type Index v :: * - type Elem v :: * + type Index v :: Type + type Elem v :: Type -- | Given a monotonic predicate p and a data structure v, find the -- element v[h] such that that diff --git a/src/Data/DynamicOrd.hs b/src/Data/DynamicOrd.hs --- a/src/Data/DynamicOrd.hs +++ b/src/Data/DynamicOrd.hs @@ -8,6 +8,7 @@ -------------------------------------------------------------------------------- module Data.DynamicOrd where +import Data.Kind import Data.Proxy import Data.Reflection import Unsafe.Coerce @@ -18,7 +19,7 @@ -- https://www.schoolofhaskell.com/user/thoughtpolice/using-reflection -- | Values of type '@a@' in our dynamically constructed 'Ord' instance -newtype O (s :: *) (a :: *) = O { runO :: a } deriving (Show) +newtype O (s :: Type) (a :: Type) = O { runO :: a } deriving (Show) -- | An Ord Dictionary newtype OrdDict a = OrdDict { compare_ :: a -> a -> Ordering } diff --git a/src/Data/PlanarGraph/IO.hs b/src/Data/PlanarGraph/IO.hs --- a/src/Data/PlanarGraph/IO.hs +++ b/src/Data/PlanarGraph/IO.hs @@ -25,7 +25,6 @@ import Data.PlanarGraph.Dart import Data.PlanarGraph.Dual import Data.PlanarGraph.EdgeOracle -import Data.Proxy import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV @@ -36,7 +35,7 @@ toJSON = toJSON . toAdjRep instance (FromJSON v, FromJSON e, FromJSON f) => FromJSON (PlanarGraph s Primal v e f) where - parseJSON v = fromAdjRep (Proxy :: Proxy s) <$> parseJSON v + parseJSON v = fromAdjRep @s <$> parseJSON v -------------------------------------------------------------------------------- @@ -71,13 +70,13 @@ -- should be in counter clockwise order. -- -- running time: \(O(n)\) -fromAdjRep :: proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s Primal v e f -fromAdjRep px gr@(Gr as fs) = g&vertexData .~ reorder vs' _unVertexId - &dartData .~ ds - &faceData .~ reorder fs' (_unVertexId._unFaceId) +fromAdjRep :: forall s v e f. Gr (Vtx v e) (Face f) -> PlanarGraph s Primal v e f +fromAdjRep (Gr as fs) = g&vertexData .~ reorder vs' _unVertexId + &dartData .~ ds + &faceData .~ reorder fs' (_unVertexId._unFaceId) where -- build the actual graph using the adjacencies - g = buildGraph px gr + g = buildGraph as -- build an edge oracle so that we can quickly lookup the dart corresponding to a -- pair of vertices. oracle = edgeOracle g @@ -95,13 +94,39 @@ -- TODO: Properly handle graphs with self-loops +-- | Read a planar graph, given by its adjacencylists in counter clockwise order. +-- +-- pre: no self-loops and no multiedges +-- +-- running time: \(O(n)\) +fromAdjRep' :: forall s v e. [Vtx v e] -> PlanarGraph s Primal v e () +fromAdjRep' as = g&vertexData .~ reorder vs' _unVertexId + &dartData .~ ds + where + -- build the actual graph using the adjacencies + g = buildGraph as + -- build an edge oracle so that we can quickly lookup the dart corresponding to a + -- pair of vertices. + oracle = edgeOracle g + -- function to lookup a given dart + findEdge' u v = fromJust $ findDart u v oracle + + vs' = V.fromList [ VertexId vi :+ v | Vtx vi _ v <- as ] + ds = V.fromList $ concatMap (\(Vtx vi us _) -> + [(findEdge' (VertexId vi) (VertexId ui), x) | (ui,x) <- us] + ) as + + -- TODO: Properly handle graphs with self-loops + + -- | Builds the graph from the adjacency lists (but ignores all associated data) -buildGraph :: proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s Primal () () () -buildGraph _ (Gr as' _) = fromAdjacencyLists as +buildGraph :: forall s v e. [Vtx v e] -> PlanarGraph s Primal () () () +buildGraph as' = fromAdjacencyLists as where as = [ (VertexId vi, V.fromList [VertexId ui | (ui,_) <- us]) | Vtx vi us _ <- as' ] + -- make sure we order the data values appropriately reorder :: V.Vector (i :+ a) -> (i -> Int) -> V.Vector a diff --git a/src/Data/Range.hs b/src/Data/Range.hs --- a/src/Data/Range.hs +++ b/src/Data/Range.hs @@ -23,6 +23,7 @@ , shiftLeft, shiftRight ) where +import Control.Monad((<=<)) import Control.DeepSeq import Control.Lens import Control.Applicative @@ -215,8 +216,9 @@ -- The intersection is empty, if after clipping, the order of the end points is inverted -- or if the endpoints are the same, but both are open. - (Range l u) `intersect` s = let i = clipLower' l . clipUpper' u $ s - in if isValidRange i then coRec i else coRec NoIntersection + (Range l u) `intersect` s = case (clipLower l <=< clipUpper u $ s) of + Nothing -> coRec NoIntersection + Just i -> coRec i -- | Get the width of the interval -- @@ -258,63 +260,45 @@ -- | Clip the interval from below. I.e. intersect with the interval {l,infty), -- where { is either open, (, orr closed, [. clipLower :: Ord a => EndPoint a -> Range a -> Maybe (Range a) -clipLower l r = let r' = clipLower' l r in if isValidRange r' then Just r' else Nothing +clipLower p rr@(Range l r) = case (p^.unEndPoint) `compare` (r^.unEndPoint) of + GT -> Nothing + EQ | isOpen r || isOpen p -> Nothing + _ -> Just $ + case (p^.unEndPoint) `compare` (l^.unEndPoint) of + LT -> rr + EQ -> if isOpen p then Range p r else rr + GT -> Range p r -- | Clip the interval from above. I.e. intersect with (-\infty, u}, where } is -- either open, ), or closed, ], clipUpper :: Ord a => EndPoint a -> Range a -> Maybe (Range a) -clipUpper u r = let r' = clipUpper' u r in if isValidRange r' then Just r' else Nothing +clipUpper p (Range l r) = case (p^.unEndPoint) `compare` (l^.unEndPoint) of + LT -> Nothing + EQ | isOpen l || isOpen p -> Nothing + _ -> Just $ Range l (p `min` r) + -- | Wether or not the first range completely covers the second one covers :: forall a. Ord a => Range a -> Range a -> Bool x `covers` y = (== Just y) . asA @(Range a) $ x `intersect` y - -- | Check if the range is valid and nonEmpty, i.e. if the lower endpoint is -- indeed smaller than the right endpoint. Note that we treat empty open-ranges -- as invalid as well. +-- +-- >>> isValidRange $ Range (Open 4) (Closed 4) +-- False +-- >>> isValidRange $ Range (Open 5) (Closed 4) +-- False +-- >>> isValidRange $ Range (Open 4) (Closed 5) +-- True +-- >>> isValidRange $ Range (Closed 5) (Closed 40) +-- True isValidRange :: Ord a => Range a -> Bool isValidRange (Range l u) = case _unEndPoint l `compare` _unEndPoint u of LT -> True - EQ | isClosed l || isClosed u -> True + EQ | isClosed l && isClosed u -> True _ -> False - --- operation is unsafe, as it may produce an invalid range (where l > u) -clipLower' :: Ord a => EndPoint a -> Range a -> Range a -clipLower' l' r@(Range l u) = case l' `cmpLower` l of - GT -> Range l' u - _ -> r --- operation is unsafe, as it may produce an invalid range (where l > u) -clipUpper' :: Ord a => EndPoint a -> Range a -> Range a -clipUpper' u' r@(Range l u) = case u' `cmpUpper` u of - LT -> Range l u' - _ -> r - --- | Compare end points, Closed < Open -cmpLower :: Ord a => EndPoint a -> EndPoint a -> Ordering -cmpLower a b = case _unEndPoint a `compare` _unEndPoint b of - LT -> LT - GT -> GT - EQ -> case (a,b) of - (Open _, Open _) -> EQ -- if both are same type, report EQ - (Closed _, Closed _) -> EQ - (Open _, _) -> GT -- otherwise, choose the Closed one - (Closed _,_) -> LT -- is the *smallest* - - --- | Compare the end points, Open < Closed -cmpUpper :: Ord a => EndPoint a -> EndPoint a -> Ordering -cmpUpper a b = case _unEndPoint a `compare` _unEndPoint b of - LT -> LT - GT -> GT - EQ -> case (a,b) of - (Open _, Open _) -> EQ -- if both are same type, report EQ - (Closed _, Closed _) -> EQ - (Open _, _) -> LT -- otherwise, choose the Closed one - (Closed _,_) -> GT -- is the *largest* - - - -------------------------------------------------------------------------------- diff --git a/test/Algorithms/Graph/DFSSpec.hs b/test/Algorithms/Graph/DFSSpec.hs --- a/test/Algorithms/Graph/DFSSpec.hs +++ b/test/Algorithms/Graph/DFSSpec.hs @@ -5,7 +5,7 @@ import Control.DeepSeq (NFData (rnf)) import Control.Exception (evaluate) import qualified Data.Foldable as F -import Data.PlanarGraph.Core (VertexId (VertexId), World (Primal)) +import Data.PlanarGraph (VertexId (VertexId), World (Primal)) import qualified Data.Set as S import Data.Tree (Tree (rootLabel, subForest)) import Test.Hspec (Spec, anyErrorCall, describe, it, shouldBe, shouldThrow) diff --git a/test/Algorithms/LogarithmicMethodSpec.hs b/test/Algorithms/LogarithmicMethodSpec.hs --- a/test/Algorithms/LogarithmicMethodSpec.hs +++ b/test/Algorithms/LogarithmicMethodSpec.hs @@ -33,13 +33,13 @@ instance Ord a => LogarithmicMethodDS DummySucc a where build = Dummy . NonEmpty.sort -successor' :: Ord a => a -> DummySucc a -> Option (Min a) +successor' :: Ord a => a -> DummySucc a -> Maybe (Min a) successor' q (Dummy xs) = case NonEmpty.dropWhile (< q) xs of - [] -> Option Nothing - (s:_) -> Option (Just (Min s)) + [] -> Nothing + (s:_) -> Just (Min s) successor :: Ord a => a -> InsertionOnly DummySucc a -> Maybe a -successor q = fmap getMin . getOption . queryWith (successor' q) +successor q = fmap getMin . queryWith (successor' q) fromList :: Ord a => [a] -> InsertionOnly DummySucc a fromList = foldr insert empty diff --git a/test/Data/EdgeOracleSpec.hs b/test/Data/EdgeOracleSpec.hs --- a/test/Data/EdgeOracleSpec.hs +++ b/test/Data/EdgeOracleSpec.hs @@ -3,7 +3,7 @@ import Control.Arrow import Data.Ext import Data.PlanarGraph.EdgeOracle -import Data.PlanarGraph.Core +import Data.PlanarGraph import Data.Semigroup import qualified Data.Set as S import Test.Hspec diff --git a/test/Data/RangeSpec.hs b/test/Data/RangeSpec.hs --- a/test/Data/RangeSpec.hs +++ b/test/Data/RangeSpec.hs @@ -18,6 +18,11 @@ it "closed cap open, disjoint" $ do ((ClosedRange (1::Int) 10) `intersect` (OpenRange 50 (60 :: Int))) `shouldBe` (coRec NoIntersection) + it "endpoints overlap but open/closed" $ do + let r1, r2 :: Range Int + r1 = ClosedRange 3 6 + r2 = Range (Open 1) (Open 3) + in (r1 `intersects` r2) `shouldBe` False -- it "closed intersect open" $ -- ((OpenRange 1 (10 :: Int)) `intersect` (ClosedRange 10 (12 :: Int))) -- `shouldBe` (coRec NoIntersection)