{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-}

--
-- (c) 2012 Wei Ke
--      license:          GPL-3
--      license-file:     LICENSE
--
-- |
-- The "Graph" module defines the general graph type and graph operations,
-- with the node type 'nty' and the edge-label type 'laty' as type parameters.
-- Such a graph is viewed both as components, i.e., 'Nsg' for nodes and 'Esg' for edges, 
-- and as a whole, i.e., 'Hg' for type graphs and 'Gg' for rooted graphs.
-- The fundamental graph operations are on nodes and edges, for flexible applications.
-- The set of nodes is implemented as a "Data.Set",
-- while the set of edges is implemented as a "Data.Map" from
-- the pair of source node and out-going label to the target node.
-- The order of the keys of the edge "Data.Map" is defined as such
-- the edges with the same source node are grouped together,
-- and can be efficiently split out.
-- Both the set of nodes and the set of edges are exported abstractly 
-- as instances of 'GSet' and optional 'GSetEx'.
--
module Graph ( GSet(..), GSetEx(..)
             , Nsg
             , Eg(E), Esg
             , Hg(H), Gg(G)
             , nodeLT, nodeGT, newNode
             , gc, gcWith1stLev, gcs
             , findEdge, findTg, findTrace, findTraceTg, prefixFind
             , getOutEdges, getOutLas, getInLas, getAllLas
             
             -- H
             , emptyH, newNodeH, addNodeH, addNodesH, addEdgeH, addEdgesH
             , gcH
             , findEdgeH, findTgH, findTraceH, findTraceTgH, prefixFindH
             , getOutEdgesH, getOutLasH, getInLasH, getAllLasH
             , containsH
             
             -- G
             , gcG, gcGr
             , findEdgeG, findEdgeGr, findTgG, findTgGr, prefixFindG, prefixFindGr
             , getOutEdgesG, getOutEdgesGr
             
             -- H/G
             , greltoh
             )
where

import Data.Set(Set)
import qualified Data.Set as S
import Data.Map (Map)
import qualified Data.Map as M
import Control.Monad

-- | 
-- common set operations for both nodes and edges in graphs,
-- with /ety/ the element type and /sty/ the set type.
class GSet ety sty | sty -> ety where
    empty :: sty                    -- ^ the empty set
    singleton :: ety -> sty         -- ^ the singletone set containing the given element
    fromList :: [ety] -> sty        -- ^ constructs a set from a list of elements
    toList :: sty -> [ety]          -- ^ converts a set to a list
    (+.) :: sty -> ety -> sty       -- ^ adds an element to a set
    (+..) :: sty -> sty -> sty      -- ^ unions two sets (right bias)
    (+../) :: sty -> [ety] -> sty   -- ^ adds a list of elements to a set (right bias)

-- | 
-- additional (optional) set operations.
class GSet ety sty => GSetEx ety sty | sty -> ety where
    (-..) :: sty -> sty -> sty      -- ^ returns the difference of two sets
    contains :: sty -> ety -> Bool  -- ^ tests if a set contains an element
    size :: sty -> Int              -- ^ returns the size of a set

-- | 
-- sets of nodes
newtype Nsg nty = Nsg (Set nty) deriving (Eq, Ord)

instance (Eq nty, Show nty) => Show (Nsg nty) where
    show (Nsg ns) = show (S.toList ns)

instance Ord nty => GSet nty (Nsg nty) where
    empty = Nsg S.empty
    singleton n = Nsg (S.singleton n)
    toList (Nsg x) = S.toAscList x
    fromList nl = Nsg (S.fromList nl)
    (Nsg x) +.. (Nsg y) = Nsg (S.union x y)
    (Nsg x) +../ nl = Nsg (S.union x (S.fromList nl))
    (Nsg x) +. n = Nsg (S.insert n x)

