PathAnonymity.hs

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 d = snd $ pathAnonymityCertificate d

-- | Path anonymity of a digraph together with a path witnessing
-- | that the anonymity is at least the returned value.
pathAnonymityCertificate d = (map (iToV M.!) p, k)
  where
    (p,k) = pathAnonymityCertificateI di
    (di, itova) = linearizeVertices d
    iToV = M.fromList itova

pathAnonymityCertificateI di =
  maximumBy (\(_,k1) (_,k2) -> compare k1 k2) $
    map (\p -> (p, pathPathAnonymityI di p)) $
        allMaximalPaths di

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

numCriticalPaths' _ _ [] = 0
numCriticalPaths' vF vM (_:vs)
  | null vm = 0
  | otherwise = 1 + numCriticalPaths' vF vM vs'
  where
    vm  = dropWhile (not . (`S.member` vM)) vs
    vs' = dropWhile (not . (`S.member` vF)) vm
        
shortcuts' di blocked v =
  [ (v,w)
  | u <- us
  , w <- filter (`S.member` blocked) $ outneighbors di u
  ]
  where
    us = metaBfs di v (\_ -> []) (filter (not . (`S.member` blocked)))

directShortcuts' di blocked v = [ (v,w)
     | w <- outneighbors di v
     , w `S.member` blocked
     ]