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
type Rule n = Pattern n (Rewrite n [Node])
rewrite ∷ (Match → Rewrite n [Node]) → Rule n
rewrite r = liftM r history
erase ∷ View [Port] n ⇒ Rule n
erase = do
hist ← history
return $ do
mapM_ deleteNode $ nub hist
return []
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]
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
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 $ do
ns1 ← rw1
ns2 ← apply r2
return (ns1 ⧺ ns2)
exhaustive ∷ Rule n → Rule n
exhaustive = foldr1 (>>>) . repeat
everywhere ∷ Rule n → Rule n
everywhere r = do
ms ← matches r
exhaustive $ restrictOverlap (\hist future → future ∈ ms) r
apply ∷ Rule n → Rewrite n [Node]
apply r = maybe (return []) snd . listToMaybe =<< liftM (runPattern r) ask