module HGraph.Directed.PathAnonymity
       ( pathAnonymity
       , pathAnonymityCertificate
       , pathPathAnonymityI
       )
where

import HGraph.Directed
import HGraph.Directed.Connectivity
import qualified Data.Map as M
import qualified Data.Set as S
import Data.List

pathAnonymity :: t b -> b
pathAnonymity t b
d = ([b], b) -> b
forall a b. (a, b) -> b
snd (([b], b) -> b) -> ([b], b) -> b
forall a b. (a -> b) -> a -> b
$ t b -> ([b], b)
forall {t :: * -> *} {b} {b}.
(Adjacency t, Ord b, Num b, DirectedGraph t) =>
t b -> ([b], b)
pathAnonymityCertificate t b
d

-- | Path anonymity of a digraph together with a path witnessing
-- | that the anonymity is at least the returned value.
pathAnonymityCertificate :: t b -> ([b], b)
pathAnonymityCertificate t b
d = ((Int -> b) -> [Int] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Map Int b
iToV Map Int b -> Int -> b
forall k a. Ord k => Map k a -> k -> a
M.!) [Int]
p, b
k)
  where
    ([Int]
p,b
k) = t Int -> ([Int], b)
forall {t :: * -> *} {a} {a}.
(Adjacency t, Ord a, Ord a, Num a, DirectedGraph t) =>
t a -> ([a], a)
pathAnonymityCertificateI t Int
di
    (t Int
di, [(Int, b)]
itova) = t b -> (t Int, [(Int, b)])
forall a. t a -> (t Int, [(Int, a)])
forall (t :: * -> *) a.
DirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t b
d
    iToV :: Map Int b
iToV = [(Int, b)] -> Map Int b
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, b)]
itova

pathAnonymityCertificateI :: t a -> ([a], a)
pathAnonymityCertificateI t a
di =
  (([a], a) -> ([a], a) -> Ordering) -> [([a], a)] -> ([a], a)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (\([a]
_,a
k1) ([a]
_,a
k2) -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
k1 a
k2) ([([a], a)] -> ([a], a)) -> [([a], a)] -> ([a], a)
forall a b. (a -> b) -> a -> b
$
    ([a] -> ([a], a)) -> [[a]] -> [([a], a)]
forall a b. (a -> b) -> [a] -> [b]
map (\[a]
p -> ([a]
p, t a -> [a] -> a
forall {t :: * -> *} {a} {a}.
(Adjacency t, Ord a, Num a) =>
t a -> [a] -> a
pathPathAnonymityI t a
di [a]
p)) ([[a]] -> [([a], a)]) -> [[a]] -> [([a], a)]
forall a b. (a -> b) -> a -> b
$
        t a -> [[a]]
forall {t :: * -> *} {b}.
(Adjacency t, DirectedGraph t) =>
t b -> [[b]]
allMaximalPaths t a
di

-- | Path anonymity of a maximal path.
-- | The path provided is assumed to be maximal.
pathPathAnonymityI :: t a -> [a] -> a
pathPathAnonymityI t a
di [a]
p
  | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 [a]
p = a
0
  | Bool
otherwise = [a] -> a
numCriticalPaths [a]
p 
  where
    ps :: Set a
ps = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
p
    pI :: Map a Integer
pI = ((a, Integer) -> Map a Integer -> Map a Integer)
-> Map a Integer -> [(a, Integer)] -> Map a Integer
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(a
k,Integer
i) -> (Integer -> Integer -> Integer)
-> a -> Integer -> Map a Integer -> Map a Integer
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (\Integer
o Integer
_ -> Integer
o) a
k Integer
i) Map a Integer
forall k a. Map k a
M.empty ([(a, Integer)] -> Map a Integer)
-> [(a, Integer)] -> Map a Integer
forall a b. (a -> b) -> a -> b
$ [a] -> [Integer] -> [(a, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
p [Integer
0..]
    pr :: [a]
pr = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
p
    isCycle :: Bool
isCycle = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
1 [a]
p [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
1 [a]
pr
    f0 :: a
f0 = [a] -> a
forall a. HasCallStack => [a] -> a
head [a]
p
    mn :: a
mn
      | Bool
isCycle   = [a] -> a
forall a. HasCallStack => [a] -> a
head ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 [a]
pr
      | Bool
otherwise = [a] -> a
forall a. HasCallStack => [a] -> a
head [a]
pr
    m0 :: [a]
m0 = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
1 ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\a
v -> [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
ps)) (t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
di a
v)) [a]
p
    fn :: [a]
fn = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
1 ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\a
v -> [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
ps)) (t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
di a
v)) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$
          (if Bool
isCycle then [a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail else [a] -> [a]
forall a. a -> a
id) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a]
pr
    vF :: Set a
