module GraphRewriting.Pattern (module GraphRewriting.Pattern, PatternT, Pattern, Match, (<|>)) where
import Prelude.Unicode
import GraphRewriting.Pattern.Internal
import GraphRewriting.Graph.Read
import Control.Monad.Reader
import Control.Monad.List
import Control.Monad.Identity
import qualified Data.Set as Set (empty, insert, member)
import Control.Applicative
import Data.Functor
import Data.Monoid
type Pattern n = PatternT n Identity
instance Monad m ⇒ Monad (PatternT n m) where
return x = PatternT $ \h → return ([],x)
p >>= f = PatternT $ \h → do
(m1,x) ← patternT p h
(m2,y) ← patternT (f x) (reverse m1 ⧺ h)
return (m1 ⧺ m2, y)
fail str = PatternT $ \h → lift (fail str)
instance MonadTrans (PatternT n) where
lift m = PatternT $ \h → do
x ← lift $ lift m
return ([],x)
instance Monad m ⇒ Functor (PatternT n m) where fmap = liftM
instance Monad m ⇒ Applicative (PatternT n m) where
pure = return
f <*> x = do
f' ← f
f' <$> x
instance Monad m ⇒ Alternative (PatternT n m) where
empty = mzero
(<|>) = mplus
instance Monad m ⇒ Monoid (PatternT n m a) where
mempty = mzero
mappend = mplus
instance Monad m ⇒ MonadPlus (PatternT n m) where
mzero = fail "empty result list"
mplus p q = PatternT $ \h → do
g ← ask
lift $ runReaderT (patternT p h) g `mplus` runReaderT (patternT q h) g
runPatternT ∷ PatternT n m a → Graph n → m [(Match,a)]
runPatternT = runPatternT' []
runPattern ∷ Pattern n a → Graph n → [(Match,a)]
runPattern p = runIdentity . runPatternT 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 ∷ Monad m ⇒ [a] → PatternT n m a
branch xs = PatternT $ \h → lift $ ListT $ return [([],x) | x ← xs]
branchNodes ∷ Monad m ⇒ [Node] → PatternT n m Node
branchNodes ns = do
n ← branch ns
visit n
return n
probe ∷ Monad m ⇒ PatternT n m a → PatternT n m Bool
probe p = not . null <$> matches p
matches ∷ Monad m ⇒ PatternT n m a → PatternT n m [Match]
matches p = map fst <$> match p
match ∷ Monad m ⇒ PatternT n m a → PatternT n m [(Match, a)]
match p = PatternT $ \h → do
matches ← liftM (runReaderT $ patternT p h) ask
let roundup = liftM (\xs → [(concatMap fst xs, xs)]) (runListT matches)
lift $ ListT roundup
anyOf ∷ Alternative f ⇒ [f a] → f a
anyOf = foldr (<|>) empty
require ∷ Monad m ⇒ Bool → m ()
require p = unless p $ fail "requirement not met"
requireFailure ∷ Monad m ⇒ PatternT n m a → PatternT n m ()
requireFailure p = require . not =<< probe p
requireM ∷ Monad m ⇒ m Bool → m ()
requireM p = p >>= require
liftReader ∷ Monad m ⇒ Reader (Graph n) a → PatternT n m a
liftReader r = PatternT $ \h → do
x ← runReader r `liftM` ask
return ([],x)
node ∷ (Monad m, View v n) ⇒ PatternT n m v
node = liftReader . inspectNode =<< branchNodes =<< liftReader readNodeList
nodeAt ∷ (Monad m, View v n) ⇒ Node → PatternT n m v
nodeAt ref = do
n ← liftReader $ inspectNode ref
PatternT $ \h → lift $ return ([ref],n)
edge ∷ Monad m ⇒ PatternT n m Edge
edge = branch =<< liftReader readEdgeList
nodeWith ∷ (Monad m, View v n) ⇒ Edge → PatternT n m v
nodeWith e = liftReader . inspectNode =<< branchNodes =<< liftReader (attachedNodes e)
edgeOf ∷ (Monad m, View [Port] n) ⇒ Node → PatternT n m Edge
edgeOf n = branch =<< liftReader (attachedEdges n)
neighbour ∷ Monad m => (View [Port] n, View v n) ⇒ Node → PatternT n m v
neighbour n = liftReader . inspectNode =<< branchNodes =<< liftReader (neighbours n)
relative ∷ (Monad m, View [Port] n, View v n) ⇒ Node → PatternT n m v
relative n = liftReader . inspectNode =<< branchNodes =<< liftReader (relatives n)
adverse ∷ (Monad m, View [Port] n, View v n) ⇒ Port → Node → PatternT n m v
adverse p n = liftReader . inspectNode =<< branchNodes =<< liftReader (adverseNodes n p)
visit ∷ Monad m ⇒ Node → PatternT n m ()
visit n = do
exists ← liftReader $ existNode n
if exists
then PatternT $ \h → lift $ return ([n],())
else fail $ "visit: node with ID " ⧺ show n ⧺ " does not exist"
amnesia ∷ Monad m ⇒ PatternT n m a → PatternT n m a
amnesia p = PatternT $ \h → do
(h',x) ← patternT p h
return ([],x)
history ∷ Monad m ⇒ PatternT n m Match
history = PatternT $ \h → return ([],h)
previous ∷ Monad m ⇒ PatternT n m Node
previous = head <$> history
nextFresh ∷ Monad m ⇒ PatternT n m a → PatternT n m a
nextFresh = restrictOverlap $ \past future → null future ∨ not (head future ∈ past)
nextIs ∷ Monad m ⇒ Node → PatternT n m a → PatternT n m a
nextIs next = restrictOverlap $ \past future → not (null future) ∧ head future ≡ next
restrictOverlap ∷ Monad m ⇒ (Match → Match → Bool) → PatternT n m a → PatternT n m a
restrictOverlap c p = PatternT $ \h → do
(h',x) ← patternT p h
require (c h h')
return (h',x)
linear ∷ Monad m ⇒ PatternT n m a → PatternT n m 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