module Language.ArrayForth.State where
import Data.Functor ((<$>))
import Data.Vector.Unboxed (Vector, (//))
import qualified Data.Vector.Unboxed as V
import Text.Printf (printf)
import Language.ArrayForth.NativeProgram
import Language.ArrayForth.Opcode (F18Word)
import Language.ArrayForth.Stack
type Memory = Vector Int
emptyMem :: Memory
emptyMem = V.replicate 64 0
data State =
State { a, b, i, p, r, s, t :: !F18Word
, dataStack, returnStack :: !Stack
, memory :: !Memory }
instance Show State where
show State {p, a, b, r, s, t, dataStack} =
printf "p:%s a:%s b:%s r:%s\n %s %s %s" p' a' b' r' t' s' (show dataStack)
where [p', a', b', r', s', t'] = map show [p, a, b, r, s, t]
startState :: State
startState = State 0 0 0 0 0 0 0 empty empty emptyMem
next :: State -> Instrs
next State {memory, p} = fromBits $ memory ! p
dpop :: State -> (State, F18Word)
dpop state@State {s, t, dataStack} =
let (ds', res) = pop dataStack in (state {t = s, s = res, dataStack = ds'}, t)
dpush :: State -> F18Word -> State
dpush state@State {s, t, dataStack} word =
state {t = word, s = t, dataStack = push dataStack s}
rpop :: State -> (State, F18Word)
rpop state@State {r, returnStack} =
let (rs', res) = pop returnStack in (state {r = res, returnStack = rs'}, r)
rpush :: State -> F18Word -> State
rpush state@State {r, returnStack} word =
state {r = word, returnStack = push returnStack r}
toMem :: (Integral a, Integral b) => a -> b
toMem = fromIntegral . (`mod` 64)
(!) :: Memory -> F18Word -> F18Word
memory ! i | toMem i < V.length memory = fromIntegral $ memory V.! toMem i
| otherwise = error "Memory out of bounds."
set :: Memory -> F18Word -> F18Word -> Memory
set mem index value = mem // [(toMem index, fromIntegral $ value)]
setProgram :: F18Word -> NativeProgram -> State -> State
setProgram start program state@State {memory} = state' {i = toBits $ next state'}
where state' = state {memory = memory // prog}
prog = zip [toMem start..] (fromIntegral . toBits <$> program)