{-|
Module      : Data.Graph.AdjacencyList.WFI
Description : Floyd-Warshall all-pairs shortest paths
Copyright   : Thodoris Papakonstantinou, 2017-2026
License     : LGPL-3
Maintainer  : dev@tpapak.com
Stability   : experimental
Portability : POSIX

Implementation of the
<https://en.wikipedia.org/wiki/Floyd%E2%80%93Warshall_algorithm Floyd-Warshall algorithm>
for computing all-pairs shortest path distances on a weighted or unweighted
directed graph.  Complexity: O(V^3).
 -}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}


module Data.Graph.AdjacencyList.WFI
  ( Distances (..)
  , Weight
  , IMArray
  , shortestDistances
  , unweightedShortestDistances
  , adjacencyArray
  ) where

import Data.List
import Data.Maybe
import qualified Data.Map   as M
import qualified Data.IntMap   as IM

import Data.Graph.AdjacencyList

-- | In an unweighted graph the weight is 1 for each edge
type Weight = Rational

-- | Two-dimensional distance matrix: vertex → vertex → 'Weight'.
type IMArray = IM.IntMap (IM.IntMap Weight)
-- | The array containing the distances from vertex to vertex
newtype Distances = Distances IMArray
  deriving (Distances -> Distances -> Bool
(Distances -> Distances -> Bool)
-> (Distances -> Distances -> Bool) -> Eq Distances
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Distances -> Distances -> Bool
== :: Distances -> Distances -> Bool
$c/= :: Distances -> Distances -> Bool
/= :: Distances -> Distances -> Bool
Eq, Eq Distances
Eq Distances =>
(Distances -> Distances -> Ordering)
-> (Distances -> Distances -> Bool)
-> (Distances -> Distances -> Bool)
-> (Distances -> Distances -> Bool)
-> (Distances -> Distances -> Bool)
-> (Distances -> Distances -> Distances)
-> (Distances -> Distances -> Distances)
-> Ord Distances
Distances -> Distances -> Bool
Distances -> Distances -> Ordering
Distances -> Distances -> Distances
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Distances -> Distances -> Ordering
compare :: Distances -> Distances -> Ordering
$c< :: Distances -> Distances -> Bool
< :: Distances -> Distances -> Bool
$c<= :: Distances -> Distances -> Bool
<= :: Distances -> Distances -> Bool
$c> :: Distances -> Distances -> Bool
> :: Distances -> Distances -> Bool
$c>= :: Distances -> Distances -> Bool
>= :: Distances -> Distances -> Bool
$cmax :: Distances -> Distances -> Distances
max :: Distances -> Distances -> Distances
$cmin :: Distances -> Distances -> Distances
min :: Distances -> Distances -> Distances
Ord, ReadPrec [Distances]
ReadPrec Distances
Int -> ReadS Distances
ReadS [Distances]
(Int -> ReadS Distances)
-> ReadS [Distances]
-> ReadPrec Distances
-> ReadPrec [Distances]
-> Read Distances
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Distances
readsPrec :: Int -> ReadS Distances
$creadList :: ReadS [Distances]
readList :: ReadS [Distances]
$creadPrec :: ReadPrec Distances
readPrec :: ReadPrec Distances
$creadListPrec :: ReadPrec [Distances]
readListPrec :: ReadPrec [Distances]
Read)

instance Show Distances where
  show :: Distances -> String
show (Distances IMArray
d) =
    let vs :: [Int]
vs = IMArray -> [Int]
forall a. IntMap a -> [Int]
IM.keys IMArray
d
     in IMArray -> String
forall a. Show a => a -> String
show IMArray
d

-- | Reads distance array. Nothing corresponds to infinite distance
shortestDistance :: IMArray -> Vertex -> Vertex -> Maybe Weight
shortestDistance :: IMArray -> Int -> Int -> Maybe Weight
shortestDistance IMArray
dists Int
u Int
v = do
  IntMap Weight
vmap <- Int -> IMArray -> Maybe (IntMap Weight)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
u IMArray
dists
  Int -> IntMap Weight -> Maybe Weight
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap Weight
vmap

-- | Build the initial distance matrix from a graph's edges (unit weights).
-- Self-distances are 0; direct edges have distance 1; all others are absent
-- (infinite).  Pass the result to 'shortestDistances' to run Floyd-Warshall.
adjacencyArray :: Graph -> Distances
adjacencyArray :: Graph -> Distances
adjacencyArray Graph
g =
  let es :: [Edge]
