graph-rewriting 0.6.0 → 0.7.0

raw patch · 12 files changed

+266/−171 lines, 12 filesdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: mtl

API changes (from Hackage documentation)

Files

• Data/View.hs +18/−0
• GraphRewriting/Graph.hs +3/−3
• GraphRewriting/Graph/Internal.hs +19/−9
• GraphRewriting/Graph/Read.hs +13/−10
• GraphRewriting/Graph/Write.hs +10/−12
• GraphRewriting/Graph/Write/Unsafe.hs +10/−15
• GraphRewriting/Pattern.hs +108/−67
• GraphRewriting/Pattern/InteractionNet.hs +11/−12
• GraphRewriting/Pattern/Internal.hs +6/−1
• GraphRewriting/Rule.hs +56/−36
• GraphRewriting/Rule/Internal.hs +6/−1
• graph-rewriting.cabal +6/−5

@@ -2,6 +2,12 @@ -- | The multi-parameter type-class 'View' provides an abstraction @View v n@ of a type @n@ that exposes a value of type @v@. It allows both to 'inspect' and 'update' the value, while hiding the internal structure of the value type (@n@). module Data.View where +-- TODO: Better?+--class Has v n where+--	inspect ∷ n → v+--+--class Has v n ⇒ View v n where+ -- | Minimal complete definition: @inspect@ and one of {@update@, @adjust@} class View v n where 	inspect ∷ n → v@@ -14,6 +20,18 @@ instance View n n where 	inspect = id 	update = const++instance (View v1 n, View v2 n) ⇒ View (v1,v2) n where+	inspect n = (inspect n, inspect n)+	update (v1,v2) = update v1 . update v2++instance (View v1 n, View v2 n, View v3 n) ⇒ View (v1,v2,v3) n where+	inspect n = (inspect n, inspect n, inspect n)+	update (v1,v2,v3) = update v1 . update v2 . update v3++instance (View v1 n, View v2 n, View v3 n, View v4 n) ⇒ View (v1,v2,v3,v4) n where+	inspect n = (inspect n, inspect n, inspect n, inspect n)+	update (v1,v2,v3,v4) = update v1 . update v2 . update v3 . update v4  -- | convenience function that can be used to access record fields of the exposed type examine ∷ View v n ⇒ (v → field) → n → field

@@ -33,10 +33,10 @@  -- | apply a monadic graph modification to a graph runGraph ∷ Rewrite n a → Graph n → (a, Graph n)-runGraph = runState+runGraph = runState . rewrite  evalGraph ∷ Rewrite n a → Graph n → a-evalGraph = evalState+evalGraph = evalState . rewrite  execGraph ∷ Rewrite n a → Graph n → Graph n-execGraph = execState+execGraph = execState . rewrite

