{-# 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 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
(Path cost label -> Path cost label -> Bool)
-> (Path cost label -> Path cost label -> Bool)
-> Eq (Path cost label)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall cost label.
(Eq label, Eq cost) =>
Path cost label -> Path cost label -> Bool
$c== :: forall cost label.
(Eq label, Eq cost) =>
Path cost label -> Path cost label -> Bool
== :: Path cost label -> Path cost label -> Bool
$c/= :: forall cost label.
(Eq label, Eq cost) =>
Path cost label -> Path cost label -> Bool
/= :: Path cost label -> Path cost label -> Bool
Eq, Vertex -> Path cost label -> ShowS
[Path cost label] -> ShowS
Path cost label -> String
(Vertex -> Path cost label -> ShowS)
-> (Path cost label -> String)
-> ([Path cost label] -> ShowS)
-> Show (Path cost label)
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall cost label.
(Show label, Show cost) =>
Vertex -> Path cost label -> ShowS
forall cost label.
(Show label, Show cost) =>
[Path cost label] -> ShowS
forall cost label.
(Show label, Show cost) =>
Path cost label -> String
$cshowsPrec :: forall cost label.
(Show label, Show cost) =>
Vertex -> Path cost label -> ShowS
showsPrec :: Vertex -> Path cost label -> ShowS
$cshow :: forall cost label.
(Show label, Show cost) =>
Path cost label -> String
show :: Path cost label -> String
$cshowList :: forall cost label.
(Show label, Show cost) =>
[Path cost label] -> ShowS
showList :: [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
_) = Path cost label -> Vertex
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
_) = Path cost label -> Vertex
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 = Vertex -> Path cost label
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
  | Path cost label -> Vertex
forall cost label. Path cost label -> Vertex
pathTo Path cost label
p1 Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Path cost label -> Vertex
forall cost label. Path cost label -> Vertex
pathFrom Path cost label
p2 = String -> Path cost label
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)
_ -> Path cost label -> Path cost label -> cost -> 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 (Path cost label -> cost
forall cost label. Num cost => Path cost label -> cost
pathCost Path cost label
p1 cost -> cost -> cost
forall a. Num a => a -> a -> a
+ Path cost label -> cost
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 = Path cost label -> [Edge cost label] -> [Edge cost label]
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 Edge cost label -> [Edge cost label] -> [Edge cost label]
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 = Path cost label -> [Edge cost label] -> [Edge cost label]
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 Edge cost label -> [Edge cost label] -> [Edge cost label]
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
_) = Seq (Edge cost label)
forall a. Seq a
Seq.empty
pathEdgesSeq (Singleton Edge cost label
e) = Edge cost label -> Seq (Edge cost label)
forall a. a -> Seq a
Seq.singleton Edge cost label
e
pathEdgesSeq (Append Path cost label
p1 Path cost label
p2 cost
_) = Path cost label -> Seq (Edge cost label)
forall cost label. Path cost label -> Seq (Edge cost label)
pathEdgesSeq Path cost label
p1 Seq (Edge cost label)
-> Seq (Edge cost label) -> Seq (Edge cost label)
forall a. Semigroup a => a -> a -> a
<> Path cost label -> Seq (Edge cost label)
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 = Path cost label -> Vertex
forall cost label. Path cost label -> Vertex
pathFrom Path cost label
p Vertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
: Path cost label -> [Vertex] -> [Vertex]
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 Vertex -> [Vertex] -> [Vertex]
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 = Path cost label -> Vertex
forall cost label. Path cost label -> Vertex
pathTo Path cost label
p Vertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
: Path cost label -> [Vertex] -> [Vertex]
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 Vertex -> [Vertex] -> [Vertex]
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 = Bool -> Path cost label -> Seq Vertex
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) = Vertex -> Seq Vertex
forall a. a -> Seq a
Seq.singleton Vertex
v
    f Bool
False (Empty Vertex
_) = Seq Vertex
forall a. Monoid a => a
mempty
    f Bool
True  (Singleton (Vertex
v1,Vertex
v2,cost
_,label
_)) = [Vertex] -> Seq Vertex
forall a. [a] -> Seq a
Seq.fromList [Vertex
v1, Vertex
v2]
    f Bool
