{-# 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.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 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, Int -> Path cost label -> ShowS
[Path cost label] -> ShowS
Path cost label -> String
(Int -> Path cost label -> ShowS)
-> (Path cost label -> String)
-> ([Path cost label] -> ShowS)
-> Show (Path cost label)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall cost label.
(Show cost, Show label) =>
Int -> 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 :: Int -> Path cost label -> ShowS
$cshowsPrec :: forall cost label.
(Show cost, Show label) =>
Int -> Path cost label -> ShowS
Show)

-- | Source vertex
pathFrom :: Path cost label -> Vertex
pathFrom :: Path cost label -> Int
pathFrom (Empty Int
v) = Int
v
pathFrom (Singleton (Int
from,Int
_,cost
_,label
_)) = Int
from
pathFrom (Append Path cost label
p1 Path cost label
_ cost
_) = Path cost label -> Int
forall cost label. Path cost label -> Int
pathFrom Path cost label
p1

-- | Target vertex
pathTo :: Path cost label -> Vertex
pathTo :: Path cost label -> Int
pathTo (Empty Int
v) = Int
v
pathTo (Singleton (Int
_,Int
to,cost
_,label
_)) = Int
to
pathTo (Append Path cost label
_ Path cost label
p2 cost
_) = Path cost label -> Int
forall cost label. Path cost label -> Int
pathTo Path cost label
p2

