{-# OPTIONS_GHC -package mtl -cpp #-}

-- Compile as follows:
--  ghc --make -o UniversalMachine UniversalMachine.hs -cpp
--  ghc --make -O2 -o um-prof -prof -auto-all UniversalMachine.hs

-- for i386 architectures:
--  gcc -c swap.c -O2
--  ghc --make -o UniversalMachine UniversalMachine.hs -Di386_TARGET_ARCH -cpp -O2 swap.o

-- TODO: architecture detection

import Control.Monad
import Data.Bits
import Data.Char
import System.IO
import System.Environment
import MachineState

--Key    (\b.bb)(\v.vv)06AAWIWZ1P2GRZcZPr
main :: IO ()
main =  do
  args <- getArgs
  case args of 
     [file] -> 
        do load file
           spin
     _ -> 
        putStrLn "Use: um <codex>"

load :: String -> IO ()
load file = do
  isState <- checkIsState file
  if isState then loadState file else do
    pa  <- readCodex file
    putProgram pa

toChar :: Platter -> Char
toChar =  chr . toInt

toPlatter :: Char -> Platter
toPlatter =  fromInteger . toInteger . ord

toInt :: Platter -> Int
toInt =  fromInteger . toInteger

readInput :: IO Platter
readInput =  do
  c <- getChar
  -- if it is magic key '?' we proceed to save
  if c == '?' then do -- check again
    c <- getChar
    if c == '?' then do -- now we save
      retreatFinger
      saveState "current.st"
      advanceFinger
      putStrLn "UM: Current state stored in current.st"
      readInput -- Collect the key again
     else return (toPlatter '?') -- we lose the second character
   else return (toPlatter c)

writeOutput   :: Platter -> IO ()
writeOutput p = putStr txt >> hFlush stdout
 where txt = [toChar p]

data Operator = ConditionalMove !RegisterId !RegisterId !RegisterId
              | ArrayIndex      !RegisterId !RegisterId !RegisterId
              | ArrayAmendment  !RegisterId !RegisterId !RegisterId
              | Addition        !RegisterId !RegisterId !RegisterId
              | Multiplication  !RegisterId !RegisterId !RegisterId
              | Division        !RegisterId !RegisterId !RegisterId
              | NotAnd          !RegisterId !RegisterId !RegisterId
              | Halt
              | Allocation                  !RegisterId !RegisterId
              | Abandonment                             !RegisterId
              | Output                                  !RegisterId
              | Input                                   !RegisterId
              | LoadProgram                RegisterId   !RegisterId
              | Orthography                                !RegisterId !Platter

toOperator   :: Platter -> Operator
toOperator p =  let op = shiftR p 28
                    a  = shiftR p  6 .&. 7
                    b  = shiftR p  3 .&. 7
                    c  =        p    .&. 7
                    d  = shiftR p 25 .&. 7
                    v  =        p    .&. 0x1ffffff
                in  case op of
  0  -> ConditionalMove a b c
  1  -> ArrayIndex      a b c
  2  -> ArrayAmendment  a b c
  3  -> Addition        a b c
  4  -> Multiplication  a b c
  5  -> Division        a b c
  6  -> NotAnd          a b c
  7  -> Halt
  8  -> Allocation        b c
  9  -> Abandonment         c
  10 -> Output              c
  11 -> Input               c
  12 -> LoadProgram       b c
  13 -> Orthography           d v
  _  -> error "unknown operator number"

spin :: IO ()
spin = do
   -- for debugging
   -- when (n >= 10000000) $ error "Stop spinning"
   -- when (n `mod` 10000000 == 0) $ putStrLn $ "cycle " ++ show (n `div` 1000000) ++ " million..."
   
   -- perform next operation
   p <- getCurrentPlatter
   advanceFinger
   performCycle (toOperator p)

   -- go to the next cycle or stop
   b <- isHalted
   unless b spin
 
performCycle    :: Operator -> IO ()
performCycle op =  case op of

  ConditionalMove a b c -> do
    rv <- getRegister b
    p  <- getRegister c
    if p == 0
       then return ()
       else putRegister a rv

  ArrayIndex a b c -> do
    aid <- getRegister b
    j   <- getRegister c
    rv  <- indexArray aid j
    putRegister a rv

  ArrayAmendment a b c -> do
    aid <- getRegister a
    j   <- getRegister b
    p   <- getRegister c
    ammendArray aid j p

  Addition a b c -> do
    p1 <- getRegister b
    p2 <- getRegister c
    putRegister a (p1 + p2)

  Multiplication a b c -> do
    p1 <- getRegister b
    p2 <- getRegister c
    putRegister a (p1 * p2)

  Division a b c -> do
    p1 <- getRegister b
    p2 <- getRegister c
    putRegister a (p1 `div` p2)

  NotAnd a b c -> do
    p1 <- getRegister b
    p2 <- getRegister c
    putRegister a (complement $ p1 .&. p2)

  Halt -> halt

  Allocation b c -> do
    p   <- getRegister c
    aid <- allocateArray p
    putRegister b aid

  Abandonment c -> do
     p   <- getRegister c
     deallocateArray p

  Output c -> do
    p <- getRegister c
    writeOutput p

  Input c -> do
    p <- readInput
    putRegister c p

  LoadProgram b c -> do
    aid <- getRegister b
    j   <- getRegister c
    loadProgram aid j

  Orthography d v -> do
    putRegister d v