{-# LANGUAGE   TypeFamilies
             , FlexibleContexts
             , UndecidableInstances
             , MultiParamTypeClasses
  #-}
module Data.Graph.Inductive.Graph where

import Data.Maybe (isNothing,listToMaybe,fromMaybe,fromJust)
import Data.List (foldl', group, sort, sortBy, unfoldr)
import Data.Function(on)
import Control.Arrow(first, second)
import Control.Monad(liftM2)
import Text.Read(Lexeme(Ident), readPrec, parens, lexP)
import Text.ParserCombinators.ReadP(string, skipSpaces)
import Text.ParserCombinators.ReadPrec(ReadPrec, lift, prec)

import Data.Graph.Inductive.InstanceHelpers

{- TODO
abstract node (hide constructor, do not export it)
lookupNode vs lookupNodeM, where to put Maybe, MonadPlus

helper functions for labels of type ()
-}

-- -----------------------------------------------------------------------------
-- Context

data Context g = Context { predecessors :: [(Node g, EdgeLabel g)]
                         , node :: Node g
                         , label :: NodeLabel g
                         , successors :: [(Node g, EdgeLabel g)]
                         }


instance ( InductiveGraph g, Show (Node g), Show (NodeLabel g)
         , Show (EdgeLabel g)) => Show (Context g) where
  showsPrec d (Context pr n l sc)
    = showParen (d > 10)
      $ showString "Context" . showChar ' '
      . showsPrec 11 pr . showChar ' '
      . showsPrec 11 n . showChar ' '
      . showsPrec 11 l . showChar ' '
      . showsPrec 11 sc

instance ( InductiveGraph g, Read (Node g), Read (NodeLabel g)
         , Read (EdgeLabel g)) => Read (Context g) where
  readPrec = parens . prec 10 . lift
             $ do _ <- string "Context"
                  skipSpaces
                  pr <- readP
                  skipSpaces
                  n <- readP
                  skipSpaces
                  l <- readP
                  skipSpaces
                  sc <- readP
                  return $ Context pr n l sc

instance ( InductiveGraph g, Ord (Node g), Eq (NodeLabel g)
         , Ord (EdgeLabel g)) => Eq (Context g) where

  (Context pr1 n1 l1 sc1) == (Context pr2 n2 l2 sc2)
    = n1 == n2 && l1 == l2 && sortEq pr1 pr2 && sortEq sc1 sc2
    where
      sortEq = (==) `on` sort

instance ( InductiveGraph g, Ord (Node g), Ord (NodeLabel g)
         , Ord (EdgeLabel g)) => Ord (Context g) where
  compare (Context pr1 n1 l1 sc1) (Context pr2 n2 l2 sc2)
    = fromMaybe EQ . listToMaybe . filter (/= EQ)
      $ [ compare n1 n2
        , compare l1 l2
        , cmpSrt pr1 pr2
        , cmpSrt sc1 sc2
        ]
    where
      cmpSrt = compare `on` sort

-- -----------------------------------------------------------------------------
-- Edge

data Edge g = Edge { source :: Node g
                   , target :: Node g
                   }

instance (InductiveGraph g, Eq (Node g)) => Eq (Edge g) where
  (Edge s1 t1) == (Edge s2 t2) = s1 == s2 && t1 == t2

instance (InductiveGraph g, Ord (Node g)) => Ord (Edge g) where
  compare (Edge s1 t1) (Edge s2 t2)
    | s1 == s2  = compare t1 t2
    | otherwise = compare s1 s2

instance (InductiveGraph g, Show (Node g)) => Show (Edge g) where
  showsPrec d (Edge s t) = showParen (d > 10)
                           $ showString "Edge" . showChar ' '
                           . showsPrec 11 s . showChar ' '
                           . showsPrec 11 t

instance (InductiveGraph g, Read (Node g)) => Read (Edge g) where
  readPrec = parens . prec 10 . lift
             $ do _ <- string "Edge"
                  skipSpaces
                  s <- readP
                  skipSpaces
                  t <- readP
                  return $ Edge s t

-- -----------------------------------------------------------------------------
-- Aliases

type LNode g = (Node g, NodeLabel g)
type LEdge g = (Edge g, EdgeLabel g)

-- -----------------------------------------------------------------------------

{- |

  Minimal complete definition:

  * All three associated types: 'Node', 'NodeLabel' and 'EdgeLabel'.

  * Either 'empty' and 'insert' (preferred) or 'fromContexts'.

  * Either 'match' or 'context'.

 -}
class Eq (Node g) => InductiveGraph g where

    -- | The index type used to distinguish individual nodes within the graph.
    type Node g

    -- | The type of the labels attached to each node.  Use @()@ if
    --   the graph type doesn't support node labels.
    type NodeLabel g

    -- | The type of the labels attached to each edge.  Use @()@ if
    --   the graph type doesn't support edge labels.
    type EdgeLabel g

    -- | An empty graph.  Defaults to @'fromContexts' []@.
    empty :: g
    empty = fromContexts []

    -- | Insert a new 'Context' into the graph.  If the node in the
    --   context is already present in the graph, then this should not
    --   change the graph.  See 'insertWith' for the option to merge
    --   'Context's if that node is already present in the graph.
    --
    --   Defaults to @insert c = 'fromContexts . (:) c . 'toContexts'@.
    insert :: Context g -> g -> g
    insert c = fromContexts . (:) c . toContexts

    -- | Delete the specified node and all incident edges.
    deleteNode :: Node g -> g -> g

    -- | A decomposing list of 'Context's, such that
    --   @'map' 'fromContexts' . 'tails' $ toContexts g$
    --   will result in valid sub-graphs of @g@.
    toContexts   :: g -> [Context g]
    toContexts g = unfoldr matchIt (g, nodes g)
      where
        -- Caches the available nodes to avoid grabbing a new one each time.
        matchIt (_,  [])     = Nothing
        matchIt (g', (n:ns)) = fmap (second (flip (,) ns)) $ match g n

    -- | Take a decomposing list of 'Context's and use them to build a
    --   graph.  Defaults to @'foldr' 'insert' 'empty'@.
    fromContexts :: [Context g] -> g
    fromContexts = foldr insert empty

    -- | Determine if a graph is @(==) empty@; defaults to
    --   @'null' . 'toContexts'@.
    isEmpty :: g -> Bool
    isEmpty = null . toContexts

    -- | Build a graph out of a list of labelled nodes and edges.
    --   Defaults to
    --   @'foldr' 'insertEdge' . 'foldr' 'insertNode' 'empty'@
    mkGraph       :: [LNode g] -> [LEdge g]-> g
    mkGraph ns es = foldr insertEdge (foldr insertNode empty ns) es

    -- | An extended version of 'insert' allows you to specify what to
    --   do if the node in the 'Context' is already present or not.
    --   The function takes in the 'Context' already in the graph and
    --   then the new 'Context'.  Defaults to:
    --
    --   > insertWith f c g = 'insert' ('maybe' c ('flip' f c)
    --   >                              . 'context' g $ 'node' c)
    --   >                             g
    insertWith       :: (Context g -> Context g -> Context g)
                        -> Context g -> g -> g
    insertWith f c g = insert (maybe c (flip f c) . context g $ node c) g

    -- | Insert the specified 'LNode' into the graph.  Defaults to
    --   @insertNode (n,l) = 'insert' ('Context' [] n l [])@
    insertNode       :: LNode g -> g -> g
    insertNode (n,l) = insert (Context [] n l [])

    -- | Insert the specified 'LEdge' into the graph.  Defaults to
    --
    --   > insertEdge (Edge src tgt, el) = adjust nc src
    --   >   where
    --   >     nc ctxt = ctxt { successors = (tgt, el) : successors ctxt }
    insertEdge                    :: LEdge g -> g -> g
    insertEdge (Edge src tgt, el) = adjust nc src
      where
        nc ctxt = ctxt { successors = (tgt, el) : successors ctxt }

    -- | Remove the specified 'Edge' from the graph.  Defaults to
    --
    --   > deleteEdge e = 'adjust' nc ('source' e)
    --   >   where
    --   >     nc c = c { 'successors' = 'filter' ((/=) ('target' e) . 'fst')
    --   >                             $ 'successors' c }
    deleteEdge   :: Edge g -> g -> g
    deleteEdge e = adjust nc (source e)
      where
        nc c = c { successors = filter ((/=) (target e) . fst) $ successors c }

    -- | Attempt to decompose a graph into the 'Context' for the given
    --   node and the rest of the graph.  Defaults to:
    --
    --   > match g n = fmap (flip (,) $ deleteNode n g) $ context g n
    match     :: g -> Node g -> Maybe (Context g,g)
    match g n = fmap (flip (,) $ deleteNode n g) $ context g n

    -- | Determine if the given node is currently in the graph.  Defaults to:
    --   @hasNode g n = 'any' ((n==) . 'node') $ 'toContexts' g@
    hasNode     :: g -> Node g -> Bool
    hasNode g n = any ((n==) . node) $ toContexts g

    -- | Determine if the given node is currently in the graph.  Defaults to:
    --
    --   > hasEdge g (Edge s t) = maybe False hasEg $ context g s
    --   >   where
    --   >     hasEg = any (t==) . map fst . successors
    hasEdge :: g -> Edge g -> Bool
    hasEdge g (Edge s t) = maybe False hasEg $ context g s
      where
        hasEg = any (t==) . map fst . successors

    -- | Find the 'Context' corresponding to the provided node.  Defaults to:
    --
    --   > context = 'fmap' 'fst' '...' 'match'
    context :: g -> Node g -> Maybe (Context g)
    context = fmap fst ... match

    -- | Do we really need this?
    context' :: g -> Node g -> Context g
    context' g v = fromMaybe (error ("Exception, node does not exist: ")) $ context g v

    -- | Returns all nodes in the graph.  Defaults to
    --   @'map' 'fst' . 'labNodes'@
    nodes :: g -> [Node g]
    nodes = map fst . labNodes

    -- | Returns all 'Edge's in the graph.  Defaults to
    --   @'map' 'fst' . 'labEdges'@.
    edges :: g -> [Edge g]
    edges = map fst . labEdges

    labNodes :: g -> [LNode g]
    labNodes = map (liftM2 (,) node label) . toContexts

    labEdges :: g -> [LEdge g]
    labEdges = concatMap mkEdges . toContexts
      where
        mkEdges (Context ei n _ oe) = map (first (Edge n)) ei
                                      ++ map (first (flip Edge n)) oe

    lookupNode :: g -> Node g -> NodeLabel g
    lookupNode = fromJust ... lookupNodeM

    lookupEdge :: g -> Edge g -> [EdgeLabel g]
    lookupEdge = fromJust ... lookupEdgeM

    lookupNodeM :: g -> Node g -> Maybe (NodeLabel g)
    lookupNodeM = fmap label ... context

    -- Should we just make this [] rather than Maybe [] ?
    lookupEdgeM :: g -> Edge g -> Maybe [EdgeLabel g]
    lookupEdgeM g (Edge s t) = fmap getLabels $ context g s
      where
        getLabels = map snd . filter ((t==) . fst) . successors

    deg,degIn,degOut   :: g -> Node g -> Int
    deg g n = (degIn g n) + (degOut g n)
    degIn = length...predecessors...fromJust...context
    degOut = length...successors...fromJust...context

    -- | The number of edges in the graph.  Defaults to @'length'
    --   . 'edges'@.
    size :: g -> Int
    size = length . edges

    -- | The number of nodes in the graph.  Defaults to @'length'
    --   . 'nodes'@.
    order :: g -> Int
    order = length . toContexts

    -- | Apply a function to the 'Context' corresponding to the
    --   supplied node.  Defaults to:
    --
    --   > adjust f n g = 'maybe' g ('uncurry' ('insert' . f)) $ 'match' g n
    adjust       :: (Context g -> Context g) -> Node g -> g -> g
    adjust f n g = maybe g (uncurry (insert . f)) $ match g n

    --folds,maps,filters use the ordering of toContexts

    gfoldr     :: (Context g -> b -> b) -> b -> g -> b
    gfoldr f i = foldr f i . toContexts

    gfoldl'     :: (b -> Context g -> b) -> b -> g -> b
    gfoldl' f i = foldl' f i . toContexts

    gfilter   :: (Context g -> Bool) -> g -> g
    gfilter f = fromContexts . filter f . toContexts

-- | To be able to apply mapping functions on the labels, we have to restrict
--   the graph types back to those with kind @* -> * -> *@.  Note that the
--   type-checker can't currently deal with super-class constraints, so there
--   is as yet no way to force at the type-level that @MappableGraph g n e@
--   has @NodeLabel (g n e) ~ n@ and @EdgeLabel (g n e) ~ e@.
class (InductiveGraph (g n e)) => MappableGraph g n e where

    gmap   :: (InductiveGraph (g n' e')) => (Context (g n e) -> Context (g n' e'))
              -> g n e -> g n' e'
    gmap f = fromContexts . map f . toContexts

    nmap   :: ( InductiveGraph (g n' e)
              , Node (g n e) ~ Node (g n' e)
              , EdgeLabel (g n e) ~ EdgeLabel (g n' e))
              => (NodeLabel (g n e) -> NodeLabel (g n' e))
                 -> g n e -> g n' e
    nmap f = gmap f'
      where
        f' (Context ei n l eo) = Context ei n (f l) eo

    emap   :: ( InductiveGraph (g n e')
              , Node (g n e) ~ Node (g n e')
              , NodeLabel (g n e) ~ NodeLabel (g n e'))
              => (EdgeLabel (g n e) -> EdgeLabel (g n e'))
                 -> g n e -> g n e'
    emap f = gmap f'
        where
          f' (Context ei n l eo) = Context (applyF ei) n l (applyF eo)
          applyF = map (second f)

(...) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(...) = (.) . (.)
infixr 9 ...

showsPrecGraph     :: (InductiveGraph g, Show (Context g)) => Int -> g -> ShowS
showsPrecGraph d g = showParen (d > 10)
                     $ showString "fromContexts "
                     . showsPrec 11 (toContexts g)

readPrecGraph :: (InductiveGraph g, Read (Context g)) => ReadPrec g
readPrecGraph = parens . prec 10
                $ do Ident "fromContexts" <- lexP
                     cs <- readPrec
                     return (fromContexts cs)

graphEquality       :: ( InductiveGraph g, Ord (Node g), Eq (NodeLabel g)
                       , Ord (EdgeLabel g)) => g -> g -> Bool
graphEquality g1 g2 = eqOn sortedNodes && eqOn sortedEdges
  where
    eqOn f = ((==) `on` f) g1 g2
    sortedNodes = sortBy (compare `on` fst) . labNodes
    sortedEdges = sort . labEdges

topologyEquality       :: (InductiveGraph g, Ord (Node g)) => g -> g -> Bool
topologyEquality g1 g2 = eqOn (sort . nodes) && eqOn (countSort . edges)
  where
    eqOn f = ((==) `on` f) g1 g2
    countSort = map (\ es -> (head es, length es)) . group . sort

--Conversion Code:
{-
unconv :: ([(b,Int)],Int,a,[(b,Int)]) -> Context (g a b)
unconv (ei,n,l,eo)=Context (switch ei) n l (switch eo)
    where switch = map (\(a,b)->(b,a))

conv :: Context (g a b) -> ([(b,Int)],Int,a,[(b,Int)])
conv (Context ei n l eo)=(switch ei,n,l,switch eo)
    where switch = map (\(a,b)->(b,a))

instance (Graph (g a b)) => G.Graph g where
    empty=empty
    isEmpty=isEmpty
    match n gr = maybe (Nothing,gr) (\(c,g)->(Just $ conv c,g)) (match gr n)
    mkGraph ns es = mkGraph ns $ map (\(a,b,c)->(Edge a b,c)) es
    labNodes = labNodes

instance (Node (g a b)~Int,Graph (g a b)) => G.DynGraph g where
    (&) = insert.unconv

instance (G.DynGraph g)=> InductiveGraph (g a b) where
    type Node (g a b) = Int
    type NodeLabel (g a b) = a
    type EdgeLabel (g a b) = b

    empty = G.empty
    deleteNode =G.delNode
    toContexts gr | G.isEmpty gr    = []
                 | otherwise        =  unconv c : toContexts r where
                                            (c,r)=G.matchAny gr

    insert = (G.&).conv where

instance (G.DynGraph g) => Graph (g a b)
-}