{-# LANGUAGE Arrows #-}
module Circuit where

import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow
import Control.Monad

-----------------------

newtype Automata i o = Automata{ trans :: i -> (o, Automata i o) }

instance Category Automata where
  id = Automata (\i -> (i, id))
  g . f = Automata $ \x ->
    case trans f x of
    (y, f') ->
      case trans g y of
      (z, g') ->
        (z, g' . f')

instance Arrow Automata where
  arr f = Automata (\i -> (f i, arr f))
  first f = Automata $ \(x,y) ->
    case trans f x of
      (z, f') -> ((z,y), first f')

instance ArrowLoop Automata where
  loop f = Automata $ \x ->
    let ((x',y), f') = trans f (x,y)
    in (x', loop f')
                 
delay :: a -> Automata a a
delay x = Automata (\x' -> (x, delay x'))

-----------------------

op :: (Int,Int) -> (Int,Int)
op (0,0) = (0,2)
op (0,1) = (2,2)
op (0,2) = (1,2)
op (1,0) = (1,2)
op (1,1) = (0,0)
op (1,2) = (2,1)
op (2,0) = (2,2)
op (2,1) = (1,1)
op (2,2) = (0,0)

gate :: Automata (Int,Int) (Int,Int)
gate = arr op

wire :: Automata Int Int
wire = returnA

wire' :: Automata Int Int
wire' = delay 0

simulate :: Automata i o -> [i] -> [o]
simulate am [] = []
simulate am (x:xs) =
  case trans am x of
    (y,am') -> y : simulate am' xs

-----------------------

sample1 :: Automata Int Int
sample1 = proc i -> do
  rec
    ~(o,y) <- gate -< (i,x)
    x <- wire' -< y
  returnA -< o

sample2 :: Automata Int Int
sample2 = proc i -> do
  rec
    ~(o,y) <- gate -< (x,i)
    x <- wire' -< y
  returnA -< o

sample3 :: Automata Int Int
sample3 = proc i -> do
  rec
    ~(y,o) <- gate -< (i,x)
    x <- wire' -< y
  returnA -< o

sample4 :: Automata Int Int
sample4 = proc i -> do
  rec
    ~(y,o) <- gate -< (x,i)
    x <- wire' -< y
  returnA -< o

keyCircuit :: Automata Int Int
keyCircuit = proc i -> do
  rec
    ~(o0L, o0R)  <- gate -< (i0L, i0R)
    ~(o1L, o1R)  <- gate -< (i1L, i1R)
    ~(o2L, o2R)  <- gate -< (i2L, i2R)
    ~(o3L, o3R)  <- gate -< (i3L, i3R)
    ~(o4L, o4R)  <- gate -< (i4L, i4R)
    ~(o5L, o5R)  <- gate -< (i5L, i5R)
    ~(o6L, o6R)  <- gate -< (i6L, i6R)
    ~(o7L, o7R)  <- gate -< (i7L, i7R)
    ~(o8L, o8R)  <- gate -< (i8L, i8R)
    ~(o9L, o9R)  <- gate -< (i9L, i9R)
    ~(o10L,o10R) <- gate -< (i10L,i10R)
    ~(o11L,o11R) <- gate -< (i11L,i11R)
    ~(o12L,o12R) <- gate -< (i12L,i12R)
    ~(o13L,o13R) <- gate -< (i13L,i13R)
    ~(o14L,o14R) <- gate -< (i14L,i14R)
    ~(o15L,o15R) <- gate -< (i15L,i15R)
    ~(o16L,o16R) <- gate -< (i16L,i16R)
    ~(o17L,o17R) <- gate -< (i17L,i17R)
    ~(o18L,o18R) <- gate -< (i18L,i18R)
    ~(o19L,o19R) <- gate -< (i19L,i19R)
    -- 19L:
    let i19L = i
    -- 12R13R0#1R12R,
    i0L <- wire' -< o12R
    i0R <- wire' -< o13R
    -- 14R0L0#4R9L,
    i1L <- wire' -< o14R
    i1R <- wire -< o0L
    -- 9R10R0#3L8L,
    i2L <- wire' -< o9R
    i2R <- wire' -< o10R
    -- 2L17R0#5L9R,
    i3L <- wire -< o2L
    i3R <- wire' -< o17R
    -- 15R1L0#10R13R,
    i4L <- wire' -< o15R
    i4R <- wire -< o1L
    -- 3L18R0#6L15L,
    i5L <- wire -< o3L
    i5R <- wire' -< o18R
    -- 5L11R0#13L12L,
    i6L <- wire -< o5L
    i6R <- wire' -< o11R
    -- 19R16R0#11R8R,
    i7L <- wire' -< o19R
    i7R <- wire' -< o16R
    -- 2R7R0#11L10L,
    i8L <- wire -< o2R
    i8R <- wire -< o7R
    -- 1R3R0#18L2L,
    i9L <- wire -< o1R
    i9R <- wire -< o3R
    -- 8R4L0#16L2R,
    i10L <- wire -< o8R
    i10R <- wire -< o4L
    -- 8L7L0#15R6R,
    i11L <- wire -< o8L
    i11R <- wire -< o7L
    -- 6R0R0#14L0L,
    i12L <- wire -< o6R
    i12R <- wire -< o0R
    -- 6L4R0#14R0R,
    i13L <- wire -< o6L
    i13R <- wire -< o4R
    -- 12L13L0#17L1L,
    i14L <- wire -< o12L
    i14R <- wire -< o13L
    -- 5R11L0#16R4L,
    i15L <- wire -< o5R
    i15R <- wire -< o11L
    -- 10L15L0#17R7R,
    i16L <- wire -< o10L
    i16R <- wire -< o15L
    -- 14L16L0#18R3R,
    i17L <- wire -< o14L
    i17R <- wire -< o16L
    -- 9L17L0#19R5R,
    i18L <- wire -< o9L
    i18R <- wire -< o17L
    -- X18L0#X7L:
    i19R <- wire -< o18L
    -- 19L
    let o = o19L
  returnA -< o

serverInput, inputForKey :: [Int]
serverInput = [0,1,2,0,2,1,0,1,2,1,0,2,0,1,2,0,2]
inputForKey = [0,2,2,2,2,2,2,0,2,1,0,1,1,0,0,1,1]

key = simulate keyCircuit inputForKey
-- [1,1,0,2,1,2,1,0,1,1,2,1,0,1,2,2,1]