hgeometry-combinatorial 0.12.0.3 → 0.13

raw patch · 19 files changed

+525/−162 lines, 19 filesdep ~semigroupoidsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: semigroupoids

API changes (from Hackage documentation)

Files

• changelog +10/−0
• changelog.org +10/−0
• hgeometry-combinatorial.cabal +9/−2
• src/Algorithms/LogarithmicMethod.hs +151/−0
• src/Data/Ext.hs +4/−0
• src/Data/Ext/Multi.hs +0/−62
• src/Data/Intersection.hs +6/−4
• src/Data/LSeq.hs +7/−1
• src/Data/PlanarGraph.hs +8/−4
• src/Data/PlanarGraph/AdjRep.hs +3/−3
• src/Data/PlanarGraph/Core.hs +139/−25
• src/Data/PlanarGraph/Dual.hs +83/−23
• src/Data/PlanarGraph/IO.hs +3/−1
• src/Data/PlanarGraph/Immutable.hs +12/−6
• src/Data/PlanarGraph/Mutable.hs +31/−29
• src/Data/Range.hs +1/−0
• src/Data/Set/Util.hs +1/−1
• test/Algorithms/DivideAndConquerSpec.hs +2/−1
• test/Algorithms/LogarithmicMethodSpec.hs +45/−0

@@ -2,6 +2,16 @@  * Changelog +** 0.13++- Moved 'intersects' from the HasIntersectionWith class into a new+  class IsIntersectableWith. This allows separate (weaker) constraints+  for checking *if* geometries intersect rather than computing exact+  intersections.+- Bug fixes in the orientations of boundaries in PlanarGraph.+- Implementation of Logaritmic Method, wich allows us to transform a+  static data structure into an insertion only data structure+ ** 0.12  - Add Data.Double.Approximate: Floating point numbers take take

@@ -2,6 +2,16 @@  * Changelog +** 0.13++- Moved 'intersects' from the HasIntersectionWith class into a new+  class IsIntersectableWith. This allows separate (weaker) constraints+  for checking *if* geometries intersect rather than computing exact+  intersections.+- Bug fixes in the orientations of boundaries in PlanarGraph.+- Implementation of Logaritmic Method, wich allows us to transform a+  static data structure into an insertion only data structure+ ** 0.12  - Add Data.Double.Approximate: Floating point numbers take take

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                hgeometry-combinatorial-version:             0.12.0.3+version:             0.13 synopsis:            Data structures, and Data types. description:     The Non-geometric data types and algorithms used in HGeometry.@@ -46,6 +46,7 @@                     -- * Algorithmic Strategies                     Algorithms.DivideAndConquer                     Algorithms.BinarySearch+                    Algorithms.LogarithmicMethod                      -- * Graph Algorithms                     Algorithms.Graph.DFS@@ -56,6 +57,9 @@                      Algorithms.StringSearch.KMP +++                     -- * Numeric Data Types                     Data.RealNumber.Rational                     Data.Double.Approximate@@ -72,7 +76,7 @@                     Data.Range                      Data.Ext-                    Data.Ext.Multi+                    -- Data.Ext.Multi                      Data.LSeq                     Data.CircularSeq@@ -129,6 +133,7 @@               , bifunctors              >= 4.1               , bytestring              >= 0.10               , containers              >= 0.5.9+              -- , data-default               , dlist                   >= 0.7               , lens                    >= 4.18               , contravariant           >= 1.5@@ -223,6 +228,7 @@    other-modules: Algorithms.StringSearch.KMPSpec                  Algorithms.DivideAndConquerSpec+                 Algorithms.LogarithmicMethodSpec                  Algorithms.Graph.DFSSpec                  Algorithms.Graph.BFSSpec                  Data.RangeSpec@@ -254,6 +260,7 @@                       , directory                       , yaml                       , MonadRandom+                      , semigroupoids   -- -- Such a mess:   -- if impl(ghc == 9.*)   --   build-depends:      singletons              == 3.*