instance Ord nty => GSetEx nty (Nsg nty) where
    (Nsg x) -.. (Nsg y) = Nsg (S.difference x y)
    contains (Nsg x) n = S.member n x
    size (Nsg x) = S.size x

-- | 
-- edges
data Eg nty laty = E nty laty nty deriving Eq

instance (Show nty, Show laty) => Show (Eg nty laty) where
    show (E n la n') = show n ++ "--" ++ show la ++ "->" ++ show n'

-- | 
-- edge keys: source node + outgoing label
data EK nty laty = MinEK nty | EK nty laty | MaxEK nty deriving Eq

instance (Ord nty, Ord laty) => Ord (EK nty laty) where
    compare (MinEK x) (MinEK y) = compare x y
    compare (MinEK x) (EK y _) =
            case compare x y of
                EQ -> LT
                c -> c
    compare (MinEK x) (MaxEK y) =
            case compare x y of
                EQ -> LT
                c -> c
    compare (EK x1 x2) (EK y1 y2) =
            case compare x1 y1 of
                EQ -> compare x2 y2
                c -> c
    compare (EK x _) (MaxEK y) =
            case compare x y of
                EQ -> LT
                c -> c
    compare (MaxEK x) (MaxEK y) = compare x y
    compare x y =
            case compare y x of
                LT -> GT
                EQ -> EQ
                GT -> LT

-- |
-- maps from edge keys to target nodes
type Em nty laty = Map (EK nty laty) nty

-- |
-- sets of edges 
newtype Esg nty laty = Esg (Em nty laty) deriving Eq

instance (Ord nty, Ord laty, Show nty, Show laty) => Show (Esg nty laty) where
    show es = show (toList es)

instance (Ord nty, Ord laty) => GSet (Eg nty laty) (Esg nty laty) where
    empty = Esg M.empty
    singleton (E s la t) = Esg (M.singleton (EK s la) t)
    toList (Esg x) = [E s la t | (EK s la, t) <- M.toAscList x]
    fromList el = Esg (M.fromList [(EK s la, t) | E s la t <- el])
    (Esg x) +.. (Esg y) = Esg (M.unionWith override x y)
    x +../ el = x +.. (fromList el)
    (Esg x) +. E s la t = Esg (M.insert (EK s la) t x)

override :: a -> a -> a
override _ y = y

-- | 
-- type graphs
data Hg nty laty = H (Nsg nty) (Esg nty laty) deriving Show

-- | 
-- rooted graph
data Gg nty laty = G (Nsg nty) (Esg nty laty) nty deriving (Eq, Show)

getoem :: (Ord nty, Ord laty) => Em nty laty -> nty -> Em nty laty
getoem x n = mid where
    (_lt, rest) = M.split (MinEK n) x
    (mid, _gt) = M.split (MaxEK n) rest

gc :: (Ord nty, Ord laty) => Esg nty laty -> nty -> Gg nty laty
gc (Esg x) r = G ns es r where
    (ns, es) = gc0 x (S.singleton r) M.empty

gcs :: (Ord nty, Ord laty) => Esg nty laty -> [nty] -> Hg nty laty
gcs (Esg x) nl = H ns es where
    (ns, es) = gc0 x (S.fromList nl) M.empty

gc0 :: (Ord nty, Ord laty) => Em nty laty -> Set nty -> Em nty laty -> (Nsg nty, Esg nty laty)
gc0 ex ny ey = 
        if M.null ez then (Nsg ny, Esg ey)
        else gc0 ex' (S.union ny (S.fromList (M.elems ez))) (ey `M.union` ez) 
    where (ez, ex') = M.partitionWithKey (\(EK s _) _ -> s `S.member` ny) ex

gcWith1stLev :: (Ord nty, Ord laty) => (laty -> Bool) -> Esg nty laty -> nty -> Gg nty laty
gcWith1stLev p (Esg x) r = gc (Esg (foldl (flip M.delete) x el)) r where
    el = [ek | ek@(EK _ la) <- M.keys (getoem x r), not (p la)] 

nodeLT :: Ord nty => Nsg nty -> nty -> Maybe nty
nodeLT (Nsg s) n = S.lookupLT n s

nodeGT :: Ord nty => Nsg nty -> nty -> Maybe nty
nodeGT (Nsg s) n = S.lookupGT n s

newNode :: Ord nty => (Nsg nty -> nty) -> Nsg nty -> (Nsg nty, nty)
newNode uni ns = (ns +. n, n) where n = uni ns

findEdge :: (Ord nty, Ord laty) => Esg nty laty -> nty -> laty -> Maybe (Eg nty laty)
findEdge es n la = findTg es n la >>= \n' -> return (E n la n')

findTg :: (Ord nty, Ord laty) => Esg nty laty -> nty -> laty -> Maybe nty
findTg (Esg x) n la = M.lookup (EK n la) x

findTrace :: (Ord nty, Ord laty) => Esg nty laty -> nty -> [laty] -> Maybe (Eg nty laty)
findTrace _ _ [] = Nothing
findTrace es n [la] = findEdge es n la
findTrace es n (la:las) = findTg es n la >>= \x -> findTrace es x las

findTraceTg :: (Ord nty, Ord laty) => Esg nty laty -> nty -> [laty] -> Maybe nty
findTraceTg es n las = findTrace es n las >>= \(E _ _ n') -> return n'

prefixFind :: (Ord nty, Ord laty) => Esg nty laty -> nty -> laty -> laty -> Maybe (Eg nty laty)  
prefixFind es n pre la = findEdge es n la `mplus` (findTg es n pre >>= \n' -> prefixFind es n' pre la)

getOutEdges :: (Ord nty, Ord laty) => Esg nty laty -> nty -> [Eg nty laty]
getOutEdges (Esg x) n = toList (Esg (getoem x n))

getOutLas :: (Ord nty, Ord laty) => Esg nty laty -> nty -> [laty]
getOutLas es n = [la | E _ la _ <- getOutEdges es n]

getInLas :: (Eq nty, Ord laty) => Esg nty laty -> nty -> [laty]
getInLas (Esg x) n = S.toList (M.foldWithKey (\(EK _ la) n' las -> if n == n' then S.insert la las else las) S.empty x)

getAllLas :: (Eq nty, Ord laty) => Esg nty laty -> [laty]
getAllLas (Esg x) = S.toList (M.foldWithKey (\(EK _ la) _ las -> S.insert la las) S.empty x)

--
-- H version
--

emptyH :: (Ord nty, Ord laty) => Hg nty laty
emptyH =  H empty empty

newNodeH :: Ord nty => (Nsg nty -> nty) -> Hg nty laty -> (Hg nty laty, nty)
newNodeH uni (H ns es) = (H ns' es, n) where (ns', n) = newNode uni ns

addNodeH :: Ord nty => Hg nty laty -> nty -> Hg nty laty
addNodeH (H ns es) n = H (ns +. n) es

addNodesH :: Ord nty => Hg nty laty -> [nty] -> Hg nty laty
addNodesH (H ns es) nl = H (ns +../ nl) es

addEdgeH :: (Ord nty, Ord laty) => Hg nty laty -> Eg nty laty -> Hg nty laty
addEdgeH (H ns es) e@(E s _ t) = H (ns +../ [s, t]) (es +. e)

addEdgesH :: (Ord nty, Ord laty) => Hg nty laty -> [Eg nty laty] -> Hg nty laty
addEdgesH (H ns es) es' = H (ns +../ concat [[s, t] | E s _ t <- es']) (es +../ es')

gcH :: (Ord nty, Ord laty) => Hg nty laty -> nty -> Gg nty laty
gcH (H _ es) r = gc es r

findEdgeH :: (Ord nty, Ord laty) => Hg nty laty -> nty -> laty -> Maybe (Eg nty laty)
findEdgeH (H _ es) n la = findEdge es n la

findTgH :: (Ord nty, Ord laty) => Hg nty laty -> nty -> laty -> Maybe nty
findTgH (H _ es) n la = findTg es n la

findTraceH :: (Ord nty, Ord laty) => Hg nty laty -> nty -> [laty] -> Maybe (Eg nty laty)
findTraceH (H _ es) n las = findTrace es n las

findTraceTgH :: (Ord nty, Ord laty) => Hg nty laty -> nty -> [laty] -> Maybe nty
findTraceTgH (H _ es) n las = findTraceTg es n las

prefixFindH :: (Ord nty, Ord laty) => Hg nty laty -> nty -> laty -> laty -> Maybe (Eg nty laty)  
prefixFindH (H _ es) n pre la = prefixFind es n pre la

getOutEdgesH :: (Ord nty, Ord laty) => Hg nty laty -> nty -> [Eg nty laty]
getOutEdgesH (H _ es) n = getOutEdges es n

getOutLasH :: (Ord nty, Ord laty) => Hg nty laty -> nty -> [laty]
getOutLasH (H _ es) n = getOutLas es n

getInLasH :: (Eq nty, Ord laty) => Hg nty laty -> nty -> [laty]
getInLasH (H _ es) n = getInLas es n

getAllLasH :: (Eq nty, Ord laty) => Hg nty laty -> [laty]
getAllLasH (H _ es) = getAllLas es

containsH :: Ord nty => Hg nty laty -> nty -> Bool
containsH (H ns _) n = ns `contains` n

--
-- G version
--

gcG :: (Ord nty, Ord laty) => Gg nty laty -> nty -> Gg nty laty
gcG (G _ es _) r = gc es r

gcGr :: (Ord nty, Ord laty) => Gg nty laty -> Gg nty laty
gcGr (G _ es r) = gc es r

findEdgeG :: (Ord nty, Ord laty) => Gg nty laty -> nty -> laty -> Maybe (Eg nty laty)
findEdgeG (G _ es _) n la = findEdge es n la

findEdgeGr :: (Ord nty, Ord laty) => Gg nty laty -> laty -> Maybe (Eg nty laty)
findEdgeGr (G _ es r) la = findEdge es r la

findTgG :: (Ord nty, Ord laty) => Gg nty laty -> nty -> laty -> Maybe nty
findTgG (G _ es _) n la = findTg es n la

findTgGr :: (Ord nty, Ord laty) => Gg nty laty -> laty -> Maybe nty
findTgGr (G _ es r) la = findTg es r la

prefixFindG :: (Ord nty, Ord laty) => Gg nty laty -> nty -> laty -> laty -> Maybe (Eg nty laty)  
prefixFindG (G _ es _) n pre la = prefixFind es n pre la

prefixFindGr :: (Ord nty, Ord laty) => Gg nty laty -> laty -> laty -> Maybe (Eg nty laty)  
prefixFindGr (G _ es r) pre la = prefixFind es r pre la

getOutEdgesG :: (Ord nty, Ord laty) => Gg nty laty -> nty -> [Eg nty laty]
getOutEdgesG (G _ es _) n = getOutEdges es n

getOutEdgesGr :: (Ord nty, Ord laty) => Gg nty laty -> [Eg nty laty]
getOutEdgesGr (G _ es r) = getOutEdges es r

--
-- relations on rooted graphs to relations on nodes of the same type graph 
--

greltoh   :: (Ord nty, Ord laty) => (Gg nty laty -> Gg nty laty -> a) -> (Hg nty laty -> nty -> nty -> a)
greltoh f =  \h n n' -> f (gcH h n) (gcH h n')

--
-- end of Graph
--
-- --$Id: Graph.hs 1189 2012-11-14 05:57:21Z wke@IPM.EDU.MO $