vF
      | Bool
isCycle Bool -> Bool -> Bool
&& ((Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
fn) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
m0)) =
                    [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ [a]
fn [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a
mn a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
f0 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: ((a, a) -> a) -> [(a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> a
fst [(a, a)]
shortcutPairs)
      | Bool
otherwise = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ [a]
fn [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a
f0 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: ((a, a) -> a) -> [(a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> a
fst [(a, a)]
shortcutPairs)
    vM :: Set a
vM
      | Bool
isCycle Bool -> Bool -> Bool
&& ((Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
m0) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
fn)) = 
                    [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ [a]
m0 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a
f0 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
mn a -> [a] -> [a]
forall a. a -> [a] -> [a]
: ((a, a) -> a) -> [(a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> b
snd [(a, a)]
shortcutPairs)
      | Bool
otherwise = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ [a]
m0 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a
mn a -> [a] -> [a]
forall a. a -> [a] -> [a]
: ((a, a) -> a) -> [(a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> b
snd [(a, a)]
shortcutPairs)
    shortcuts :: a -> [(a, a)]
shortcuts a
v = ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
u,a
w) -> Map a Integer
pI Map a Integer -> a -> Integer
forall k a. Ord k => Map k a -> k -> a
M.! a
u Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Map a Integer
pI Map a Integer -> a -> Integer
forall k a. Ord k => Map k a -> k -> a
M.! a
w) ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ t a -> Set a -> a -> [(a, a)]
forall {b} {t :: * -> *}.
(Ord b, Adjacency t) =>
t b -> Set b -> b -> [(b, b)]
shortcuts' t a
di Set a
ps a
v
    shortcutPairs :: [(a, a)]
shortcutPairs = (a -> [(a, a)]) -> [a] -> [(a, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\a
v -> a -> [(a, a)]
shortcuts a
v [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ a -> [(a, a)]
directShortcuts a
v) [a]
p
    directShortcuts :: a -> [(a, a)]
directShortcuts a
v = ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
u,a
w) -> Map a Integer
pI Map a Integer -> a -> Integer
forall k a. Ord k => Map k a -> k -> a
M.! a
u Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Map a Integer
pI Map a Integer -> a -> Integer
forall k a. Ord k => Map k a -> k -> a
M.! a
w) ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ t a -> Set a -> a -> [(a, a)]
forall {t :: * -> *} {b}.
(Adjacency t, Ord b) =>
t b -> Set b -> b -> [(b, b)]
directShortcuts' t a
di Set a
ps a
v
    numCriticalPaths :: [a] -> a
numCriticalPaths = Set a -> Set a -> [a] -> a
forall {a} {a}. (Num a, Ord a) => Set a -> Set a -> [a] -> a
numCriticalPaths' Set a
vF Set a
vM

numCriticalPaths' :: Set a -> Set a -> [a] -> a
numCriticalPaths' Set a
_ Set a
_ [] = a
0
numCriticalPaths' Set a
vF Set a
vM (a
_:[a]
vs)
  | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
vm = a
0
  | Bool
otherwise = a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ Set a -> Set a -> [a] -> a
numCriticalPaths' Set a
vF Set a
vM [a]
vs'
  where
    vm :: [a]
vm  = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
vM)) [a]
vs
    vs' :: [a]
vs' = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
vF)) [a]
vm
        
shortcuts' :: t b -> Set b -> b -> [(b, b)]
shortcuts' t b
di Set b
blocked b
v =
  [ (b
v,b
w)
  | b
u <- [b]
us
  , b
w <- (b -> Bool) -> [b] -> [b]
forall a. (a -> Bool) -> [a] -> [a]
filter (b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set b
blocked) ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ t b -> b -> [b]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t b
di b
u
  ]
  where
    us :: [b]
us = t b -> b -> ([b] -> [b]) -> ([b] -> [b]) -> [b]
forall a. Ord a => t a -> a -> ([a] -> [a]) -> ([a] -> [a]) -> [a]
forall (t :: * -> *) a.
(Adjacency t, Ord a) =>
t a -> a -> ([a] -> [a]) -> ([a] -> [a]) -> [a]
metaBfs t b
di b
v (\[b]
_ -> []) ((b -> Bool) -> [b] -> [b]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (b -> Bool) -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set b
blocked)))

directShortcuts' :: t b -> Set b -> b -> [(b, b)]
directShortcuts' t b
di Set b
blocked b
v = [ (b
v,b
w)
     | b
w <- t b -> b -> [b]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t b
di b
v
     , b
w b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set b
blocked
     ]