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 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) (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
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
branch ∷ [a] → Pattern n a
branch xs = Pattern $ \m → lift [([],x) | x ← xs]
visit ∷ Node → Pattern n ()
visit n = Pattern $ \m → lift [([n],())]
branchNodes ∷ [Node] → Pattern n Node
branchNodes ns = do
n ← branch ns
visit n
return n
probe ∷ Pattern n a → Pattern n Bool
probe p = liftM (not . null) (matches p)
matches ∷ Pattern n a → Pattern n [Match]
matches p = Pattern $ \m → do
lma ← liftM (runReaderT $ pattern p m) ask
let matches = map fst lma
return (nub $ concat matches, matches)
(<|>) ∷ Pattern n a → Pattern n a → Pattern n a
(<|>) = mplus
anyOf ∷ [Pattern n a] → Pattern n a
anyOf [] = fail "anyOf []"
anyOf xs = foldr1 (<|>) xs
require ∷ Monad m ⇒ Bool → m ()
require p = unless p $ fail "requirement not met"
requireFailure ∷ Pattern n a → Pattern n ()
requireFailure p = do require . not =<< probe p
requireM ∷ Monad m ⇒ m Bool → m ()
requireM p = p >>= require
liftReader ∷ Reader (Graph n) a → Pattern n a
liftReader r = Pattern $ \m → do
x ← liftM (runReader r) ask
return ([],x)
node ∷ View v n ⇒ Pattern n v
node = liftReader . inspectNode =<< branchNodes =<< liftReader readNodeList
previous ∷ Pattern n Node
previous = liftM head history
edge ∷ Pattern n Edge
edge = branch =<< liftReader readEdgeList
nodeAt ∷ View v n ⇒ Edge → Pattern n v
nodeAt e = liftReader . inspectNode =<< branchNodes =<< liftReader (attachedNodes e)
edgeOf ∷ View [Port] n ⇒ Node → Pattern n Edge
edgeOf n = branch =<< liftReader (attachedEdges n)
neighbour ∷ (View [Port] n, View v n) ⇒ Node → Pattern n v
neighbour n = liftReader . inspectNode =<< branchNodes =<< liftReader (neighbours n)
relative ∷ (View [Port] n, View v n) ⇒ Node → Pattern n v
relative n = liftReader . inspectNode =<< branchNodes =<< liftReader (relatives n)
adverse ∷ (View [Port] n, View v n) ⇒ Port → Node → Pattern n v
adverse p n = liftReader . inspectNode =<< branchNodes =<< liftReader (adverseNodes n p)
amnesia ∷ Pattern n a → Pattern n a
amnesia p = Pattern $ \m → do
(m',x) ← pattern p m
return ([],x)
history ∷ Pattern n Match
history = Pattern $ \m → return ([],m)
nextFresh ∷ Pattern n a → Pattern n a
nextFresh = restrictOverlap $ \hist (n:ns) → not (n ∈ hist)
nextIs ∷ Node → Pattern n a → Pattern n a
nextIs next = restrictOverlap $ \hist (n:ns) → n ≡ next
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)
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