Advent of Code 2020 day08

Main.hs

module Main where

import Data.Char ( toUpper )

main :: IO ()
main = print . finalAcc . run . load . map toUpper . filter ('+' /=) =<< readFile "day08.txt"

finalAcc :: [VMState] -> Acc
finalAcc states = case last states of
    vm -> _acc vm

type Code = (OP, Arg)
data OP = NOP | ACC | JMP deriving (Eq, Show, Read)

type Arg = Int

type Offset = Int

type Mem = ([Code], Code, [Code])
derefPC :: Mem -> Code
derefPC (_, c, _) = c

type Acc = Int

type Count = Int

type Output = String
type Err = String
type Trace = [Count]

data VMState 
    = VMState { _mem :: Mem, _acc :: Acc, _pc  :: Count, _out :: Output, _trc :: Trace }

isFinalState :: VMState -> Bool
isFinalState vm = not (null (_out vm))

load :: String -> VMState
load src = case map toCode (lines src) of
    h : t -> VMState { _mem = ([], h, t), _acc = 0, _pc  = 1, _out = "", _trc = [] }

toCode :: String -> Code
toCode ln = case words ln of
    op : num : _ -> (read op, read num)

run :: VMState -> [VMState]
run vm = vm : if isFinalState vm then [] else run (step vm)

step :: VMState -> VMState
step vm = execute (decode (fetch vm)) vm

fetch :: VMState -> Code
fetch vm = derefPC (_mem vm)

decode :: Code -> (VMState -> VMState)
decode code = case code of
        (NOP, arg) -> nop arg
        (ACC, arg) -> acc arg
        (JMP, arg) -> jmp arg

nop :: Arg -> (VMState -> VMState)
nop _ vm = case _mem vm of
    (hs,c,t:ts)
        | _pc vm `elem` _trc vm -> vm { _out = "Loop!" }
        | otherwise -> vm { _mem = (c:hs, t, ts), _pc  = succ (_pc vm), _trc = _pc vm : _trc vm }
    _ -> vm { _out = "End of Program" }

acc :: Arg -> (VMState -> VMState)
acc a vm = case _mem vm of
    (hs,c,t:ts)
        | _pc vm `elem` _trc vm -> vm { _out = "Loop!" }
        | otherwise -> vm { _mem = (c:hs, t, ts), _acc = a + _acc vm
                          , _pc = succ (_pc vm), _trc = _pc vm : _trc vm }
    _ -> vm { _acc = a + _acc vm, _out = "EOP" }

jmp :: Arg -> (VMState -> VMState)
jmp a vm = case _mem vm of
    (hs,c,ts)
        | _pc vm `elem` _trc vm -> vm { _out = "Loop!" }
        | otherwise -> case compare a 0 of
            EQ -> vm {_out = "Loop!" }
            GT  -> case splitAt (pred a) ts of
                      (_, []) -> vm { _out = "Exceed EOP!" }
                      (ts',c':ts'') -> vm { _mem = (foldl (flip (:)) (c:hs) ts',c',ts'')
                                          , _pc = a + _pc vm, _trc = _pc vm : _trc vm }
            LT -> case splitAt (pred (abs a)) hs of
                      (_, []) -> vm { _out = "Exceed SOP!" }
                      (hs',c':hs'') -> vm { _mem = (hs'',c',foldl (flip (:)) (c:ts) hs')
                                          , _pc = a + _pc vm, _trc = _pc vm : _trc vm }

execute :: (VMState -> VMState) -> VMState -> VMState
execute = id