xiretza/aoc2020
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

day8: add haskell solution

Browse source
This commit is contained in:
Xiretza 2020-12-10 16:32:50 +01:00
parent a449a49c18
commit 173bab5a0f
Signed by: xiretza
GPG key ID: 17B78226F7139993
3 changed files with 746 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
data/day8.expected Normal file
View file

@ -0,0 +1,2 @@
1797
1036

625
data/day8.input Normal file
View file

@ -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

119
day8/day8.hs Normal file
View file

@ -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