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 Data.List (nub)
type Rule n = Pattern n (Rewrite n ())
apply ∷ Rule n → Rewrite n ()
apply = let void m = m >> return () in void . apply'
apply' ∷ Rule n → Rewrite n Bool
apply' r = do
contractions ← evalPattern r <$> ask
if null contractions
then return False
else head contractions >> return True
rewrite ∷ (Match → Rewrite n a) → Rule n
rewrite r = do
h ← history
return $ r h >> return ()
erase ∷ View [Port] n ⇒ Rule n
erase = rewrite $ mapM_ deleteNode . nub
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])
(>>>) ∷ Rule n → Rule n → Rule n
r1 >>> r2 = do
rw1 ← r1
return $ rw1 >> apply r2
exhaustive ∷ Rule n → Rule n
exhaustive = foldr1 (>>>) . repeat
everywhere ∷ Rule n → Rule n
everywhere r = do
ms ← amnesia $ matches r
exhaustive $ restrictOverlap (\hist future → future ∈ ms) r
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)