{-# LANGUAGE UnicodeSyntax, FlexibleInstances, FlexibleContexts #-} -- | 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 (Replace, module GraphRewriting.Rule) where import Prelude.Unicode 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.Functor import Data.Monoid -- | A rewriting rule is defined as a 'Pattern' that returns a 'Rewrite' type Rule n = Pattern n (Rewrite n ()) -- | Apply rule at an arbitrary position if applicable apply ∷ Rule n → Rewrite n () apply = let void m = m >> return () in void . apply' -- | Apply rule at an arbitrary position. Return value states whether the rule was applicable. apply' ∷ Rule n → Rewrite n Bool apply' r = do contractions ← evalPattern r <$> ask if null contractions then return False else head contractions >> return True -- rule construction --------------------------------------------------------- -- | primitive rule construction with the matched nodes of the left hand side as a parameter rewrite ∷ (Match → Rewrite n a) → Rule n rewrite r = do h ← history return $ r h >> return () -- | constructs a rule that deletes all of the matched nodes from the graph erase ∷ View [Port] n ⇒ Rule n erase = rewrite $ mapM_ deleteNode . nub -- | 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 = rewrite $ \hist → do mapM_ mergeEs $ joinEdges ess mapM_ deleteNode $ nub hist 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 mapM_ mergeEs =<< joinEdges . snd <$> rhs mapM_ deleteNode lhs byNode ∷ (View [Port] n, View v n) ⇒ v → Replace n () byNode v = Replace $ do n ← head <$> readNodeList _ ← 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 --------------------------------------------------------------- -- | 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 $ rw1 >> apply r2 -- | Make a rule exhaustive, i.e. such that (when applied) it reduces redexes until no redexes are occur in the graph. exhaustive ∷ Rule n → Rule n exhaustive = foldr1 (>>>) . repeat -- | Make a rule parallel, i.e. such that (when applied) all current redexes are contracted one by one. Neither new redexes or destroyed redexes are reduced. everywhere ∷ Rule n → Rule n everywhere r = do ms ← amnesia $ matches r exhaustive $ restrictOverlap (\hist future → future ∈ ms) r -- | Repeatedly apply the rules from the given list prefering earlier entries. -- Returns a list of indexes reporting the sequence of rules that has applied. benchmark ∷ [Rule n] → Rewrite n [Int] benchmark rules = rec where rec = do contractions ← evalPattern (anyOf indexedRules) <$> ask case contractions of [] → return [] (i,rw) : _ → fmap (i:) (rw >> rec) indexedRules = zipWith addIndex [0..] rules where addIndex i rule = do rw ← rule return (i, rw)