{-# LANGUAGE UnicodeSyntax, FlexibleContexts #-}
-- | Patterns allow monadic scrutinisation of the graph (modifications are not possible) while keeping track of matched nodes (history). A 'Pattern' is interpreted by 'runPattern' that returns a result for each position in the graph where the pattern matches. It is allowed to 'fail' inside the 'Pattern' monad, indicating that the pattern does not match, which corresponds to conditional rewriting.
module GraphRewriting.Pattern (module GraphRewriting.Pattern, Pattern, Match) where

import Prelude.Unicode
import GraphRewriting.Pattern.Internal
import GraphRewriting.Graph.Read
import Control.Monad.Reader
import Data.List (nub)
import Data.Set as Set (empty, insert, member)


--instance Functor (Pattern n) where

instance Monad (Pattern n) where
	return x = Pattern $ \m → return ([],x)
	p >>= f = Pattern $ \m → do
		(m1,x) ← pattern p m
		(m2,y) ← pattern (f x) (reverse m1 ⧺ m)
		return (m1 ⧺ m2, y)
	fail str = Pattern $ \m → lift []

instance MonadPlus (Pattern n) where
	mzero = fail "empty result list"
	mplus p q = Pattern $ \m → do
		g ← ask
		lift $ runReaderT (pattern p m) g ⧺ runReaderT (pattern q m) g

-- | Apply a pattern on a graph returning a result for each matching position in the graph together with the matched nodes.
runPattern ∷ Pattern n a → Graph n → [(Match,a)]
runPattern p = runReaderT $ pattern p []

evalPattern ∷ Pattern n a → Graph n → [a]
evalPattern p = map snd . runPattern p

execPattern ∷ Pattern n a → Graph n → [Match]
execPattern p = map fst . runPattern p

-- combinators ---------------------------------------------------------------

-- | Something like an implicit monadic map
branch ∷ [a] → Pattern n a
branch xs = Pattern $ \m → lift [([],x) | x ← xs]

visit ∷ Node → Pattern n ()
visit n = Pattern $ \m → lift [([n],())]

-- | 'branch' on each node, visit it, and return it
branchNodes ∷ [Node] → Pattern n Node
branchNodes ns = do
	n ← branch ns
	visit n
	return n

-- | Probe whether a pattern matches somewhere on the graph. You might want to combine this with 'amnesia'.
probe ∷ Pattern n a → Pattern n Bool
probe p = liftM (not . null) (matches p)

-- | probe a pattern returning the matches it has on the graph. You might want to combine this with 'amnesia'.
matches ∷ Pattern n a → Pattern n [Match]
matches p = map fst `liftM` match p

-- | probe a pattern returning the matches it has on the graph. You might want to combine this with 'amnesia'.
match ∷ Pattern n a → Pattern n [(Match, a)]
match p = Pattern $ \m → do
	lma ← liftM (runReaderT $ pattern p m) ask
	return (nub $ concat $ map fst lma, lma)

-- | choice
(<|>) ∷ Pattern n a → Pattern n a → Pattern n a
(<|>) = mplus

-- | choice over a list of patterns
anyOf ∷ [Pattern n a] → Pattern n a
anyOf [] = fail "anyOf []"
anyOf xs = foldr1 (<|>) xs

-- | conditional rewriting: 'fail' when predicate is not met
require ∷ Monad m ⇒ Bool → m ()
require p = unless p $ fail "requirement not met"

-- | 'fail' if given pattern succeeds, succeed if it fails.
requireFailure ∷ Pattern n a → Pattern n ()
requireFailure p = require . not =<< probe p

-- | 'fail' when monadic predicate is not met
requireM ∷ Monad m ⇒ m Bool → m ()
requireM p = p >>= require

-- some base patterns --------------------------------------------------------

-- | Lift a scrutinisation from 'Reader' to 'Pattern' leaving the history unchanged.
liftReader ∷ Reader (Graph n) a → Pattern n a
liftReader r = Pattern $ \m → do
	x ← liftM (runReader r) ask
	return ([],x)

-- | any node anywhere in the graph
node ∷ View v n ⇒ Pattern n v
node = liftReader . inspectNode =<< branchNodes =<< liftReader readNodeList

-- | a reference to the lastly matched node
previous ∷ Pattern n Node
previous = liftM head history

-- | any edge anywhere in the graph
edge ∷ Pattern n Edge
edge = branch =<< liftReader readEdgeList

-- | node that is connected to given edge
nodeAt ∷ View v n ⇒ Edge → Pattern n v
nodeAt e = liftReader . inspectNode =<< branchNodes =<< liftReader (attachedNodes e)

-- | edge that is attached to given node
edgeOf ∷ View [Port] n ⇒ Node → Pattern n Edge
edgeOf n = branch =<< liftReader (attachedEdges n)

-- | node that is connected to the given node, but not that node itself
neighbour ∷ (View [Port] n, View v n) ⇒ Node → Pattern n v
neighbour n = liftReader . inspectNode =<< branchNodes =<< liftReader (neighbours n)

-- | node that is connected to the given node, permitting the node itself
relative ∷ (View [Port] n, View v n) ⇒ Node → Pattern n v
relative n = liftReader . inspectNode =<< branchNodes =<< liftReader (relatives n)

-- | nodes connected to given port of the specified node, not including the node itself
adverse ∷ (View [Port] n, View v n) ⇒ Port → Node → Pattern n v
adverse p n = liftReader . inspectNode =<< branchNodes =<< liftReader (adverseNodes n p)

-- controlling history and future --------------------------------------------

-- | Do not remember any of the nodes matched by the supplied pattern
amnesia ∷ Pattern n a → Pattern n a
amnesia p = Pattern $ \m → do
	(m',x) ← pattern p m
	return ([],x)

-- | list of nodes matched until now with the most recent node in head position
history ∷ Pattern n Match
history = Pattern $ \m → return ([],m)

-- | only match nodes in the next pattern that have not been matched before
nextFresh ∷ Pattern n a → Pattern n a
nextFresh = restrictOverlap $ \past future → null future ∨ not (head future ∈ past)

-- | only accept the given node in the next match
nextIs ∷ Node → Pattern n a → Pattern n a
nextIs next = restrictOverlap $ \past future → not (null future) ∧ head future ≡ next

-- | First match is the history with the most recently matched node in head position. Second match is the future with the next matched node in head position.
restrictOverlap ∷ (Match → Match → Bool) → Pattern n a → Pattern n a
restrictOverlap c p = Pattern $ \m → do
	(m',x) ← pattern p m
	require (c m m')
	return (m',x)

-- | Nodes in the future may not be matched more than once.
linear ∷ Pattern n a → Pattern n a
linear = restrictOverlap $ \hist future → isLinear Set.empty future where
	isLinear left [] = True
	isLinear left (r:rs) = not (r `Set.member` left) ∧ isLinear (r `Set.insert` left) rs