@@ -1,33 +1,35 @@-{-# LANGUAGE UnicodeSyntax, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# LANGUAGE UnicodeSyntax, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving #-} module GraphRewriting.Graph.Internal where +import Prelude.Unicode import Control.Monad.State import Data.IntMap as Map (IntMap, lookup) import Data.IntSet (IntSet)-import Control.Monad.Reader.Class+import Control.Monad.Reader   -- | Hypergraph that holds nodes of type @n@. Nodes can be referenced by type 'Node', edges by type 'Edge', see "GraphRewriting.Graph.Read" and "GraphRewriting.Graph.Write" data Graph n = Graph {nodeMap ∷ IntMap n, edgeMap ∷ IntMap IntSet, nextKey ∷ Int} -type Rewrite n = State (Graph n)+newtype Rewrite n a = Rewrite {rewrite ∷ State (Graph n) a}+	deriving (MonadState (Graph n), Monad, Functor, MonadFix) -newtype Node = Node {nKey ∷ Int} deriving (Eq, Ord)-newtype Port = Edge {eKey ∷ Int} deriving (Eq, Ord)+newtype Node = Node {nKey ∷ Int} deriving (Eq, Ord) -- TODO: change this into Integer to avert overflow+newtype Port = Edge {eKey ∷ Int} deriving (Eq, Ord) -- TODO: change this into Integer to avert overflow type Edge = Port -- ^ a hyperedge really, connecting a non-empty subset of the graph's nodes (see 'attachedNodes')  instance Show Node where show = show . nKey instance Show Edge where show = show . eKey -instance MonadReader s (State s) where-	ask = get-	local mod reader = liftM (evalState reader . mod) ask+instance MonadReader (Graph n) (Rewrite n) where+	ask = Rewrite get+	local f m = Rewrite $ liftM (evalState (rewrite m) . f) get  readRef ∷ Monad m ⇒ Int → IntMap a → m a readRef key = maybe (fail "readRef: referentiation failed") return . Map.lookup key  readEdge ∷ MonadReader (Graph n) r ⇒ Edge → r IntSet-readEdge (Edge p) = readRef p =<< asks edgeMap+readEdge (Edge e) = maybe (fail $ "readEdge: edge with ID " ⧺ show e ⧺ " does not exist") return . readRef e =<< asks edgeMap  modifyNodeMap ∷ (IntMap n → IntMap n) → Rewrite n () modifyNodeMap f = modify $ \g → g {nodeMap = f $ nodeMap g}@@ -35,8 +37,16 @@ modifyEdgeMap ∷ (IntMap IntSet → IntMap IntSet) → Rewrite n () modifyEdgeMap f = modify $ \g → g {edgeMap = f $ edgeMap g} +-- | allocate and reserve a new ref newRef ∷ Rewrite n Int newRef = do 	i ← gets nextKey 	modify $ \g → g {nextKey = i + 1} 	return i++-- | Hand out an infinite number of fresh refs, without reserving them (obviously).+freeRefs ∷ MonadReader (Graph n) r ⇒ r [Int]+freeRefs = enumFrom `liftM` asks nextKey++reserveRefs ∷ [Int] → Rewrite n ()+reserveRefs refs = modify $ \g → g {nextKey = maximum refs}

@@ -2,7 +2,9 @@  -- | Enquiry of the graph structure. Note: In this module the term "node" is often used synonymously to "node reference" and "node value". The two can easily distinguished by their type: the former has type 'Node' the latter usually 'n'. module GraphRewriting.Graph.Read-	(module GraphRewriting.Graph.Read, module GraphRewriting.Graph.Types, module Data.View)+	(module Data.View,+	 module GraphRewriting.Graph.Types,+	 module GraphRewriting.Graph.Read) where  import Prelude.Unicode@@ -18,11 +20,14 @@ type WithGraph n = Reader (Graph n)  -- | This forces the use of the 'Reader' monad. Wrapping a sequence of monadic read-only operations (such as those defined below) into a read-only block can save much overhead e.g. in the state monad.-readOnly ∷ WithGraph n a → Rewrite n a+readOnly ∷ MonadReader (Graph n) m ⇒ Reader (Graph n) a → m a readOnly r = liftM (runReader r) ask +existNode ∷ MonadReader (Graph n) m ⇒ Node → m Bool+existNode (Node n) = liftM (Map.member n) (asks nodeMap)+ readNode ∷ MonadReader (Graph n) m ⇒ Node → m n-readNode (Node n) = readRef n =<< asks nodeMap+readNode (Node n) = maybe (fail $ "readNode: node with ID " ⧺ show n ⧺ " does not exist") return . readRef n =<< asks nodeMap  -- | a wrapper to 'inspect' the given node inspectNode ∷ (View v n, MonadReader (Graph n) m) ⇒ Node → m v@@ -54,13 +59,13 @@  -- | list of nodes that are connected to the given node, not including the node itself neighbours ∷ (View [Port] n, MonadReader (Graph n) m) ⇒ Node → m [Node]-neighbours n@(Node i) = do+neighbours n = do 	is ← liftM Set.unions $ mapM readEdge =<< inspectNode n-	return $ map Node $ Set.elems $ Set.delete i is+	return $ map Node $ Set.elems $ Set.delete (nKey n) is  -- | list of nodes that are connected to the given node, including the node itself relatives ∷ (View [Port] n, MonadReader (Graph n) m) ⇒ Node → m [Node]-relatives n@(Node i) = do+relatives n = do 	is ← liftM Set.unions $ mapM readEdge =<< inspectNode n 	return $ map Node $ Set.elems is @@ -73,10 +78,8 @@ connected n1 n2 = liftM (n2 ∈) (relatives n2)  -- | whether the given ports features a dangling edge-free ∷ (View [Port] n, MonadReader (Graph n) m) ⇒ Port → m Bool-free p = do-	c ← edgeCardinality p-	return (c ≡ 1)+dangling ∷ (View [Port] n, MonadReader (Graph n) m) ⇒ Port → m Bool+dangling = liftM (≡ 1) . edgeCardinality  -- | Map node-relative enquiry over the nodes of the graph. withNodes ∷ MonadReader (Graph n) m ⇒ (Node → m a) → m [a]

@@ -17,6 +17,7 @@ import GraphRewriting.Graph.Read import qualified GraphRewriting.Graph.Write.Unsafe as Unsafe import Control.Monad+import Control.Applicative import Data.Maybe (catMaybes) import Data.View import Data.List@@ -30,10 +31,10 @@  -- | modify the node value modifyNode ∷ View [Port] n ⇒ Node → (n → n) → Rewrite n ()-modifyNode n@(Node i) f = do-	esBefore ← liftM nub (inspectNode n)+modifyNode n f = do+	esBefore ← nub <$> inspectNode n 	Unsafe.modifyNode n f-	esAfter ← liftM nub (inspectNode n)+	esAfter ← nub <$> inspectNode n 	Unsafe.register n (esAfter \\ esBefore) 	Unsafe.unregister n (esBefore \\ esAfter) @@ -46,9 +47,7 @@ adjustNode n = modifyNode n . adjust  adjustNodeM ∷ (View [Port] n, View v n) ⇒ Node → (v → Rewrite n v) → Rewrite n ()-adjustNodeM n f = do-	v' ← f =<< inspectNode n-	updateNode n v'+adjustNodeM n f = updateNode n =<< f =<< inspectNode n  -- | add a new node with value @n@ to the graph newNode ∷ View [Port] n ⇒ n → Rewrite n Node@@ -65,25 +64,24 @@  -- | Create a new (unconnected) edge. It is expected that the created edge is connected to a port sooner or later. Otherwise the graph will invove unconnected edges. newEdge ∷ Rewrite n Edge-newEdge = liftM Edge newRef+newEdge = Edge <$> newRef  -- | remove node from the graph deleteNode ∷ View [Port] n ⇒ Node → Rewrite n () deleteNode n = do-	es ← liftM nub (inspectNode n)-	Unsafe.unregister n es+	Unsafe.unregister n =<< nub <$> inspectNode n 	modifyNodeMap (Map.delete $ nKey n)  -- | Disconnect ports connected to the given edge by assigning a new (dangling) edge to each of the ports. Then the edge is deleted. deleteEdge ∷ View [Port] n ⇒ Edge → Rewrite n [Edge] deleteEdge e = do-	es ← liftM concat $ mapM disconnectPorts =<< attachedNodes e+	es ← fmap concat $ mapM disconnectPorts =<< attachedNodes e 	modifyEdgeMap $ Map.delete (eKey e) 	return es 	where 	disconnectPorts n = do 		ports ← inspectNode n-		(freshEdges, ports') ← liftM unzip $ mapM substPort ports+		(freshEdges, ports') ← unzip <$> mapM substPort ports 		updateNode n ports' 		return $ catMaybes freshEdges 	substPort p = if p ≡ e@@ -96,7 +94,7 @@ mergeEdges ∷ View [Port] n ⇒ Edge → Edge → Rewrite n () mergeEdges e1 e2 = when (e1 ≢ e2) $ do 		ns ← attachedNodes e2-		mapM_ (Unsafe.adjustNode $ map replacePort) ns+		sequence_ [Unsafe.modifyNode n (adjust $ map replacePort) | n ← ns] 		modifyEdgeMap $ Map.adjust (Set.union $ Set.fromList $ map nKey ns) (eKey e1) 		deleteEdge e2 >> return () 	where replacePort p = if p ≡ e2 then e1 else p

@@ -3,7 +3,7 @@  -- (TODO: use Functor/Traversable/Foldable instead of lists?) module GraphRewriting.Graph.Write.Unsafe-	(module GraphRewriting.Graph.Write.Unsafe, module GraphRewriting.Graph.Types, module Data.View)+	(module GraphRewriting.Graph.Write.Unsafe, module GraphRewriting.Graph.Types) where  import Prelude.Unicode@@ -11,29 +11,24 @@ import GraphRewriting.Graph.Types import GraphRewriting.Graph.Internal import GraphRewriting.Graph.Read-import Data.View import qualified Data.IntMap as Map import qualified Data.IntSet as Set  --- TODO: For the major version change Adjust parameter orders to the ones used in GraphRewriting.Graph.Write+writeNode ∷ Node → n → Rewrite n ()+writeNode r = modifyNode r . const  modifyNode ∷ Node → (n → n) → Rewrite n ()-modifyNode n@(Node i) f = modifyNodeMap . Map.insert i . f =<< readNode n--updateNode ∷ View v n ⇒ v → Node → Rewrite n ()-updateNode v = adjustNode (const v)+modifyNode n f = modifyNodeMap . Map.insert (nKey n) . f =<< readNode n -adjustNode ∷ View v n ⇒ (v → v) → Node → Rewrite n ()-adjustNode f n = modifyNode n $ adjust f+updateNode ∷ View v n ⇒ Node → v → Rewrite n ()+updateNode n = adjustNode n . const -adjustNodeM ∷ (View [Port] n, View v n) ⇒ (v → Rewrite n v) → Node → Rewrite n ()-adjustNodeM f n = do-	v' ← f =<< inspectNode n-	updateNode v' n+adjustNode ∷ View v n ⇒ Node → (v → v) → Rewrite n ()+adjustNode n = modifyNode n . adjust -writeNode ∷ Node → n → Rewrite n ()-writeNode r = modifyNode r . const+adjustNodeM ∷ (View [Port] n, View v n) ⇒ Node → (v → Rewrite n v) → Rewrite n ()+adjustNodeM n f = updateNode n =<< f =<< inspectNode n  unregister ∷ Node → [Edge] → Rewrite n () unregister (Node n) es = modifyEdgeMap $ flip (foldr $ Map.update deleteN) (map eKey es)

@@ -1,34 +1,65 @@ {-# 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+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 Data.List (nub)-import Data.Set as Set (empty, insert, member)+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  ---instance Functor (Pattern n) where+-- | A pattern represents a graph scrutinisation that memorises all the scrutinised nodes during matching.+type Pattern n = PatternT n Identity -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)+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 = Pattern $ \m → lift []+	fail str = PatternT $ \h → lift (fail str) -instance MonadPlus (Pattern n) where+instance MonadTrans (PatternT n) where+	lift m = PatternT $ \h → do+		x ← lift $ lift m+		return ([],x)++-- TODO: Change constraint to Functor m if possible+instance Monad m ⇒ Functor (PatternT n m) where fmap = liftM++-- TODO: Change constraint from Monad m if possible+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 = Pattern $ \m → do+	mplus p q = PatternT $ \h → do -- TODO: this implements choice. Is mplus the right function for that? 		g ← ask-		lift $ runReaderT (pattern p m) g ⧺ runReaderT (pattern q m) g+		lift $ runReaderT (patternT p h) g `mplus` runReaderT (patternT q h) g +runPatternT ∷ PatternT n m a → Graph n → m [(Match,a)]+runPatternT = runPatternT' []+ -- | 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 []+runPattern p = runIdentity . runPatternT p  evalPattern ∷ Pattern n a → Graph n → [a] evalPattern p = map snd . runPattern p@@ -39,48 +70,42 @@ -- 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 ∷ Monad m ⇒ [a] → PatternT n m a -- TODO: express this using Alternative?+branch xs = PatternT $ \h → lift $ ListT $ return [([],x) | x ← xs] --- | 'branch' on each node, visit it, and return it-branchNodes ∷ [Node] → Pattern n Node-branchNodes ns = do+-- | 'branch' on each node, add it to the history, and return it+branchNodes ∷ Monad m ⇒ [Node] → PatternT n m Node+branchNodes ns = do -- TODO: express this using Alternative? 	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 ∷ Monad m ⇒ PatternT n m a → PatternT n m Bool+probe p = 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+matches ∷ Monad m ⇒ PatternT n m a → PatternT n m [Match]+matches p = map fst <$> match p +-- TODO: isn't this essentially same as runPatternT? -- | 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+match ∷ Monad m ⇒ PatternT n m a → PatternT n m [(Match, a)]+match p = PatternT $ \h → do+	matches ← liftM (runReaderT $ patternT p h) ask -- list of all possible matches+	let roundup = liftM (\xs → [(concatMap fst xs, xs)]) (runListT matches) -- concatenation into one big match+	lift $ ListT roundup  -- | choice over a list of patterns-anyOf ∷ [Pattern n a] → Pattern n a-anyOf [] = fail "anyOf []"-anyOf xs = foldr1 (<|>) xs+anyOf ∷ Alternative f ⇒ [f a] → f a+anyOf = foldr (<|>) empty  -- | 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 ∷ Monad m ⇒ PatternT n m a → PatternT n m () requireFailure p = require . not =<< probe p  -- | 'fail' when monadic predicate is not met@@ -90,72 +115,88 @@ -- 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+liftReader ∷ Monad m ⇒ Reader (Graph n) a → PatternT n m a+liftReader r = PatternT $ \h → do+	x ← runReader r `liftM` ask 	return ([],x)  -- | any node anywhere in the graph-node ∷ View v n ⇒ Pattern n v+node ∷ (Monad m, View v n) ⇒ PatternT n m v node = liftReader . inspectNode =<< branchNodes =<< liftReader readNodeList --- | a reference to the lastly matched node-previous ∷ Pattern n Node-previous = liftM head history+-- | A specific node+nodeAt ∷ (Monad m, View v n) ⇒ Node → PatternT n m v+nodeAt ref = do+	n ← liftReader $ inspectNode ref+	PatternT $ \h → lift $ return ([ref],n)  -- | any edge anywhere in the graph-edge ∷ Pattern n Edge+edge ∷ Monad m ⇒ PatternT n m 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)+nodeWith ∷ (Monad m, View v n) ⇒ Edge → PatternT n m v+nodeWith e = liftReader . inspectNode =<< branchNodes =<< liftReader (attachedNodes e)  -- | edge that is attached to given node-edgeOf ∷ View [Port] n ⇒ Node → Pattern n Edge+edgeOf ∷ (Monad m, View [Port] n) ⇒ Node → PatternT n m 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 ∷ Monad m => (View [Port] n, View v n) ⇒ Node → PatternT n m 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 ∷ (Monad m, View [Port] n, View v n) ⇒ Node → PatternT n m 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+-- | nodes connected to given port of the specified node, not including the node itself.+-- Consider as an alternative 'linear' combined with 'nodeWith'.+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)  -- controlling history and future -------------------------------------------- +-- | A specific node+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"+ -- | 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+amnesia ∷ Monad m ⇒ PatternT n m a → PatternT n m a+amnesia p = PatternT $ \h → do+	(h',x) ← patternT p h 	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)+history ∷ Monad m ⇒ PatternT n m Match+history = PatternT $ \h → return ([],h) +-- | a reference to the lastly matched node+previous ∷ Monad m ⇒ PatternT n m Node+previous = head <$> history+ -- | only match nodes in the next pattern that have not been matched before-nextFresh ∷ Pattern n a → Pattern n a+nextFresh ∷ Monad m ⇒ PatternT n m a → PatternT n m 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 ∷ Monad m ⇒ Node → PatternT n m a → PatternT n m 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)+-- | Restrict a pattern based on the which of nodes have matched been previously and which nodes will be matched in the future. The first parameter of the supplied function is the history with the most recently matched node in head position. The second parameter is the future with the next matched node in head position.+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)+-- TODO: the check is only done after the whole pattern has matched (maybe do the check more often inbetween?)  -- | Nodes in the future may not be matched more than once.-linear ∷ Pattern n a → Pattern n a+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

@@ -1,31 +1,30 @@+{-# LANGUAGE UnicodeSyntax, FlexibleContexts, MultiParamTypeClasses #-} -- | Offers an 'activePair' pattern for convenient implementation of interaction nets. module GraphRewriting.Pattern.InteractionNet where  import Prelude.Unicode import Data.View+import Data.Functor import GraphRewriting.Graph.Types-import GraphRewriting.Graph.Read+--import GraphRewriting.Graph.Read import GraphRewriting.Pattern   -- | Index that identifies the principal port within the list of ports-class INet v where principalPort ∷ v → Int+class INet n where principalPort ∷ n → Port  -- | Instead of @(,)@ to save parentheses-data Pair x = x :-: x+data Pair a = a :-: a +instance Functor Pair where fmap f (x :-: y) = f x :-: f y+ pair ∷ Pair a → (a,a) pair (x :-: y) = (x,y)  activePair ∷ (View [Port] n, View v n, INet v) ⇒ Pattern n (Pair v)-activePair = do+activePair = linear $ do 	v1 ← node-	n1 ← previous-	ports1 ← liftReader (inspectNode n1)-	let pp1 = ports1 !! principalPort v1-	v2 ← adverse pp1 n1-	n2 ← previous-	ports2 ← liftReader (inspectNode n2)-	let pp2 = ports2 !! principalPort v2-	require (pp1 ≡ pp2)+	let pp1 = principalPort v1+	v2 ← nodeWith pp1+	require (pp1 ≡ principalPort v2) 	return (v1 :-: v2)

@@ -3,10 +3,15 @@  import GraphRewriting.Graph.Types import Control.Monad.Reader+import Control.Monad.List  +-- TODO: change the dependency of Match into a ReaderT Match? -- | A pattern represents a graph scrutinisation that memorises all the scrutinised nodes during matching.-newtype Pattern n a = Pattern {pattern ∷ Match → ReaderT (Graph n) [] (Match, a)}+newtype PatternT n m a = PatternT {patternT ∷ Match → ReaderT (Graph n) (ListT m) (Match, a)}++runPatternT' ∷ Match → PatternT n m a → Graph n → m [(Match,a)]+runPatternT' h p = runListT . runReaderT (patternT p h)  -- | Nodes matched in the evaluation of a pattern with the lastly matched node at the head type Match = [Node]

@@ -2,18 +2,20 @@ -- | Rewrite rules are represented as nested monads: a 'Rule' is a 'Pattern' that returns a 'Rewrite' the latter directly defining the transformation of the graph. -- -- For rule construction a few functions a provided: The most basic one is 'rewrite'. But in most cases 'erase', 'rewire', and 'replace*' should be more convenient. These functions express rewrites that /replace/ the matched nodes of the 'Pattern', which comes quite close to the @L -> R@ form in which graph rewriting rules are usually expressed.-module GraphRewriting.Rule where+module GraphRewriting.Rule (Replace, module GraphRewriting.Rule) where  import Prelude.Unicode-import GraphRewriting.Graph-import GraphRewriting.Graph.Internal (Port (Edge))++import GraphRewriting.Graph.Read import GraphRewriting.Graph.Write import GraphRewriting.Rule.Internal import GraphRewriting.Pattern import Control.Monad.State import Control.Monad.Reader+import Control.Applicative import Data.List (nub)-import Data.Either+import Data.Functor+import Data.Monoid   -- | A rewriting rule is defined as a 'Pattern' that returns a 'Rewrite'@@ -22,7 +24,7 @@ -- | Apply rule at an arbitrary position if applicable apply ∷ Rule n → Rewrite n () apply r = do-	contractions ← liftM (evalPattern r) ask+	contractions ← evalPattern r <$> ask 	when (not $ null contractions) (head contractions >> return ())  -- rule construction ---------------------------------------------------------@@ -43,40 +45,58 @@ 	mapM_ mergeEs $ joinEdges ess 	mapM_ deleteNode $ nub hist -data RHS v = Node v | Wire Edge Edge | Merge [Edge] --- | Constructs a rule that replaces the matched nodes of the left-hand side by new nodes and rewirings. It generates an amount of new edges specified by the 'Int'. In most cases the functions below named @replace*@ should be sufficient.-replace ∷ (View [Port] n, View v n) ⇒ Int → ([Edge] → [RHS v]) → Rule n-replace n rhs = do-	let vs = fst $ partition (replicate n $ Edge 0)-	lhsNodes ← liftM nub history-	when (null lhsNodes ∧ not (null vs)) (fail "need at least one matching node to clone new nodes from")+instance Monad (Replace n) where+	return x = Replace $ return (x, [])+	Replace r1 >>= f = Replace $ do+		(x1, merges1) ← r1+		let Replace r2 = f x1+		(y, merges2) ← r2+		return (y, merges1 ⧺ merges2)++instance Functor (Replace n) where+	fmap f (Replace r) = Replace $ do+		(x, merges) ← r+		return (f x, merges)++instance Applicative (Replace n) where+	Replace rf <*> Replace rx = Replace $ do+		(f, merges1) ← rf+		(x, merges2) ← rx+		return (f x, merges1 ⧺ merges2)+	pure = return++instance Monoid (Replace n ()) where+	mempty = return ()+	mappend = (>>)++replace ∷ View [Port] n ⇒ Replace n () → Rule n+replace (Replace rhs) = do+	lhs ← nub <$> history+	when (null lhs) (fail "replace: must match at least one node") 	return $ do-		es ← replicateM n newEdge-		let (vs,ess) = partition es-		zipWithM_ copyNode (cycle lhsNodes) vs-		mapM_ mergeEs $ joinEdges ess-		mapM_ deleteNode lhsNodes-	where partition es = partitionEithers $ map splitRHS (rhs es) where-		splitRHS (Node v) = Left v-		splitRHS (Wire e1 e2) = Right [e1,e2]-		splitRHS (Merge es) = if length es < 2-			then error "Merge requires list length >= 2"-			else Right es+		mapM_ mergeEs =<< joinEdges . snd <$> rhs+		mapM_ deleteNode lhs --- | Replaces the matched nodes by a list of new nodes and rewirings.-replace0 vs = replace 0 $ \[]                        → vs--- | Replaces the matched nodes by a list of new nodes and rewirings. It also generates one new edge.-replace1 vs = replace 1 $ \[e1]                      → vs e1--- | Replaces the matched nodes by a list of new nodes and rewirings. It also generates two new edges.-replace2 vs = replace 2 $ \[e1,e2]                   → vs e1 e2--- | You get the idea.-replace3 vs = replace 3 $ \[e1,e2,e3]                → vs e1 e2 e3-replace4 vs = replace 4 $ \[e1,e2,e3,e4]             → vs e1 e2 e3 e4-replace5 vs = replace 5 $ \[e1,e2,e3,e4,e5]          → vs e1 e2 e3 e4 e5-replace6 vs = replace 6 $ \[e1,e2,e3,e4,e5,e6]       → vs e1 e2 e3 e4 e5 e6-replace7 vs = replace 7 $ \[e1,e2,e3,e4,e5,e6,e7]    → vs e1 e2 e3 e4 e5 e6 e7-replace8 vs = replace 8 $ \[e1,e2,e3,e4,e5,e6,e7,e8] → vs e1 e2 e3 e4 e5 e6 e7 e8+byNode ∷ (View [Port] n, View v n) ⇒ v → Replace n ()+byNode v = Replace $ do+	n ← head <$> readNodeList+	void $ copyNode n v+	return ((), [])++byNewNode ∷ View [Port] n ⇒ n → Replace n ()+byNewNode n = Replace $ newNode n >> return ((), [])++byEdge ∷ Replace n Edge+byEdge = Replace $ do+	e ← newEdge+	return (e, [])++byWire ∷ Edge → Edge → Replace n ()+byWire e1 e2 = byConnector [e1,e2]++byConnector ∷ [Edge] → Replace n ()+byConnector es = Replace $ return ((), [es])  -- combinators --------------------------------------------------------------- 

@@ -1,4 +1,4 @@-{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE UnicodeSyntax, FlexibleContexts #-} module GraphRewriting.Rule.Internal where  import GraphRewriting.Graph.Internal@@ -6,6 +6,11 @@ import qualified Data.IntSet as Set  +type MergeEdges = [Edge]++newtype Replace n a = Replace (Rewrite n (a, [MergeEdges]))++mergeEs :: View [Port] n ⇒ MergeEdges -> Rewrite n () mergeEs (e:es) = mapM_ (mergeEdges e) es  type Set = Set.IntSet

@@ -1,5 +1,5 @@ Name:           graph-rewriting-Version:        0.6.0+Version:        0.7.0 Copyright:      (c) 2010, Jan Rochel License:        BSD3 License-File:   LICENSE@@ -10,7 +10,7 @@ Build-Type:     Simple Synopsis:       Monadic graph rewriting of hypergraphs with ports and multiedges Description:-  This library provides a monadic EDSL to define your own port graph rewrite system in Haskell. Once you have specified the signature of your nodes and a set of rewrite rules, you can apply these rules on a graph to effect a graph transformation. The aim of this library is to make it as convenient as possible to define such a system and experiment with it and is not designed as a backend for high-performance computation.+  This library provides a monadic EDSL to define your own port graph rewrite system in Haskell. Once you have specified the signature of your nodes and a set of rewrite rules, you can apply these rules on a graph to effect a graph transformation. The aim of this library is to make it as convenient as possible to define such a system and experiment with it and is not intended as a backend for high-performance computation. Category:       Graphs, Data Cabal-Version:  >= 1.6 @@ -18,7 +18,7 @@   Build-Depends:     base >= 4 && < 4.6,     base-unicode-symbols >= 0.2 && < 0.3,-    mtl >= 1.1 && < 1.2,+    mtl >= 1.1 && < 2.1,     containers >= 0.3 && < 0.5   Exposed-Modules:     Data.View@@ -31,7 +31,7 @@     GraphRewriting.Pattern     GraphRewriting.Pattern.InteractionNet     GraphRewriting.Rule---  Other-Modules:+  Other-Modules:     GraphRewriting.Graph.Internal     GraphRewriting.Pattern.Internal     GraphRewriting.Rule.Internal@@ -42,4 +42,5 @@     TypeSynonymInstances     MultiParamTypeClasses     OverlappingInstances-  GHC-Options:    -fno-warn-duplicate-exports+    GeneralizedNewtypeDeriving+  GHC-Options:    -fno-warn-duplicate-exports -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-do-bind -fwarn-wrong-do-bind -fwarn-unrecognised-pragmas