@@ -0,0 +1,151 @@+{-# LANGUAGE DefaultSignatures #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Algorithms.LogarithmicMethod+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--------------------------------------------------------------------------------+module Algorithms.LogarithmicMethod+  ( InsertionOnly(..)+  , empty+  , LogarithmicMethodDS(..)+  , insert+  , queryWith+  )+  where++import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (mapMaybe)+import Data.Semigroup.Foldable++--------------------------------------------------------------------------------++-- | Represents an insertion-only data structure built from static+-- data structures.+--+-- In particular, we maintain \(O(\log n)\) static data structures of+-- sizes \(2^i\), for \(i \in [0..c\log n]\).+newtype InsertionOnly static a = InsertionOnly [Maybe (static a)]+  deriving (Show,Eq,Ord)++-- | Builds an empty structure+empty :: InsertionOnly static a+empty = InsertionOnly []++instance Functor static => Functor (InsertionOnly static) where+  fmap f (InsertionOnly dss) = InsertionOnly $ map (fmap (fmap f)) dss++instance Traversable static => Traversable (InsertionOnly static) where+  traverse f (InsertionOnly dss) = InsertionOnly <$> traverse (traverse (traverse f)) dss++instance Foldable static => Foldable (InsertionOnly static) where+  foldMap f = queryWith (foldMap f)+  length = sum . mapMaybe (uncurry (<$)) . withSizes++instance LogarithmicMethodDS static a => Semigroup (InsertionOnly static a) where+  (InsertionOnly ds1) <> (InsertionOnly ds2) = InsertionOnly $ runMergeWith Nothing ds1 0 ds2 0++instance LogarithmicMethodDS static a => Monoid (InsertionOnly static a) where+  mempty = empty+++class LogarithmicMethodDS static a where+  {-# MINIMAL build #-}+  -- | Create a new static data structure storing only one value.+  singleton :: a          -> static a+  singleton = build . (:| [])++  -- | Given a NonEmpty list of a's build a static a.+  build     :: NonEmpty a -> static a++  -- | Merges two structurs of the same size. Has a default+  -- implementation via build in case the static structure is Foldable1.+  merge     :: static a   -> static a -> static a+  default merge :: Foldable1 static => static a -> static a -> static a+  merge as bs = build $ toNonEmpty as <> toNonEmpty bs+++type Power = Word++-- | 2^h, for whatever value h.+pow2   :: Integral i => Power -> i+pow2 h = 2 ^ h++-- | Annotate the data structures with their sizes+withSizes                     :: Integral i => InsertionOnly static a -> [(i,Maybe (static a))]+withSizes (InsertionOnly dss) = zipWith (\i ds -> (pow2 i,ds))  [0..] dss++-- | Inserts an element into the data structure+--+-- running time: \(O(M(n)\log n / n)\), where \(M(n)\) is the time+-- required to merge two data structures of size \(n\).+insert                       :: LogarithmicMethodDS static a+                             => a -> InsertionOnly static a -> InsertionOnly static a+insert x (InsertionOnly dss) = InsertionOnly $ runMerge (singleton x) 0 0 dss++-- | Runs the merging procedure. If there are two data structures of+-- the same size they are merged.+runMerge         :: LogarithmicMethodDS static a+                 => static a -- ^ ds1+                 -> Power    -- ^ ds1 has size 2^i+                 -> Power    -- ^ the first entry in the next list corresponds to size 2^j+                 -> [Maybe (static a)] -> [Maybe (static a)]+runMerge ds1 i j = \case+  []                                -> [Just ds1]+  dss@(Nothing  : dss') | i == j    -> Just ds1 : dss' -- replace+                        | otherwise -> Just ds1 : dss  -- cons+  dss@(Just ds2 : dss') | i == j    -> Nothing : runMerge (ds1 `merge` ds2) (i+1) (j+1) dss'+                        | otherwise -> Just ds1 : dss -- cons -- I don't think insert can ever+                                                              -- trigger this scenario.++-- | merges two structures (potentially with a carry)+--+-- invariant: size carry == size ds1 <= size ds2+runMergeWith                ::  LogarithmicMethodDS static a+                            => Maybe (static a) -- ^ carry, if it exists+                            -> [Maybe (static a)] -> Power+                            -- ^ size of the first ds+                            -> [Maybe (static a)] -> Power+                            -- ^ size of the second ds+                            -> [Maybe (static a)]+runMergeWith mc ds1 i ds2 j = case (ds1,ds2) of+  ([],_)            -> case mc of+                         Nothing  -> ds2+                         Just c   -> runMerge c i j ds2+  (_,[])            -> case mc of+                         Nothing  -> ds1+                         Just c   -> runMerge c i i ds1+  (m1:ds1',m2:ds2') -> case (m1,m2) of+    (Nothing,Nothing) -> mc : runMergeWith Nothing ds1' (i+1) ds2' (j+1)+    (Nothing,Just d2) -> case mc of+         Nothing | i == j    -> m2 : runMergeWith Nothing ds1' (i+1) ds2' (j+1)+                 | otherwise -> m1 : runMergeWith Nothing ds1' (i+1) ds2 j+         Just c  | i == j    -> Nothing : runMergeWith (Just $ c `merge` d2) ds1' (i+1) ds2' (j+1)+                 | otherwise -> mc : runMergeWith Nothing ds1' (i+1) ds2 j+                   -- i < j, so invariant (i+1) <= j again holds holds++    (Just d1,Nothing) -> case mc of+                           Nothing -> m1 : runMergeWith Nothing ds1' (i+1) ds2' (j+1)+                           Just c  -> Nothing : runMergeWith (Just $ c `merge` d1) ds1' (i+1) ds2' (j+1)++    (Just d1,Just d2) -> case mc of+         Nothing | i == j    -> Nothing : runMergeWith (Just $ d1 `merge` d2) ds1' (i+1) ds2' (j+1)+                 | otherwise -> m1      : runMergeWith Nothing ds1' (i+1) ds2 j++         Just c  | i == j    -> mc : runMergeWith (Just $ d1 `merge` d2) ds1' (i+1) ds2' (j+1)+                 | otherwise -> Nothing : runMergeWith (Just $ c `merge` d1) ds1' (i+1) ds2 j+                       -- i < j, so invariant holds++-- | Given a decomposable query algorithm for the static structure,+-- lift it to a query algorithm on the insertion only structure.+--+-- pre: (As indicated by the Monoid constraint), the query answer+-- should be decomposable. I.e. we should be able to anser the query+-- on a set \(A \cup B\) by answering the query on \(A\) and \(B\)+-- separately, and combining their results.+--+-- running time: \(O(Q(n)\log n)\), where \(Q(n)\) is the query time+-- on the static structure.+queryWith                           :: Monoid m => (static a -> m) -> InsertionOnly static a -> m+queryWith query (InsertionOnly dss) = foldMap (foldMap query) dss

@@ -21,6 +21,7 @@ import Data.Bifoldable import Data.Bifunctor.Apply import Data.Bitraversable+-- import Data.Default import Data.Functor.Apply (liftF2) import Data.Semigroup.Bifoldable import Data.Semigroup.Bitraversable@@ -73,6 +74,9 @@  instance (Arbitrary c, Arbitrary e) => Arbitrary (c :+ e) where   arbitrary = (:+) <$> arbitrary <*> arbitrary++-- instance (Default a, Default b) => Default (a :+ b) where+--   def = def :+ def  -- | Access the core of an extended value. _core :: (core :+ extra) -> core

@@ -1,62 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Data.Ext--- Copyright   :  (C) Frank Staals--- License     :  see the LICENSE file--- Maintainer  :  Frank Staals------ A pair-like data type to represent a 'core' type that has extra information--- as well.-------------------------------------------------------------------------------------module Data.Ext.Multi where--import Control.DeepSeq-import Control.Lens-import Data.Coerce-import Data.Vinyl-import GHC.Generics (Generic)-import Test.QuickCheck------------------------------------------------------------------------------------data family core :+ (extras :: [*]) :: *--newtype instance core :+ '[]    = Only core deriving (Eq,Ord,NFData,Arbitrary,Generic,Show)-data    instance core :+ (t:ts) = WithExtra !core (HList (t:ts))---infixr 1 :+--pattern (:+)   :: c -> HList (e:extras) -> c :+ (e:extras)-pattern c :+ r = WithExtra c r-{-# COMPLETE (:+) #-}--ext :: c -> c :+ '[]-ext = Only------------------------------------------------------------------------------------class HasCore extras where-  core :: Lens (core :+ extras) (core' :+ extras) core core'--instance HasCore '[] where-  core = lens coerce (const coerce)-instance HasCore (t:ts) where-  core = lens (\(c :+ _) -> c) (\(_ :+ r) c -> c :+ r)------------------------------------------------------------------------------------class HasExtras extras extras' where-  extra :: Lens (core :+ extras) (core :+ extras') (HList extras) (HList extras')--instance HasExtras '[] '[] where-  extra = lens (const RNil) const-instance HasExtras '[] (t:ts) where-  extra = lens (const RNil) (\(Only c) r -> c :+ r)-instance HasExtras (t:ts) '[] where-  extra = lens (\(_ :+ r) -> r) (\(c :+ _) _ -> Only c)-instance HasExtras (t:ts) (a:as) where-  extra = lens (\(_ :+ r) -> r) (\(c :+ _) r' -> c :+ r')----------------------------------------------------------------------------------

@@ -35,17 +35,19 @@ coRec :: (a ∈ as) => a -> CoRec Identity as coRec = CoRec . Identity --- | Class relationship between intersectable geometric objects.-class IsIntersectableWith g h where-  intersect :: g -> h -> Intersection g h-+class HasIntersectionWith g h where   -- | g `intersects` h  <=> The intersection of g and h is non-empty.   --   -- The default implementation computes the intersection of g and h,   -- and uses nonEmptyIntersection to determine if the intersection is   -- non-empty.   intersects :: g -> h -> Bool+  default intersects :: IsIntersectableWith g h => g -> h -> Bool   g `intersects` h = nonEmptyIntersection (Identity g) (Identity h) $ g `intersect` h++-- | Class relationship between intersectable geometric objects.+class HasIntersectionWith g h => IsIntersectableWith g h where+  intersect :: g -> h -> Intersection g h    -- | Helper to implement `intersects`.   nonEmptyIntersection :: proxy g -> proxy h -> Intersection g h -> Bool

@@ -29,6 +29,7 @@                 , unstableSort, unstableSortBy                 , head, tail, last, init                 , append+                , reverse                  , ViewL(..)                 , viewl@@ -57,7 +58,7 @@ import qualified Data.Traversable as Tr import           GHC.Generics (Generic) import           GHC.TypeLits-import           Prelude hiding (drop,take,head,last,tail,init,zipWith)+import           Prelude hiding (drop,take,head,last,tail,init,zipWith,reverse) import           Test.QuickCheck (Arbitrary(..),vector)  --------------------------------------------------------------------------------@@ -229,6 +230,11 @@  wrapUnsafe :: (S.Seq a -> S.Seq b) -> LSeq n a -> LSeq m b wrapUnsafe f = LSeq . f . toSeq++-- | Reverses the sequence.+reverse :: LSeq n a -> LSeq n a+reverse = wrapUnsafe S.reverse+  -------------------------------------------------------------------------------- 

@@ -45,6 +45,7 @@                        , tailOf, headOf, endPoints                        , incidentEdges, incomingEdges, outgoingEdges, neighboursOf                        , nextIncidentEdge, prevIncidentEdge+                       , nextIncidentEdgeFrom, prevIncidentEdgeFrom                         -- * Associated Data @@ -69,10 +70,12 @@  -------------------------------------------------------------------------------- -- $setup+-- >>> import qualified Data.Vector as V+-- >>> import Control.Lens -- >>> :{ -- let dart i s = Dart (Arc i) (read s) --     (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..]---     myGraph :: PlanarGraph () Primal () String ()+--     myGraph :: PlanarGraph () Primal String String String --     myGraph = planarGraph [ [ (Dart aA Negative, "a-") --                             , (Dart aC Positive, "c+") --                             , (Dart aB Positive, "b+")@@ -89,7 +92,10 @@ --                             ] --                           , [ (Dart aG Negative, "g-") --                             ]---                           ]+--                           ] & vertexData .~ V.fromList ["u","v","w","x"]+--                             & faceData   .~ V.fromList ["f_3", "f_infty","f_1","f_2"]+--     showWithData     :: HasDataOf s i => s -> i -> (i, DataOf s i)+--     showWithData g i = (i, g^.dataOf i) -- :} -- --@@ -97,8 +103,6 @@ -- arrows are just to indicate what the Positive direction of the darts is. -- -- ![myGraph](docs/Data/PlanarGraph/testG.png)--   --------------------------------------------------------------------------------

@@ -21,7 +21,7 @@ -- | Data type representing the graph in its JSON/Yaml format data Gr v f = Gr { adjacencies :: [v]                  , faces       :: [f]-                 } deriving (Generic)+                 } deriving (Generic, Show, Eq)  instance Bifunctor Gr where   bimap f g (Gr vs fs) = Gr (map f vs) (map g fs)@@ -44,7 +44,7 @@                                         -- vertices. This is not (yet)                                         -- enforced by the data type.                    , vData :: v-                   } deriving (Generic)+                   } deriving (Generic, Show, Eq)  instance Bifunctor Vtx where   bimap f g (Vtx i as x) = Vtx i (map (second g) as) (f x)@@ -59,7 +59,7 @@ data Face f = Face { incidentEdge :: (Int,Int) -- ^ an edge (u,v) s.t. the face                                                -- is right from (u,v)                    , fData        :: f-                   } deriving (Generic,Functor)+                   } deriving (Generic,Functor, Show, Eq)  instance ToJSON f   => ToJSON   (Face f) where   toEncoding = genericToEncoding defaultOptions

