{-# OPTIONS -w #-}
module InstructionSet where

import Data.Word
import Data.Bits
import Data.Ix

type UInt32 = Word32
type UInt8 = Word8

newtype Reg = Reg UInt8
    deriving (Eq, Ord, Ix, Show, Num, Enum, Real, Integral)

data RegPos = RegA | RegB | RegC

-- registers are always ordered alphabetically
data Instruction =
      CMove !Reg !Reg !Reg      -- conditional move
    | ArrI  !Reg !Reg !Reg      -- array index
    | ArrA  !Reg !Reg !Reg      -- array amendment
    | Add   !Reg !Reg !Reg      -- addition
    | Mult  !Reg !Reg !Reg      -- multiplication
    | Div   !Reg !Reg !Reg      -- division
    | NAnd  !Reg !Reg !Reg      -- not-and
    | Halt                      -- stop computation
    | Alloc !Reg !Reg           -- a new empty array is created
    | Aband !Reg                -- abandon an array, its ident can now be reused
    | Outp  !Reg                -- output, display to the console , uint8 0..255 incl
    | Inp   !Reg                -- wait for input
    | Load  !Reg !Reg           -- load program.
    | Ortho !Reg !UInt32        -- load immediately (?)
    deriving (Eq, Show)

extrReg :: UInt32 -> RegPos -> Reg
extrReg i pos = i `seq` pos `seq`
  let i' = case pos of
             RegA -> shiftR i 6
             RegB -> shiftR i 3
             _ -> i
      mask :: UInt32 = 7      -- 0...0111
  in Reg (toUInt8 $ i' .&. mask)
{-# INLINE extrReg #-}

mkReg :: Integral a => a -> Reg
mkReg i = Reg (toUInt8 i)
{-# INLINE mkReg #-}

minReg, maxReg :: Reg
minReg = Reg (toUInt8 (0 :: Int))
maxReg = Reg (toUInt8 (7 :: Int))

toUInt8 :: Integral a => a -> UInt8
toUInt8 i = fromIntegral i
{-# INLINE toUInt8 #-}

toUInt32 :: Integral a => a -> UInt32
toUInt32 i = fromIntegral i
{-# INLINE toUInt32 #-}

--
-- Decode a UInt32 to an instruction.
--
{-# INLINE decode #-}
decode :: UInt32 -> Instruction
decode i | i `seq` False = undefined
decode i =
  let opcode = shiftR i 28
  in case () of
      _| opcode <= 6  -> decodeBasicOperator opcode
       | opcode <= 12 -> decodeOtherOperator opcode
       | opcode == 13 -> decodeOrthography
  where
      decodeBasicOperator :: UInt32 -> Instruction
      decodeBasicOperator opcode = opcode `seq`
        let instr = case opcode of
                      0 -> CMove
                      1 -> ArrI
                      2 -> ArrA
                      3 -> Add
                      4 -> Mult
                      5 -> Div
                      6 -> NAnd
        in instr (extrReg i RegA)
                 (extrReg i RegB)
                 (extrReg i RegC)

      decodeOtherOperator :: UInt32 -> Instruction
      decodeOtherOperator opcode = opcode `seq`
        case opcode of
          7 -> Halt
          8 -> Alloc (extrReg i RegB)
                     (extrReg i RegC)
          9 -> Aband (extrReg i RegC)
          10 -> Outp (extrReg i RegC)
          11 -> Inp (extrReg i RegC)
          12 -> Load (extrReg i RegB)
                     (extrReg i RegC)

      decodeOrthography :: Instruction
      decodeOrthography =
        let mask = (2 `shiftL` 24) - 1   -- 00000001...1
            val = i .&. mask
            regA = Reg . toUInt8 $ shiftR i 25 .&. 7
        in Ortho regA val

---------

-- instrBitString
instrBits :: UInt32 -> String
instrBits n = n `seq` padWithZeros (uint32ToBits n)
{-# INLINE instrBits #-}

padWithZeros :: String -> String
padWithZeros str =
  let len = 32 - length str
  in take len (repeat '0') ++ str
{-# INLINE padWithZeros #-}

uint32ToBits :: UInt32 -> String
uint32ToBits n = n `seq` reverse (uint32ToBits' n)
  where
    uint32ToBits' 0 = ""
    uint32ToBits' m
        | m `mod` 2 == 0 = '0':next
        | otherwise      = '1':next
        where next = uint32ToBits' (m `div` 2)
{-# INLINE uint32ToBits #-}