hgeometry-combinatorial 0.12.0.2 → 0.12.0.3

raw patch · 5 files changed

+121/−26 lines, 5 filesdep +witherabledep ~lineardep ~vector-builderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: witherable

Dependency ranges changed: linear, vector-builder

API changes (from Hackage documentation)

Files

• hgeometry-combinatorial.cabal +7/−4
• src/Algorithms/Graph/BFS.hs +66/−0
• src/Data/LSeq.hs +13/−13
• src/Data/Range.hs +9/−9
• test/Algorithms/Graph/BFSSpec.hs +26/−0

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                hgeometry-combinatorial-version:             0.12.0.2+version:             0.12.0.3 synopsis:            Data structures, and Data types. description:     The Non-geometric data types and algorithms used in HGeometry.@@ -13,7 +13,7 @@ maintainer:          frank@fstaals.net -- copyright: -tested-with:         GHC >= 8.4+tested-with:         GHC >= 8.8  category:            Geometry build-type:          Simple@@ -49,6 +49,7 @@                      -- * Graph Algorithms                     Algorithms.Graph.DFS+                    Algorithms.Graph.BFS                     Algorithms.Graph.MST                     Algorithms.FloydWarshall @@ -142,14 +143,15 @@               , quickcheck-instances    >= 0.3               , reflection              >= 2.1               , primitive               >= 0.6.3.0-              , linear                  >= 1.20.8+              , linear                  >= 1.21               , hashable                >= 1.2+              , witherable              >= 0.4                , vector                  >= 0.11               , data-clist              >= 0.1.2.3               , vector-circular         >= 0.1.2               , nonempty-vector         >= 0.2.0.0-              , vector-builder          >= 0.3.7   && <= 0.3.8+              , vector-builder          >= 0.3.7               , unordered-containers                , aeson                   >= 1.0@@ -222,6 +224,7 @@   other-modules: Algorithms.StringSearch.KMPSpec                  Algorithms.DivideAndConquerSpec                  Algorithms.Graph.DFSSpec+                 Algorithms.Graph.BFSSpec                  Data.RangeSpec                  Data.EdgeOracleSpec                  Data.PlanarGraphSpec

