module GraphRewriting.Rule where
import Prelude.Unicode
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
type Rule n = Pattern n (Rewrite n ())
apply ∷ Rule n → Rewrite n ()
apply r = do
contractions ← liftM (evalPattern r) ask
when (not $ null contractions) (head contractions >> return ())
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
data RHS v = Node v | Wire Edge Edge | Merge [Edge]
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")
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
replace0 vs = replace 0 $ \[] → vs
replace1 vs = replace 1 $ \[e1] → vs e1
replace2 vs = replace 2 $ \[e1,e2] → vs e1 e2
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
(>>>) ∷ 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