False (Singleton (Vertex
v1,Vertex
_,cost
_,label
_))  = Vertex -> Seq Vertex
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 Seq Vertex -> Seq Vertex -> Seq Vertex
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
  | Path cost label -> cost
forall cost label. Num cost => Path cost label -> cost
pathCost Path cost label
p1 cost -> cost -> Bool
forall a. Ord a => a -> a -> Bool
<= Path cost label -> cost
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) = (Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> b)
-> Fold cost label b
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 (a -> b) -> (a -> a) -> a -> b
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 = (Vertex -> ())
-> (Edge cost label -> ())
-> (() -> () -> ())
-> (() -> a)
-> Fold cost label 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
_ -> ()) (\()
_ ()
_ -> ()) (a -> () -> a
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 =
    (Vertex -> Pair a a)
-> (Edge cost label -> Pair a a)
-> (Pair a a -> Pair a a -> Pair a a)
-> (Pair a a -> b)
-> Fold cost label b
forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Vertex
v -> a -> a -> Pair a a
forall a b. a -> b -> Pair a b
Pair (Vertex -> a
fV1 Vertex
v) (Vertex -> a
fV2 Vertex
v))
         (\Edge cost label
e -> a -> a -> Pair a a
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) -> a -> a -> Pair a a
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 = (Vertex -> m)
-> (Edge cost label -> m)
-> (m -> m -> m)
-> (m -> m)
-> Fold cost label m
forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Vertex
_ -> m
forall a. Monoid a => a
mempty) Edge cost label -> m
f m -> m -> m
forall a. Monoid a => a -> a -> a
mappend m -> m
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 = (Edge cost m -> m) -> Fold cost m m
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 = (Edge cost label -> ()) -> Fold cost label ()
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) =
  (Vertex -> Pair a a)
-> (Edge cost label -> Pair a a)
-> (Pair a a -> Pair a a -> Pair a a)
-> (Pair a a -> (a, b))
-> Fold cost label (a, b)
forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Vertex
v -> a -> a -> Pair a a
forall a b. a -> b -> Pair a b
Pair (Vertex -> a
fV1 Vertex
v) (Vertex -> a
fV2 Vertex
v))
       (\Edge cost label
e -> a -> a -> Pair a a
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) -> a -> a -> Pair a a
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 = (Vertex -> Path cost label)
-> (Edge cost label -> Path cost label)
-> (Path cost label -> Path cost label -> Path cost label)
-> (Path cost label -> Path cost label)
-> Fold cost label (Path cost label)
forall cost label r a.
(Vertex -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold Vertex -> Path cost label
forall cost label. Vertex -> Path cost label
pathEmpty Edge cost label -> Path cost label
forall cost label. Edge cost label -> Path cost label
Singleton Path cost label -> Path cost label -> Path cost label
forall cost label.
Num cost =>
Path cost label -> Path cost label -> Path cost label
pathAppend Path cost label -> Path cost label
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 = (Vertex -> cost)
-> (Edge cost label -> cost)
-> (cost -> cost -> cost)
-> (cost -> cost)
-> Fold cost label 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) cost -> cost -> cost
forall a. Num a => a -> a -> a
(+) cost -> cost
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 = (Edge cost label -> First (OutEdge cost label))
-> Fold cost label (First (OutEdge cost label))
forall m cost label.
Monoid m =>
(Edge cost label -> m) -> Fold cost label m
monoid' (\(Vertex
_,Vertex
v,cost
c,label
l) -> Maybe (OutEdge cost label) -> First (OutEdge cost label)
forall a. Maybe a -> First a
First (OutEdge cost label -> Maybe (OutEdge cost label)
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 = (Edge cost label -> Last (InEdge cost label))
-> Fold cost label (Last (InEdge cost label))
forall m cost label.
Monoid m =>
(Edge cost label -> m) -> Fold cost label m
monoid' (\(Vertex
v,Vertex
_,cost
c,label
l) -> Maybe (InEdge cost label) -> Last (InEdge cost label)
forall a. Maybe a -> Last a
Last (InEdge cost label -> Maybe (InEdge cost label)
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 s. ST s (IntMap (cost, a))) -> IntMap (cost, a)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (IntMap (cost, a))) -> IntMap (cost, a))
-> (forall s. ST s (IntMap (cost, a))) -> IntMap (cost, a)
forall a b. (a -> b) -> a -> b
$ do
  let n :: Vertex