-- | Cost of a path
pathCost :: Num cost => Path cost label -> cost
pathCost :: Path cost label -> cost
pathCost (Empty Int
_) = cost
0
pathCost (Singleton (Int
_,Int
_,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 :: Int -> Path cost label
pathEmpty = Int -> Path cost label
forall cost label. Int -> Path cost label
Empty

-- | Concatenation of two paths
pathAppend :: (Num cost) => Path cost label -> Path cost label -> Path cost label
pathAppend :: Path cost label -> Path cost label -> Path cost label
pathAppend Path cost label
p1 Path cost label
p2
  | Path cost label -> Int
forall cost label. Path cost label -> Int
pathTo Path cost label
p1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Path cost label -> Int
forall cost label. Path cost label -> Int
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 Int
_, Path cost label
_) -> Path cost label
p2
        (Path cost label
_, Empty Int
_) -> 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 :: 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 Int
_) [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 :: 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 Int
_) [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 :: Path cost label -> Seq (Edge cost label)
pathEdgesSeq (Empty Int
_) = 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 :: Path cost label -> [Int]
pathVertexes Path cost label
p = Path cost label -> Int
forall cost label. Path cost label -> Int
pathFrom Path cost label
p Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Path cost label -> [Int] -> [Int]
forall cost label. Path cost label -> [Int] -> [Int]
f Path cost label
p []
  where
    f :: Path cost label -> [Int] -> [Int]
f (Empty Int
_) [Int]
xs = [Int]
xs
    f (Singleton (Int
_,Int
v2,cost
_,label
_)) [Int]
xs = Int
v2 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
xs
    f (Append Path cost label
p1 Path cost label
p2 cost
_) [Int]
xs = Path cost label -> [Int] -> [Int]
f Path cost label
p1 (Path cost label -> [Int] -> [Int]
f Path cost label
p2 [Int]
xs)

-- | Vertexes of a path, but in the reverse order
pathVertexesBackward :: Path cost label -> [Vertex]
pathVertexesBackward :: Path cost label -> [Int]
pathVertexesBackward Path cost label
p = Path cost label -> Int
forall cost label. Path cost label -> Int
pathTo Path cost label
p Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Path cost label -> [Int] -> [Int]
forall cost label. Path cost label -> [Int] -> [Int]
f Path cost label
p []
  where
    f :: Path cost label -> [Int] -> [Int]
f (Empty Int
_) [Int]
xs = [Int]
xs
    f (Singleton (Int
v1,Int
_,cost
_,label
_)) [Int]
xs = Int
v1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
xs
    f (Append Path cost label
p1 Path cost label
p2 cost
_) [Int]
xs = Path cost label -> [Int] -> [Int]
f Path cost label
p2 (Path cost label -> [Int] -> [Int]
f Path cost label
p1 [Int]
xs)

-- | Vertex of a path, but as `Seq`
pathVertexesSeq :: Path cost label -> Seq Vertex
pathVertexesSeq :: Path cost label -> Seq Int
pathVertexesSeq Path cost label
p = Bool -> Path cost label -> Seq Int
forall cost label. Bool -> Path cost label -> Seq Int
f Bool
True Path cost label
p
  where
    f :: Bool -> Path cost label -> Seq Int
f Bool
True  (Empty Int
v) = Int -> Seq Int
forall a. a -> Seq a
Seq.singleton Int
v
    f Bool
False (Empty Int
_) = Seq Int
forall a. Monoid a => a
mempty
    f Bool
True  (Singleton (Int
v1,Int
v2,cost
_,label
_)) = [Int] -> Seq Int
forall a. [a] -> Seq a
Seq.fromList [Int
v1, Int
v2]
    f Bool
False (Singleton (Int
v1,Int
_,cost
_,label
_))  = Int -> Seq Int
forall a. a -> Seq a
Seq.singleton Int
v1
    f Bool
b (Append Path cost label
p1 Path cost label
p2 cost
_) = Bool -> Path cost label -> Seq Int
f Bool
False Path cost label
p1 Seq Int -> Seq Int -> Seq Int
forall a. Semigroup a => a -> a -> a
<> Bool -> Path cost label -> Seq Int
f Bool
b Path cost label
p2

pathMin :: (Num cost, Ord cost) => Path cost label -> Path cost label -> Path cost label
pathMin :: 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 :: Fold cost label a -> Path cost label -> a
pathFold (Fold Int -> 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 Int
v) = Int -> a
fV Int
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 :: (a -> b) -> Fold cost label a -> Fold cost label b
fmap a -> b
f (Fold Int -> a
fV Edge cost label -> a
fE a -> a -> a
fC a -> a
fD) = (Int -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> b)
-> Fold cost label b
forall cost label r a.
(Int -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold Int -> 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 :: a -> Fold cost label a
pure a
a = (Int -> ())
-> (Edge cost label -> ())
-> (() -> () -> ())
-> (() -> a)
-> Fold cost label a
forall cost label r a.
(Int -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Int
_ -> ()) (\Edge cost label
_ -> ()) (\()
_ ()
_ -> ()) (a -> () -> a
forall a b. a -> b -> a
const a
a)

  {-# INLINE (<*>) #-}
  Fold Int -> a
fV1 Edge cost label -> a
fE1 a -> a -> a
fC1 a -> a -> b
fD1 <*> :: Fold cost label (a -> b) -> Fold cost label a -> Fold cost label b
<*> Fold Int -> a
fV2 Edge cost label -> a
fE2 a -> a -> a
fC2 a -> a
fD2 =
    (Int -> 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.
(Int -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Int
v -> a -> a -> Pair a a
forall a b. a -> b -> Pair a b
Pair (Int -> a
fV1 Int
v) (Int -> a
fV2 Int
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' :: (Edge cost label -> m) -> Fold cost label m
monoid' Edge cost label -> m
f = (Int -> m)
-> (Edge cost label -> m)
-> (m -> m -> m)
-> (m -> m)
-> Fold cost label m
forall cost label r a.
(Int -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Int
_ -> 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 :: 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' (\(Int
_,Int
_,cost
_,m
m) -> m
m)

-- | Ignore contents and return a unit value.
unit :: Fold cost label ()
unit :: 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 :: Fold cost label a -> Fold cost label b -> Fold cost label (a, b)
pair (Fold Int -> a
fV1 Edge cost label -> a
fE1 a -> a -> a
fC1 a -> a
fD1) (Fold Int -> a
fV2 Edge cost label -> a
fE2 a -> a -> a
fC2 a -> b
fD2) =
  (Int -> 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.
(Int -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Int
v -> a -> a -> Pair a a
forall a b. a -> b -> Pair a b
Pair (Int -> a
fV1 Int
v) (Int -> a
fV2 Int
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 :: Fold cost label (Path cost label)
path = (Int -> 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.
(Int -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold Int -> Path cost label
forall cost label. Int -> 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 :: Fold cost label cost
cost = (Int -> cost)
-> (Edge cost label -> cost)
-> (cost -> cost -> cost)
-> (cost -> cost)
-> Fold cost label cost
forall cost label r a.
(Int -> a)
-> (Edge cost label -> a)
-> (a -> a -> a)
-> (a -> r)
-> Fold cost label r
Fold (\Int
_ -> cost
0) (\(Int
_,Int
_,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 :: 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' (\(Int
_,Int
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 (Int
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 :: 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' (\(Int
v,Int
_,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 (Int
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 :: Fold cost label a -> Graph cost label -> [Int] -> IntMap (cost, a)
bellmanFord (Fold Int -> a
fV Edge cost label -> a
fE a -> a -> a
fC a -> a
fD) Graph cost label
g [Int]
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 :: Int
n = Graph cost label -> Int
forall a. IntMap a -> Int
IntMap.size Graph cost label
g
  HashTable s Int (Pair cost a)
d <- Int -> ST s (HashTable s Int (Pair cost a))
forall s k v. Int -> ST s (HashTable s k v)
C.newSized Int
n
  [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
ss ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
s -> HashTable s Int (Pair cost a) -> Int -> Pair cost a -> 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 Int (Pair cost a)
d Int
s (cost -> a -> Pair cost a
forall a b. a -> b -> Pair a b
Pair cost
0 (Int -> a
fV Int
s))

  STRef s IntSet
updatedRef <- IntSet -> ST s (STRef s IntSet)
forall a s. a -> ST s (STRef s a)
newSTRef ([Int] -> IntSet
IntSet.fromList [Int]
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
$ Int -> ExceptT () (ST s) () -> ExceptT () (ST s) ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
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 (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 (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
      [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntSet -> [Int]
IntSet.toList IntSet
us) ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
u -> do
        -- modifySTRef' updatedRef (IntSet.delete u) -- possible optimization
        Just (Pair cost
du a
a) <- HashTable s Int (Pair cost a) -> Int -> ST s (Maybe (Pair cost a))
forall (h :: * -> * -> * -> *) k s v.
(HashTable h, Eq k, Hashable k) =>
h s k v -> k -> ST s (Maybe v)
H.lookup HashTable s Int (Pair cost a)
d Int
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]
-> Int -> Graph cost label -> [OutEdge cost label]
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault [] Int
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
$ \(Int
v, cost
c, label
l) -> do
          Maybe (Pair cost a)
m <- HashTable s Int (Pair cost a) -> Int -> ST s (Maybe (Pair cost a))
forall (h :: * -> * -> * -> *) k s v.
(HashTable h, Eq k, Hashable k) =>
h s k v -> k -> ST s (Maybe v)
H.lookup HashTable s Int (Pair cost a)
d Int
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 (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe (Pair cost a)
_ -> do
              HashTable s Int (Pair cost a) -> Int -> Pair cost a -> 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 Int (Pair cost a)
d Int
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 (Int
u,Int
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 (Int -> IntSet -> IntSet
IntSet.insert Int
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 (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 Int (Pair cost a) -> ST s (IntMap (Pair cost a))
forall (h :: * -> * -> * -> *) s v.
HashTable h =>
h s Int v -> ST s (IntMap v)
freezeHashTable HashTable s Int (Pair cost a)
d

freezeHashTable :: H.HashTable h => h s Int v -> ST s (IntMap v)
freezeHashTable :: h s Int v -> ST s (IntMap v)
freezeHashTable h s Int v
h = (IntMap v -> (Int, v) -> ST s (IntMap v))
-> IntMap v -> h s Int v -> ST s (IntMap v)
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 (Int
k,v
v) -> IntMap v -> ST s (IntMap v)
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
$! Int -> v -> IntMap v -> IntMap v
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k v
v IntMap v
m) IntMap v
forall a. IntMap a
IntMap.empty h s Int 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 :: Fold cost label a
-> Graph cost label
-> IntMap (cost, Last (InEdge cost label))
-> Maybe a
bellmanFordDetectNegativeCycle (Fold Int -> 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
  [(Int, (cost, Last (InEdge cost label)))]
-> ((Int, (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))
-> [(Int, (cost, Last (InEdge cost label)))]
forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap (cost, Last (InEdge cost label))
d) (((Int, (cost, Last (InEdge cost label))) -> Either a ())
 -> Either a ())
-> ((Int, (cost, Last (InEdge cost label))) -> Either a ())
-> Either a ()
forall a b. (a -> b) -> a -> b
$ \(Int
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]
-> Int -> Graph cost label -> [InEdge cost label]
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault [] Int
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
$ \(Int
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))
-> Int -> (cost, Last (InEdge cost label))
forall a. IntMap a -> Int -> a
IntMap.! Int
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' = Int
-> (cost, Last (InEdge cost label))
-> IntMap (cost, Last (InEdge cost label))
-> IntMap (cost, Last (InEdge cost label))
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
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 (Int
u, cost
c, label
l))) IntMap (cost, Last (InEdge cost label))
d
            parent :: Int -> Int
parent Int
u = do
              case Int
-> IntMap (cost, Last (InEdge cost label))
-> Maybe (cost, Last (InEdge cost label))
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
u IntMap (cost, Last (InEdge cost label))
d' of
                Just (cost
_, Last (Just (Int
v,cost
_,label
_))) -> Int
v
                Maybe (cost, Last (InEdge cost label))
_ -> Int
forall a. HasCallStack => a
undefined
            u0 :: Int
u0 = Int -> Int -> Int
go (Int -> Int
parent (Int -> Int
parent Int
v)) (Int -> Int
parent Int
v)
              where
                go :: Int -> Int -> Int
go Int
hare Int
tortoise
                  | Int
hare Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tortoise = Int
hare
                  | Bool
otherwise = Int -> Int -> Int
go (Int -> Int
parent (Int -> Int
parent Int
hare)) (Int -> Int
parent Int
tortoise)
        let go :: Int -> a -> a
go Int
u a
result = do
              let Just (cost
_, Last (Just (Int
v,cost
c,label
l))) = Int
-> IntMap (cost, Last (InEdge cost label))
-> Maybe (cost, Last (InEdge cost label))
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
u IntMap (cost, Last (InEdge cost label))
d'
              if Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
u0 then
                a -> a -> a
fC (Edge cost label -> a
fE (Int
v,Int
u,cost
c,label
l)) a
result
              else
                Int -> a -> a
go Int
v (a -> a -> a
fC (Edge cost label -> a
fE (Int
v,Int
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
$ Int -> a -> a
go Int
u0 (Int -> a
fV Int
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 :: Fold cost label a -> Graph cost label -> [Int] -> IntMap (cost, a)
dijkstra (Fold Int -> a
fV Edge cost label -> a
fE a -> a -> a
fC (a -> a
fD :: x -> a)) Graph cost label
g [Int]
ss =
  (Pair cost a -> (cost, a))
-> IntMap (Pair cost a) -> IntMap (cost, a)
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 Int a))
-> IntMap (Pair cost a) -> IntMap (Pair cost a)
loop ([Entry cost (Pair Int a)] -> Heap (Entry cost (Pair Int a))
forall a. Ord a => [a] -> Heap a
Heap.fromList [cost -> Pair Int a -> Entry cost (Pair Int a)
forall p a. p -> a -> Entry p a
Heap.Entry cost
0 (Int -> a -> Pair Int a
forall a b. a -> b -> Pair a b
Pair Int
s (Int -> a
fV Int
s)) | Int
s <- [Int]
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 Int a))
-> IntMap (Pair cost a) -> IntMap (Pair cost a)
loop Heap (Entry cost (Pair Int a))
q IntMap (Pair cost a)
visited =
      case Heap (Entry cost (Pair Int a))
-> Maybe (Entry cost (Pair Int a), Heap (Entry cost (Pair Int a)))
forall a. Heap a -> Maybe (a, Heap a)
Heap.viewMin Heap (Entry cost (Pair Int a))
q of
        Maybe (Entry cost (Pair Int a), Heap (Entry cost (Pair Int a)))
Nothing -> IntMap (Pair cost a)
visited
        Just (Heap.Entry cost
c (Pair Int
v a
a), Heap (Entry cost (Pair Int a))
q')
          | Int
v Int -> IntMap (Pair cost a) -> Bool
forall a. Int -> IntMap a -> Bool
`IntMap.member` IntMap (Pair cost a)
visited -> Heap (Entry cost (Pair Int a))
-> IntMap (Pair cost a) -> IntMap (Pair cost a)
loop Heap (Entry cost (Pair Int a))
q' IntMap (Pair cost a)
visited
          | Bool
otherwise ->
              let q2 :: Heap (Entry cost (Pair Int a))
q2 = [Entry cost (Pair Int a)] -> Heap (Entry cost (Pair Int a))
forall a. Ord a => [a] -> Heap a
Heap.fromList
                       [ cost -> Pair Int a -> Entry cost (Pair Int a)
forall p a. p -> a -> Entry p a
Heap.Entry (cost
ccost -> cost -> cost
forall a. Num a => a -> a -> a
+cost
c') (Int -> a -> Pair Int a
forall a b. a -> b -> Pair a b
Pair Int
ch (a
a a -> a -> a
`fC` Edge cost label -> a
fE (Int
v,Int
ch,cost
c',label
l)))
                       | (Int
ch,cost
c',label
l) <- [(Int, cost, label)]
-> Int -> Graph cost label -> [(Int, cost, label)]
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault [] Int
v Graph cost label
g
                       , Bool -> Bool
not (Int
ch Int -> IntMap (Pair cost a) -> Bool
forall a. Int -> IntMap a -> Bool
`IntMap.member` IntMap (Pair cost a)
visited)
                       ]
              in Heap (Entry cost (Pair Int a))
-> IntMap (Pair cost a) -> IntMap (Pair cost a)
loop (Heap (Entry cost (Pair Int a))
-> Heap (Entry cost (Pair Int a)) -> Heap (Entry cost (Pair Int a))
forall a. Heap a -> Heap a -> Heap a
Heap.union Heap (Entry cost (Pair Int a))
q' Heap (Entry cost (Pair Int a))
q2) (Int -> Pair cost a -> IntMap (Pair cost a) -> IntMap (Pair cost a)
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
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 :: Fold cost label a -> Graph cost label -> IntMap (IntMap (cost, a))
floydWarshall (Fold Int -> 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 (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 (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))
 -> Int -> IntMap (IntMap (Pair cost a)))
-> IntMap (IntMap (Pair cost a))
-> [Int]
-> IntMap (IntMap (Pair cost a))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntMap (IntMap (Pair cost a))
-> Int -> IntMap (IntMap (Pair cost a))
f IntMap (IntMap (Pair cost a))
tbl0 [Int]
vs) IntMap (IntMap (Pair cost a))
paths0
  where
    vs :: [Int]
vs = Graph cost label -> [Int]
forall a. IntMap a -> [Int]
IntMap.keys Graph cost label
g

    paths0 :: IntMap (IntMap (Pair cost x))
    paths0 :: IntMap (IntMap (Pair cost a))
paths0 = (Int -> [OutEdge cost label] -> IntMap (Pair cost a))
-> Graph cost label -> IntMap (IntMap (Pair cost a))
forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey (\Int
v [OutEdge cost label]
_ -> Int -> Pair cost a -> IntMap (Pair cost a)
forall a. Int -> a -> IntMap a
IntMap.singleton Int
v (cost -> a -> Pair cost a
forall a b. a -> b -> Pair a b
Pair cost
0 (Int -> a
fV Int
v))) Graph cost label
g

    tbl0 :: IntMap (IntMap (Pair cost x))
    tbl0 :: IntMap (IntMap (Pair cost a))
tbl0 = (Int -> [OutEdge cost label] -> IntMap (Pair cost a))
-> Graph cost label -> IntMap (IntMap (Pair cost a))
forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey (\Int
v [OutEdge cost label]
es -> (Pair cost a -> Pair cost a -> Pair cost a)
-> [(Int, Pair cost a)] -> IntMap (Pair cost a)
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith Pair cost a -> Pair cost a -> Pair cost a
minP [(Int
u, (cost -> a -> Pair cost a
forall a b. a -> b -> Pair a b
Pair cost
c (Edge cost label -> a
fE (Int
v,Int
u,cost
c,label
l)))) | (Int
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))
-> Int -> IntMap (IntMap (Pair cost a))
f IntMap (IntMap (Pair cost a))
tbl Int
vk =
      case Int
-> IntMap (IntMap (Pair cost a)) -> Maybe (IntMap (Pair cost a))
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
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 Int -> IntMap (Pair cost a) -> Maybe (Pair cost a)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
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 :: (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

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