import Prelude
import System.Environment
import Data.Array

type Memory = [Int]

data Registers = Registers { pc :: Int,
                             is :: Int,
                             r0 :: Int,
                             r1 :: Int
                           } deriving (Show)

type State = (Memory, Registers)

emptyMem ::     Int -> Memory
emptyMem size = take size $ repeat 0

constructMem :: [String] -> Memory
constructMem s = constructMemFromString s 16

constructMemFromString ::            [String] -> Int -> Memory
constructMemFromString code size = (take size (map (constrain . read) code)) ++ emptyMem (size - length code)

setMemVal :: Memory -> Int -> Int -> Memory
setMemVal (x:xs) i v
   | i == 0    = [v] ++ xs
   | otherwise = x:(setMemVal xs (i-1) v)

getMemVal :: Memory -> Int -> Int
getMemVal m v = m !! v

constructRegisters = (Registers 0 0 0 0)

getPC :: Registers -> Int
getPC (Registers pc _ _ _) = pc

constrain :: Int -> Int
constrain x = mod x 16

add (m, Registers pc is r0 r1 ) =
   return $ (m, Registers (constrain (pc + 1)) (getMemVal m pc) (constrain (r0 + r1)) r1)

sub (m, Registers pc is r0 r1 ) =
   return $ (m, Registers (constrain (pc + 1)) (getMemVal m pc) (constrain (r0 - r1)) r1)

incR0 (m, Registers pc is r0 r1 ) =
   return $ (m, Registers (constrain (pc + 1)) (getMemVal m pc) (constrain (r0 + 1)) r1)

incR1 (m, Registers pc is r0 r1 ) =
   return $ (m, Registers (constrain (pc + 1)) (getMemVal m pc) r0 (constrain (r1 + 1)))

decR0 (m, Registers pc is r0 r1 ) =
   return $ (m, Registers (constrain (pc + 1)) (getMemVal m pc) (constrain (r0 - 1)) r1)

decR1 (m, Registers pc is r0 r1 ) =
   return $ (m, Registers (constrain (pc + 1)) (getMemVal m pc) r0 (constrain (r1 - 1)))

ding (m, Registers pc is r0 r1 ) = do {
   putStrLn "DING!";
   return $ (m, Registers (constrain (pc + 1)) (getMemVal m pc) r0 r1);
}

out (m, Registers pc is r0 r1 ) = do {
   putStrLn $ show $ getMemVal m (constrain (pc + 1));
   return $ (m, Registers (constrain (pc + 2)) (getMemVal m pc) r0 r1);
}

loadR0 (m, Registers pc is r0 r1 ) =
   return $ (m, Registers (constrain (pc + 2)) (getMemVal m pc) (getMemVal m (getMemVal m (constrain (pc + 1)))) r1)

loadR1 (m, Registers pc is r0 r1 ) =
   return $ (m, Registers (constrain (pc + 2)) (getMemVal m pc) r0 (getMemVal m (getMemVal m (constrain (pc + 1)))))

storeR0 (m, Registers pc is r0 r1 ) =
   return $ (setMemVal m (getMemVal m (constrain (pc + 1))) r0, Registers (constrain (pc + 2)) (getMemVal m pc) r0 r1)

storeR1 (m, Registers pc is r0 r1 ) =
   return $ (setMemVal m (getMemVal m (constrain (pc + 1))) r1, Registers (constrain (pc + 2)) (getMemVal m pc) r0 r1)

jmp (m, Registers pc is r0 r1 ) =
   return $ (m, Registers (constrain (getMemVal m (pc + 1))) (getMemVal m pc) r0 r1)

jmpR0 (m, Registers pc is r0 r1 ) =
   return $ if r0 == 0 then (m, Registers (constrain (getMemVal m (pc + 1))) is r0 r1) else (m, Registers (pc + 1) (getMemVal m pc) r0 r1)

jmpNotR0 (m, Registers pc is r0 r1 ) =
   return $ if r0 /= 0 then (m, Registers (constrain (getMemVal m (pc + 1))) is r0 r1) else (m, Registers (pc + 1) (getMemVal m pc) r0 r1)

executeInstruction :: State -> Int -> IO State
executeInstruction s nis
   | nis == 1 = add s
   | nis == 2 = sub s
   | nis == 3 = incR0 s
   | nis == 4 = incR1 s
   | nis == 5 = decR0 s
   | nis == 6 = decR1 s
   | nis == 7 = ding s
   | nis == 8 = out s
   | nis == 9 = loadR0 s
   | nis == 10 = loadR1 s
   | nis == 11 = storeR0 s
   | nis == 12 = storeR1 s
   | nis == 13 = jmp s
   | nis == 14 = jmpR0 s
   | nis == 15 = jmpNotR0 s
   | otherwise = return s

fetchExecute :: State -> IO State
fetchExecute (m, r) = executeInstruction (m, r) (getMemVal m (getPC r))

run :: State -> IO()
run (m,r) = do
   if getMemVal m (getPC r) == 0 then return () else do {
      newState <- fetchExecute (m,r);
      run newState;
   }

main = do {
    args <- getArgs;
   run ((constructMem args), (constructRegisters))
}