@@ -24,6 +24,7 @@ import           GHC.Generics               (Generic) import           Unsafe.Coerce              (unsafeCoerce) + --------------------------------------------------------------------------------  --------------------------------------------------------------------------------@@ -31,7 +32,7 @@ -- >>> :{ -- let dart i s = Dart (Arc i) (read s) --     (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..]---     myGraph :: PlanarGraph () Primal () String ()+--     myGraph :: PlanarGraph () Primal String String String --     myGraph = planarGraph [ [ (Dart aA Negative, "a-") --                             , (Dart aC Positive, "c+") --                             , (Dart aB Positive, "b+")@@ -48,7 +49,10 @@ --                             ] --                           , [ (Dart aG Negative, "g-") --                             ]---                           ]+--                           ] & vertexData .~ V.fromList ["u","v","w","x"]+--                             & faceData   .~ V.fromList ["f_3", "f_infty","f_1","f_2"]+--     showWithData     :: HasDataOf s i => s -> i -> (i, DataOf s i)+--     showWithData g i = (i, g^.dataOf i) -- :} -- --@@ -185,6 +189,9 @@                  (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'@@ -226,12 +233,12 @@ -- | Traverse the vertices -- -- >>> (^.vertexData) <$> traverseVertices (\i x -> Just (i,x)) myGraph--- Just [(VertexId 0,()),(VertexId 1,()),(VertexId 2,()),(VertexId 3,())]+-- Just [(VertexId 0,"u"),(VertexId 1,"v"),(VertexId 2,"w"),(VertexId 3,"x")] -- >>> traverseVertices (\i x -> print (i,x)) myGraph >> pure ()--- (VertexId 0,())--- (VertexId 1,())--- (VertexId 2,())--- (VertexId 3,())+-- (VertexId 0,"u")+-- (VertexId 1,"v")+-- (VertexId 2,"w")+-- (VertexId 3,"x") traverseVertices   :: Applicative m                    => (VertexId s w -> v -> m v')                    -> PlanarGraph s w v e f@@ -262,10 +269,10 @@ -- | Traverses the faces -- -- >>> traverseFaces (\i x -> print (i,x)) myGraph >> pure ()--- (FaceId 0,())--- (FaceId 1,())--- (FaceId 2,())--- (FaceId 3,())+-- (FaceId 0,"f_3")+-- (FaceId 1,"f_infty")+-- (FaceId 2,"f_1")+-- (FaceId 3,"f_2") traverseFaces   :: Applicative m                 => (FaceId s w -> f -> m f')                 -> PlanarGraph s w v e f@@ -408,36 +415,59 @@  -- | The tail of a dart, i.e. the vertex this dart is leaving from --+-- >>> showWithData myGraph $ tailOf (Dart (Arc 3) Positive) myGraph+-- (VertexId 2,"w")+-- -- running time: \(O(1)\) tailOf     :: Dart s -> PlanarGraph s w v e f -> VertexId s w tailOf d g = VertexId . fst $ lookupIdx (g^.embedding) d  -- | The vertex this dart is heading in to --+-- showWithData myGraph $ headOf (Dart (Arc 3) Positive) myGraph+-- (VertexId 1,"v")+-- -- running time: \(O(1)\) headOf   :: Dart s -> PlanarGraph s w v e f -> VertexId s w headOf d = tailOf (twin d)  -- | endPoints d g = (tailOf d g, headOf d g) --+-- >>> endPoints (Dart (Arc 3) Positive) myGraph+-- (VertexId 2,VertexId 1)+-- -- running time: \(O(1)\) endPoints :: Dart s -> PlanarGraph s w v e f -> (VertexId s w, VertexId s w) endPoints d g = (tailOf d g, headOf d g) - -- | All edges incident to vertex v, in counterclockwise order around v. -----+-- >>> incidentEdges (VertexId 1) myGraph+-- [Dart (Arc 4) -1,Dart (Arc 1) -1,Dart (Arc 3) -1,Dart (Arc 5) +1]+-- >>> mapM_ (print . showWithData myGraph) $ incidentEdges (VertexId 1) myGraph+-- (Dart (Arc 4) -1,"e-")+-- (Dart (Arc 1) -1,"b-")+-- (Dart (Arc 3) -1,"d-")+-- (Dart (Arc 5) +1,"g+")+-- >>> mapM_ (print . showWithData myGraph) $ incidentEdges (VertexId 3) myGraph+-- (Dart (Arc 5) -1,"g-") -- -- 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 edges incident to vertex v in incoming direction -- (i.e. pointing into v) in counterclockwise order around v. --+-- >>> incomingEdges (VertexId 1) myGraph+-- [Dart (Arc 4) +1,Dart (Arc 1) +1,Dart (Arc 3) +1,Dart (Arc 5) -1]+-- >>> mapM_ (print . showWithData myGraph) $ incomingEdges (VertexId 1) myGraph+-- (Dart (Arc 4) +1,"e+")+-- (Dart (Arc 1) +1,"b+")+-- (Dart (Arc 3) +1,"d+")+-- (Dart (Arc 5) -1,"g-")+-- -- running time: \(O(k)\), where \(k) is the total number of incident edges of v incomingEdges     :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (Dart s) incomingEdges v g = orient <$> incidentEdges v g@@ -457,30 +487,79 @@ -- | Gets the neighbours of a particular vertex, in counterclockwise order -- around the vertex. --+-- >>> mapM_ (print . showWithData myGraph) $ neighboursOf (VertexId 1) myGraph -- around v+-- (VertexId 2,"w")+-- (VertexId 0,"u")+-- (VertexId 2,"w")+-- (VertexId 3,"x")+-- >>> mapM_ (print . showWithData myGraph) $ neighboursOf (VertexId 3) myGraph -- around x+-- (VertexId 1,"v")+-- -- running time: \(O(k)\), where \(k\) is the output size neighboursOf     :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w) neighboursOf v g = flip tailOf g <$> incomingEdges v g  -- | Given a dart d that points into some vertex v, report the next dart in the--- cyclic order around v.+-- cyclic (counterclockwise) order around v. --+-- >>> nextIncidentEdge (dart 3 "+1") myGraph+-- Dart (Arc 5) +1+-- >>> showWithData myGraph $ nextIncidentEdge (dart 3 "+1") myGraph+-- (Dart (Arc 5) +1,"g+")+-- >>> showWithData myGraph $ nextIncidentEdge (dart 1 "+1") myGraph+-- (Dart (Arc 3) -1,"d-")+-- -- 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+nextIncidentEdge   :: Dart s -> PlanarGraph s w v e f -> Dart s+nextIncidentEdge d = nextIncidentEdgeFrom (twin d) +-- | Given a dart d that points into some vertex v, report the previous dart in the+-- cyclic (counterclockwise) order around v.+--+-- >>> prevIncidentEdge (dart 3 "+1") myGraph+-- Dart (Arc 1) -1+-- >>> showWithData myGraph $ prevIncidentEdge (dart 3 "+1") myGraph+-- (Dart (Arc 1) -1,"b-")+--+-- running time: \(O(1)\)+prevIncidentEdge   :: Dart s -> PlanarGraph s w v e f -> Dart s+prevIncidentEdge d = prevIncidentEdgeFrom (twin d) --- | Given a dart d that points into some vertex v, report the next dart in the--- cyclic order around v.++-- | Given a dart d that points away from some vertex v, report the+-- next dart in the cyclic (counterclockwise) order around v. --+-- >>> nextIncidentEdgeFrom (Dart (Arc 3) Positive) myGraph+-- Dart (Arc 2) -1+-- >>> showWithData myGraph $ nextIncidentEdgeFrom (Dart (Arc 3) Positive) myGraph+-- (Dart (Arc 2) -1,"c-")+-- >>> showWithData myGraph $ nextIncidentEdgeFrom (dart 1 "+1") myGraph+-- (Dart (Arc 0) +1,"a+")+-- -- 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+nextIncidentEdgeFrom     :: Dart s -> PlanarGraph s w v e f -> Dart s+nextIncidentEdgeFrom d g = let perm  = g^.embedding+                               (i,j) = lookupIdx perm d+                           in next (perm^?!orbits.ix i) j  +-- | Given a dart d that points into away from vertex v, report the previous dart in the+-- cyclic (counterclockwise) order around v.+--+-- >>> prevIncidentEdgeFrom (Dart (Arc 3) Positive) myGraph+-- Dart (Arc 4) +1+-- >>> showWithData myGraph $ prevIncidentEdgeFrom (Dart (Arc 3) Positive) myGraph+-- (Dart (Arc 4) +1,"e+")+-- >>> showWithData myGraph $ prevIncidentEdgeFrom (Dart (Arc 1) Positive) myGraph+-- (Dart (Arc 2) +1,"c+")+--+-- running time: \(O(1)\)+prevIncidentEdgeFrom     :: Dart s -> PlanarGraph s w v e f -> Dart s+prevIncidentEdgeFrom d g = let perm  = g^.embedding+                               (i,j) = lookupIdx perm d+                           in previous (perm^?!orbits.ix i) j++ -------------------------------------------------------------------------------- -- * Access data @@ -506,6 +585,9 @@   -- | Data corresponding to the endpoints of the dart+--+-- >>> myGraph^.endPointDataOf (Dart (Arc 3) Positive)+-- ("w","v") endPointDataOf   :: Dart s -> Getter (PlanarGraph s w v e f) (v,v) endPointDataOf d = to $ endPointData d @@ -551,3 +633,35 @@                         (g^.rawDartData)                         (g^.vertexData)                         g++++--------------------------------------------------------------------------------++-- myGraph :: PlanarGraph () Primal String String 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-")+--                             ]+--                           ]+--           & vertexData .~ V.fromList ["u","v","w","x"]+--           & faceData   .~ V.fromList ["f_3", "f_infty","f_1","f_2"]+--   where+--     (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..]++-- dart i s = Dart (Arc i) (read s)++-- showWithData     :: HasDataOf s i => s -> i -> (i, DataOf s i)+-- showWithData g i = (i, g^.dataOf i)

@@ -24,7 +24,7 @@ -- >>> :{ -- let dart i s = Dart (Arc i) (read s) --     (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..]---     myGraph :: PlanarGraph () Primal () String ()+--     myGraph :: PlanarGraph () Primal String String String --     myGraph = planarGraph [ [ (Dart aA Negative, "a-") --                             , (Dart aC Positive, "c+") --                             , (Dart aB Positive, "b+")@@ -41,7 +41,10 @@ --                             ] --                           , [ (Dart aG Negative, "g-") --                             ]---                           ]+--                           ] & vertexData .~ V.fromList ["u","v","w","x"]+--                             & faceData   .~ V.fromList ["f_3", "f_infty","f_1","f_2"]+--     showWithData     :: HasDataOf s i => s -> i -> (i, DataOf s i)+--     showWithData g i = (i, g^.dataOf i) -- :} -- --@@ -61,14 +64,17 @@  -- | The face to the left of the dart --+-- -- >>> leftFace (dart 1 "+1") myGraph -- FaceId 1+-- >>> showWithData myGraph $ leftFace (dart 1 "+1") myGraph+-- (FaceId 1,"f_infty") -- >>> leftFace (dart 1 "-1") myGraph -- FaceId 2--- >>> leftFace (dart 2 "+1") myGraph--- FaceId 2--- >>> leftFace (dart 0 "+1") myGraph--- FaceId 0+-- >>> showWithData myGraph $ leftFace (dart 1 "-1") myGraph+-- (FaceId 2,"f_1")+-- >>> showWithData myGraph $ leftFace (dart 0 "+1") myGraph+-- (FaceId 0,"f_3") -- -- running time: \(O(1)\). leftFace     :: Dart s -> PlanarGraph s w v e f -> FaceId s w@@ -77,50 +83,95 @@  -- | The face to the right of the dart --+-- -- >>> rightFace (dart 1 "+1") myGraph -- FaceId 2+-- >>> showWithData myGraph $ rightFace (dart 1 "+1") myGraph+-- (FaceId 2,"f_1") -- >>> rightFace (dart 1 "-1") myGraph -- FaceId 1--- >>> rightFace (dart 2 "+1") myGraph--- FaceId 1--- >>> rightFace (dart 0 "+1") myGraph--- FaceId 1+-- >>> showWithData myGraph $ rightFace (dart 1 "-1") myGraph+-- (FaceId 1,"f_infty")+-- >>> showWithData myGraph $ rightFace (dart 0 "+1") myGraph+-- (FaceId 1,"f_infty") -- -- running time: \(O(1)\). rightFace     :: Dart s -> PlanarGraph s w v e f -> FaceId s w rightFace d g = FaceId . tailOf d $ _dual g  --- | Get the next edge along the face+-- | Get the next edge (in clockwise order) along the face that is to+-- the right of this dart. --+-- >> showWithData myGraph $ nextEdge (dart 1 "+1") myGraph+-- (Dart (Arc 3) -1,"d-")+-- >> showWithData myGraph $ nextEdge (dart 2 "+1") myGraph+-- (Dart (Arc 4) +1,"e+")+-- -- running time: \(O(1)\). nextEdge   :: Dart s -> PlanarGraph s w v e f -> Dart s-nextEdge d = nextIncidentEdge d . _dual+nextEdge d = nextIncidentEdgeFrom d . _dual+  -- prevIncidentEdge (twin d) (_dual g)+  -- where+  --   f = rightFace d g --- | Get the previous edge along the face+-- | Get the previous edge (in clockwise order) along the face that is+-- to the right of this dart. --+-- >>> showWithData myGraph $ prevEdge (dart 1 "+1") myGraph+-- (Dart (Arc 2) -1,"c-")+-- >>> showWithData myGraph $ prevEdge (dart 3 "-1") myGraph+-- (Dart (Arc 1) +1,"b+")+-- -- running time: \(O(1)\).-prevEdge :: Dart s -> PlanarGraph s w v e f -> Dart s-prevEdge d = prevIncidentEdge d . _dual-+prevEdge   :: Dart s -> PlanarGraph s w v e f -> Dart s+prevEdge d = prevIncidentEdgeFrom d . _dual  -- | Gets a dart bounding this face. I.e. a dart d such that the face lies to -- the right of the dart.+--+-- >>> boundaryDart (FaceId $ VertexId 2) myGraph+-- Dart (Arc 1) +1+-- >>> showWithData myGraph $ boundaryDart (FaceId $ VertexId 2) myGraph+-- (Dart (Arc 1) +1,"b+")+-- >>> showWithData myGraph $ boundaryDart (FaceId $ VertexId 1) myGraph+-- (Dart (Arc 2) +1,"c+") boundaryDart   :: FaceId s w -> PlanarGraph s w v e f -> Dart s boundaryDart f = V.head . boundary f--- TODO: make sure that this is indeed to the right. --- | The darts bounding this face, for internal faces in clockwise order, for--- the outer face in counter clockwise order.+-- | The darts bounding this face. The darts are reported in order+-- along the face. This means that for internal faces the darts are+-- reported in *clockwise* order along the boundary, whereas for the+-- outer face the darts are reported in counter clockwise order. --+-- >>> boundary (FaceId $ VertexId 2) myGraph+-- [Dart (Arc 1) +1,Dart (Arc 3) -1,Dart (Arc 2) -1]+-- >>> mapM_ (print . showWithData myGraph) $ boundary (FaceId $ VertexId 2) myGraph+-- (Dart (Arc 1) +1,"b+")+-- (Dart (Arc 3) -1,"d-")+-- (Dart (Arc 2) -1,"c-")+-- >>> boundary (FaceId $ VertexId 1) myGraph+-- [Dart (Arc 2) +1,Dart (Arc 4) +1,Dart (Arc 1) -1,Dart (Arc 0) +1]+-- >>> mapM_ (print . showWithData myGraph) $ boundary (FaceId $ VertexId 1) myGraph+-- (Dart (Arc 2) +1,"c+")+-- (Dart (Arc 4) +1,"e+")+-- (Dart (Arc 1) -1,"b-")+-- (Dart (Arc 0) +1,"a+") -- -- 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 ---- | Generates the darts incident to a face, starting with the given dart.+-- | Given a dart d, generates the darts bounding the face that is to+-- the right of the given dart. The darts are reported in order along+-- the face. This means that for internal faces the darts are reported+-- in *clockwise* order along the boundary, whereas for the outer face+-- the darts are reported in counter clockwise order. --+-- >>> mapM_ (print . showWithData myGraph) $ boundary' (dart 1 "+1") myGraph+-- (Dart (Arc 1) +1,"b+")+-- (Dart (Arc 3) -1,"d-")+-- (Dart (Arc 2) -1,"c-") -- -- \(O(k)\), where \(k\) is the number of darts reported boundary'     :: Dart s -> PlanarGraph s w v e f -> V.Vector (Dart s)@@ -132,9 +183,18 @@         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.+-- | The vertices bounding this face, for internal faces in clockwise+-- order, for the outer face in counter clockwise order. --+-- >>> mapM_ (print . showWithData myGraph) $ boundaryVertices (FaceId $ VertexId 2) myGraph+-- (VertexId 0,"u")+-- (VertexId 1,"v")+-- (VertexId 2,"w")+-- >>> mapM_ (print . showWithData myGraph) $ boundaryVertices (FaceId $ VertexId 1) myGraph+-- (VertexId 0,"u")+-- (VertexId 2,"w")+-- (VertexId 1,"v")+-- (VertexId 0,"u") -- -- running time: \(O(k)\), where \(k\) is the output size. boundaryVertices     :: FaceId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w)

