Create a gist now

Instantly share code, notes, and snippets.

Some solution, still debug or (de)compile are missing.
{-# LANGUAGE LambdaCase #-}
module Main where
import qualified Data.IntMap.Strict as M
import Data.Word
import Data.Char
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State.Lazy
import qualified Data.Binary as DB
import qualified Data.ByteString.Lazy as BS
import Data.Bits
data Machine = Machine
{ mem :: M.IntMap Word16
, stack :: [Word16]
, ip :: Word16
, input :: String
}
type Syn = State Machine
run :: Machine -> String
run m = evalState (run') m
data OP = OP
{ opcode :: Word16
, desc :: String
, leng :: Word16
, code :: Syn String
}
microcode :: [OP]
microcode =
[ OP 0 "halt" 1 (nope)
, OP 1 "set" 3 (store <$> getMem 1 <*$> getValue 2 >> runN 3)
, OP 2 "push" 2 (push <$$> getValue 1 >> runN 2)
, OP 3 "pop" 2 (pop >>= \case Just v -> store <$> getMem 1 <*$> pure v >> runN 2; Nothing -> (error "empty stack") )
, OP 4 "eq" 4 (do b <- getValue 2; c <- getValue 3; store <$> getMem 1 <*$> pure (if b == c then 1 else 0); runN 4)
, OP 5 "gt" 4 (do b <- getValue 2; c <- getValue 3; store <$> getMem 1 <*$> pure (if b > c then 1 else 0); runN 4)
, OP 6 "jmp" 2 (setip <$$> getValue 1 >> run')
, OP 7 "jt" 3 (do a <- getValue 1; if (a/=0) then (setip <$$> getValue 2 >> run') else runN 3)
, OP 8 "jf" 3 (do a <- getValue 1; if (a==0) then (setip <$$> getValue 2 >> run') else runN 3)
, OP 9 "add" 4 (store <$> getMem 1 <*$> ( (`mod` 32768) <$> ((+) <$> getValue 2 <*> getValue 3)) >> runN 4)
, OP 10 "mult" 4 (store <$> getMem 1 <*$> ( (`mod` 32768) <$> ((*) <$> getValue 2 <*> getValue 3)) >> runN 4)
, OP 11 "mod" 4 (store <$> getMem 1 <*$> (mod <$> getValue 2 <*> getValue 3) >> runN 4)
, OP 12 "and" 4 (store <$> getMem 1 <*$> ((.&.) <$> getValue 2 <*> getValue 3) >> runN 4)
, OP 13 "or" 4 (store <$> getMem 1 <*$> ((.|.) <$> getValue 2 <*> getValue 3) >> runN 4)
, OP 14 "not" 3 (store <$> getMem 1 <*$> ((.&. 32767) . complement <$> getValue 2) >> runN 3)
, OP 15 "rmem" 3 (store <$> getMem 1 <*$> (retrive <$$> getValue 2) >> runN 3)
, OP 16 "wmem" 3 (store <$> getValue 1 <*$> getValue 2 >> runN 3)
, OP 17 "call" 2 (push . (+2) <$$> gets ip >> setip <$$> getValue 1 >> run')
, OP 18 "ret" 1 ((\case Just v -> setip v >> run'; Nothing -> nope) <$$> pop )
, OP 19 "in" 2 ((:) <$> (chr . fromIntegral <$> getValue 1) <*> runN 2)
, OP 20 "out" 2 (store <$> getMem 1 <*$> getCh >> runN 2)
, OP 21 "nope" 1 (runN 1)
]
infixl 4 <$$>, <*$>
(<$$>):: (Monad f, Functor f) => (a -> f b) -> f a -> f b
(<$$>) a b = join $ a <$> b
(<*$>) :: (Monad f, Functor f) => f (a -> f b) -> f a -> f b
(<*$>) a b = do { x1 <- a; x2 <- b; x1 x2 }
run' :: Syn String
run' = do
i <- getMem 0
code (microcode !! fromEnum i)
runN :: Word16 -> Syn String
runN i = incip i >> run'
getCh :: Syn Word16
getCh = do
(c:input') <- gets input
modify $ \s -> s{input = input'}
return $ fromIntegral $ ord c
push :: Word16 -> Syn ()
push v = modify $ \s -> s{stack = v : stack s}
pop :: Syn (Maybe Word16)
pop = do
v <-gets stack
if null v
then return Nothing
else do
modify $ \s -> s{stack = tail( stack s)}
return $ Just $ head v
getValue :: Word16 -> Syn Word16
getValue n = do
i <- getMem n
if (i > 32767)
then (retrive i)
else (return i)
retrive :: Word16 -> Syn Word16
retrive addr = (M.findWithDefault 0 (fromIntegral addr)) <$> gets mem
store :: Word16 -> Word16 -> Syn ()
store addr value = modify $ \s -> s{mem = M.insert (fromIntegral addr) value (mem s)}
nope :: Syn String
nope = return ""
load :: [Word16] -> String -> Machine
load prog i = Machine (M.fromAscList $ zip [0..] prog) [] 0 i
incip :: Word16 -> Syn ()
incip n = modify $ \s -> s{ip = ip s + n}
setip :: Word16 -> Syn ()
setip c = modify $ \s -> s{ip = c}
getMem :: Word16 -> Syn Word16
getMem offset = (M.findWithDefault 0) <$> gets (fromIntegral . (+offset) . ip) <*> gets mem
decodee :: BS.ByteString -> [Word16]
decodee bs = if BS.null bs then [] else let b2 = (BS.take 2 bs) in (DB.decode $ BS.pack [ b2 `BS.index` 1 , BS.head b2] ) : decodee (BS.drop 2 bs)
main::IO()
main = do
ma <- decodee <$> BS.readFile "challenge.bin"
inp <- getContents
putStrLn $ run (load ma inp)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment