src/advent18/advent18a.ipynb

   1 {
   2  "cells": [
   3   {
   4    "cell_type": "code",
   5    "execution_count": 47,
   6    "metadata": {},
   7    "outputs": [],
   8    "source": [
   9     "{-# LANGUAGE NegativeLiterals #-}\n",
  10     "{-# LANGUAGE FlexibleContexts #-}\n",
  11     "{-# LANGUAGE OverloadedStrings #-}\n",
  12     "{-# LANGUAGE TypeFamilies #-}"
  13    ]
  14   },
  15   {
  16    "cell_type": "code",
  17    "execution_count": 48,
  18    "metadata": {},
  19    "outputs": [],
  20    "source": [
  21     "-- import Prelude hiding ((++))\n",
  22     "import Data.Text (Text)\n",
  23     "import qualified Data.Text as T\n",
  24     "import qualified Data.Text.IO as TIO\n",
  25     "\n",
  26     "import Text.Megaparsec hiding (State)\n",
  27     "import qualified Text.Megaparsec.Lexer as L\n",
  28     "import Text.Megaparsec.Text (Parser)\n",
  29     "import qualified Control.Applicative as CA\n",
  30     "\n",
  31     "import qualified Data.Map.Strict as M\n",
  32     "import Data.Map.Strict ((!))\n",
  33     "\n",
  34     "import Control.Monad (when)\n",
  35     "import Control.Monad.State.Lazy\n",
  36     "import Control.Monad.Reader\n",
  37     "import Control.Monad.Writer"
  38    ]
  39   },
  40   {
  41    "cell_type": "code",
  42    "execution_count": 49,
  43    "metadata": {},
  44    "outputs": [],
  45    "source": [
  46     "data Location = Literal Integer | Register Char deriving (Show, Eq)\n",
  47     "data Instruction =   Snd Location\n",
  48     "                   | Set Location Location \n",
  49     "                   | Add Location Location \n",
  50     "                   | Mul Location Location\n",
  51     "                   | Mod Location Location\n",
  52     "                   | Rcv Location\n",
  53     "                   | Jgz Location Location\n",
  54     "                   deriving (Show, Eq)\n",
  55     "\n",
  56     "data Machine = Machine { registers :: M.Map Char Integer\n",
  57     "                       , lastSound :: Integer\n",
  58     "                       , pc :: Int\n",
  59     "                       } \n",
  60     "               deriving (Show, Eq)\n",
  61     "\n",
  62     "type ProgrammedMachine = WriterT [Integer] (ReaderT [Instruction] (State Machine)) ()"
  63    ]
  64   },
  65   {
  66    "cell_type": "code",
  67    "execution_count": 50,
  68    "metadata": {},
  69    "outputs": [],
  70    "source": [
  71     "emptyMachine = Machine {registers = M.empty, lastSound = 0, pc = 0}"
  72    ]
  73   },
  74   {
  75    "cell_type": "code",
  76    "execution_count": 51,
  77    "metadata": {},
  78    "outputs": [],
  79    "source": [
  80     "sc :: Parser ()\n",
  81     "sc = L.space (skipSome spaceChar) CA.empty CA.empty\n",
  82     "\n",
  83     "lexeme  = L.lexeme sc\n",
  84     "\n",
  85     "integer       = lexeme L.integer\n",
  86     "signedInteger = L.signed sc integer\n",
  87     "\n",
  88     "symb = L.symbol sc\n",
  89     "\n",
  90     "-- reg :: Parser String\n",
  91     "-- reg = id <$> some letterChar\n",
  92     "\n",
  93     "reg = lexeme (some letterChar)\n",
  94     "\n",
  95     "location = (Literal <$> signedInteger) <|> register\n",
  96     "register = (Register . head) <$> reg\n",
  97     "\n",
  98     "instructionsP = instructionP `sepBy` space\n",
  99     "instructionP = choice [sndP, setP, addP, mulP, modP, rcvP, jgzP]\n",
 100     "\n",
 101     "sndP = Snd <$> (try (symb \"snd\") *> location)\n",
 102     "setP = Set <$> (try (symb \"set\") *> register) <*> location\n",
 103     "addP = Add <$> (try (symb \"add\") *> register) <*> location\n",
 104     "mulP = Mul <$> (try (symb \"mul\") *> register) <*> location\n",
 105     "modP = Mod <$> (try (symb \"mod\") *> register) <*> location\n",
 106     "rcvP = Rcv <$> (try (symb \"rcv\") *> location)\n",
 107     "jgzP = Jgz <$> (try (symb \"jgz\") *> location) <*> location\n",
 108     "\n",
 109     "successfulParse :: Text -> [Instruction]\n",
 110     "successfulParse input = \n",
 111     "        case parse instructionsP \"input\" input of\n",
 112     "                Left  _error -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err\n",
 113     "                Right instructions  -> instructions"
 114    ]
 115   },
 116   {
 117    "cell_type": "code",
 118    "execution_count": 52,
 119    "metadata": {},
 120    "outputs": [],
 121    "source": [
 122     "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\""
 123    ]
 124   },
 125   {
 126    "cell_type": "code",
 127    "execution_count": 53,
 128    "metadata": {},
 129    "outputs": [
 130     {
 131      "data": {
 132       "text/plain": [
 133        "[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))]"
 134       ]
 135      },
 136      "metadata": {},
 137      "output_type": "display_data"
 138     }
 139    ],
 140    "source": [
 141     "successfulParse sample"
 142    ]
 143   },
 144   {
 145    "cell_type": "code",
 146    "execution_count": 54,
 147    "metadata": {},
 148    "outputs": [
 149     {
 150      "data": {
 151       "text/plain": [
 152        "[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))]"
 153       ]
 154      },
 155      "metadata": {},
 156      "output_type": "display_data"
 157     }
 158    ],
 159    "source": [
 160     "sampleInstructions = successfulParse sample\n",
 161     "sampleInstructions"
 162    ]
 163   },
 164   {
 165    "cell_type": "code",
 166    "execution_count": 55,
 167    "metadata": {},
 168    "outputs": [],
 169    "source": [
 170     "evaluate :: Machine -> Location -> Integer\n",
 171     "evaluate _ (Literal i)  = i\n",
 172     "evaluate m (Register r) = M.findWithDefault 0 r (registers m)"
 173    ]
 174   },
 175   {
 176    "cell_type": "code",
 177    "execution_count": 56,
 178    "metadata": {},
 179    "outputs": [],
 180    "source": [
 181     "applyInstruction :: Instruction -> Machine -> Machine\n",
 182     "\n",
 183     "applyInstruction (Snd sound) m = m {lastSound = freq, pc = pc'}\n",
 184     "    where pc' = pc m + 1\n",
 185     "          freq = evaluate m sound\n",
 186     "\n",
 187     "applyInstruction (Set (Register a) b) m = m {registers = reg', pc = pc'}\n",
 188     "    where pc' = pc m + 1\n",
 189     "          y = evaluate m b\n",
 190     "          reg' = M.insert a y $ registers m\n",
 191     "\n",
 192     "applyInstruction (Add (Register a) b) m = m {registers = reg', pc = pc'}\n",
 193     "    where pc' = pc m + 1\n",
 194     "          x = evaluate m (Register a) \n",
 195     "          y = evaluate m b\n",
 196     "          reg' = M.insert a (x + y) $ registers m\n",
 197     "\n",
 198     "applyInstruction (Mul (Register a) b) m = m {registers = reg', pc = pc'}\n",
 199     "    where pc' = pc m + 1\n",
 200     "          x = evaluate m (Register a) \n",
 201     "          y = evaluate m b\n",
 202     "          reg' = M.insert a (x * y) $ registers m\n",
 203     "\n",
 204     "applyInstruction (Mod (Register a) b) m = m {registers = reg', pc = pc'}\n",
 205     "    where pc' = pc m + 1\n",
 206     "          x = evaluate m (Register a) \n",
 207     "          y = evaluate m b\n",
 208     "          reg' = M.insert a (x `mod` y) $ registers m\n",
 209     "\n",
 210     "applyInstruction (Rcv a) m = m {pc = pc'}\n",
 211     "    where pc' = pc m + 1\n",
 212     "    \n",
 213     "applyInstruction (Jgz a b) m = m {pc = pc'}\n",
 214     "    where x = evaluate m a\n",
 215     "          y = evaluate m b\n",
 216     "          pc' = if x > 0 then pc m + (fromIntegral y) else pc m + 1"
 217    ]
 218   },
 219   {
 220    "cell_type": "code",
 221    "execution_count": 57,
 222    "metadata": {},
 223    "outputs": [],
 224    "source": [
 225     "executeInstruction :: ProgrammedMachine\n",
 226     "executeInstruction =\n",
 227     "    do  instrs <- ask\n",
 228     "        m <- get\n",
 229     "        let instr = instrs!!(pc m)\n",
 230     "--         tell [(\"pc = \" ++ show (pc m))]\n",
 231     "        put (applyInstruction instr m)"
 232    ]
 233   },
 234   {
 235    "cell_type": "code",
 236    "execution_count": 58,
 237    "metadata": {},
 238    "outputs": [],
 239    "source": [
 240     "isRecover :: Instruction -> Bool\n",
 241     "isRecover (Rcv _) = True\n",
 242     "isRecover _ = False"
 243    ]
 244   },
 245   {
 246    "cell_type": "code",
 247    "execution_count": 59,
 248    "metadata": {},
 249    "outputs": [],
 250    "source": [
 251     "-- handleRecover :: ProgrammedMachine\n",
 252     "-- handleRecover = \n",
 253     "--     do  instrs <- ask\n",
 254     "--         m <- get\n",
 255     "--         let instr = instrs!!(pc m)\n",
 256     "--         when (isReceive instr)\n",
 257     "--             $\n",
 258     "--             do let Rcv a = instr\n",
 259     "--                let x = evaluate m a\n",
 260     "--                when (x /= 0) (tell ([\"reccovering \" ++ (show (lastSound m))]))"
 261    ]
 262   },
 263   {
 264    "cell_type": "code",
 265    "execution_count": 60,
 266    "metadata": {},
 267    "outputs": [],
 268    "source": [
 269     "recoverTriggers :: [Instruction] -> Machine -> Bool\n",
 270     "recoverTriggers instrs m = \n",
 271     "        if isRecover instr\n",
 272     "        then (x /= 0)\n",
 273     "        else False\n",
 274     "        where instr = instrs!!(pc m)\n",
 275     "              Rcv a = instr\n",
 276     "              x = evaluate m a"
 277    ]
 278   },
 279   {
 280    "cell_type": "code",
 281    "execution_count": 61,
 282    "metadata": {},
 283    "outputs": [],
 284    "source": [
 285     "executeInstructions = \n",
 286     "    do  instrs <- ask\n",
 287     "        m <- get\n",
 288     "--         tell [\"instrs = \" ++ (show instrs)]\n",
 289     "        when (pc m >= 0 && pc m < length instrs)\n",
 290     "            $\n",
 291     "            do let rt = recoverTriggers instrs m\n",
 292     "               if rt\n",
 293     "               then tell [lastSound m]\n",
 294     "               else do executeInstruction\n",
 295     "                       executeInstructions"
 296    ]
 297   },
 298   {
 299    "cell_type": "code",
 300    "execution_count": null,
 301    "metadata": {},
 302    "outputs": [],
 303    "source": []
 304   },
 305   {
 306    "cell_type": "code",
 307    "execution_count": 62,
 308    "metadata": {},
 309    "outputs": [
 310     {
 311      "data": {
 312       "text/plain": [
 313        "(((),[4]),Machine {registers = fromList [('a',1)], lastSound = 4, pc = 6})"
 314       ]
 315      },
 316      "metadata": {},
 317      "output_type": "display_data"
 318     }
 319    ],
 320    "source": [
 321     "runState (runReaderT (runWriterT executeInstructions) sampleInstructions ) emptyMachine"
 322    ]
 323   },
 324   {
 325    "cell_type": "code",
 326    "execution_count": 63,
 327    "metadata": {},
 328    "outputs": [
 329     {
 330      "data": {
 331       "text/plain": [
 332        "(((),[]),Machine {registers = fromList [('a',0)], lastSound = 4, pc = 7})"
 333       ]
 334      },
 335      "metadata": {},
 336      "output_type": "display_data"
 337     }
 338    ],
 339    "source": [
 340     "runState (\n",
 341     "    runReaderT (\n",
 342     "        runWriterT executeInstructions\n",
 343     "               ) \n",
 344     "        (take 7 sampleInstructions) \n",
 345     "         ) \n",
 346     "         emptyMachine"
 347    ]
 348   },
 349   {
 350    "cell_type": "code",
 351    "execution_count": 64,
 352    "metadata": {},
 353    "outputs": [
 354     {
 355      "data": {
 356       "text/plain": [
 357        "[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))]"
 358       ]
 359      },
 360      "metadata": {},
 361      "output_type": "display_data"
 362     }
 363    ],
 364    "source": [
 365     "sampleInstructions"
 366    ]
 367   },
 368   {
 369    "cell_type": "code",
 370    "execution_count": 65,
 371    "metadata": {},
 372    "outputs": [],
 373    "source": [
 374     "part1 instructions = \n",
 375     "    runState (\n",
 376     "        runReaderT (\n",
 377     "            runWriterT executeInstructions\n",
 378     "                   ) \n",
 379     "            instructions \n",
 380     "             ) \n",
 381     "             emptyMachine"
 382    ]
 383   },
 384   {
 385    "cell_type": "code",
 386    "execution_count": 68,
 387    "metadata": {},
 388    "outputs": [],
 389    "source": [
 390     "main :: IO ()\n",
 391     "main = do \n",
 392     "        text <- TIO.readFile \"../../data/advent18.txt\"\n",
 393     "        let instrs = successfulParse text\n",
 394     "        let ((result, l), machinef) = part1 instrs\n",
 395     "        print $ head l\n",
 396     "--         print $ part2 instrs"
 397    ]
 398   },
 399   {
 400    "cell_type": "code",
 401    "execution_count": 69,
 402    "metadata": {},
 403    "outputs": [
 404     {
 405      "data": {
 406       "text/plain": [
 407        "1187"
 408       ]
 409      },
 410      "metadata": {},
 411      "output_type": "display_data"
 412     }
 413    ],
 414    "source": [
 415     "main"
 416    ]
 417   },
 418   {
 419    "cell_type": "code",
 420    "execution_count": null,
 421    "metadata": {},
 422    "outputs": [],
 423    "source": []
 424   }
 425  ],
 426  "metadata": {
 427   "kernelspec": {
 428    "display_name": "Haskell",
 429    "language": "haskell",
 430    "name": "haskell"
 431   },
 432   "language_info": {
 433    "codemirror_mode": "ihaskell",
 434    "file_extension": ".hs",
 435    "name": "haskell",
 436    "version": "8.0.2"
 437   }
 438  },
 439  "nbformat": 4,
 440  "nbformat_minor": 2
 441 }