{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
module ToySolver.Graph.ShortestPath
(
Graph
, Edge
, OutEdge
, InEdge
, Fold (..)
, monoid'
, monoid
, unit
, pair
, path
, firstOutEdge
, lastInEdge
, cost
, Path (..)
, pathFrom
, pathTo
, pathCost
, pathEmpty
, pathAppend
, pathEdges
, pathEdgesBackward
, pathEdgesSeq
, pathVertexes
, pathVertexesBackward
, pathVertexesSeq
, pathFold
, pathMin
, bellmanFord
, dijkstra
, floydWarshall
, bellmanFordDetectNegativeCycle
) where
import Control.Monad
import Control.Monad.ST
import Control.Monad.Trans
import Control.Monad.Trans.Except
import Data.Hashable
import qualified Data.HashTable.Class as H
import qualified Data.HashTable.ST.Cuckoo as C
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Heap as Heap
import Data.List (foldl')
import Data.Maybe (fromJust)
import Data.Monoid
import Data.Ord
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.STRef
type Graph cost label = IntMap [OutEdge cost label]
type Vertex = Int
type Edge cost label = (Vertex, Vertex, cost, label)
type OutEdge cost label = (Vertex, cost, label)
type InEdge cost label = (Vertex, cost, label)
data Path cost label
= Empty Vertex
| Singleton (Edge cost label)
| Append (Path cost label) (Path cost label) !cost
deriving (Path cost label -> Path cost label -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall cost label.
(Eq cost, Eq label) =>
Path cost label -> Path cost label -> Bool
/= :: Path cost label -> Path cost label -> Bool
$c/= :: forall cost label.
(Eq cost, Eq label) =>
Path cost label -> Path cost label -> Bool
== :: Path cost label -> Path cost label -> Bool
$c== :: forall cost label.
(Eq cost, Eq label) =>
Path cost label -> Path cost label -> Bool
Eq, Vertex -> Path cost label -> ShowS
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall cost label.
(Show cost, Show label) =>
Vertex -> Path cost label -> ShowS
forall cost label.
(Show cost, Show label) =>
[Path cost label] -> ShowS
forall cost label.
(Show cost, Show label) =>
Path cost label -> String
showList :: [Path cost label] -> ShowS
$cshowList :: forall cost label.
(Show cost, Show label) =>
[Path cost label] -> ShowS
show :: Path cost label -> String
$cshow :: forall cost label.
(Show cost, Show label) =>
Path cost label -> String
showsPrec :: Vertex -> Path cost label -> ShowS
$cshowsPrec :: forall cost label.
(Show cost, Show label) =>
Vertex -> Path cost label -> ShowS
Show)
pathFrom :: Path cost label -> Vertex
pathFrom :: forall cost label. Path cost label -> Vertex
pathFrom (Empty Vertex
v) = Vertex
v
pathFrom (Singleton (Vertex
from,Vertex
_,cost
_,label
_)) = Vertex
from
pathFrom (Append Path cost label
p1 Path cost label
_ cost
_) = forall cost label. Path cost label -> Vertex
pathFrom Path cost label
p1
pathTo :: Path cost label -> Vertex
pathTo :: forall cost label. Path cost label -> Vertex
pathTo (Empty Vertex
v) = Vertex
v
pathTo (Singleton (Vertex
_,Vertex
to,cost
_,label
_)) = Vertex
to
pathTo (Append Path cost label
_ Path cost label
p2 cost
_) = forall cost label. Path cost label -> Vertex
pathTo Path cost label
p2
pathCost :: Num cost => Path cost label -> cost
pathCost :: forall cost label. Num cost => Path cost label -> cost
pathCost (Empty Vertex
_) = cost
0
pathCost (Singleton (Vertex
_,Vertex
_,cost
c,label
_)) = cost
c
pathCost (Append Path cost label
_ Path cost label
_ cost
c) = cost
c
pathEmpty :: Vertex -> Path cost label
pathEmpty :: forall cost label. Vertex -> Path cost label
pathEmpty = forall cost label. Vertex -> Path cost label
Empty
pathAppend :: (Num cost) => Path cost label -> Path cost label -> Path cost label
pathAppend :: forall cost label.
Num cost =>
Path cost label -> Path cost label -> Path cost label
pathAppend Path cost label
p1 Path cost label
p2
| forall cost label. Path cost label -> Vertex
pathTo Path cost label
p1 forall a. Eq a => a -> a -> Bool
/= forall cost label. Path cost label -> Vertex
pathFrom Path cost label
p2 = forall a. HasCallStack => String -> a
error String
"ToySolver.Graph.ShortestPath.pathAppend: pathTo/pathFrom mismatch"
| Bool
otherwise =
case (Path cost label
p1, Path cost label
p2) of
(Empty Vertex
_, Path cost label
_) -> Path cost label
p2
(Path cost label
_, Empty Vertex
_) -> Path cost label
p1
(Path cost label, Path cost label)
_ -> forall cost label.
Path cost label -> Path cost label -> cost -> Path cost label
Append Path cost label
p1 Path cost label
p2 (forall cost label. Num cost => Path cost label -> cost
pathCost Path cost label
p1 forall a. Num a => a -> a -> a
+ forall cost label. Num cost => Path cost label -> cost
pathCost Path cost label
p2)
pathEdges :: Path cost label -> [Edge cost label]
pathEdges :: forall cost label. Path cost label -> [Edge cost label]
pathEdges Path cost label
p = forall {cost} {label}.
Path cost label -> [Edge cost label] -> [Edge cost label]
f Path cost label
p []
where
f :: Path cost label -> [Edge cost label] -> [Edge cost label]
f (Empty Vertex
_) [Edge cost label]
xs = [Edge cost label]
xs
f (Singleton Edge cost label
e) [Edge cost label]
xs = Edge cost label
e forall a. a -> [a] -> [a]
: [Edge cost label]
xs
f (Append Path cost label
p1 Path cost label
p2 cost
_) [Edge cost label]
xs = Path cost label -> [Edge cost label] -> [Edge cost label]
f Path cost label
p1 (Path cost label -> [Edge cost label] -> [Edge cost label]
f Path cost label
p2 [Edge cost label]
xs)
pathEdgesBackward :: Path cost label -> [Edge cost label]
pathEdgesBackward :: forall cost label. Path cost label -> [Edge cost label]
pathEdgesBackward Path cost label
p = forall {cost} {label}.
Path cost label -> [Edge cost label] -> [Edge cost label]
f Path cost label
p []
where
f :: Path cost label -> [Edge cost label] -> [Edge cost label]
f (Empty Vertex
_) [Edge cost label]
xs = [Edge cost label]
xs
f (Singleton Edge cost label
e) [Edge cost label]
xs = Edge cost label
e forall a. a -> [a] -> [a]
: [Edge cost label]
xs
f (Append Path cost label
p1 Path cost label
p2 cost
_) [Edge cost label]
xs = Path cost label -> [Edge cost label] -> [Edge cost label]
f Path cost label
p2 (Path cost label -> [Edge cost label] -> [Edge cost label]
f Path cost label
p1 [Edge cost label]
xs)
pathEdgesSeq :: Path cost label -> Seq (Edge cost label)
pathEdgesSeq :: forall cost label. Path cost label -> Seq (Edge cost label)
pathEdgesSeq (Empty Vertex
_) = forall a. Seq a
Seq.empty
pathEdgesSeq (Singleton Edge cost label
e) = forall a. a -> Seq a
Seq.singleton Edge cost label
e
pathEdgesSeq (Append Path cost label
p1 Path cost label
p2 cost
_) = forall cost label. Path cost label -> Seq (Edge cost label)
pathEdgesSeq Path cost label
p1 forall a. Semigroup a => a -> a -> a
<> forall cost label. Path cost label -> Seq (Edge cost label)
pathEdgesSeq Path cost label
p2
pathVertexes :: Path cost label -> [Vertex]
pathVertexes :: forall cost label. Path cost label -> [Vertex]
pathVertexes Path cost label
p = forall cost label. Path cost label -> Vertex
pathFrom Path cost label
p forall a. a -> [a] -> [a]
: forall {cost} {label}. Path cost label -> [Vertex] -> [Vertex]
f Path cost label
p []
where
f :: Path cost label -> [Vertex] -> [Vertex]
f (Empty Vertex
_) [Vertex]
xs = [Vertex]
xs
f (Singleton (Vertex
_,Vertex
v2,cost
_,label
_)) [Vertex]
xs = Vertex
v2 forall a. a -> [a] -> [a]
: [Vertex]
xs
f (Append Path cost label
p1 Path cost label
p2 cost
_) [Vertex]
xs = Path cost label -> [Vertex] -> [Vertex]
f Path cost label
p1 (Path cost label -> [Vertex] -> [Vertex]
f Path cost label
p2 [Vertex]
xs)
pathVertexesBackward :: Path cost label -> [Vertex]
pathVertexesBackward :: forall cost label. Path cost label -> [Vertex]
pathVertexesBackward Path cost label
p = forall cost label. Path cost label -> Vertex
pathTo Path cost label
p forall a. a -> [a] -> [a]
: forall {cost} {label}. Path cost label -> [Vertex] -> [Vertex]
f Path cost label
p []
where
f :: Path cost label -> [Vertex] -> [Vertex]
f (Empty Vertex
_) [Vertex]
xs = [Vertex]
xs
f (Singleton (Vertex
v1,Vertex
_,cost
_,label
_)) [Vertex]
xs = Vertex
v1 forall a. a -> [a] -> [a]
: [Vertex]
xs
f (Append Path cost label
p1 Path cost label
p2 cost
_) [Vertex]
xs = Path cost label -> [Vertex] -> [Vertex]
f Path cost label
p2 (Path cost label -> [Vertex] -> [Vertex]
f Path cost label
p1 [Vertex]
xs)
pathVertexesSeq :: Path cost label -> Seq Vertex
pathVertexesSeq :: forall cost label. Path cost label -> Seq Vertex
pathVertexesSeq Path cost label
p = forall {cost} {label}. Bool -> Path cost label -> Seq Vertex
f Bool
True Path cost label
p
where
f :: Bool -> Path cost label -> Seq Vertex
f Bool
True (Empty Vertex
v) = forall a. a -> Seq a
Seq.singleton Vertex
v
f Bool
False (Empty Vertex
_) = forall a. Monoid a => a
mempty
f Bool
True (Singleton (Vertex
v1,Vertex
v2,cost
_,label
_)) = forall a. [a] -> Seq a
Seq.fromList [Vertex
v1, Vertex
v2]
f Bool
False (Singleton (Vertex
v1,Vertex
_,cost
_,label
_)) = forall a. a -> Seq a
Seq.singleton Vertex
v1
f Bool
b (Append Path cost label
p1 Path cost label
p2 cost
_) = Bool -> Path cost label -> Seq Vertex
f Bool
False Path cost label
p1 forall a. Semigroup a => a -> a -> a
<> Bool -> Path cost label -> Seq Vertex
f Bool
b Path cost label
p2
pathMin :: (Num cost, Ord cost) => Path cost label -> Path cost label -> Path cost label
pathMin :: forall cost label.
(Num cost, Ord cost) =>
Path cost label -> Path cost label -> Path cost label
pathMin Path cost label
p1 Path cost label
p2
| forall cost label. Num cost => Path cost label -> cost
pathCost Path cost label
p1 forall a. Ord a => a -> a -> Bool
<= forall cost label. Num cost => Path cost label -> cost
pathCost Path cost label
p2 = Path cost label
p1
| Bool
otherwise = Path cost label
p2
pathFold :: Fold cost label a -> Path cost label -> a
pathFold :: forall cost label a. Fold cost label a -> Path cost label -> a
pathFold (Fold Vertex -> a
fV Edge cost label -> a
fE a -> a -> a
fC a -> a
fD) Path cost label
p = a -> a
fD (Path cost label -> a
h Path cost label
p)
where
h :: Path cost label -> a
h (Empty Vertex
v) = Vertex -> a
fV Vertex
v
h (Singleton Edge cost label
e) = Edge cost label -> a
fE Edge cost label
e
h (Append Path cost label
p1 Path cost label
p2 cost
_) = a -> a -> a
fC (Path cost label -> a
h Path cost label
p1) (Path cost label -> a
h Path cost label
p2)
data Pair a b = Pair !a !b
data Fold cost label r
= forall a. Fold (Vertex -> a) (Edge cost label -> a) (a -> a -> a) (a -> r)
instance Functor (Fold cost label) where
{-# INLINE fmap #-}
fmap :: forall a b. (a -> b) -> Fold cost label a -> Fold cost label b
fmap a -> b
f (Fold Vertex -> a
fV Edge cost label -> a
fE a -> a -> a
fC a -> a
fD) = forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold Vertex -> a
fV Edge cost label -> a
fE a -> a -> a
fC (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
fD)
instance Applicative (Fold cost label) where
{-# INLINE pure #-}
pure :: forall a. a -> Fold cost label a
pure a
a = forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Vertex
_ -> ()) (\Edge cost label
_ -> ()) (\()
_ ()
_ -> ()) (forall a b. a -> b -> a
const a
a)
{-# INLINE (<*>) #-}
Fold Vertex -> a
fV1 Edge cost label -> a
fE1 a -> a -> a
fC1 a -> a -> b
fD1 <*> :: forall a b.
Fold cost label (a -> b) -> Fold cost label a -> Fold cost label b
<*> Fold Vertex -> a
fV2 Edge cost label -> a
fE2 a -> a -> a
fC2 a -> a
fD2 =
forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Vertex
v -> forall a b. a -> b -> Pair a b
Pair (Vertex -> a
fV1 Vertex
v) (Vertex -> a
fV2 Vertex
v))
(\Edge cost label
e -> forall a b. a -> b -> Pair a b
Pair (Edge cost label -> a
fE1 Edge cost label
e) (Edge cost label -> a
fE2 Edge cost label
e))
(\(Pair a
a1 a
b1) (Pair a
a2 a
b2) -> forall a b. a -> b -> Pair a b
Pair (a -> a -> a
fC1 a
a1 a
a2) (a -> a -> a
fC2 a
b1 a
b2))
(\(Pair a
a a
b) -> a -> a -> b
fD1 a
a (a -> a
fD2 a
b))
monoid' :: Monoid m => (Edge cost label -> m) -> Fold cost label m
monoid' :: forall m cost label.
Monoid m =>
(Edge cost label -> m) -> Fold cost label m
monoid' Edge cost label -> m
f = forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Vertex
_ -> forall a. Monoid a => a
mempty) Edge cost label -> m
f forall a. Monoid a => a -> a -> a
mappend forall a. a -> a
id
monoid :: Monoid m => Fold cost m m
monoid :: forall m cost. Monoid m => Fold cost m m
monoid = forall m cost label.
Monoid m =>
(Edge cost label -> m) -> Fold cost label m
monoid' (\(Vertex
_,Vertex
_,cost
_,m
m) -> m
m)
unit :: Fold cost label ()
unit :: forall cost label. Fold cost label ()
unit = forall m cost label.
Monoid m =>
(Edge cost label -> m) -> Fold cost label m
monoid' (\Edge cost label
_ -> ())
pair :: Fold cost label a -> Fold cost label b -> Fold cost label (a,b)
pair :: forall cost label a b.
Fold cost label a -> Fold cost label b -> Fold cost label (a, b)
pair (Fold Vertex -> a
fV1 Edge cost label -> a
fE1 a -> a -> a
fC1 a -> a
fD1) (Fold Vertex -> a
fV2 Edge cost label -> a
fE2 a -> a -> a
fC2 a -> b
fD2) =
forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Vertex
v -> forall a b. a -> b -> Pair a b
Pair (Vertex -> a
fV1 Vertex
v) (Vertex -> a
fV2 Vertex
v))
(\Edge cost label
e -> forall a b. a -> b -> Pair a b
Pair (Edge cost label -> a
fE1 Edge cost label
e) (Edge cost label -> a
fE2 Edge cost label
e))
(\(Pair a
a1 a
b1) (Pair a
a2 a
b2) -> forall a b. a -> b -> Pair a b
Pair (a -> a -> a
fC1 a
a1 a
a2) (a -> a -> a
fC2 a
b1 a
b2))
(\(Pair a
a a
b) -> (a -> a
fD1 a
a, a -> b
fD2 a
b))
path :: (Num cost) => Fold cost label (Path cost label)
path :: forall cost label. Num cost => Fold cost label (Path cost label)
path = forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold forall cost label. Vertex -> Path cost label
pathEmpty forall cost label. Edge cost label -> Path cost label
Singleton forall cost label.
Num cost =>
Path cost label -> Path cost label -> Path cost label
pathAppend forall a. a -> a
id
cost :: Num cost => Fold cost label cost
cost :: forall cost label. Num cost => Fold cost label cost
cost = forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Vertex
_ -> cost
0) (\(Vertex
_,Vertex
_,cost
c,label
_) -> cost
c) forall a. Num a => a -> a -> a
(+) forall a. a -> a
id
firstOutEdge :: Fold cost label (First (OutEdge cost label))
firstOutEdge :: forall cost label. Fold cost label (First (OutEdge cost label))
firstOutEdge = forall m cost label.
Monoid m =>
(Edge cost label -> m) -> Fold cost label m
monoid' (\(Vertex
_,Vertex
v,cost
c,label
l) -> forall a. Maybe a -> First a
First (forall a. a -> Maybe a
Just (Vertex
v,cost
c,label
l)))
lastInEdge :: Fold cost label (Last (InEdge cost label))
lastInEdge :: forall cost label. Fold cost label (Last (InEdge cost label))
lastInEdge = forall m cost label.
Monoid m =>
(Edge cost label -> m) -> Fold cost label m
monoid' (\(Vertex
v,Vertex
_,cost
c,label
l) -> forall a. Maybe a -> Last a
Last (forall a. a -> Maybe a
Just (Vertex
v,cost
c,label
l)))
bellmanFord
:: Real cost
=> Fold cost label a
-> Graph cost label
-> [Vertex]
-> IntMap (cost, a)
bellmanFord :: forall cost label a.
Real cost =>
Fold cost label a
-> Graph cost label -> [Vertex] -> IntMap (cost, a)
bellmanFord (Fold Vertex -> a
fV Edge cost label -> a
fE a -> a -> a
fC a -> a
fD) Graph cost label
g [Vertex]
ss = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
let n :: Vertex
n = forall a. IntMap a -> Vertex
IntMap.size Graph cost label
g
HashTable s Vertex (Pair cost a)
d <- forall s k v. Vertex -> ST s (HashTable s k v)
C.newSized Vertex
n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Vertex]
ss forall a b. (a -> b) -> a -> b
$ \Vertex
s -> forall (h :: * -> * -> * -> *) k s v.
(HashTable h, Eq k, Hashable k) =>
h s k v -> k -> v -> ST s ()
H.insert HashTable s Vertex (Pair cost a)
d Vertex
s (forall a b. a -> b -> Pair a b
Pair cost
0 (Vertex -> a
fV Vertex
s))
STRef s IntSet
updatedRef <- forall a s. a -> ST s (STRef s a)
newSTRef ([Vertex] -> IntSet
IntSet.fromList [Vertex]
ss)
Either () ()
_ <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Vertex -> m a -> m ()
replicateM_ Vertex
n forall a b. (a -> b) -> a -> b
$ do
IntSet
us <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s IntSet
updatedRef
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IntSet -> Bool
IntSet.null IntSet
us) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s IntSet
updatedRef IntSet
IntSet.empty
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntSet -> [Vertex]
IntSet.toList IntSet
us) forall a b. (a -> b) -> a -> b
$ \Vertex
u -> do
Pair cost
du a
a <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (h :: * -> * -> * -> *) k s v.
(HashTable h, Eq k, Hashable k) =>
h s k v -> k -> ST s (Maybe v)
H.lookup HashTable s Vertex (Pair cost a)
d Vertex
u
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. a -> Vertex -> IntMap a -> a
IntMap.findWithDefault [] Vertex
u Graph cost label
g) forall a b. (a -> b) -> a -> b
$ \(Vertex
v, cost
c, label
l) -> do
Maybe (Pair cost a)
m <- forall (h :: * -> * -> * -> *) k s v.
(HashTable h, Eq k, Hashable k) =>
h s k v -> k -> ST s (Maybe v)
H.lookup HashTable s Vertex (Pair cost a)
d Vertex
v
case Maybe (Pair cost a)
m of
Just (Pair cost
c0 a
_) | cost
c0 forall a. Ord a => a -> a -> Bool
<= cost
du forall a. Num a => a -> a -> a
+ cost
c -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe (Pair cost a)
_ -> do
forall (h :: * -> * -> * -> *) k s v.
(HashTable h, Eq k, Hashable k) =>
h s k v -> k -> v -> ST s ()
H.insert HashTable s Vertex (Pair cost a)
d Vertex
v (forall a b. a -> b -> Pair a b
Pair (cost
du forall a. Num a => a -> a -> a
+ cost
c) (a
a a -> a -> a
`fC` Edge cost label -> a
fE (Vertex
u,Vertex
v,cost
c,label
l)))
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s IntSet
updatedRef (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
v)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pair cost
c a
x) -> (cost
c, a -> a
fD a
x))) forall a b. (a -> b) -> a -> b
$ forall (h :: * -> * -> * -> *) s v.
HashTable h =>
h s Vertex v -> ST s (IntMap v)
freezeHashTable HashTable s Vertex (Pair cost a)
d
freezeHashTable :: H.HashTable h => h s Int v -> ST s (IntMap v)
freezeHashTable :: forall (h :: * -> * -> * -> *) s v.
HashTable h =>
h s Vertex v -> ST s (IntMap v)
freezeHashTable h s Vertex v
h = forall (h :: * -> * -> * -> *) a k v s.
HashTable h =>
(a -> (k, v) -> ST s a) -> a -> h s k v -> ST s a
H.foldM (\IntMap v
m (Vertex
k,v
v) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Vertex -> a -> IntMap a -> IntMap a
IntMap.insert Vertex
k v
v IntMap v
m) forall a. IntMap a
IntMap.empty h s Vertex v
h
bellmanFordDetectNegativeCycle
:: forall cost label a. Real cost
=> Fold cost label a
-> Graph cost label
-> IntMap (cost, Last (InEdge cost label))
-> Maybe a
bellmanFordDetectNegativeCycle :: forall cost label a.
Real cost =>
Fold cost label a
-> Graph cost label
-> IntMap (cost, Last (InEdge cost label))
-> Maybe a
bellmanFordDetectNegativeCycle (Fold Vertex -> a
fV Edge cost label -> a
fE a -> a -> a
fC a -> a
fD) Graph cost label
g IntMap (cost, Last (InEdge cost label))
d = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
fD) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. IntMap a -> [(Vertex, a)]
IntMap.toList IntMap (cost, Last (InEdge cost label))
d) forall a b. (a -> b) -> a -> b
$ \(Vertex
u,(cost
du,Last (InEdge cost label)
_)) ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. a -> Vertex -> IntMap a -> a
IntMap.findWithDefault [] Vertex
u Graph cost label
g) forall a b. (a -> b) -> a -> b
$ \(Vertex
v, cost
c, label
l) -> do
let (cost
dv,Last (InEdge cost label)
_) = IntMap (cost, Last (InEdge cost label))
d forall a. IntMap a -> Vertex -> a
IntMap.! Vertex
v
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (cost
du forall a. Num a => a -> a -> a
+ cost
c forall a. Ord a => a -> a -> Bool
< cost
dv) forall a b. (a -> b) -> a -> b
$ do
let d' :: IntMap (cost, Last (InEdge cost label))
d' = forall a. Vertex -> a -> IntMap a -> IntMap a
IntMap.insert Vertex
v (cost
du forall a. Num a => a -> a -> a
+ cost
c, forall a. Maybe a -> Last a
Last (forall a. a -> Maybe a
Just (Vertex
u, cost
c, label
l))) IntMap (cost, Last (InEdge cost label))
d
parent :: Vertex -> Vertex
parent Vertex
u = do
case forall a. Vertex -> IntMap a -> Maybe a
IntMap.lookup Vertex
u IntMap (cost, Last (InEdge cost label))
d' of
Just (cost
_, Last (Just (Vertex
v,cost
_,label
_))) -> Vertex
v
Maybe (cost, Last (InEdge cost label))
_ -> forall a. HasCallStack => a
undefined
u0 :: Vertex
u0 = Vertex -> Vertex -> Vertex
go (Vertex -> Vertex
parent (Vertex -> Vertex
parent Vertex
v)) (Vertex -> Vertex
parent Vertex
v)
where
go :: Vertex -> Vertex -> Vertex
go Vertex
hare Vertex
tortoise
| Vertex
hare forall a. Eq a => a -> a -> Bool
== Vertex
tortoise = Vertex
hare
| Bool
otherwise = Vertex -> Vertex -> Vertex
go (Vertex -> Vertex
parent (Vertex -> Vertex
parent Vertex
hare)) (Vertex -> Vertex
parent Vertex
tortoise)
let go :: Vertex -> a -> a
go Vertex
u a
result = do
let Just (cost
_, Last (Just (Vertex
v,cost
c,label
l))) = forall a. Vertex -> IntMap a -> Maybe a
IntMap.lookup Vertex
u IntMap (cost, Last (InEdge cost label))
d'
if Vertex
v forall a. Eq a => a -> a -> Bool
== Vertex
u0 then
a -> a -> a
fC (Edge cost label -> a
fE (Vertex
v,Vertex
u,cost
c,label
l)) a
result
else
Vertex -> a -> a
go Vertex
v (a -> a -> a
fC (Edge cost label -> a
fE (Vertex
v,Vertex
u,cost
c,label
l)) a
result)
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Vertex -> a -> a
go Vertex
u0 (Vertex -> a
fV Vertex
u0)
dijkstra
:: forall cost label a. Real cost
=> Fold cost label a
-> Graph cost label
-> [Vertex]
-> IntMap (cost, a)
dijkstra :: forall cost label a.
Real cost =>
Fold cost label a
-> Graph cost label -> [Vertex] -> IntMap (cost, a)
dijkstra (Fold Vertex -> a
fV Edge cost label -> a
fE a -> a -> a
fC (a -> a
fD :: x -> a)) Graph cost label
g [Vertex]
ss =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pair cost
c a
x) -> (cost
c, a -> a
fD a
x)) forall a b. (a -> b) -> a -> b
$
Heap (Entry cost (Pair Vertex a))
-> IntMap (Pair cost a) -> IntMap (Pair cost a)
loop (forall a. Ord a => [a] -> Heap a
Heap.fromList [forall p a. p -> a -> Entry p a
Heap.Entry cost
0 (forall a b. a -> b -> Pair a b
Pair Vertex
s (Vertex -> a
fV Vertex
s)) | Vertex
s <- [Vertex]
ss]) forall a. IntMap a
IntMap.empty
where
loop
:: Heap.Heap (Heap.Entry cost (Pair Vertex x))
-> IntMap (Pair cost x)
-> IntMap (Pair cost x)
loop :: Heap (Entry cost (Pair Vertex a))
-> IntMap (Pair cost a) -> IntMap (Pair cost a)
loop Heap (Entry cost (Pair Vertex a))
q IntMap (Pair cost a)
visited =
case forall a. Heap a -> Maybe (a, Heap a)
Heap.viewMin Heap (Entry cost (Pair Vertex a))
q of
Maybe
(Entry cost (Pair Vertex a), Heap (Entry cost (Pair Vertex a)))
Nothing -> IntMap (Pair cost a)
visited
Just (Heap.Entry cost
c (Pair Vertex
v a
a), Heap (Entry cost (Pair Vertex a))
q')
| Vertex
v forall a. Vertex -> IntMap a -> Bool
`IntMap.member` IntMap (Pair cost a)
visited -> Heap (Entry cost (Pair Vertex a))
-> IntMap (Pair cost a) -> IntMap (Pair cost a)
loop Heap (Entry cost (Pair Vertex a))
q' IntMap (Pair cost a)
visited
| Bool
otherwise ->
let q2 :: Heap (Entry cost (Pair Vertex a))
q2 = forall a. Ord a => [a] -> Heap a
Heap.fromList
[ forall p a. p -> a -> Entry p a
Heap.Entry (cost
cforall a. Num a => a -> a -> a
+cost
c') (forall a b. a -> b -> Pair a b
Pair Vertex
ch (a
a a -> a -> a
`fC` Edge cost label -> a
fE (Vertex
v,Vertex
ch,cost
c',label
l)))
| (Vertex
ch,cost
c',label
l) <- forall a. a -> Vertex -> IntMap a -> a
IntMap.findWithDefault [] Vertex
v Graph cost label
g
, Bool -> Bool
not (Vertex
ch forall a. Vertex -> IntMap a -> Bool
`IntMap.member` IntMap (Pair cost a)
visited)
]
in Heap (Entry cost (Pair Vertex a))
-> IntMap (Pair cost a) -> IntMap (Pair cost a)
loop (forall a. Heap a -> Heap a -> Heap a
Heap.union Heap (Entry cost (Pair Vertex a))
q' Heap (Entry cost (Pair Vertex a))
q2) (forall a. Vertex -> a -> IntMap a -> IntMap a
IntMap.insert Vertex
v (forall a b. a -> b -> Pair a b
Pair cost
c a
a) IntMap (Pair cost a)
visited)
floydWarshall
:: forall cost label a. Real cost
=> Fold cost label a
-> Graph cost label
-> IntMap (IntMap (cost, a))
floydWarshall :: forall cost label a.
Real cost =>
Fold cost label a -> Graph cost label -> IntMap (IntMap (cost, a))
floydWarshall (Fold Vertex -> a
fV Edge cost label -> a
fE a -> a -> a
fC (a -> a
fD :: x -> a)) Graph cost label
g =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pair cost
c a
x) -> (cost
c, a -> a
fD a
x))) forall a b. (a -> b) -> a -> b
$
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith (forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith Pair cost a -> Pair cost a -> Pair cost a
minP) (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntMap (IntMap (Pair cost a))
-> Vertex -> IntMap (IntMap (Pair cost a))
f IntMap (IntMap (Pair cost a))
tbl0 [Vertex]
vs) IntMap (IntMap (Pair cost a))
paths0
where
vs :: [Vertex]
vs = forall a. IntMap a -> [Vertex]
IntMap.keys Graph cost label
g
paths0 :: IntMap (IntMap (Pair cost x))
paths0 :: IntMap (IntMap (Pair cost a))
paths0 = forall a b. (Vertex -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey (\Vertex
v [OutEdge cost label]
_ -> forall a. Vertex -> a -> IntMap a
IntMap.singleton Vertex
v (forall a b. a -> b -> Pair a b
Pair cost
0 (Vertex -> a
fV Vertex
v))) Graph cost label
g
tbl0 :: IntMap (IntMap (Pair cost x))
tbl0 :: IntMap (IntMap (Pair cost a))
tbl0 = forall a b. (Vertex -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey (\Vertex
v [OutEdge cost label]
es -> forall a. (a -> a -> a) -> [(Vertex, a)] -> IntMap a
IntMap.fromListWith Pair cost a -> Pair cost a -> Pair cost a
minP [(Vertex
u, (forall a b. a -> b -> Pair a b
Pair cost
c (Edge cost label -> a
fE (Vertex
v,Vertex
u,cost
c,label
l)))) | (Vertex
u,cost
c,label
l) <- [OutEdge cost label]
es]) Graph cost label
g
minP :: Pair cost x -> Pair cost x -> Pair cost x
minP :: Pair cost a -> Pair cost a -> Pair cost a
minP = forall a. (a -> a -> Ordering) -> a -> a -> a
minBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Pair cost
c a
_) -> cost
c))
f :: IntMap (IntMap (Pair cost x))
-> Vertex
-> IntMap (IntMap (Pair cost x))
f :: IntMap (IntMap (Pair cost a))
-> Vertex -> IntMap (IntMap (Pair cost a))
f IntMap (IntMap (Pair cost a))
tbl Vertex
vk =
case forall a. Vertex -> IntMap a -> Maybe a
IntMap.lookup Vertex
vk IntMap (IntMap (Pair cost a))
tbl of
Maybe (IntMap (Pair cost a))
Nothing -> IntMap (IntMap (Pair cost a))
tbl
Just IntMap (Pair cost a)
hk -> forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map IntMap (Pair cost a) -> IntMap (Pair cost a)
h IntMap (IntMap (Pair cost a))
tbl
where
h :: IntMap (Pair cost x) -> IntMap (Pair cost x)
h :: IntMap (Pair cost a) -> IntMap (Pair cost a)
h IntMap (Pair cost a)
m =
case forall a. Vertex -> IntMap a -> Maybe a
IntMap.lookup Vertex
vk IntMap (Pair cost a)
m of
Maybe (Pair cost a)
Nothing -> IntMap (Pair cost a)
m
Just (Pair cost
c1 a
x1) -> forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith Pair cost a -> Pair cost a -> Pair cost a
minP IntMap (Pair cost a)
m (forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (\(Pair cost
c2 a
x2) -> (forall a b. a -> b -> Pair a b
Pair (cost
c1forall a. Num a => a -> a -> a
+cost
c2) (a -> a -> a
fC a
x1 a
x2))) IntMap (Pair cost a)
hk)
minBy :: (a -> a -> Ordering) -> a -> a -> a
minBy :: forall a. (a -> a -> Ordering) -> a -> a -> a
minBy a -> a -> Ordering
f a
a a
b =
case a -> a -> Ordering
f a
a a
b of
Ordering
LT -> a
a
Ordering
EQ -> a
a
Ordering
GT -> a
b