{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.PlanarGraph.EdgeOracle
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Data structure to represent a planar graph with which we can test in
-- \(O(1)\) time if an edge between a pair of vertices exists.
--------------------------------------------------------------------------------
module Data.PlanarGraph.EdgeOracle where

import           Control.Applicative (Alternative(..))
import           Control.Lens hiding ((.=))
import           Control.Monad.ST (ST)
import           Control.Monad.State.Strict
import           Data.Bitraversable
import           Data.Ext
import qualified Data.Foldable as F
import           Data.Maybe (catMaybes, isJust)
import           Data.PlanarGraph.Core
import           Data.PlanarGraph.Dart
import           Data.Traversable (fmapDefault,foldMapDefault)
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

--------------------------------------------------------------------------------

-- | Edge Oracle:
--
-- main idea: store adjacency lists in such a way that we store an edge (u,v)
-- either in u's adjacency list or in v's. This can be done s.t. all adjacency
-- lists have length at most 6.
--
-- note: Every edge is stored exactly once (i.e. either at u or at v, but not both)
newtype EdgeOracle s w a =
  EdgeOracle { EdgeOracle s w a -> Vector (Vector (VertexId s w :+ a))
_unEdgeOracle :: V.Vector (V.Vector (VertexId s w :+ a)) }
                         deriving (Int -> EdgeOracle s w a -> ShowS
[EdgeOracle s w a] -> ShowS
EdgeOracle s w a -> String
(Int -> EdgeOracle s w a -> ShowS)
-> (EdgeOracle s w a -> String)
-> ([EdgeOracle s w a] -> ShowS)
-> Show (EdgeOracle s w a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (s :: k) (w :: World) a.
Show a =>
Int -> EdgeOracle s w a -> ShowS
forall k (s :: k) (w :: World) a.
Show a =>
[EdgeOracle s w a] -> ShowS
forall k (s :: k) (w :: World) a.
Show a =>
EdgeOracle s w a -> String
showList :: [EdgeOracle s w a] -> ShowS
$cshowList :: forall k (s :: k) (w :: World) a.
Show a =>
[EdgeOracle s w a] -> ShowS
show :: EdgeOracle s w a -> String
$cshow :: forall k (s :: k) (w :: World) a.
Show a =>
EdgeOracle s w a -> String
showsPrec :: Int -> EdgeOracle s w a -> ShowS
$cshowsPrec :: forall k (s :: k) (w :: World) a.
Show a =>
Int -> EdgeOracle s w a -> ShowS
Show,EdgeOracle s w a -> EdgeOracle s w a -> Bool
(EdgeOracle s w a -> EdgeOracle s w a -> Bool)
-> (EdgeOracle s w a -> EdgeOracle s w a -> Bool)
-> Eq (EdgeOracle s w a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (s :: k) (w :: World) a.
Eq a =>
EdgeOracle s w a -> EdgeOracle s w a -> Bool
/= :: EdgeOracle s w a -> EdgeOracle s w a -> Bool
$c/= :: forall k (s :: k) (w :: World) a.
Eq a =>
EdgeOracle s w a -> EdgeOracle s w a -> Bool
== :: EdgeOracle s w a -> EdgeOracle s w a -> Bool
$c== :: forall k (s :: k) (w :: World) a.
Eq a =>
EdgeOracle s w a -> EdgeOracle s w a -> Bool
Eq)

instance Functor (EdgeOracle s w) where
  fmap :: (a -> b) -> EdgeOracle s w a -> EdgeOracle s w b
fmap = (a -> b) -> EdgeOracle s w a -> EdgeOracle s w b
forall (t :: * -> *) a b. Traversable t => (a -> b) -> t a -> t b
fmapDefault

instance Foldable (EdgeOracle s w) where
  foldMap :: (a -> m) -> EdgeOracle s w a -> m
foldMap = (a -> m) -> EdgeOracle s w a -> m
forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault

instance Traversable (EdgeOracle s w) where
  traverse :: (a -> f b) -> EdgeOracle s w a -> f (EdgeOracle s w b)
traverse a -> f b
f (EdgeOracle Vector (Vector (VertexId s w :+ a))
v) = Vector (Vector (VertexId s w :+ b)) -> EdgeOracle s w b
forall k (s :: k) (w :: World) a.
Vector (Vector (VertexId s w :+ a)) -> EdgeOracle s w a
EdgeOracle (Vector (Vector (VertexId s w :+ b)) -> EdgeOracle s w b)
-> f (Vector (Vector (VertexId s w :+ b))) -> f (EdgeOracle s w b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Vector (VertexId s w :+ a) -> f (Vector (VertexId s w :+ b)))
-> Vector (Vector (VertexId s w :+ a))
-> f (Vector (Vector (VertexId s w :+ b)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Vector (VertexId s w :+ a) -> f (Vector (VertexId s w :+ b))
g Vector (Vector (VertexId s w :+ a))
v
    where
      -- g   :: V.Vector (VertexId :+ a) -> f (V.Vector (VertexId :+ b))
      g :: Vector (VertexId s w :+ a) -> f (Vector (VertexId s w :+ b))
g = ((VertexId s w :+ a) -> f (VertexId s w :+ b))
-> Vector (VertexId s w :+ a) -> f (Vector (VertexId s w :+ b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((VertexId s w -> f (VertexId s w))
-> (a -> f b) -> (VertexId s w :+ a) -> f (VertexId s w :+ b)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse VertexId s w -> f (VertexId s w)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> f b
f)


-- | 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 :: PlanarGraph s w v e f -> EdgeOracle s w (Dart s)
edgeOracle PlanarGraph s w v e f
g = [(VertexId s w, Vector (VertexId s w :+ Dart s))]
-> EdgeOracle s w (Dart s)
forall k (f :: * -> *) (s :: k) (w :: World) e.
Foldable f =>
[(VertexId s w, f (VertexId s w :+ e))] -> EdgeOracle s w e
buildEdgeOracle [ (VertexId s w
v, VertexId s w -> Dart s -> VertexId s w :+ Dart s
mkAdjacency VertexId s w
v (Dart s -> VertexId s w :+ Dart s)
-> Vector (Dart s) -> Vector (VertexId s w :+ Dart s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VertexId s w -> PlanarGraph s w v e f -> Vector (Dart s)
forall k (s :: k) (w :: World) v e f.
VertexId s w -> PlanarGraph s w v e f -> Vector (Dart s)
incidentEdges VertexId s w
v PlanarGraph s w v e f
g)
                               | VertexId s w
v <- Vector (VertexId s w) -> [VertexId s w]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Vector (VertexId s w) -> [VertexId s w])
-> Vector (VertexId s w) -> [VertexId s w]
forall a b. (a -> b) -> a -> b
$ PlanarGraph s w v e f -> Vector (VertexId s w)
forall k (s :: k) (w :: World) v e f.
PlanarGraph s w v e f -> Vector (VertexId s w)
vertices' PlanarGraph s w v e f
g
                               ]
  where
    mkAdjacency :: VertexId s w -> Dart s -> VertexId s w :+ Dart s
mkAdjacency VertexId s w
v Dart s
d = VertexId s w -> Dart s -> VertexId s w
otherVtx VertexId s w
v Dart s
d VertexId s w -> Dart s -> VertexId s w :+ Dart s
forall core extra. core -> extra -> core :+ extra
:+ Dart s
d
    otherVtx :: VertexId s w -> Dart s -> VertexId s w
otherVtx VertexId s w
v Dart s
d = let u :: VertexId s w
u = Dart s -> PlanarGraph s w v e f -> VertexId s w
forall k (s :: k) (w :: World) v e f.
Dart s -> PlanarGraph s w v e f -> VertexId s w
tailOf Dart s
d PlanarGraph s w v e f
g in if VertexId s w
u VertexId s w -> VertexId s w -> Bool
forall a. Eq a => a -> a -> Bool
== VertexId s w
v then Dart s -> PlanarGraph s w v e f -> VertexId s w
forall k (s :: k) (w :: World) v e f.
Dart s -> PlanarGraph s w v e f -> VertexId s w
headOf Dart s
d PlanarGraph s w v e f
g else VertexId s w
u



-- | Builds an edge oracle that can be used to efficiently test if two vertices
-- are connected by an edge.
--
-- running time: \(O(n)\)
buildEdgeOracle        :: forall f s w e. (Foldable f)
                       => [(VertexId s w, f (VertexId s w :+ e))] -> EdgeOracle s w e
buildEdgeOracle :: [(VertexId s w, f (VertexId s w :+ e))] -> EdgeOracle s w e
buildEdgeOracle [(VertexId s w, f (VertexId s w :+ e))]
inAdj' = Vector (Vector (VertexId s w :+ e)) -> EdgeOracle s w e
forall k (s :: k) (w :: World) a.
Vector (Vector (VertexId s w :+ a)) -> EdgeOracle s w a
EdgeOracle (Vector (Vector (VertexId s w :+ e)) -> EdgeOracle s w e)
-> Vector (Vector (VertexId s w :+ e)) -> EdgeOracle s w e
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MVector s (Vector (VertexId s w :+ e))))
-> Vector (Vector (VertexId s w :+ e))
forall a. (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s (Vector (VertexId s w :+ e))))
 -> Vector (Vector (VertexId s w :+ e)))
-> (forall s. ST s (MVector s (Vector (VertexId s w :+ e))))
-> Vector (Vector (VertexId s w :+ e))
forall a b. (a -> b) -> a -> b
$ do
                          MVector s Int
counts <- Vector Int -> ST s (MVector (PrimState (ST s)) Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
UV.thaw Vector Int
initCounts
                          MVector s Bool
marks  <- Int -> Bool -> ST s (MVector (PrimState (ST s)) Bool)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> a -> m (MVector (PrimState m) a)
UMV.replicate (MVector s Int -> Int
forall a s. Unbox a => MVector s a -> Int
UMV.length MVector s Int
counts) Bool
False
                          MVector s (Vector (VertexId s w :+ e))
outV   <- Int
-> ST s (MVector (PrimState (ST s)) (Vector (VertexId s w :+ e)))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new (MVector s Int -> Int
forall a s. Unbox a => MVector s a -> Int
UMV.length MVector s Int
counts)
                          MVector s Int
-> MVector s Bool
-> MVector s (Vector (VertexId s w :+ e))
-> [Int]
-> ST s ()
forall s'.
MVector s' Int
-> MVector s' Bool
-> MVector s' (Vector (VertexId s w :+ e))
-> [Int]
-> ST s' ()
build MVector s Int
counts MVector s Bool
marks MVector s (Vector (VertexId s w :+ e))
outV [Int]
initQ
                          MVector s (Vector (VertexId s w :+ e))
-> ST s (MVector s (Vector (VertexId s w :+ e)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVector s (Vector (VertexId s w :+ e))
outV
    -- main idea: maintain a vector with counts; i.e. how many unprocessed
    -- vertices are adjacent to u, and a bit vector with marks to keep track if
    -- a vertex has been processed yet. When we process a vertex, we keep only
    -- the adjacencies of unprocessed verticese.
  where
    -- Convert to a vector representation
    inAdj :: Vector (Vector (VertexId s w :+ e))
inAdj = (forall s. ST s (MVector s (Vector (VertexId s w :+ e))))
-> Vector (Vector (VertexId s w :+ e))
forall a. (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s (Vector (VertexId s w :+ e))))
 -> Vector (Vector (VertexId s w :+ e)))
-> (forall s. ST s (MVector s (Vector (VertexId s w :+ e))))
-> Vector (Vector (VertexId s w :+ e))
forall a b. (a -> b) -> a -> b
$ do
              MVector s (Vector (VertexId s w :+ e))
mv <- Int
-> ST s (MVector (PrimState (ST s)) (Vector (VertexId s w :+ e)))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new ([(VertexId s w, f (VertexId s w :+ e))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(VertexId s w, f (VertexId s w :+ e))]
inAdj')
              [(VertexId s w, f (VertexId s w :+ e))]
-> ((VertexId s w, f (VertexId s w :+ e)) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(VertexId s w, f (VertexId s w :+ e))]
inAdj' (((VertexId s w, f (VertexId s w :+ e)) -> ST s ()) -> ST s ())
-> ((VertexId s w, f (VertexId s w :+ e)) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(VertexId Int
i,f (VertexId s w :+ e)
adjI) ->
                MVector (PrimState (ST s)) (Vector (VertexId s w :+ e))
-> Int -> Vector (VertexId s w :+ e) -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s (Vector (VertexId s w :+ e))
MVector (PrimState (ST s)) (Vector (VertexId s w :+ e))
mv Int
i ([VertexId s w :+ e] -> Vector (VertexId s w :+ e)
forall a. [a] -> Vector a
V.fromList ([VertexId s w :+ e] -> Vector (VertexId s w :+ e))
-> (f (VertexId s w :+ e) -> [VertexId s w :+ e])
-> f (VertexId s w :+ e)
-> Vector (VertexId s w :+ e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (VertexId s w :+ e) -> [VertexId s w :+ e]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (f (VertexId s w :+ e) -> Vector (VertexId s w :+ e))
-> f (VertexId s w :+ e) -> Vector (VertexId s w :+ e)
forall a b. (a -> b) -> a -> b
$ f (VertexId s w :+ e)
adjI)
              MVector s (Vector (VertexId s w :+ e))
-> ST s (MVector s (Vector (VertexId s w :+ e)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVector s (Vector (VertexId s w :+ e))
mv

    initCounts :: Vector Int
initCounts = Vector Int -> Vector Int
forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
V.convert (Vector Int -> Vector Int)
-> (Vector (Vector (VertexId s w :+ e)) -> Vector Int)
-> Vector (Vector (VertexId s w :+ e))
-> Vector Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector (VertexId s w :+ e) -> Int)
-> Vector (Vector (VertexId s w :+ e)) -> Vector Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector (VertexId s w :+ e) -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
GV.length (Vector (Vector (VertexId s w :+ e)) -> Vector Int)
-> Vector (Vector (VertexId s w :+ e)) -> Vector Int
forall a b. (a -> b) -> a -> b
$ Vector (Vector (VertexId s w :+ e))
inAdj
    -- initial vertices available for processing
    initQ :: [Int]
initQ = (Int -> Int -> [Int] -> [Int]) -> [Int] -> Vector Int -> [Int]
forall (v :: * -> *) a b.
Vector v a =>
(Int -> a -> b -> b) -> b -> v a -> b
GV.ifoldr (\Int
i Int
k [Int]
q -> if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 then Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
q else [Int]
q) [] Vector Int
initCounts

    -- | Construct the adjacencylist for vertex i. I.e. by retaining only adjacent
    -- vertices that have not been processed yet.
    extractAdj         :: UMV.MVector s' Bool -> Int
                       -> ST s' (V.Vector (VertexId s w :+ e))
    extractAdj :: MVector s' Bool -> Int -> ST s' (Vector (VertexId s w :+ e))
extractAdj MVector s' Bool
marks Int
i = let p :: (VertexId s w :+ e) -> ST s' Bool
p = (Bool -> Bool) -> ST s' Bool -> ST s' Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (ST s' Bool -> ST s' Bool)
-> ((VertexId s w :+ e) -> ST s' Bool)
-> (VertexId s w :+ e)
-> ST s' Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector (PrimState (ST s')) Bool -> Int -> ST s' Bool
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UMV.read MVector s' Bool
MVector (PrimState (ST s')) Bool
marks (Int -> ST s' Bool)
-> ((VertexId s w :+ e) -> Int)
-> (VertexId s w :+ e)
-> ST s' Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((VertexId s w :+ e) -> Getting Int (VertexId s w :+ e) Int -> Int
forall s a. s -> Getting a s a -> a
^.(VertexId s w -> Const Int (VertexId s w))
-> (VertexId s w :+ e) -> Const Int (VertexId s w :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((VertexId s w -> Const Int (VertexId s w))
 -> (VertexId s w :+ e) -> Const Int (VertexId s w :+ e))
-> ((Int -> Const Int Int)
    -> VertexId s w -> Const Int (VertexId s w))
-> Getting Int (VertexId s w :+ e) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> VertexId s w -> Const Int (VertexId s w)
forall k (s :: k) (w :: World). Getter (VertexId s w) Int
unVertexId)
                         in ((VertexId s w :+ e) -> ST s' Bool)
-> Vector (VertexId s w :+ e) -> ST s' (Vector (VertexId s w :+ e))
forall (m :: * -> *) (v :: * -> *) a.
(Monad m, Vector v a) =>
(a -> m Bool) -> v a -> m (v a)
GV.filterM  (VertexId s w :+ e) -> ST s' Bool
p (Vector (VertexId s w :+ e) -> ST s' (Vector (VertexId s w :+ e)))
-> Vector (VertexId s w :+ e) -> ST s' (Vector (VertexId s w :+ e))
forall a b. (a -> b) -> a -> b
$ Vector (Vector (VertexId s w :+ e))
inAdj Vector (Vector (VertexId s w :+ e))
-> Int -> Vector (VertexId s w :+ e)
forall a. Vector a -> Int -> a
V.! Int
i

    -- | Decreases the number of adjacencies that vertex j has
    -- if it has <= 6 adjacencies left it has become available for processing
    decrease                          :: UMV.MVector s' Int -> (VertexId s w :+ e')
                                      -> ST s' (Maybe Int)
    decrease :: MVector s' Int -> (VertexId s w :+ e') -> ST s' (Maybe Int)
decrease MVector s' Int
counts (VertexId Int
j :+ e'
_) = do Int
k <- MVector (PrimState (ST s')) Int -> Int -> ST s' Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UMV.read MVector s' Int
MVector (PrimState (ST s')) Int
counts Int
j
                                           let k' :: Int
k'  = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                                           MVector (PrimState (ST s')) Int -> Int -> Int -> ST s' ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
UMV.write MVector s' Int
MVector (PrimState (ST s')) Int
counts Int
j Int
k'
                                           Maybe Int -> ST s' (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> ST s' (Maybe Int)) -> Maybe Int -> ST s' (Maybe Int)
forall a b. (a -> b) -> a -> b
$ if Int
k' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
j else Maybe Int
forall a. Maybe a
Nothing

    -- The actual algorithm that builds the items
    build :: UMV.MVector s' Int -> UMV.MVector s' Bool
          -> MV.MVector s' (V.Vector (VertexId s w :+ e)) -> [Int] -> ST s' ()
    build :: MVector s' Int
-> MVector s' Bool
-> MVector s' (Vector (VertexId s w :+ e))
-> [Int]
-> ST s' ()
build MVector s' Int
_      MVector s' Bool
_     MVector s' (Vector (VertexId s w :+ e))
_    []    = () -> ST s' ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    build MVector s' Int
counts MVector s' Bool
marks MVector s' (Vector (VertexId s w :+ e))
outV (Int
i:[Int]
q) = do
             Bool
b <- MVector (PrimState (ST s')) Bool -> Int -> ST s' Bool
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UMV.read MVector s' Bool
MVector (PrimState (ST s')) Bool
marks Int
i
             [Maybe Int]
nq <- if Bool
b then [Maybe Int] -> ST s' [Maybe Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                        else do
                          Vector (VertexId s w :+ e)
adjI <- MVector s' Bool -> Int -> ST s' (Vector (VertexId s w :+ e))
forall s'.
MVector s' Bool -> Int -> ST s' (Vector (VertexId s w :+ e))
extractAdj MVector s' Bool
marks Int
i
                          MVector (PrimState (ST s')) (Vector (VertexId s w :+ e))
-> Int -> Vector (VertexId s w :+ e) -> ST s' ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s' (Vector (VertexId s w :+ e))
MVector (PrimState (ST s')) (Vector (VertexId s w :+ e))
outV Int
i Vector (VertexId s w :+ e)
adjI
                          MVector (PrimState (ST s')) Bool -> Int -> Bool -> ST s' ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
UMV.write MVector s' Bool
MVector (PrimState (ST s')) Bool
marks Int
i Bool
True
                          Vector (Maybe Int) -> [Maybe Int]
forall a. Vector a -> [a]
V.toList (Vector (Maybe Int) -> [Maybe Int])
-> ST s' (Vector (Maybe Int)) -> ST s' [Maybe Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((VertexId s w :+ e) -> ST s' (Maybe Int))
-> Vector (VertexId s w :+ e) -> ST s' (Vector (Maybe Int))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MVector s' Int -> (VertexId s w :+ e) -> ST s' (Maybe Int)
forall s' e'.
MVector s' Int -> (VertexId s w :+ e') -> ST s' (Maybe Int)
decrease MVector s' Int
counts) Vector (VertexId s w :+ e)
adjI
             MVector s' Int
-> MVector s' Bool
-> MVector s' (Vector (VertexId s w :+ e))
-> [Int]
-> ST s' ()
forall s'.
MVector s' Int
-> MVector s' Bool
-> MVector s' (Vector (VertexId s w :+ e))
-> [Int]
-> ST s' ()
build MVector s' Int
counts MVector s' Bool
marks MVector s' (Vector (VertexId s w :+ e))
outV ([Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Int]
nq [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int]
q)



-- | Test if u and v are connected by an edge.
--
-- running time: \(O(1)\)
hasEdge     :: VertexId s w -> VertexId s w -> EdgeOracle s w a -> Bool
hasEdge :: VertexId s w -> VertexId s w -> EdgeOracle s w a -> Bool
hasEdge VertexId s w
u VertexId s w
v = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool)
-> (EdgeOracle s w a -> Maybe a) -> EdgeOracle s w a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VertexId s w -> VertexId s w -> EdgeOracle s w a -> Maybe a
forall k (s :: k) (w :: World) a.
VertexId s w -> VertexId s w -> EdgeOracle s w a -> Maybe a
findEdge VertexId s w
u VertexId s w
v


-- | Find the edge data corresponding to edge (u,v) if such an edge exists
--
-- running time: \(O(1)\)
findEdge :: VertexId s w -> VertexId s w -> EdgeOracle s w a -> Maybe a
findEdge :: VertexId s w -> VertexId s w -> EdgeOracle s w a -> Maybe a
findEdge  (VertexId Int
u) (VertexId Int
v) (EdgeOracle Vector (Vector (VertexId s w :+ a))
os) = Int -> Int -> Maybe a
find' Int
u Int
v Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Int -> Maybe a
find' Int
v Int
u
  where
    find' :: Int -> Int -> Maybe a
find' Int
j Int
i = ((VertexId s w :+ a) -> a) -> Maybe (VertexId s w :+ a) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((VertexId s w :+ a) -> Getting a (VertexId s w :+ a) a -> a
forall s a. s -> Getting a s a -> a
^.Getting a (VertexId s w :+ a) a
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra) (Maybe (VertexId s w :+ a) -> Maybe a)
-> (Vector (VertexId s w :+ a) -> Maybe (VertexId s w :+ a))
-> Vector (VertexId s w :+ a)
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((VertexId s w :+ a) -> Bool)
-> Vector (VertexId s w :+ a) -> Maybe (VertexId s w :+ a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (\(VertexId Int
k :+ a
_) -> Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k) (Vector (VertexId s w :+ a) -> Maybe a)
-> Vector (VertexId s w :+ a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ Vector (Vector (VertexId s w :+ a))
os Vector (Vector (VertexId s w :+ a))
-> Int -> Vector (VertexId s w :+ a)
forall a. Vector a -> Int -> a
V.! Int
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 s w
-> VertexId s w -> EdgeOracle s w (Dart s) -> Maybe (Dart s)
findDart (VertexId Int
u) (VertexId Int
v) (EdgeOracle Vector (Vector (VertexId s w :+ Dart s))
os) = (Dart s -> Dart s) -> Int -> Int -> Maybe (Dart s)
find' Dart s -> Dart s
forall k (s :: k). Dart s -> Dart s
twin Int
u Int
v Maybe (Dart s) -> Maybe (Dart s) -> Maybe (Dart s)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Dart s -> Dart s) -> Int -> Int -> Maybe (Dart s)
find' Dart s -> Dart s
forall a. a -> a
id Int
v Int
u
  where
    -- looks up j in the adjacencylist of i and applies f to the result
    find' :: (Dart s -> Dart s) -> Int -> Int -> Maybe (Dart s)
find' Dart s -> Dart s
f Int
j Int
i = ((VertexId s w :+ Dart s) -> Dart s)
-> Maybe (VertexId s w :+ Dart s) -> Maybe (Dart s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dart s -> Dart s
f (Dart s -> Dart s)
-> ((VertexId s w :+ Dart s) -> Dart s)
-> (VertexId s w :+ Dart s)
-> Dart s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((VertexId s w :+ Dart s)
-> Getting (Dart s) (VertexId s w :+ Dart s) (Dart s) -> Dart s
forall s a. s -> Getting a s a -> a
^.Getting (Dart s) (VertexId s w :+ Dart s) (Dart s)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra)) (Maybe (VertexId s w :+ Dart s) -> Maybe (Dart s))
-> (Vector (VertexId s w :+ Dart s)
    -> Maybe (VertexId s w :+ Dart s))
-> Vector (VertexId s w :+ Dart s)
-> Maybe (Dart s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((VertexId s w :+ Dart s) -> Bool)
-> Vector (VertexId s w :+ Dart s)
-> Maybe (VertexId s w :+ Dart s)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (\(VertexId Int
k :+ Dart s
_) -> Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k) (Vector (VertexId s w :+ Dart s) -> Maybe (Dart s))
-> Vector (VertexId s w :+ Dart s) -> Maybe (Dart s)
forall a b. (a -> b) -> a -> b
$ Vector (Vector (VertexId s w :+ Dart s))
os Vector (Vector (VertexId s w :+ Dart s))
-> Int -> Vector (VertexId s w :+ Dart s)
forall a. Vector a -> Int -> a
V.! Int
i