graph-rewriting-cl-0.2.2: Rules.hs

{-# LANGUAGE UnicodeSyntax, FlexibleContexts #-}
module Rules where

import Prelude.Unicode
import Graph
import GraphRewriting


-- The set-up ----------------------------------------------------------------

arity0 ∷ (View [Port] n, View Vertex n) ⇒ Edge → Pattern n Vertex
arity0 i = anyOf [c,v,e] where
	c = do {c@Combinator {} ← nodeAt i; return c}
	v = do {v@Variable   {} ← nodeAt i; return v}
	e = do {e@Eraser     {} ← nodeAt i; return e}

erase0 ∷ (View [Port] n, View Vertex n) ⇒ Rule n 
erase0 = linear $ do
	Eraser {out = o} ← node
	n ← arity0 o
	erase

eraseApplicator ∷ (View [Port] n, View Vertex n) ⇒ Rule n 
eraseApplicator = linear $ do
	Eraser {out = o} ← node
	Applicator {inp = i, out1 = o1, out2 = o2} ← nodeAt o
	require (o ≡ i)
	replace0 [Node $ Eraser {out = o1}, Node $ Eraser {out = o2}]

duplicate ∷ (View [Port] n, View Vertex n) ⇒ Rule n
duplicate = duplicateApplicator <|> do
	Duplicator {inp1 = i1, inp2 = i2, out = o} ← node
	n ← arity0 o
	replace0 $ [Node $ n {inp = i1}, Node $ n {inp = i2}]

duplicateApplicator ∷ (View [Port] n, View Vertex n) ⇒ Rule n 
duplicateApplicator = do
	Duplicator {inp1 = i1, inp2 = i2, out = o} ← node
	Applicator {inp = i, out1 = o1, out2 = o2} ← nodeAt o
	replace4 $ \l1 l2 x1 x2 →
		[Node $ Applicator {inp = i1, out1 = l1, out2 = x1},
		 Node $ Applicator {inp = i2, out1 = x2, out2 = l2},
		 Node $ Duplicator {inp1 = l1, inp2 = x2, out = o1},
		 Node $ Duplicator {inp1 = x1, inp2 = l2, out = o2}]

eliminate ∷ (View [Port] n, View Vertex n) ⇒ Rule n
eliminate = do
	Eraser {out = oE} ← node
	Duplicator {out = oD, inp1 = i1, inp2 = i2} ← nodeAt oE
	require (oE ≡ i1 ∨ oE ≡ i2)
	if oE ≡ i1
		then rewire [[oD,i2]]
		else rewire [[oD,i1]]

combinatorPattern ∷ (View [Port] n, View Vertex n) ⇒ Combinator → Int → Pattern n (Edge, [Edge])
combinatorPattern c arity = do
	Combinator {inp = i, combinator = c'} ← node
	require (c ≡ c')
	accumulateArguments i arity
	where
	accumulateArguments i 0 = return (i,[])
	accumulateArguments i n = do
		Applicator {inp = iA, out1 = o1, out2 = o2} ← nodeAt i
		require (i ≡ o1)
		(i',args) ← accumulateArguments iA (n-1)
		return (i',o2:args)

-- The show-down -------------------------------------------------------------

combinatorS ∷ (View [Port] n, View Vertex n) ⇒ Rule n
combinatorS = do
	(i, [f,g,x]) ← combinatorPattern S 3
	replace4 $ \l lr r rr →
		[Node $ Applicator {inp = l, out1 = f, out2 = lr},
		 Node $ Applicator {inp = r, out1 = g, out2 = rr},
		 Node $ Duplicator {inp1 = lr, inp2 = rr, out = x},
		 Node $ Applicator {inp = i, out1 = l, out2 = r}]

combinatorK ∷ (View [Port] n, View Vertex n) ⇒ Rule n
combinatorK = do
	(i, [x,y]) ← combinatorPattern K 2
	replace0 [Node $ Eraser {out = y}, Wire i x]

combinatorI ∷ (View [Port] n, View Vertex n) ⇒ Rule n
combinatorI = do
	(i, [x]) ← combinatorPattern I 1
	rewire [[i,x]]

combinatorB ∷ (View [Port] n, View Vertex n) ⇒ Rule n
combinatorB = do
	(i, [x,y,z]) ← combinatorPattern B 3
	replace1 $ \r →
		[Node $ Applicator {inp = r, out1 = y, out2 = z},
		 Node $ Applicator {inp = i, out1 = x, out2 = r}]

combinatorC ∷ (View [Port] n, View Vertex n) ⇒ Rule n
combinatorC = do
	(i, [x,y,z]) ← combinatorPattern C 3
	replace1 $ \l →
		[Node $ Applicator {inp = l, out1 = x, out2 = z},
		 Node $ Applicator {inp = i, out1 = l, out2 = y}]

combinatorS' ∷ (View [Port] n, View Vertex n) ⇒ Rule n
combinatorS' = do
	(i, [k,x,y,z]) ← combinatorPattern S' 4
	replace5 $ \l lr lrr r rr →
		[Node $ Applicator {inp = lr, out1 = x, out2 = lrr},
		 Node $ Applicator {inp = l, out1 = k, out2 = lr},
		 Node $ Applicator {inp = r, out1 = y, out2 = rr},
		 Node $ Duplicator {inp1 = lrr, inp2 = rr, out = z},
		 Node $ Applicator {inp = i, out1 = l, out2 = r}]

combinatorB' ∷ (View [Port] n, View Vertex n) ⇒ Rule n
combinatorB' = do
	(i, [k,x,y,z]) ← combinatorPattern B' 4
	replace2 $ \l r →
		[Node $ Applicator {inp = l, out1 = k, out2 = x},
		 Node $ Applicator {inp = r, out1 = y, out2 = z},
		 Node $ Applicator {inp = i, out1 = l, out2 = r}]

combinatorC' ∷ (View [Port] n, View Vertex n) ⇒ Rule n
combinatorC' = do
	(i, [k,x,y,z]) ← combinatorPattern C' 4
	replace2 $ \l lr →
		[Node $ Applicator {inp = l, out1 = k, out2 = lr},
		 Node $ Applicator {inp = lr, out1 = x, out2 = z},
		 Node $ Applicator {inp = i, out1 = l, out2 = y}]

combinatorW ∷ (View [Port] n, View Vertex n) ⇒ Rule n
combinatorW = do
	(i, [x,y]) ← combinatorPattern W 2
	replace3 $ \l lr r →
		[Node $ Applicator {inp = l, out1 = x, out2 = lr},
		 Node $ Duplicator {inp1 = lr, inp2 = r, out = y},
		 Node $ Applicator {inp = i, out1 = l, out2 = r}]