n = Graph cost label -> Vertex
forall a. IntMap a -> Vertex
IntMap.size Graph cost label
g
  HashTable s Vertex (Pair cost a)
d <- Vertex -> ST s (HashTable s Vertex (Pair cost a))
forall s k v. Vertex -> ST s (HashTable s k v)
C.newSized Vertex
n
  [Vertex] -> (Vertex -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Vertex]
ss ((Vertex -> ST s ()) -> ST s ()) -> (Vertex -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Vertex
s -> HashTable s Vertex (Pair cost a)
-> Vertex -> Pair cost a -> ST s ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST 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 (cost -> a -> Pair cost a
forall a b. a -> b -> Pair a b
Pair cost
0 (Vertex -> a
fV Vertex
s))

  STRef s IntSet
updatedRef <- IntSet -> ST s (STRef s IntSet)
forall a s. a -> ST s (STRef s a)
newSTRef ([Vertex] -> IntSet
IntSet.fromList [Vertex]
ss)
  Either () ()
_ <- ExceptT () (ST s) () -> ST s (Either () ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT () (ST s) () -> ST s (Either () ()))
-> ExceptT () (ST s) () -> ST s (Either () ())
forall a b. (a -> b) -> a -> b
$ Vertex -> ExceptT () (ST s) () -> ExceptT () (ST s) ()
forall (m :: * -> *) a. Applicative m => Vertex -> m a -> m ()
replicateM_ Vertex
n (ExceptT () (ST s) () -> ExceptT () (ST s) ())
-> ExceptT () (ST s) () -> ExceptT () (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
    IntSet
us <- ST s IntSet -> ExceptT () (ST s) IntSet
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s IntSet -> ExceptT () (ST s) IntSet)
-> ST s IntSet -> ExceptT () (ST s) IntSet
forall a b. (a -> b) -> a -> b
$ STRef s IntSet -> ST s IntSet
forall s a. STRef s a -> ST s a
readSTRef STRef s IntSet
updatedRef
    Bool -> ExceptT () (ST s) () -> ExceptT () (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IntSet -> Bool
IntSet.null IntSet
us) (ExceptT () (ST s) () -> ExceptT () (ST s) ())
-> ExceptT () (ST s) () -> ExceptT () (ST s) ()
forall a b. (a -> b) -> a -> b
$ () -> ExceptT () (ST s) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ()
    ST s () -> ExceptT () (ST s) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> ExceptT () (ST s) ())
-> ST s () -> ExceptT () (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
      STRef s IntSet -> IntSet -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s IntSet
updatedRef IntSet
IntSet.empty
      [Vertex] -> (Vertex -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntSet -> [Vertex]
IntSet.toList IntSet
us) ((Vertex -> ST s ()) -> ST s ()) -> (Vertex -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Vertex
u -> do
        -- modifySTRef' updatedRef (IntSet.delete u) -- possible optimization
        Pair cost
du a
a <- (Maybe (Pair cost a) -> Pair cost a)
-> ST s (Maybe (Pair cost a)) -> ST s (Pair cost a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe (Pair cost a) -> Pair cost a
forall a. HasCallStack => Maybe a -> a
fromJust (ST s (Maybe (Pair cost a)) -> ST s (Pair cost a))
-> ST s (Maybe (Pair cost a)) -> ST s (Pair cost a)
forall a b. (a -> b) -> a -> b
$ HashTable s Vertex (Pair cost a)
-> Vertex -> ST s (Maybe (Pair cost a))
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe v)
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
        [OutEdge cost label] -> (OutEdge cost label -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([OutEdge cost label]
-> Vertex -> Graph cost label -> [OutEdge cost label]
forall a. a -> Vertex -> IntMap a -> a
IntMap.findWithDefault [] Vertex
u Graph cost label
g) ((OutEdge cost label -> ST s ()) -> ST s ())
-> (OutEdge cost label -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Vertex
v, cost
c, label
l) -> do
          Maybe (Pair cost a)
m <- HashTable s Vertex (Pair cost a)
-> Vertex -> ST s (Maybe (Pair cost a))
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe v)
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 cost -> cost -> Bool
forall a. Ord a => a -> a -> Bool
<= cost
du cost -> cost -> cost
forall a. Num a => a -> a -> a
+ cost
c -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe (Pair cost a)
_ -> do
              HashTable s Vertex (Pair cost a)
-> Vertex -> Pair cost a -> ST s ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST 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
v (cost -> a -> Pair cost a
forall a b. a -> b -> Pair a b
Pair (cost
du cost -> cost -> cost
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)))
              STRef s IntSet -> (IntSet -> IntSet) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s IntSet
updatedRef (Vertex -> IntSet -> IntSet
IntSet.insert Vertex
v)

  (IntMap (Pair cost a) -> IntMap (cost, a))
-> ST s (IntMap (Pair cost a)) -> ST s (IntMap (cost, a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Pair cost a -> (cost, a))
-> IntMap (Pair cost a) -> IntMap (cost, a)
forall a b. (a -> b) -> IntMap a -> IntMap b
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))) (ST s (IntMap (Pair cost a)) -> ST s (IntMap (cost, a)))
-> ST s (IntMap (Pair cost a)) -> ST s (IntMap (cost, a))
forall a b. (a -> b) -> a -> b
$ HashTable s Vertex (Pair cost a) -> ST s (IntMap (Pair cost a))
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 = (IntMap v -> (Vertex, v) -> ST s (IntMap v))
-> IntMap v -> h s Vertex v -> ST s (IntMap v)
forall a k v s. (a -> (k, v) -> ST s a) -> a -> h s k v -> ST s a
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) -> IntMap v -> ST s (IntMap v)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap v -> ST s (IntMap v)) -> IntMap v -> ST s (IntMap v)
forall a b. (a -> b) -> a -> b
$! Vertex -> v -> IntMap v -> IntMap v
forall a. Vertex -> a -> IntMap a -> IntMap a
IntMap.insert Vertex
k v
v IntMap v
m) IntMap v
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 = (a -> Maybe a) -> (() -> Maybe a) -> Either a () -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (a -> a) -> a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
fD) (Maybe a -> () -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) (Either a () -> Maybe a) -> Either a () -> Maybe a
forall a b. (a -> b) -> a -> b
$ do
  [(Vertex, (cost, Last (InEdge cost label)))]
-> ((Vertex, (cost, Last (InEdge cost label))) -> Either a ())
-> Either a ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntMap (cost, Last (InEdge cost label))
-> [(Vertex, (cost, Last (InEdge cost label)))]
forall a. IntMap a -> [(Vertex, a)]
IntMap.toList IntMap (cost, Last (InEdge cost label))
d) (((Vertex, (cost, Last (InEdge cost label))) -> Either a ())
 -> Either a ())
-> ((Vertex, (cost, Last (InEdge cost label))) -> Either a ())
-> Either a ()
forall a b. (a -> b) -> a -> b
$ \(Vertex
u,(cost
du,Last (InEdge cost label)
_)) ->
    [InEdge cost label]
-> (InEdge cost label -> Either a ()) -> Either a ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([InEdge cost label]
-> Vertex -> Graph cost label -> [InEdge cost label]
forall a. a -> Vertex -> IntMap a -> a
IntMap.findWithDefault [] Vertex
u Graph cost label
g) ((InEdge cost label -> Either a ()) -> Either a ())
-> (InEdge cost label -> Either a ()) -> Either a ()
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 IntMap (cost, Last (InEdge cost label))
-> Vertex -> (cost, Last (InEdge cost label))
forall a. IntMap a -> Vertex -> a
IntMap.! Vertex
v
      Bool -> Either a () -> Either a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (cost
du cost -> cost -> cost
forall a. Num a => a -> a -> a
+ cost
c cost -> cost -> Bool
forall a. Ord a => a -> a -> Bool
< cost
dv) (Either a () -> Either a ()) -> Either a () -> Either a ()
forall a b. (a -> b) -> a -> b
$ do
        -- a negative cycle is detected
        let d' :: IntMap (cost, Last (InEdge cost label))
