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
type Rule n = Pattern n (Rewrite n ())
apply ∷ Rule n → Rewrite n ()
apply = 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
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])
(>>>) ∷ 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)