{-# 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}]