From bad4db394608a5997c5739cfd6324820a6479e4a Mon Sep 17 00:00:00 2001
From: Xiretza <xiretza@xiretza.xyz>
Date: Thu, 10 Dec 2020 16:32:50 +0100
Subject: [PATCH] day8: add haskell solution

---
 2020/data/day8.expected |   2 +
 2020/data/day8.input    | 625 ++++++++++++++++++++++++++++++++++++++++
 2020/day8/day8.hs       | 119 ++++++++
 3 files changed, 746 insertions(+)
 create mode 100644 2020/data/day8.expected
 create mode 100644 2020/data/day8.input
 create mode 100644 2020/day8/day8.hs

diff --git a/2020/data/day8.expected b/2020/data/day8.expected
new file mode 100644
index 0000000..b5fe61e
--- /dev/null
+++ b/2020/data/day8.expected
@@ -0,0 +1,2 @@
+1797
+1036
diff --git a/2020/data/day8.input b/2020/data/day8.input
new file mode 100644
index 0000000..11cfbaa
--- /dev/null
+++ b/2020/data/day8.input
@@ -0,0 +1,625 @@
+acc +17
+acc +37
+acc -13
+jmp +173
+nop +100
+acc -7
+jmp +447
+nop +283
+acc +41
+acc +32
+jmp +1
+jmp +585
+jmp +1
+acc -5
+nop +71
+acc +49
+acc -18
+jmp +527
+jmp +130
+jmp +253
+acc +11
+acc -11
+jmp +390
+jmp +597
+jmp +1
+acc +6
+acc +0
+jmp +588
+acc -17
+jmp +277
+acc +2
+nop +163
+jmp +558
+acc +38
+jmp +369
+acc +13
+jmp +536
+acc +38
+acc +39
+acc +6
+jmp +84
+acc +11
+nop +517
+acc +48
+acc +47
+jmp +1
+acc +42
+acc +0
+acc +2
+acc +24
+jmp +335
+acc +44
+acc +47
+jmp +446
+nop +42
+nop +74
+acc +45
+jmp +548
+jmp +66
+acc +1
+jmp +212
+acc +18
+jmp +1
+acc +4
+acc -16
+jmp +366
+acc +0
+jmp +398
+acc +45
+jmp +93
+acc +40
+acc +38
+acc +21
+nop +184
+jmp -46
+nop -9
+jmp +53
+acc +46
+acc +36
+jmp +368
+acc +16
+acc +8
+acc -9
+acc -4
+jmp +328
+acc -15
+acc -5
+acc +21
+jmp +435
+acc -5
+acc +36
+jmp +362
+acc +26
+jmp +447
+jmp +1
+jmp +412
+acc +11
+acc +41
+nop -32
+acc +17
+jmp -63
+jmp +1
+nop +393
+jmp +62
+acc +18
+acc +30
+nop +417
+jmp +74
+acc +29
+acc +23
+jmp +455
+jmp +396
+jmp +395
+acc +33
+nop +137
+nop +42
+jmp +57
+jmp +396
+acc +7
+acc +0
+jmp +354
+acc +15
+acc +50
+jmp -12
+jmp +84
+nop +175
+acc +5
+acc -2
+jmp -82
+acc +1
+acc +26
+jmp +288
+nop -113
+nop +366
+acc +45
+jmp +388
+acc +21
+acc +38
+jmp +427
+acc +33
+jmp -94
+nop -118
+nop +411
+jmp +472
+nop +231
+nop +470
+acc +48
+jmp -124
+jmp +1
+acc +5
+acc +37
+acc +42
+jmp +301
+acc -11
+acc -17
+acc +14
+jmp +357
+acc +6
+acc +20
+acc +13
+jmp +361
+jmp -65
+acc +29
+jmp +26
+jmp +329
+acc +32
+acc +32
+acc +17
+jmp -102
+acc -6
+acc +33
+acc +9
+jmp +189
+acc +3
+jmp -128
+jmp -142
+acc +24
+acc -5
+jmp +403
+acc +28
+jmp +310
+acc +34
+acc +4
+acc +33
+acc +18
+jmp +227
+acc -8
+acc -15
+jmp +112
+jmp +54
+acc +21
+acc +23
+acc +20
+jmp +320
+acc +13
+jmp -77
+acc +15
+nop +310
+nop +335
+jmp +232
+acc -3
+nop +50
+acc +41
+jmp +112
+nop -10
+acc +29
+acc +27
+jmp +52
+acc +40
+nop -132
+acc -16
+acc +27
+jmp +309
+acc -8
+nop +147
+acc +20
+acc +46
+jmp +202
+acc +27
+jmp -43
+jmp +1
+acc +33
+acc -13
+jmp +300
+acc +1
+jmp -202
+acc -17
+acc +0
+acc +34
+jmp -5
+nop +335
+acc -16
+acc -17
+jmp -120
+acc -19
+acc -13
+acc +4
+jmp +368
+jmp +21
+acc +39
+acc +39
+acc -18
+jmp -157
+nop +280
+acc +33
+nop -37
+jmp +32
+acc -16
+acc +18
+acc +46
+jmp -121
+acc -19
+jmp +195
+acc +28
+jmp +124
+jmp +331
+jmp -228
+jmp -146
+jmp +85
+jmp +60
+acc +20
+acc -9
+jmp +303
+jmp -122
+jmp +111
+acc +32
+acc +0
+acc +39
+acc +29
+jmp -31
+nop +320
+jmp -63
+jmp +223
+nop -149
+acc -12
+acc -11
+acc +32
+jmp +309
+jmp -13
+acc -19
+jmp -123
+acc +21
+acc +18
+acc +49
+jmp +175
+acc -14
+nop -129
+acc -2
+acc +31
+jmp +79
+acc +23
+acc +50
+acc +39
+acc +7
+jmp -235
+jmp -166
+acc +9
+jmp +293
+acc -11
+jmp +76
+acc +44
+acc +3
+acc +37
+jmp +123
+nop -104
+jmp -157
+acc +14
+acc +10
+acc +28
+jmp +25
+acc +37
+jmp +188
+jmp -49
+acc -11
+jmp -90
+acc -8
+jmp +197
+acc +5
+jmp +115
+acc +44
+jmp -228
+nop -2
+acc +46
+jmp +130
+nop +183
+nop +106
+acc +27
+acc +37
+jmp -309
+acc +28
+acc -4
+acc -12
+acc +38
+jmp +93
+acc +8
+acc +23
+acc -9
+acc +6
+jmp -42
+acc +10
+acc +35
+acc +4
+jmp -231
+acc +19
+acc +7
+acc +23
+acc +11
+jmp -90
+acc +0
+nop +158
+nop -150
+acc +33
+jmp +107
+acc +48
+acc -2
+jmp -104
+acc +6
+nop -57
+nop +172
+acc -11
+jmp -7
+acc +6
+acc +50
+acc -9
+acc +12
+jmp -171
+acc +3
+jmp +26
+acc +42
+acc +31
+acc +20
+acc +32
+jmp -48
+acc +13
+jmp -6
+jmp +178
+acc +47
+jmp -153
+acc +28
+nop +74
+jmp -162
+acc -15
+nop -104
+acc -9
+jmp -227
+acc +49
+acc -19
+acc +41
+jmp -318
+acc +9
+acc +12
+acc +7
+jmp +34
+jmp +137
+nop -143
+acc -8
+acc +5
+acc +31
+jmp -20
+jmp -237
+acc +39
+acc +0
+jmp -298
+acc +45
+acc -19
+acc +11
+jmp -151
+acc +40
+acc +27
+nop +150
+nop -391
+jmp -341
+acc +1
+acc +11
+acc +18
+nop -234
+jmp +77
+nop +104
+jmp -65
+acc +32
+jmp -27
+nop -317
+nop +159
+acc +14
+acc -10
+jmp -348
+acc +29
+jmp +32
+acc +48
+acc -19
+jmp +17
+jmp -201
+jmp -224
+nop +26
+acc -7
+acc +23
+acc +46
+jmp -6
+acc +22
+acc +39
+acc +9
+acc +23
+jmp -30
+jmp -243
+acc +47
+acc -15
+jmp -298
+jmp -393
+jmp +1
+acc +3
+nop -24
+acc +7
+jmp -59
+acc -6
+acc +26
+jmp -102
+acc +34
+acc +24
+jmp -207
+acc +36
+acc +40
+acc +41
+jmp +1
+jmp -306
+jmp +57
+jmp +1
+nop +99
+acc +28
+jmp -391
+acc +50
+jmp -359
+acc -5
+jmp +9
+jmp -355
+acc +5
+acc +2
+jmp -77
+acc +40
+acc +28
+acc +22
+jmp -262
+nop -287
+acc +34
+acc -4
+nop +112
+jmp -195
+acc +29
+nop -94
+nop -418
+jmp +24
+jmp -190
+acc +2
+jmp -311
+jmp -178
+jmp -276
+acc -12
+acc -18
+jmp +62
+jmp -174
+nop +31
+acc +33
+nop -158
+jmp -417
+acc +3
+acc +21
+acc +47
+jmp +87
+acc +45
+jmp -77
+acc +6
+acc -10
+jmp +1
+jmp -240
+acc +7
+acc +47
+jmp -379
+acc -14
+acc +50
+nop -75
+acc +30
+jmp +70
+jmp -392
+jmp -430
+acc +22
+acc -2
+jmp -492
+jmp +1
+acc -6
+acc +38
+jmp -36
+nop -336
+jmp -32
+jmp +61
+acc +20
+acc -9
+acc +2
+jmp -175
+acc +21
+acc -2
+jmp -6
+jmp -527
+acc +11
+acc +16
+jmp -262
+jmp +1
+nop -327
+acc +29
+jmp -114
+acc +11
+acc +17
+acc +26
+nop -104
+jmp -428
+nop -178
+nop -242
+acc +29
+acc +5
+jmp -245
+jmp -417
+jmp -278
+acc +35
+acc +21
+jmp +1
+nop -263
+jmp +8
+acc +42
+jmp -95
+nop -312
+acc -11
+acc +34
+acc +0
+jmp +19
+acc +8
+acc -13
+acc +32
+acc +21
+jmp -208
+acc +15
+acc +39
+nop -194
+jmp -280
+jmp +24
+nop -516
+acc +21
+acc +48
+jmp -367
+jmp -121
+acc +49
+acc -16
+jmp -136
+acc +0
+jmp -148
+jmp -85
+jmp -103
+nop -446
+jmp -242
+acc -12
+acc +13
+acc +31
+acc -1
+jmp -435
+nop -420
+acc +22
+acc -5
+jmp -567
+nop -354
+acc +11
+acc +33
+acc +45
+jmp -76
+acc -2
+acc +0
+acc +25
+acc +46
+jmp -555
+acc +0
+acc +11
+nop -2
+jmp -394
+jmp -395
+acc +8
+acc +14
+acc +47
+acc +22
+jmp +1
diff --git a/2020/day8/day8.hs b/2020/day8/day8.hs
new file mode 100644
index 0000000..7015731
--- /dev/null
+++ b/2020/day8/day8.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+import AoC
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.ST
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Data.Array.ST
+import Data.Maybe
+import Text.ParserCombinators.ReadP
+import Text.Read.Lex
+
+data Instruction = Nop Int | Acc Int | Jmp Int deriving (Show)
+data MemoryCell = MemoryCell { instruction :: Instruction
+                             , executed :: Bool
+                             }
+                             deriving (Show)
+type Memory s = STArray s Int MemoryCell
+data Machine s = Machine { pc :: Int
+                         , acc :: Int
+                         , memory :: Memory s
+                         }
+
+data RunError = OutOfRange | WouldLoop | Breakpoint deriving (Show)
+
+type MachineRunner s = Machine s -> ExceptT RunError (ST s) (Machine s)
+
+parseInstruction :: ReadP Instruction
+parseInstruction = choice [ Nop <$> parseIns "nop"
+                          , Acc <$> parseIns "acc"
+                          , Jmp <$> parseIns "jmp"
+                          ]
+    where parseIns name = string name >> char ' ' >> parseNumber
+          parseNumber = do
+              sign <- option '+' (choice $ map char $ "+-")
+              num <- readDecP
+              return $ case sign of
+                         '+' -> num
+                         '-' -> -num
+
+newMemory :: [Instruction] -> ST s (Memory s)
+newMemory insns = newListArray (0, length insns-1) $ [MemoryCell { instruction = ins, executed = False } | ins <- insns]
+
+newMachine :: [Instruction] -> ST s (Machine s)
+newMachine insns = do
+    mem <- newMemory insns
+    return $ Machine { pc = 0, acc = 0, memory = mem }
+
+stepMachine :: Machine s -> ST s (Machine s)
+stepMachine m = do
+    cell <- readArray (memory m) (pc m)
+    writeArray (memory m) (pc m) $ cell { executed = True }
+    (pcF, accF) <- case instruction cell of
+                     Nop _ -> return ((+1), id)
+                     Acc i -> return ((+1), (+i))
+                     Jmp i -> return ((+i), id)
+    
+    let newPc = pcF $ pc m
+        newAcc = accF $ acc m
+
+    return $ m { pc = newPc, acc = newAcc }
+
+runUnless :: (Machine s -> MaybeT (ST s) RunError) -> MachineRunner s -> MachineRunner s
+runUnless p stepper m = do
+    res <- lift $ runMaybeT $ p m
+    case res of
+      Nothing -> stepper m
+      Just e -> throwE e
+
+breakOnLoop :: MachineRunner s -> MachineRunner s
+breakOnLoop = runUnless alreadyExecuted
+    where alreadyExecuted m =
+            do cell <- lift $ readArray (memory m) (pc m)
+               unless (executed cell) empty
+               return WouldLoop
+
+breakOnAddr :: Int -> MachineRunner s -> MachineRunner s
+breakOnAddr addr = runUnless $ fetchFrom addr
+    where fetchFrom addr m =
+            do unless (pc m == addr) empty
+               return Breakpoint
+
+runUntilError :: MachineRunner s -> Machine s -> ST s (RunError, Int, Int)
+runUntilError step m = do
+    result <- runExceptT $ step m
+    case result of
+      Right m' -> runUntilError step m'
+      Left e -> return (e, (pc m), (acc m))
+
+part1 :: [Instruction] -> Int
+part1 is = fromJust $ runST $ runMaybeT $ do
+    (WouldLoop, _, acc) <- lift $ newMachine is >>= runUntilError stepper
+    return acc
+    where stepper = breakOnLoop (lift . stepMachine)
+
+tryTerminate :: Machine s -> MaybeT (ST s) Int
+tryTerminate m = do
+    breakpoint <- fmap (\(_, max) -> max + 1) $ lift $ getBounds (memory m)
+    (Breakpoint, _, acc) <- lift $ runUntilError (stepper breakpoint) m
+    return acc
+    where stepper b = breakOnAddr b . breakOnLoop $ (lift . stepMachine)
+
+jmpNopFlips :: [Instruction] -> [[Instruction]]
+jmpNopFlips [] = []
+jmpNopFlips (x:xs) = case x of
+                       Jmp i -> (Nop i:xs) : rest
+                       Nop i -> (Jmp i:xs) : rest
+                       _ -> rest
+    where rest = (x:) <$> jmpNopFlips xs
+
+part2 :: [Instruction] -> Int
+part2 instructions = fromJust $ msum $ runST $ mapM testInstructions possibleInstructions
+    where testInstructions is = runMaybeT $ lift (newMachine is) >>= tryTerminate
+          possibleInstructions = instructions : jmpNopFlips instructions
+
+main = runAoC (map (fromJust . oneCompleteResult parseInstruction) . lines) part1 part2