module Algebra.Graph.Labelled.AdjacencyMap.Internal (
AdjacencyMap (..), consistent
) where
import Prelude ()
import Prelude.Compat
import Control.DeepSeq
import Data.Map.Strict (Map)
import Data.Monoid (Monoid, getSum, Sum (..))
import Data.Set (Set, (\\))
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Algebra.Graph.Label
newtype AdjacencyMap e a = AM {
adjacencyMap :: Map a (Map a e) } deriving (Eq, NFData)
instance (Ord a, Show a, Ord e, Show e) => Show (AdjacencyMap e a) where
showsPrec p (AM m)
| Set.null vs = showString "empty"
| null es = showParen (p > 10) $ vshow vs
| vs == used = showParen (p > 10) $ eshow es
| otherwise = showParen (p > 10) $
showString "overlay (" . vshow (vs \\ used) .
showString ") (" . eshow es . showString ")"
where
vs = Map.keysSet m
es = internalEdgeList m
used = referredToVertexSet m
vshow vs = case Set.toAscList vs of
[x] -> showString "vertex " . showsPrec 11 x
xs -> showString "vertices " . showsPrec 11 xs
eshow es = case es of
[(e, x, y)] -> showString "edge " . showsPrec 11 e .
showString " " . showsPrec 11 x .
showString " " . showsPrec 11 y
xs -> showString "edges " . showsPrec 11 xs
instance (Ord e, Monoid e, Ord a) => Ord (AdjacencyMap e a) where
compare (AM x) (AM y) = mconcat
[ compare (vNum x) (vNum y)
, compare (vSet x) (vSet y)
, compare (eNum x) (eNum y)
, compare (eSet x) (eSet y)
, cmp ]
where
vNum = Map.size
vSet = Map.keysSet
eNum = getSum . foldMap (Sum . Map.size)
eSet m = [ (x, y) | (x, ys) <- Map.toAscList m, (y, _) <- Map.toAscList ys ]
cmp | x == y = EQ
| overlays [x, y] == y = LT
| otherwise = compare x y
overlays :: (Eq e, Monoid e, Ord a) => [Map a (Map a e)] -> Map a (Map a e)
overlays = Map.unionsWith (\x -> Map.filter (/= zero) . Map.unionWith mappend x)
instance (Eq e, Dioid e, Num a, Ord a) => Num (AdjacencyMap e a) where
fromInteger x = AM $ Map.singleton (fromInteger x) Map.empty
AM x + AM y = AM $ overlays [x, y]
AM x * AM y = AM $ overlays $ x : y :
[ Map.fromSet (const targets) (Map.keysSet x) ]
where
targets = Map.fromSet (const one) (Map.keysSet y)
signum = const (AM Map.empty)
abs = id
negate = id
consistent :: (Ord a, Eq e, Monoid e) => AdjacencyMap e a -> Bool
consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` Map.keysSet m
&& and [ e /= zero | (_, es) <- Map.toAscList m, (_, e) <- Map.toAscList es ]
referredToVertexSet :: Ord a => Map a (Map a e) -> Set a
referredToVertexSet m = Set.fromList $ concat
[ [x, y] | (x, ys) <- Map.toAscList m, (y, _) <- Map.toAscList ys ]
internalEdgeList :: Map a (Map a e) -> [(e, a, a)]
internalEdgeList m =
[ (e, x, y) | (x, ys) <- Map.toAscList m, (y, e) <- Map.toAscList ys ]