es = Graph -> [Edge]
edges Graph
g
      dists :: IMArray
dists = (IMArray -> Edge -> IMArray) -> IMArray -> [Edge] -> IMArray
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IMArray
dists (Edge Int
u Int
v) ->
        let vmap :: IntMap Weight
vmap = case Int -> IMArray -> Maybe (IntMap Weight)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
u IMArray
dists of 
                      Maybe (IntMap Weight)
Nothing -> IntMap Weight
forall a. IntMap a
IM.empty
                      Just IntMap Weight
vmap' -> IntMap Weight
vmap'
         in Int -> IntMap Weight -> IMArray -> IMArray
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
u ((Int -> Weight -> IntMap Weight -> IntMap Weight
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
v Weight
1) IntMap Weight
vmap) IMArray
dists
                ) IMArray
forall a. IntMap a
IM.empty [Edge]
es
   in IMArray -> Distances
Distances (IMArray -> Distances) -> IMArray -> Distances
forall a b. (a -> b) -> a -> b
$ (Int -> IntMap Weight -> IntMap Weight) -> IMArray -> IMArray
forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IM.mapWithKey (\Int
i IntMap Weight
m -> Int -> Weight -> IntMap Weight -> IntMap Weight
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Weight
0 IntMap Weight
m) IMArray
dists 

-- | Get all shortest distances given initial weights on edges
shortestDistances :: Graph -> Distances -> Distances
shortestDistances :: Graph -> Distances -> Distances
shortestDistances Graph
g (Distances IMArray
dists) = IMArray -> Distances
Distances (IMArray -> Distances) -> IMArray -> Distances
forall a b. (a -> b) -> a -> b
$ (IMArray -> Int -> IMArray) -> IMArray -> [Int] -> IMArray
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IMArray -> Int -> IMArray
update IMArray
dists [Int]
vs
  where
    vs :: [Int]
vs = Graph -> [Int]
vertices Graph
g
    update :: IMArray -> Int -> IMArray
update IMArray
d Int
k = (Int -> IntMap Weight -> IntMap Weight) -> IMArray -> IMArray
forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IM.mapWithKey Int -> IntMap Weight -> IntMap Weight
shortmap IMArray
d
      where
        shortmap :: Vertex -> IM.IntMap Weight -> IM.IntMap Weight
        shortmap :: Int -> IntMap Weight -> IntMap Weight
shortmap Int
i IntMap Weight
jmap = (Int -> IntMap Weight -> IntMap Weight)
-> IntMap Weight -> [Int] -> IntMap Weight
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> IntMap Weight -> IntMap Weight
shortest IntMap Weight
forall a. IntMap a
IM.empty [Int]
vs
          where shortest :: Int -> IntMap Weight -> IntMap Weight
shortest Int
j IntMap Weight
m =
                  case (Maybe Weight
old,Maybe Weight
new) of
                    (Maybe Weight
Nothing, Maybe Weight
Nothing) -> IntMap Weight
m
                    (Maybe Weight
Nothing, Just Weight
w ) -> Int -> Weight -> IntMap Weight -> IntMap Weight
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
j Weight
w IntMap Weight
m
                    (Just Weight
w, Maybe Weight
Nothing) -> Int -> Weight -> IntMap Weight -> IntMap Weight
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
j Weight
w IntMap Weight
m
                    (Just Weight
w1, Just Weight
w2) -> Int -> Weight -> IntMap Weight -> IntMap Weight
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
j (Weight -> Weight -> Weight
forall a. Ord a => a -> a -> a
min Weight
w1 Weight
w2) IntMap Weight
m
                  where
                    old :: Maybe Weight
old = Int -> IntMap Weight -> Maybe Weight
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
j IntMap Weight
jmap
                    new :: Maybe Weight
new = do Weight
w1 <- IMArray -> Int -> Int -> Maybe Weight
shortestDistance IMArray
d Int
i Int
k
                             Weight
w2 <- IMArray -> Int -> Int -> Maybe Weight
shortestDistance IMArray
d Int
k Int
j
                             Weight -> Maybe Weight
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Weight
w1Weight -> Weight -> Weight
forall a. Num a => a -> a -> a
+Weight
w2)

-- | Get all shortest unweighted distances
unweightedShortestDistances :: Graph -> Distances
unweightedShortestDistances :: Graph -> Distances
unweightedShortestDistances Graph
g = Graph -> Distances -> Distances
shortestDistances Graph
g (Graph -> Distances
adjacencyArray Graph
g)