graph-rewriting-0.4.8: GraphRewriting/Rule.hs

-- | 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. The 'Rewrite' itself is expected to return a list of newly created nodes.
--
-- 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

import Prelude.Unicode
import Data.Maybe (listToMaybe)
import GraphRewriting.Graph
import GraphRewriting.Graph.Internal (Port (Edge))
import GraphRewriting.Graph.Write
import GraphRewriting.Rule.Internal
import GraphRewriting.Pattern
import Control.Monad.State
import Control.Monad.Reader
import Data.List (nub)
import Data.Either


-- A rewriting rule is defined as a 'Pattern' that returns a 'Rewrite'
type Rule n = Pattern n (Rewrite n [Node])

-- rule construction ---------------------------------------------------------

-- | primitive rule construction with the matched nodes of the left hand side as a parameter
rewrite ∷ (Match → Rewrite n [Node]) → Rule n
rewrite r = liftM r history

-- | constructs a rule that deletes all of the matched nodes from the graph
erase ∷ View [Port] n ⇒ Rule n
erase = do
	hist ← history
	return $ do
		mapM_ deleteNode $ nub hist
		return []

-- | Constructs a rule from a list of rewirings. Each rewiring specifies a list of hyperedges that are to be merged into a single hyperedge. All matched nodes of the left-hand side are removed.
rewire ∷ View [Port] n ⇒ [[Edge]] → Rule n
rewire ess = do
	hist ← history
	return $ do
		mapM_ mergeEs $ joinEdges ess
		mapM_ deleteNode $ nub hist
		return []

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)
	hist ← history
	when (null hist ∧ not (null vs)) (fail "need at least one matching node to clone new nodes from")
	return $ do
		es ← replicateM n newEdge
		let (vs,ess) = partition es
		ns ← zipWithM copyNode (cycle hist) vs
		mapM_ mergeEs $ joinEdges ess
		mapM_ deleteNode $ nub hist
		return ns
	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

-- | 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

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

-- | Apply two rules consecutively. Second rule is only applied if first one succeeds. Fails if (and only if) first rule fails.
(>>>) ∷ Rule n → Rule n → Rule n
r1 >>> r2 = do
	rw1 ← r1
	return $ do
		ns1 ← rw1
		ns2 ← apply r2
		return (ns1 ⧺ ns2)

-- | Apply a rule repeatedly as long as it is applicable. Fails if rule cannot be applied at all.
exhaustive ∷ Rule n → Rule n
exhaustive = foldr1 (>>>) . repeat

-- | Apply a rule to all current redexes one by one. Neither new redexes or destroyed redexes are reduced.
everywhere ∷ Rule n → Rule n
everywhere r = do
	ms ← matches r
	exhaustive $ restrictOverlap (\hist future → future ∈ ms) r

-- | Apply rule at an arbitrary position if applicable
apply ∷ Rule n → Rewrite n [Node]
apply r = maybe (return []) snd . listToMaybe =<< liftM (runPattern r) ask