d' = Vertex
-> (cost, Last (InEdge cost label))
-> IntMap (cost, Last (InEdge cost label))
-> IntMap (cost, Last (InEdge cost label))
forall a. Vertex -> a -> IntMap a -> IntMap a
IntMap.insert Vertex
v (cost
du cost -> cost -> cost
forall a. Num a => a -> a -> a
+ cost
c, Maybe (InEdge cost label) -> Last (InEdge cost label)
forall a. Maybe a -> Last a
Last (InEdge cost label -> Maybe (InEdge cost label)
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 Vertex
-> IntMap (cost, Last (InEdge cost label))
-> Maybe (cost, Last (InEdge cost label))
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))
_ -> Vertex
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 Vertex -> Vertex -> Bool
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))) = Vertex
-> IntMap (cost, Last (InEdge cost label))
-> Maybe (cost, Last (InEdge cost label))
forall a. Vertex -> IntMap a -> Maybe a
IntMap.lookup Vertex
u IntMap (cost, Last (InEdge cost label))
d'
              if Vertex
v Vertex -> Vertex -> Bool
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)
        a -> Either a ()
forall a b. a -> Either a b
Left (a -> Either a ()) -> a -> Either a ()
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 =
  (Pair cost a -> (cost, a))
-> IntMap (Pair cost a) -> IntMap (cost, a)
forall a b. (a -> b) -> IntMap a -> IntMap b
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)) (IntMap (Pair cost a) -> IntMap (cost, a))
-> IntMap (Pair cost a) -> IntMap (cost, a)
forall a b. (a -> b) -> a -> b
$
    Heap (Entry cost (Pair Vertex a))
-> IntMap (Pair cost a) -> IntMap (Pair cost a)
loop ([Entry cost (Pair Vertex a)] -> Heap (Entry cost (Pair Vertex a))
forall a. Ord a => [a] -> Heap a
Heap.fromList [cost -> Pair Vertex a -> Entry cost (Pair Vertex a)
forall p a. p -> a -> Entry p a
Heap.Entry cost
0 (Vertex -> a -> Pair Vertex a
forall a b. a -> b -> Pair a b
Pair Vertex
s (Vertex -> a
fV Vertex
s)) | Vertex
s <- [Vertex]
ss]) IntMap (Pair cost a)
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 Heap (Entry cost (Pair Vertex a))
-> Maybe
     (Entry cost (Pair Vertex a), Heap (Entry cost (Pair Vertex a)))
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 Vertex -> IntMap (Pair cost a) -> Bool
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 = [Entry cost (Pair Vertex a)] -> Heap (Entry cost (Pair Vertex a))
forall a. Ord a => [a] -> Heap a
Heap.fromList
                       [ cost -> Pair Vertex a -> Entry cost (Pair Vertex a)
forall p a. p -> a -> Entry p a
Heap.Entry (cost
ccost -> cost -> cost
forall a. Num a => a -> a -> a
+cost
c') (Vertex -> a -> Pair Vertex a
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) <- [(Vertex, cost, label)]
-> Vertex -> Graph cost label -> [(Vertex, cost, label)]
forall a. a -> Vertex -> IntMap a -> a
IntMap.findWithDefault [] Vertex
v Graph cost label
g
                       , Bool -> Bool
not (Vertex
ch Vertex -> IntMap (Pair cost a) -> Bool
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 (Heap (Entry cost (Pair Vertex a))
-> Heap (Entry cost (Pair Vertex a))
-> Heap (Entry cost (Pair Vertex a))
forall a. Heap a -> Heap a -> Heap a
Heap.union Heap (Entry cost (Pair Vertex a))
q' Heap (Entry cost (Pair Vertex a))
q2) (Vertex
-> Pair cost a -> IntMap (Pair cost a) -> IntMap (Pair cost a)
forall a. Vertex -> a -> IntMap a -> IntMap a
IntMap.insert Vertex
v (cost -> a -> Pair cost a
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 =
  (IntMap (Pair cost a) -> IntMap (cost, a))
-> IntMap (IntMap (Pair cost a)) -> IntMap (IntMap (cost, a))
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Pair cost a -> (cost, a))
-> IntMap (Pair cost a) -> IntMap (cost, a)
forall a b. (a -> b) -> IntMap a -> IntMap b
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))) (IntMap (IntMap (Pair cost a)) -> IntMap (IntMap (cost, a)))
-> IntMap (IntMap (Pair cost a)) -> IntMap (IntMap (cost, a))
forall a b. (a -> b) -> a -> b
$
    (IntMap (Pair cost a)
 -> IntMap (Pair cost a) -> IntMap (Pair cost a))
