--- /dev/null
+{
+ "cells": [
+ {
+ "cell_type": "code",
+ "execution_count": 47,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "{-# LANGUAGE NegativeLiterals #-}\n",
+ "{-# LANGUAGE FlexibleContexts #-}\n",
+ "{-# LANGUAGE OverloadedStrings #-}\n",
+ "{-# LANGUAGE TypeFamilies #-}"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 48,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "-- import Prelude hiding ((++))\n",
+ "import Data.Text (Text)\n",
+ "import qualified Data.Text as T\n",
+ "import qualified Data.Text.IO as TIO\n",
+ "\n",
+ "import Text.Megaparsec hiding (State)\n",
+ "import qualified Text.Megaparsec.Lexer as L\n",
+ "import Text.Megaparsec.Text (Parser)\n",
+ "import qualified Control.Applicative as CA\n",
+ "\n",
+ "import qualified Data.Map.Strict as M\n",
+ "import Data.Map.Strict ((!))\n",
+ "\n",
+ "import Control.Monad (when)\n",
+ "import Control.Monad.State.Lazy\n",
+ "import Control.Monad.Reader\n",
+ "import Control.Monad.Writer"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 49,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "data Location = Literal Integer | Register Char deriving (Show, Eq)\n",
+ "data Instruction = Snd Location\n",
+ " | Set Location Location \n",
+ " | Add Location Location \n",
+ " | Mul Location Location\n",
+ " | Mod Location Location\n",
+ " | Rcv Location\n",
+ " | Jgz Location Location\n",
+ " deriving (Show, Eq)\n",
+ "\n",
+ "data Machine = Machine { registers :: M.Map Char Integer\n",
+ " , lastSound :: Integer\n",
+ " , pc :: Int\n",
+ " } \n",
+ " deriving (Show, Eq)\n",
+ "\n",
+ "type ProgrammedMachine = WriterT [Integer] (ReaderT [Instruction] (State Machine)) ()"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 50,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "emptyMachine = Machine {registers = M.empty, lastSound = 0, pc = 0}"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 51,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "sc :: Parser ()\n",
+ "sc = L.space (skipSome spaceChar) CA.empty CA.empty\n",
+ "\n",
+ "lexeme = L.lexeme sc\n",
+ "\n",
+ "integer = lexeme L.integer\n",
+ "signedInteger = L.signed sc integer\n",
+ "\n",
+ "symb = L.symbol sc\n",
+ "\n",
+ "-- reg :: Parser String\n",
+ "-- reg = id <$> some letterChar\n",
+ "\n",
+ "reg = lexeme (some letterChar)\n",
+ "\n",
+ "location = (Literal <$> signedInteger) <|> register\n",
+ "register = (Register . head) <$> reg\n",
+ "\n",
+ "instructionsP = instructionP `sepBy` space\n",
+ "instructionP = choice [sndP, setP, addP, mulP, modP, rcvP, jgzP]\n",
+ "\n",
+ "sndP = Snd <$> (try (symb \"snd\") *> location)\n",
+ "setP = Set <$> (try (symb \"set\") *> register) <*> location\n",
+ "addP = Add <$> (try (symb \"add\") *> register) <*> location\n",
+ "mulP = Mul <$> (try (symb \"mul\") *> register) <*> location\n",
+ "modP = Mod <$> (try (symb \"mod\") *> register) <*> location\n",
+ "rcvP = Rcv <$> (try (symb \"rcv\") *> location)\n",
+ "jgzP = Jgz <$> (try (symb \"jgz\") *> location) <*> location\n",
+ "\n",
+ "successfulParse :: Text -> [Instruction]\n",
+ "successfulParse input = \n",
+ " case parse instructionsP \"input\" input of\n",
+ " Left _error -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err\n",
+ " Right instructions -> instructions"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 52,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "sample = T.pack \"set a 1\\nadd a 2\\nmul a a\\nmod a 5\\nsnd a\\nset a 0\\nrcv a\\njgz a -1\\nset a 1\\njgz a -2\""
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 53,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/plain": [
+ "[Set (Register 'a') (Literal 1),Add (Register 'a') (Literal 2),Mul (Register 'a') (Register 'a'),Mod (Register 'a') (Literal 5),Snd (Register 'a'),Set (Register 'a') (Literal 0),Rcv (Register 'a'),Jgz (Register 'a') (Literal (-1)),Set (Register 'a') (Literal 1),Jgz (Register 'a') (Literal (-2))]"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ }
+ ],
+ "source": [
+ "successfulParse sample"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 54,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/plain": [
+ "[Set (Register 'a') (Literal 1),Add (Register 'a') (Literal 2),Mul (Register 'a') (Register 'a'),Mod (Register 'a') (Literal 5),Snd (Register 'a'),Set (Register 'a') (Literal 0),Rcv (Register 'a'),Jgz (Register 'a') (Literal (-1)),Set (Register 'a') (Literal 1),Jgz (Register 'a') (Literal (-2))]"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ }
+ ],
+ "source": [
+ "sampleInstructions = successfulParse sample\n",
+ "sampleInstructions"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 55,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "evaluate :: Machine -> Location -> Integer\n",
+ "evaluate _ (Literal i) = i\n",
+ "evaluate m (Register r) = M.findWithDefault 0 r (registers m)"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 56,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "applyInstruction :: Instruction -> Machine -> Machine\n",
+ "\n",
+ "applyInstruction (Snd sound) m = m {lastSound = freq, pc = pc'}\n",
+ " where pc' = pc m + 1\n",
+ " freq = evaluate m sound\n",
+ "\n",
+ "applyInstruction (Set (Register a) b) m = m {registers = reg', pc = pc'}\n",
+ " where pc' = pc m + 1\n",
+ " y = evaluate m b\n",
+ " reg' = M.insert a y $ registers m\n",
+ "\n",
+ "applyInstruction (Add (Register a) b) m = m {registers = reg', pc = pc'}\n",
+ " where pc' = pc m + 1\n",
+ " x = evaluate m (Register a) \n",
+ " y = evaluate m b\n",
+ " reg' = M.insert a (x + y) $ registers m\n",
+ "\n",
+ "applyInstruction (Mul (Register a) b) m = m {registers = reg', pc = pc'}\n",
+ " where pc' = pc m + 1\n",
+ " x = evaluate m (Register a) \n",
+ " y = evaluate m b\n",
+ " reg' = M.insert a (x * y) $ registers m\n",
+ "\n",
+ "applyInstruction (Mod (Register a) b) m = m {registers = reg', pc = pc'}\n",
+ " where pc' = pc m + 1\n",
+ " x = evaluate m (Register a) \n",
+ " y = evaluate m b\n",
+ " reg' = M.insert a (x `mod` y) $ registers m\n",
+ "\n",
+ "applyInstruction (Rcv a) m = m {pc = pc'}\n",
+ " where pc' = pc m + 1\n",
+ " \n",
+ "applyInstruction (Jgz a b) m = m {pc = pc'}\n",
+ " where x = evaluate m a\n",
+ " y = evaluate m b\n",
+ " pc' = if x > 0 then pc m + (fromIntegral y) else pc m + 1"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 57,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "executeInstruction :: ProgrammedMachine\n",
+ "executeInstruction =\n",
+ " do instrs <- ask\n",
+ " m <- get\n",
+ " let instr = instrs!!(pc m)\n",
+ "-- tell [(\"pc = \" ++ show (pc m))]\n",
+ " put (applyInstruction instr m)"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 58,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "isRecover :: Instruction -> Bool\n",
+ "isRecover (Rcv _) = True\n",
+ "isRecover _ = False"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 59,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "-- handleRecover :: ProgrammedMachine\n",
+ "-- handleRecover = \n",
+ "-- do instrs <- ask\n",
+ "-- m <- get\n",
+ "-- let instr = instrs!!(pc m)\n",
+ "-- when (isReceive instr)\n",
+ "-- $\n",
+ "-- do let Rcv a = instr\n",
+ "-- let x = evaluate m a\n",
+ "-- when (x /= 0) (tell ([\"reccovering \" ++ (show (lastSound m))]))"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 60,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "recoverTriggers :: [Instruction] -> Machine -> Bool\n",
+ "recoverTriggers instrs m = \n",
+ " if isRecover instr\n",
+ " then (x /= 0)\n",
+ " else False\n",
+ " where instr = instrs!!(pc m)\n",
+ " Rcv a = instr\n",
+ " x = evaluate m a"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 61,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "executeInstructions = \n",
+ " do instrs <- ask\n",
+ " m <- get\n",
+ "-- tell [\"instrs = \" ++ (show instrs)]\n",
+ " when (pc m >= 0 && pc m < length instrs)\n",
+ " $\n",
+ " do let rt = recoverTriggers instrs m\n",
+ " if rt\n",
+ " then tell [lastSound m]\n",
+ " else do executeInstruction\n",
+ " executeInstructions"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "metadata": {},
+ "outputs": [],
+ "source": []
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 62,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/plain": [
+ "(((),[4]),Machine {registers = fromList [('a',1)], lastSound = 4, pc = 6})"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ }
+ ],
+ "source": [
+ "runState (runReaderT (runWriterT executeInstructions) sampleInstructions ) emptyMachine"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 63,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/plain": [
+ "(((),[]),Machine {registers = fromList [('a',0)], lastSound = 4, pc = 7})"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ }
+ ],
+ "source": [
+ "runState (\n",
+ " runReaderT (\n",
+ " runWriterT executeInstructions\n",
+ " ) \n",
+ " (take 7 sampleInstructions) \n",
+ " ) \n",
+ " emptyMachine"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 64,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/plain": [
+ "[Set (Register 'a') (Literal 1),Add (Register 'a') (Literal 2),Mul (Register 'a') (Register 'a'),Mod (Register 'a') (Literal 5),Snd (Register 'a'),Set (Register 'a') (Literal 0),Rcv (Register 'a'),Jgz (Register 'a') (Literal (-1)),Set (Register 'a') (Literal 1),Jgz (Register 'a') (Literal (-2))]"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ }
+ ],
+ "source": [
+ "sampleInstructions"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 65,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "part1 instructions = \n",
+ " runState (\n",
+ " runReaderT (\n",
+ " runWriterT executeInstructions\n",
+ " ) \n",
+ " instructions \n",
+ " ) \n",
+ " emptyMachine"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 68,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "main :: IO ()\n",
+ "main = do \n",
+ " text <- TIO.readFile \"../../data/advent18.txt\"\n",
+ " let instrs = successfulParse text\n",
+ " let ((result, l), machinef) = part1 instrs\n",
+ " print $ head l\n",
+ "-- print $ part2 instrs"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 69,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/plain": [
+ "1187"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ }
+ ],
+ "source": [
+ "main"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "metadata": {},
+ "outputs": [],
+ "source": []
+ }
+ ],
+ "metadata": {
+ "kernelspec": {
+ "display_name": "Haskell",
+ "language": "haskell",
+ "name": "haskell"
+ },
+ "language_info": {
+ "codemirror_mode": "ihaskell",
+ "file_extension": ".hs",
+ "name": "haskell",
+ "version": "8.0.2"
+ }
+ },
+ "nbformat": 4,
+ "nbformat_minor": 2
+}
projects / advent-of-code-17.git / blobdiff