1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
module Main where
import Data.Char
import Data.List
import Control.Monad
import Data.Bits
import Data.Word
import qualified Data.Map as Map
import qualified Data.Set as Set
type Inttype = Word16
data Literal = LNum Inttype | LName String
data Command = Immediate Literal |
Monadic (Inttype -> Inttype) Literal |
Dyadic (Inttype -> Inttype -> Inttype) Literal Literal
type Statement = (Command,String)
type Cache = Map.Map String Inttype
complement16 :: Inttype -> Inttype
complement16 i = i `xor` 0xffff
shiftL16 :: Inttype -> Int -> Inttype
shiftL16 i n = (shiftL i n) .&. 0xffff
shiftR16 :: Inttype -> Int -> Inttype
shiftR16 i n = (shiftR i n) .&. 0xffff
parseLit :: String -> Literal
parseLit s = if isDigit (head s) then LNum (read s) else LName s
parse :: [String] -> Statement
parse l = (parse' (init $ init $ l),last l)
parse' :: [String] -> Command
parse' [n] = Immediate (parseLit n)
parse' ["NOT",n] = Monadic complement16 (parseLit n)
parse' [a,"AND",b] = Dyadic (.&.) (parseLit a) (parseLit b)
parse' [a,"OR",b] = Dyadic (.|.) (parseLit a) (parseLit b)
parse' [a,"LSHIFT",b] = Dyadic (\i n -> shiftL16 i (fromIntegral n)) (parseLit a) (parseLit b)
parse' [a,"RSHIFT",b] = Dyadic (\i n -> shiftR16 i (fromIntegral n)) (parseLit a) (parseLit b)
collectOutputs :: [Statement] -> [String]
collectOutputs stmts = Set.toList $ collectOutputs' stmts Set.empty
collectOutputs' :: [Statement] -> Set.Set String -> Set.Set String
collectOutputs' [] set = set
collectOutputs' ((_,target):ss) set = collectOutputs' ss $ Set.insert target set
neededBy :: String -> Command -> Bool
neededBy n (Immediate l) = case l of
LNum _ -> False
LName ln -> n == ln
neededBy n (Monadic _ l) = case l of
LNum _ -> False
LName ln -> n == ln
neededBy n (Dyadic _ (LNum _) b) = case b of
LNum _ -> False
LName bn -> n == bn
neededBy n (Dyadic _ (LName an) b) = case b of
LNum _ -> n == an
LName bn -> n == an || n == bn
leaves :: [Statement] -> [String]
leaves stmts = leaves' (map fst stmts) (collectOutputs stmts)
leaves' :: [Command] -> [String] -> [String]
leaves' _ [] = []
leaves' cmds (o:os) = if any (neededBy o) cmds then leaves' cmds os else o:leaves' cmds os
getValue :: String -> [Statement] -> Cache -> (Inttype,Cache)
getValue nm stmts cc = getValue' nm stmts stmts cc
getValue' :: String -> [Statement] -> [Statement] -> Cache -> (Inttype,Cache)
getValue' nm [] _ cc = case Map.lookup nm cc of
Nothing -> undefined
Just i -> (i,cc)
getValue' nm ((cmd,target):ss) stmts cc = case Map.lookup nm cc of
Nothing -> if nm == target then execCmd cmd stmts cc else getValue' nm ss stmts cc
Just i -> (i,cc)
resolveLit :: Literal -> [Statement] -> Cache -> (Inttype,Cache)
resolveLit (LNum i) _ cc = (i,cc)
resolveLit (LName n) stmts cc = (value,Map.insert n value cc2)
where (value,cc2) = getValue n stmts cc
execCmd :: Command -> [Statement] -> Cache -> (Inttype,Cache)
execCmd (Immediate l) stmts cc = resolveLit l stmts cc
execCmd (Monadic f l) stmts cc = (f resl,cc2)
where (resl,cc2) = resolveLit l stmts cc
execCmd (Dyadic f a b) stmts cc = (f resa resb,cc3)
where (resa,cc2) = resolveLit a stmts cc
(resb,cc3) = resolveLit b stmts cc2
day7 :: IO ()
day7 = do
input <- readFile "input.txt"
let stmts = [parse (words l) | l <- (lines input)]
let lvs = leaves stmts
print lvs
print [fst $ getValue lv stmts Map.empty | lv <- lvs]
main = day7
|