-> IntMap (IntMap (Pair cost a))
-> IntMap (IntMap (Pair cost a))
-> IntMap (IntMap (Pair cost a))
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith ((Pair cost a -> Pair cost a -> Pair cost a)
-> IntMap (Pair cost a)
-> IntMap (Pair cost a)
-> IntMap (Pair cost a)
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith Pair cost a -> Pair cost a -> Pair cost a
minP) ((IntMap (IntMap (Pair cost a))
 -> Vertex -> IntMap (IntMap (Pair cost a)))
-> IntMap (IntMap (Pair cost a))
-> [Vertex]
-> IntMap (IntMap (Pair cost a))
forall b a. (b -> a -> b) -> b -> [a] -> b
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 = Graph cost label -> [Vertex]
forall a. IntMap a -> [Vertex]
IntMap.keys Graph cost label
g

    paths0 :: IntMap (IntMap (Pair cost x))
    paths0 :: IntMap (IntMap (Pair cost a))
paths0 = (Vertex -> [OutEdge cost label] -> IntMap (Pair cost a))
-> Graph cost label -> IntMap (IntMap (Pair cost a))
forall a b. (Vertex -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey (\Vertex
v [OutEdge cost label]
_ -> Vertex -> Pair cost a -> IntMap (Pair cost a)
forall a. Vertex -> a -> IntMap a
IntMap.singleton Vertex
v (cost -> a -> Pair cost a
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 = (Vertex -> [OutEdge cost label] -> IntMap (Pair cost a))
-> Graph cost label -> IntMap (IntMap (Pair cost a))
forall a b. (Vertex -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey (\Vertex
v [OutEdge cost label]
es -> (Pair cost a -> Pair cost a -> Pair cost a)
-> [(Vertex, Pair cost a)] -> IntMap (Pair cost a)
forall a. (a -> a -> a) -> [(Vertex, a)] -> IntMap a
IntMap.fromListWith Pair cost a -> Pair cost a -> Pair cost a
minP [(Vertex
u, (cost -> a -> Pair cost a
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 = (Pair cost a -> Pair cost a -> Ordering)
-> Pair cost a -> Pair cost a -> Pair cost a
forall a. (a -> a -> Ordering) -> a -> a -> a
minBy ((Pair cost a -> cost) -> Pair cost a -> Pair cost a -> Ordering
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 Vertex
-> IntMap (IntMap (Pair cost a)) -> Maybe (IntMap (Pair cost a))
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 -> (IntMap (Pair cost a) -> IntMap (Pair cost a))
-> IntMap (IntMap (Pair cost a)) -> IntMap (IntMap (Pair cost a))
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 Vertex -> IntMap (Pair cost a) -> Maybe (Pair cost a)
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) -> (Pair cost a -> Pair cost a -> Pair cost a)
-> IntMap (Pair cost a)
-> IntMap (Pair cost a)
-> IntMap (Pair cost a)
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 ((Pair cost a -> Pair cost a)
-> IntMap (Pair cost a) -> IntMap (Pair cost a)
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (\(Pair cost
c2 a
x2) -> (cost -> a -> Pair cost a
forall a b. a -> b -> Pair a b
Pair (cost
c1cost -> cost -> cost
forall 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

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