@@ -0,0 +1,66 @@+{-# LANGUAGE ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Algorithms.Graph.BFS+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--------------------------------------------------------------------------------+module Algorithms.Graph.BFS+  ( bfs+  , bfs'+  ) where++import           Control.Monad.ST.Strict+import qualified Data.Foldable as F+import           Data.Sequence (Seq(..))+import qualified Data.Sequence as Seq+import           Data.Tree+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector.Unboxed.Mutable as UMV+import           Witherable++--------------------------------------------------------------------------------++-- | Runs a BFS from the first vertex in the graph. The graph is given+-- in adjacency list representation.+--+-- running time: \(O(V + E)\)+bfs      :: Foldable f => Int -> V.Vector (v, f Int) -> Tree v+bfs s gr = fmap (fst . (gr V.!)) . bfs' s . fmap snd $ gr++-- | Runs a BFS from the first vertex in the graph. The graph is given+-- in adjacency list representation.+--+-- running time: \(O(V + E)\)+bfs'      :: Foldable f => Int -> V.Vector (f Int) -> Tree Int+bfs' s gr = extract s $ V.create+         $ do st  <- UMV.replicate n False+              out <- MV.new n+              go0 st out (s :<| mempty)+              pure out+  where+    n = V.length gr+    go0        :: forall s. UMV.MVector s Bool -> MV.MVector s [Int]+               -> Seq Int -> ST s ()+    go0 st out = go+      where+        visit i = do b <- UMV.read st i+                     UMV.write st i True -- mark i as visited+                     pure $ if b then Nothing else Just i++        go :: Seq Int -> ST s ()+        go = \case+          Empty       -> pure ()+          (u:<|queue) -> do ns <- wither visit . F.toList $ gr V.! u+                            MV.write out u ns -- write that u's children are ns+                            go (queue <> Seq.fromList ns)+++-- | Give na root index and a vector s.t. v[i] lists the children of+-- node i, builds the acutal tree.+extract     :: Int -> V.Vector [Int] -> Tree Int+extract s v = go s+  where+    go i = Node i (map go $ v V.! i)

@@ -18,7 +18,7 @@                  , (<|), (|>)                 , (><)-                , eval+                , eval, eval'                  , index                 , adjust@@ -133,29 +133,29 @@  -- | \( O(1) \) Prove a sequence has at least @n@ elements. ----- >>> eval (Proxy :: Proxy 3) (fromList [1,2,3])+-- >>> eval @3 (fromList [1,2,3]) -- Just (LSeq (fromList [1,2,3]))--- >>> eval (Proxy :: Proxy 3) (fromList [1,2])+-- >>> eval @3 (fromList [1,2]) -- Nothing--- >>> eval (Proxy :: Proxy 3) (fromList [1..10])+-- >>> eval @3 (fromList [1..10]) -- Just (LSeq (fromList [1,2,3,4,5,6,7,8,9,10]))-eval :: forall proxy n m a. KnownNat n => proxy n -> LSeq m a -> Maybe (LSeq n a)-eval n (LSeq xs)+eval :: forall n m a. KnownNat n => LSeq m a -> Maybe (LSeq n a)+eval = eval' (Proxy @n)++-- | Implementatio nof eval' that takes an explicit proxy.+eval' :: forall proxy n m a. KnownNat n => proxy n -> LSeq m a -> Maybe (LSeq n a)+eval' n (LSeq xs)   | toInteger (S.length xs) >= natVal n = Just $ LSeq xs   | otherwise                           = Nothing  --- -- | Promises that the length of this LSeq is actually n. This is not -- checked. -- -- This function should be a noop-promise :: forall m n a. LSeq m a -> LSeq n a+promise :: forall n m a. LSeq m a -> LSeq n a promise = coerce - -- | Forces the first n elements of the LSeq forceLSeq   :: KnownNat n => proxy n -> LSeq m a -> LSeq n a forceLSeq n = promise . go (fromInteger $ natVal n)@@ -232,7 +232,7 @@  -------------------------------------------------------------------------------- --- | \( O(n) \). Create an l-sequence from a sequence of elements.+-- | \( O(1) \). Create an l-sequence from a sequence of elements. fromSeq :: S.Seq a -> LSeq 0 a fromSeq = LSeq @@ -269,7 +269,7 @@     where       go x = \case         S.Empty       -> (:< empty) <$> f x-        (y S.:<| ys) -> (\x' (y' :< ys') -> x' :< promise @1 @0 (y' :<| ys'))+        (y S.:<| ys) -> (\x' (y' :< ys') -> x' :< promise @0 (y' :<| ys'))                         <$> f x <.> go y ys  instance Eq a => Eq (ViewL n a) where

@@ -18,7 +18,7 @@                  , prettyShow                  , lower, upper                  , inRange, width, clipLower, clipUpper, midPoint, clampTo-                 , isValid, covers+                 , isValidRange, covers                   , shiftLeft, shiftRight                  ) where@@ -215,7 +215,7 @@   -- 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 isValid i then coRec i else coRec NoIntersection+                              in if isValidRange i then coRec i else coRec NoIntersection  -- | Get the width of the interval --@@ -257,12 +257,12 @@ -- | 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 isValid r' then Just r' else Nothing+clipLower l r = let r' = clipLower' l r in if isValidRange r' then Just r' else Nothing  -- | 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 isValid r' then Just r' else Nothing+clipUpper u r = let r' = clipUpper' u r in if isValidRange r' then Just r' else Nothing  -- | Wether or not the first range completely covers the second one covers       :: forall a. Ord a => Range a -> Range a -> Bool@@ -272,11 +272,11 @@ -- | 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.-isValid             :: Ord a => Range a -> Bool-isValid (Range l u) = case _unEndPoint l `compare` _unEndPoint u of-                          LT                            -> True-                          EQ | isClosed l || isClosed u -> True-                          _                             -> False+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+                             _                             -> False  -- operation is unsafe, as it may produce an invalid range (where l > u) clipLower'                  :: Ord a => EndPoint a -> Range a -> Range a

@@ -0,0 +1,26 @@+module Algorithms.Graph.BFSSpec (spec) where++import           Algorithms.Graph.BFS+import           Data.Tree+import qualified Data.Vector as V+import           Test.Hspec++--------------------------------------------------------------------------------++spec :: Spec+spec = it "BFS test" $+         bfs' 0 testGr `shouldBe` answer++testGr :: V.Vector [Int]+testGr = V.fromList [ [1,3, 6]+                    , [2]+                    , [3, 5]+                    , [2 ]+                    , []+                    , [4, 5]+                    , [7]+                    , [8,4]+                    , [2]+                    ]+answer :: Tree Int+answer = Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = [Node {rootLabel = 5, subForest = []}]}]},Node {rootLabel = 3, subForest = []},Node {rootLabel = 6, subForest = [Node {rootLabel = 7, subForest = [Node {rootLabel = 8, subForest = []},Node {rootLabel = 4, subForest = []}]}]}]}