graph-rewriting-ski-0.5.4: Direct/Rules.hs

module Direct.Rules where

import Prelude.Unicode
import Direct.Graph
import GraphRewriting


-- <chunk: rules>
ruleS ∷ (View [Port] n, View SKI n) ⇒ Rule n 
ruleS = do
	S {inp = si} ← node
	Applicator {inp = i1, out1 = o1, out2 = f} ← nodeAt si
	require (si ≡ o1)
	Applicator {inp = i2, out1 = o2, out2 = g} ← nodeAt i1
	require (i1 ≡ o2)
	Applicator {inp = i3, out1 = o3, out2 = x} ← nodeAt i2
	require (i2 ≡ o3)
	replace4 $ \l r lr rr →
		[Node $ Applicator {inp = i3, out1 = l, out2 = r},
		 Node $ Applicator {inp = l, out1 = f, out2 = lr},
		 Node $ Applicator {inp = r, out1 = g, out2 = rr},
		 Node $ Duplicator {inp1 = lr, inp2 = rr, out = x}]

-- <chunk: ruleK>
ruleK ∷ (View [Port] n, View SKI n) ⇒ Rule n 
ruleK = do
	K {inp = si} ← node
	Applicator {inp = i1, out1 = o1, out2 = x} ← nodeAt si
	require (si ≡ o1)
	Applicator {inp = i2, out1 = o2, out2 = y} ← nodeAt i1
	require (i1 ≡ o2)
	replace0 [Wire x i2, Node $ Eraser {inp = y}]
-- </chunk: ruleK>

ruleI ∷ (View [Port] n, View SKI n) ⇒ Rule n
ruleI = do
	I {inp = iI} ← node
	Applicator {inp = iA, out2 = o2} ← nodeAt iI
	require (iI ≡ iA)
	rewire [[iA,o2]]

combinatorAt ∷ (View [Port] n, View SKI n) ⇒ Edge → Pattern n SKI
combinatorAt e = anyOf [s,k,i] where
	s = do {s@S {} ← nodeAt e; return s}
	k = do {k@K {} ← nodeAt e; return k}
	i = do {i@I  {} ← nodeAt e; return i}

duplicateCombinator  ∷ (View [Port] n, View SKI n) ⇒ Rule n
duplicateCombinator = do
	Duplicator {inp1 = i1, inp2 = i2, out = o} ← node
	c ← combinatorAt o
	replace0 [Node $ c {inp = i1}, Node $ c {inp = i2}]

duplicateApp ∷ (View [Port] n, View SKI n) ⇒ Rule n 
duplicateApp = do
	Duplicator {inp1 = i1, inp2 = i2, out = o} ← node
	Applicator {inp = i, out1 = o1, out2 = o2} ← nodeAt o
	replace4 $ \l lr rl r →
		[Node $ Applicator {inp = i1, out1 = l, out2 = lr},
		 Node $ Applicator {inp = i2, out1 = rl, out2 = r},
		 Node $ Duplicator {inp1 = l, inp2 = rl, out = o1},
		 Node $ Duplicator {inp1 = lr, inp2 = r, out = o2}]

eraseCombinator ∷ (View [Port] n, View SKI n) ⇒ Rule n 
eraseCombinator = do
	Eraser {inp = i} ← node
	combinatorAt i
	erase

eraseApp ∷ (View [Port] n, View SKI n) ⇒ Rule n 
eraseApp = do
	Eraser {inp = i} ← node
	Applicator {out1 = o1, out2 = o2} ← nodeAt i
	replace0 [Node $ Eraser {inp = o1}, Node $ Eraser {inp = o2}]

eliminate ∷ (View [Port] n, View SKI n) ⇒ Rule n
eliminate = do
	Eraser {inp = iE} ← node
	Duplicator {out = oD, inp1 = i1, inp2 = i2} ← neighbour =<< previous
	require (iE ≡ i1 ∨ iE ≡ i2)
	if iE ≡ i1
		then rewire [[oD,i2]]
		else rewire [[oD,i1]]
-- <chunk: rules>