{-# LANGUAGE Arrows #-}
module CircuitEncoder (encode) where

import Circuit
import GenCircuit
import Control.Monad
import Control.Category
import Control.Arrow

-- simulate c0to2 (repeat 0) = repeat 2
c0to2 :: Automata Int Int
c0to2 = proc i -> do
  rec
    ~(c0,o) <- gate -< (c0',i)
    c0' <- wire' -< c0
  returnA -< o

-- simulate c2to0 (repeat 2) = repeat 0
c2to0 :: Automata Int Int
c2to0 = proc i -> do
  rec
    c2 <- c0to2 -< c0'
    ~(o,c0) <- gate -< (i,c2) 
    c0' <- wire' -< c0
  returnA -< o

-- simulate c0to1 (repeat 0) = repeat 1
c0to1 :: Automata Int Int
c0to1 = proc i -> do
  rec
    c2 <- c0to2 -< c0'
    ~(o,c2') <- gate -< (i,c2)
    c0 <- c2to0 -< c2'
    c0' <- wire' -< c0
  returnA -< o

-- simulate c1to0 (repeat 0) = repeat 1
c1to0 :: Automata Int Int
c1to0 = proc i -> do
  rec
    c1 <- c0to1 -< c0'
    ~(o,c0) <- gate -< (i,c1)
    c0' <- wire' -< c0
  returnA -< o

-- simulate c1to2 (repeat 1) = repeat 2
c1to2 :: Automata Int Int
c1to2 = proc i -> do
  rec
    ~(c2,o) <- gate -< (c0',i)
    c0 <- c2to0 -< c2
    c0' <- wire' -< c0
  returnA -< o

-- simulate c2to1 (repeat 2) = repeat 1
c2to1 :: Automata Int Int
c2to1 = proc i -> do
  rec
    c1 <- c0to1 -< c0'
    ~(o,c1') <- gate -< (i,c1)
    c0 <- c1to0 -< c1'
    c0' <- wire' -< c0
  returnA -< o

gen_c0to2 = do
  n <- newNode 
  connect (L n) (L n)
  return (R n, R n)

gen_c2to0 = do
  (c0to2_in, c0to2_out) <- gen_c0to2
  n <- newNode
  connect c0to2_out (R n)
  connect (R n) c0to2_in
  return (L n, L n)

gen_c0to1 = do
  (c0to2_in, c0to2_out) <- gen_c0to2
  n <- newNode
  (c2to0_in, c2to0_out) <- gen_c2to0
  connect c0to2_out (R n)
  connect (R n) c2to0_in
  connect c2to0_out c0to2_in
  return (L n, L n)

gen_g1 = do
  (c0to2_in, c0to2_out) <- gen_c0to2
  n <- newNode 
  connect c0to2_out (R n)
  connect (R n) c0to2_in
  return (L n, L n)

g1 = proc i -> do
  rec
    x <- c0to2 -< y'
    ~(o,y) <- gate -< (i,x)
    y' <- wire' -< y
  returnA -< o

gen_g2 = do
  (c0to1_in, c0to1_out) <- gen_c0to1
  n <- newNode
  connect c0to1_out (R n)
  connect (R n) c0to1_in
  return (L n, L n)

g2 = proc i -> do
  rec
    x <- c0to1 -< y'
    ~(o,y) <- gate -< (i,x)
    y' <- wire' -< y
  returnA -< o

gen_nop = do
  n <- newNode
  (c2to0_in, c2to0_out) <- gen_c2to0
  connect (R n) c2to0_in
  connect c2to0_out (R n)
  return (L n, L n)

nop :: Automata Int Int
nop = proc i -> do
  rec
    ~(o,c2) <- gate -< (i,c0')
    c0 <- c2to0 -< c2
    c0' <- wire' -< c0
  returnA -< o

encode ss = generate $ do
  xs <- sequence gens
  let (is, os) = unzip xs
  forM (zip (tail os) is) $ \(from,to) -> connect from to
  connect X (last is) 
  connect (head os) X
  where
    (_, gens) = head $ encode' returnA ss

encode' fs [] = return (["nop"], [gen_nop])
encode' fs (s0:ss) = do
  (name, gen, f) <- gs
  let (o, fs') = trans (fs <<< f) 0
  guard $ o == s0
  (names, gens) <- encode' fs' ss
  return (name:names, gen:gens)
  where
    gs = [("nop", gen_nop, nop), ("g1", gen_g1, g1), ("g2", gen_g2, g2)]

test = proc i -> do
  rec
    o1 <- g1 -< i1
    o2 <- nop -< i2
    o3 <- g1 -< i3
    o4 <- nop -< i
    i1 <- wire' -< o2
    i2 <- wire' -< o3
    i3 <- wire' -< o4
  returnA -< o1