{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Graph.ShortestPath
-- Copyright   :  (c) Masahiro Sakai 2016-2017
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- This module provides functions for shotest path computation.
--
-- Reference:
--
-- * Friedrich Eisenbrand. “Linear and Discrete Optimization”.
--   <https://www.coursera.org/course/linearopt>
--
--------------------------------------------------------------------------
module ToySolver.Graph.ShortestPath
  (
  -- * Graph data types
    Graph
  , Edge
  , OutEdge
  , InEdge

  -- * Fold data type
  , Fold (..)
  , monoid'
  , monoid
  , unit
  , pair
  , path
  , firstOutEdge
  , lastInEdge
  , cost

  -- * Path data types
  , Path (..)
  , pathFrom
  , pathTo
  , pathCost
  , pathEmpty
  , pathAppend
  , pathEdges
  , pathEdgesBackward
  , pathEdgesSeq
  , pathVertexes
  , pathVertexesBackward
  , pathVertexesSeq
  , pathFold
  , pathMin

  -- * Shortest-path algorithms
  , bellmanFord
  , dijkstra
  , floydWarshall

  -- * Utility functions
  , 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 -- http://hackage.haskell.org/package/heaps
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

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

-- | Graph represented as a map from vertexes to their outgoing edges
type Graph cost label = IntMap [OutEdge cost label]

-- | Vertex data type
type Vertex = Int

-- | Edge data type
type Edge cost label = (Vertex, Vertex, cost, label)

-- | Outgoing edge data type (source vertex is implicit)
type OutEdge cost label = (Vertex, cost, label)

-- | Incoming edge data type (target vertex is implicit)
type InEdge cost label = (Vertex, cost, label)

-- | path data type.
data Path cost label
  = Empty Vertex
    -- ^ empty path
  | Singleton (Edge cost label)
    -- ^ path with single edge
  | Append (Path cost label) (Path cost label) !cost
    -- ^ concatenation of two paths
  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)

-- | Source vertex
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

-- | Target vertex
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

-- | Cost of a path
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

-- | Empty path
pathEmpty :: Vertex -> Path cost label
pathEmpty :: forall cost label. Vertex -> Path cost label
pathEmpty = forall cost label. Vertex -> Path cost label
Empty

-- | Concatenation of two paths
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)

-- | Edges of a path
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)

-- | Edges of a path, but in the reverse order
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)

-- | Edges of a path, but as `Seq`
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

-- | Vertexes of a path
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)

-- | Vertexes of a path, but in the reverse order
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)

-- | Vertex of a path, but as `Seq`
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

-- | Fold a path using a given 'Fold` operation.
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)

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

-- | Strict pair type
data Pair a b = Pair !a !b

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

-- | Operations for folding edge information along with a path into a @r@ value.
--
-- @Fold cost label r@ consists of three operations
--
-- * @Vertex -> a@ corresponds to an empty path,
--
-- * @Edge cost label -> a@ corresponds to a single edge,
--
-- * @a -> a -> a@ corresponds to path concatenation,
--
-- and @a -> r@ to finish the computation.
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))

-- | Project `Edge` into a monoid value and fold using monoidal operation.
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

-- | Similar to 'monoid'' but a /label/ is directly used as a monoid value.
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)

-- | Ignore contents and return a unit value.
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
_ -> ())

-- | Pairs two `Fold` into one that produce a tuple.
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))

-- | Construct a `Path` value.
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

-- | Compute cost of a path.
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

-- | Get the first `OutEdge` of a path.
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)))

-- | Get the last `InEdge` of a path.
-- This is useful for constructing a /parent/ map of a spanning tree.
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)))

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

-- | Bellman-Ford algorithm for finding shortest paths from source vertexes
-- to all of the other vertices in a weighted graph with negative weight
-- edges allowed.
--
-- It compute shortest-paths from given source vertexes, and folds edge
-- information along shortest paths using a given 'Fold' operation.
bellmanFord
  :: Real cost
  => Fold cost label a
     -- ^ Operation used to fold shotest paths
  -> Graph cost label
  -> [Vertex]
     -- ^ List of source vertexes @vs@
  -> 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
        -- modifySTRef' updatedRef (IntSet.delete u) -- possible optimization
        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

-- | Utility function for detecting a negative cycle.
bellmanFordDetectNegativeCycle
  :: forall cost label a. Real cost
  => Fold cost label a
     -- ^ Operation used to fold a cycle
  -> Graph cost label
  -> IntMap (cost, Last (InEdge cost label))
     -- ^ Result of @'bellmanFord' 'lastInEdge' vs@
  -> 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
        -- a negative cycle is detected
        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's algorithm for finding shortest paths from source vertexes
-- to all of the other vertices in a weighted graph with non-negative edge
-- weight.
--
-- It compute shortest-paths from given source vertexes, and folds edge
-- information along shortest paths using a given 'Fold' operation.
dijkstra
  :: forall cost label a. Real cost
  => Fold cost label a
     -- ^ Operation used to fold shotest paths
  -> Graph cost label
  -> [Vertex]
     -- ^ List of source vertexes
  -> 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)

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

-- | Floyd-Warshall algorithm for finding shortest paths in a weighted graph
-- with positive or negative edge weights (but with no negative cycles).
--
-- It compute shortest-paths between each pair of vertexes, and folds edge
-- information along shortest paths using a given 'Fold' operation.
floydWarshall
  :: forall cost label a. Real cost
  => Fold cost label a
     -- ^ Operation used to fold shotest paths
  -> 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

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