@@ -141,7 +141,9 @@     toOrbit (u,adjU) = concatMap (toDart u) adjU      -- if u = v we have a self-loop, so we add both a positive and a negative dart-    toDart u v = let Just a = findEdge u v oracle+    toDart u v = let a = case findEdge u v oracle of+                           Nothing -> error $ "edge not found? " <> show (u,v)+                           Just a' -> a'                  in case u `compare` v of                       LT -> [Dart (Arc a) Positive]                       EQ -> [Dart (Arc a) Positive, Dart (Arc a) Negative]

@@ -261,7 +261,8 @@ panic tag msg = error $ "Data.PlanarGraph.Immutable." ++ tag ++ ": " ++ msg  --- $setup+-- Disabled since hashes are not stable across different versions of hashable.+-- // $setup -- -- >>> hash $ pgFromFaces [[0,1,2]] -- 2959979592048325618@@ -375,7 +376,8 @@ -- vertexId :: Vertex -> VertexId -- vertexId (Vertex vId) = vId --- $hidden+-- Disabled since hashes are not stable across different versions of hashable.+-- // $hidden -- -- >>> hash $ pgFromFaces [[0,1,2]] -- 2959979592048325618@@ -419,7 +421,8 @@ vertexHalfEdge (Vertex vId) pg = HalfEdge $ pgVertexEdges pg Vector.! vId  --- $hidden+-- Disabled since hashes are not stable across different versions of hashable.+-- // $hidden -- -- >>> hash $ pgFromFaces [[0,1,2,3],[4,3,2,1]] -- 1711135548958680232@@ -518,7 +521,8 @@       | he == first = nil       | otherwise   = cons he (g (advance he) cons nil) --- $hidden+-- Disabled since hashes are not stable across different versions of hashable.+-- // $hidden -- -- >>> hash $ pgFromFaces [[0,1,2,3],[4,3,2,1]] -- 1711135548958680232@@ -667,7 +671,8 @@ -- halfEdgeId :: HalfEdge -> HalfEdgeId -- halfEdgeId (HalfEdge eId) = eId --- $hidden+-- Disabled since hashes are not stable across different versions of hashable.+-- // $hidden -- -- >>> hash $ pgFromFaces [[0,1,2,3],[4,3,2,1]] -- 1711135548958680232@@ -864,7 +869,8 @@ halfEdgeTipVertex  :: HalfEdge -> PlanarGraph -> Vertex halfEdgeTipVertex e pg = halfEdgeVertex (halfEdgeTwin e) pg --- $hidden+-- Disabled since hashes are not stable across different versions of hashable.+-- // $hidden -- -- >>> hash $ pgFromFaces [[0,1,2]] -- 2959979592048325618

