{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeOperators, TypeSynonymInstances #-}
module Sham where

import Hardware.Chalk
import Control.Applicative
import qualified Hardware.Chalk.Combinators (zip)
import Control.Monad (liftM2)
import Data.GraphViz hiding (Component)
import Data.Unique
import Control.Monad.Writer
import Data.Typeable
import System.Directory
import Test.QuickCheck
import Data.Stream (Stream (..), unfold, (<:>))
import qualified Data.Stream (zip,take, zipWith,repeat)

data Reg = R0 | R1 | R2 | R3 deriving (Show, Eq, Read, Typeable)

type Regs = (Int, Int, Int, Int)   

data Cmd = ADD | SUB | INC deriving (Show, Eq, Read, Typeable)

instance Show (Signal a) where
  show x = "Some signal"

instance Arbitrary Cmd where
  arbitrary = oneof (map return [ADD, SUB, INC])

instance Arbitrary Reg where
  arbitrary= oneof (map return [R0, R1, R2, R3])

instance Arbitrary a => Arbitrary (Signal a) where
  arbitrary = liftM2 delay arbitrary arbitrary

initRegs :: Regs
initRegs = (0,0,0,0)

regFile ::
  Signal Reg                    -- write port
  -> Signal Int                 -- write val
  -> Signal Reg                 -- first read port
  -> Signal Reg                 -- second read port
  -> Signal (Int, Int)          -- read port outputs and next state
regFile wr val rd1 rd2 = component "RegisterFile" $
  loop (pure regStep <*> wr <*> val <*> rd1 <*> rd2) initRegs

regStep :: Reg -> Int -> Reg -> Reg -> Regs -> ((Int, Int), Regs)
regStep wr x rd1 rd2 regs =
  let regs' = updateReg (wr,x) regs
  in ((lookupReg rd1 regs', lookupReg rd2 regs'), regs')  

updateReg (R0,x) (a,b,c,d) = (x,b,c,d)
updateReg (R1,x) (a,b,c,d) = (a,x,c,d)
updateReg (R2,x) (a,b,c,d) = (a,b,x,d)
updateReg (R3,x) (a,b,c,d) = (a,b,c,x)

lookupReg R0 (a,b,c,d) = a
lookupReg R1 (a,b,c,d) = b
lookupReg R2 (a,b,c,d) = c
lookupReg R3 (a,b,c,d) = d

alu :: Signal Cmd -> Signal (Int, Int) -> Signal Int
alu cmds (xys) = component "ALU" (pure interpret <*> cmds <*> xys)
  where
  interpret ADD (x,y) = x + y
  interpret SUB (x,y) = x - y
  interpret INC (x,_) = x + 1

sham :: Signal Cmd -> Signal Reg -> Signal Reg -> Signal Reg 
  -> (Signal Reg, Signal Int)
sham cmd dest srcA srcB = (dest' , aluOutput')
  where
  aluInputs = regFile dest' aluOutput' srcA srcB
  aluOutput = alu cmd aluInputs
  aluOutput' = delay 0 aluOutput
  dest' = delay R0 dest

test :: Signal (Reg, Int)
test = 
  let cmds = input "Commands" 
      dests = input "Destination Register" 
      srcA = input "Source Register B" 
      srcB = input "Source Register A" 
  in component "SHAM" $ Hardware.Chalk.Combinators.zip $ sham cmds dests srcA srcB

aluTest :: Signal Int
aluTest = alu (input "CMDS" ) (input "REGS")



instance Show Unique where
  show u = show (hashUnique u)