@@ -111,8 +111,8 @@ data Face s = Face FaceId (PlanarGraph s) | Boundary FaceId (PlanarGraph s)   deriving Eq instance Show (Face s) where-  showsPrec d (Face fId _)     = showString "Face " . shows fId-  showsPrec d (Boundary fId _) = showString "Boundary " . shows fId+  showsPrec _ (Face fId _)     = showString "Face " . shows fId+  showsPrec _ (Boundary fId _) = showString "Boundary " . shows fId  ------------------------------------------------------------------------------- -- Planar graph@@ -139,26 +139,28 @@   <*> newVector nFaces   <*> newVector 0 -{--  For all boundary vertices:-    vertex.half-edge.face == interior-    vertex.half-edge.twin.face == exterior-  Boundary face: 0+-- {-+--   For all boundary vertices:+--     vertex.half-edge.face == interior+--     vertex.half-edge.twin.face == exterior+--   Boundary face: 0 -  create N--}--- | O(n)---   Create a planar graph with N boundary vertices.-new :: Int -> ST s (PlanarGraph s)-new n | n < 0 = panic "new" "Cannot contain negative vertices."-new 0 = empty 0 0 0-new 1 = undefined-new 2 = undefined-new n = pgFromFaces [[0..n-1]]+--   create N+-- -}+-- -- | O(n)+-- --   Create a planar graph with N boundary vertices.+-- new :: Int -> ST s (PlanarGraph s)+-- new n | n < 0 = panic "new" "Cannot contain negative vertices."+-- new 0 = empty 0 0 0+-- new 1 = undefined+-- new 2 = undefined+-- new n = pgFromFaces [[0..n-1]]  -- $setup -- -- >>> import Control.Monad.ST++-- Disabled since hashes are not stable across different versions of hashable. -- >>> runST $ pgFromFaces [[0,1,2]] >>= pgHash -- 2959979592048325618 -- >>> runST $ pgFromFaces [[0,1,2,3]] >>= pgHash@@ -320,12 +322,12 @@ -- vertexAdjacentVertices :: Vertex -> PlanarGraph -> [Vertex] -- vertexAdjacentFaces :: Vertex -> PlanarGraph -> [Face] --- O(1), internal function.-vertexNew :: PlanarGraph s -> ST s (Vertex s)-vertexNew pg = do-  vId <- readSTRef (pgNextVertexId pg)-  writeSTRef (pgNextVertexId pg) (vId+1)-  return (Vertex vId pg)+-- -- O(1), internal function.+-- vertexNew :: PlanarGraph s -> ST s (Vertex s)+-- vertexNew pg = do+--   vId <- readSTRef (pgNextVertexId pg)+--   writeSTRef (pgNextVertexId pg) (vId+1)+--   return (Vertex vId pg)  vertexSetHalfEdge :: Vertex s -> HalfEdge s -> ST s () vertexSetHalfEdge (Vertex vId pg) (HalfEdge eId pg') = eqCheck "vertexSetHalfEdge" pg pg' $@@ -346,9 +348,9 @@ edgeFromHalfEdge :: HalfEdge s -> Edge s edgeFromHalfEdge (HalfEdge he pg) = Edge (he `div` 2) pg --- | O(1)-edgeToHalfEdges :: Edge s -> (HalfEdge s, HalfEdge s)-edgeToHalfEdges (Edge e pg) = (HalfEdge (e*2) pg, HalfEdge (e*2+1) pg)+-- -- | O(1)+-- edgeToHalfEdges :: Edge s -> (HalfEdge s, HalfEdge s)+-- edgeToHalfEdges (Edge e pg) = (HalfEdge (e*2) pg, HalfEdge (e*2+1) pg)  ------------------------------------------------------------------------------- -- Half-edges@@ -357,9 +359,9 @@ halfEdgePlanarGraph :: HalfEdge s -> PlanarGraph s halfEdgePlanarGraph (HalfEdge _ pg) = pg --- | O(1)-halfEdgeIsValid :: HalfEdge s -> Bool-halfEdgeIsValid (HalfEdge eId _) = eId >= 0+-- -- | O(1)+-- halfEdgeIsValid :: HalfEdge s -> Bool+-- halfEdgeIsValid (HalfEdge eId _) = eId >= 0  -- | O(1) halfEdgeFromId :: HalfEdgeId -> PlanarGraph s -> HalfEdge s

@@ -208,6 +208,7 @@  type instance IntersectionOf (Range a) (Range a) = [ NoIntersection, Range a] +instance Ord a => Range a `HasIntersectionWith` Range a instance Ord a => Range a `IsIntersectableWith` Range a where    nonEmptyIntersection = defaultNonEmptyIntersection

@@ -136,5 +136,5 @@   -test = queryBy cmpS Set.lookupGE (S "22") $ fromListBy cmpS [S "a" , S "bbb" , S "ddddddd"]+-- test = queryBy cmpS Set.lookupGE (S "22") $ fromListBy cmpS [S "a" , S "bbb" , S "ddddddd"] -- test = succBy cmpS (S "22") $ fromListBy cmpS [S "a" , S "bbb" , S "ddddddd"]

@@ -1,10 +1,11 @@ module Algorithms.DivideAndConquerSpec where  import Algorithms.DivideAndConquer- import           Test.Hspec import           Test.QuickCheck import qualified Data.List as List++--------------------------------------------------------------------------------  spec = describe "divide and conquer strategy tests" $ do          it "mergeSort" $ property $

@@ -0,0 +1,45 @@+module Algorithms.LogarithmicMethodSpec where++import           Algorithms.LogarithmicMethod+import           Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Maybe (mapMaybe)+import           Data.Semigroup+import           Data.Semigroup.Foldable+import           Data.List.Util+import           Test.Hspec+import           Test.QuickCheck++--------------------------------------------------------------------------------++spec :: Spec+spec = describe "Logarithmic method successor test" $ do+         it "successor test" $ property $+           \q (xs :: [Int]) ->+             successor q (fromList xs)+             `shouldBe`+             minimum1 [ x | x <- xs, x >= q]++         it "merge test" $ property $+           \q (xs :: [Int]) (ys :: [Int]) ->+             successor q ((fromList xs) <> (fromList ys))+             `shouldBe`+             successor q (fromList $ xs <> ys)+++newtype DummySucc a = Dummy (NonEmpty a)+  deriving (Show,Eq,Functor,Foldable,Foldable1,Traversable)++instance Ord a => LogarithmicMethodDS DummySucc a where+  build = Dummy . NonEmpty.sort++successor'              :: Ord a => a -> DummySucc a -> Option (Min a)+successor' q (Dummy xs) = case NonEmpty.dropWhile (< q) xs of+                            []    -> Option Nothing+                            (s:_) -> Option (Just (Min s))++successor   :: Ord a => a -> InsertionOnly DummySucc a -> Maybe a+successor q = fmap getMin . getOption . queryWith (successor' q)++fromList :: Ord a => [a] -> InsertionOnly DummySucc a+fromList = foldr insert empty