-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathDay24.hs
237 lines (183 loc) · 8.92 KB
/
Day24.hs
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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
module Day24 where
import Data.List
import qualified Data.Map as M
import Data.Bits
parseSetting s = (pin,read val)
where (pin,':':' ':val) = break (==':') s
data Op = AND | OR | XOR
deriving (Show,Eq,Ord,Read)
op AND = (.&.)
op OR = (.|.)
op XOR = xor
parseGate s = (out,(read op,p1,p2))
where [p1,op,p2,"->",out] = words s
type State = M.Map String Int
type Ops = M.Map String (Op,String,String)
parse :: String -> (State, Ops)
parse s = (M.fromList $ map parseSetting ss, M.fromList $ map parseGate ops)
where ls = lines s
(ss,"":ops) = break (=="") ls
input = parse <$> readFile "input.24"
example = parse <$> readFile "example.24"
eval :: Ops -> String -> State -> State
eval ops pin state
| M.member pin state = state
| otherwise = let (o,a,b) = ops M.! pin
state' = eval ops a state
state'' = eval ops b state'
in M.insert pin (op o (state'' M.! a) (state'' M.! b)) state''
evalAll :: Ops -> State -> State
evalAll ops state = foldl' (flip (eval ops)) state (M.keys ops)
fromBits bs = foldr (\b acc -> b + 2 * acc) 0 bs
outputPins state = [(p,v) | (p@('z':_),v) <- M.assocs state]
extractOutput state = [v | ('z':_,v) <- M.assocs state]
part1 :: (State,Ops) -> Int
part1 (state,ops) = fromBits $ extractOutput final
where final = evalAll ops state
main = do
print . part1 =<< input
toBits 0 = []
toBits i = let (i',b) = i `divMod` 2 in b : toBits i'
nBits :: Int
nBits = 44
evalOn :: Ops -> [Int] -> [Int] -> State
evalOn ops x y = evalAll ops state
where s d = case show d of [c] -> ['0',c]; cs -> cs
state = M.fromList (zipWith (\i v -> ('x':s i, v)) [0..nBits] (x ++ repeat 0)
++ zipWith (\i v -> ('y':s i, v)) [0..nBits] (y ++ repeat 0))
opsAsFunction :: Ops -> [Int] -> [Int] -> [Int]
opsAsFunction ops x y = extractOutput $ evalOn ops x y
candidates ops x y = [p | ((p,a),b) <- zip (outputPins actual) expected, a/=b]
where expected = toBits (fromBits x + fromBits y)
actual = evalOn ops x y
allDeps ops pin = case M.lookup pin ops of
Nothing -> []
Just (_,a,b) -> pin : concatMap (allDeps ops) [a,b]
allDeps' ops pin = pin : case M.lookup pin ops of
Nothing -> []
Just (_,a,b) -> concatMap (allDeps' ops) [a,b]
-- (_,ops) <- input
-- cs = candidates ops [0] (replicate nBits 1)
-- nub $ concatMap (allDeps ops) cs
swap :: String -> String -> Ops -> Ops
swap a b ops = M.insert a (ops M.! b) $ M.insert b (ops M.! a) $ ops
findError :: Ops -> ([Int],[Int])
findError ops = head [ (x,y) | n <- [1..nBits], let x = replicate n 1, let y = [1], opsAsFunction ops x y /= take (nBits+2) (replicate n 0 ++ [1] ++ repeat 0) ]
-- findError ops
-- => ([1,1,1,1,1,1,1,1,1,1,1,1,1,1,1],[1])
-- candidates ops [1,1,1,1,1,1,1,1,1,1,1,1,1,1,1] [1]
-- => "z15"
-- length $ allDeps ops "z15"
-- => 61
canSwap :: Ops -> String -> String -> Bool
canSwap ops a b = not (a `elem` allDeps ops b) && not (b `elem` allDeps ops a)
allSwaps :: Ops-> [String] -> [(String,String)]
allSwaps ops pins = [(a,b) | (a:bs) <- tails pins, b <- bs, canSwap ops a b]
-- length $ allSwaps ops (allDeps ops "z15")
-- => 900
helps :: Ops -> ([Int],[Int]) -> [(String,String)] -> [(String,String)]
helps ops (x,y) swaps = [(a,b) | (a,b) <- swaps, candidates (swap a b ops) x y == []]
-- helps ops ([1,1,1,1,1,1,1,1,1,1,1,1,1,1,1],[1]) (allSwaps ops (allDeps ops "z15"))
-- => [("ctg","mrm"),("dqg","mrm")]
-- *Day24> candidates (swap "ctg" "mrm" ops) [1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1] [1]
-- ["z15"]
-- *Day24> candidates (swap "dqg" "mrm" ops) [1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1] [1]
-- ["z15"]
-- *Day24> let ops1 = swap "ctg" "mrm" ops
-- *Day24> helps ops1 ([1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1],[1]) (allSwaps ops1 (allDeps ops1 "z15"))
-- []
-- *Day24> let ops2 = swap "dqg" "mrm" ops
-- *Day24> helps ops2 ([1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1],[1]) (allSwaps ops2 (allDeps ops2 "z15"))
-- []
-- try to discover irregularities in the network
traces ops = go [] (map fst (outputPins ops))
where go seen [] = [("unconnected",M.keys ops \\ seen)]
go seen (p:pins) = let d = nub (allDeps' ops p) in (p,(d \\ seen)) : go (union d seen) pins
-- "z20" needs to be swapped with something
-- *Day24> helps ops ((replicate 20 0 ++ [1]),[]) swaps
-- [("z20","hbp"),("z20","msn"),("z20","cqr")]
-- *Day24> helps ops ((replicate 20 0 ++ [1]),(replicate 20 0 ++ [1])) swaps
-- [("z20","hbp"),("z20","fkg"),("z20","wrb"),("z20","mjm"),("z20","vct"),("z20","msn"),("z20","cqr")]
-- *Day24> helps ops ((replicate 19 0 ++ [1,1]),(replicate 19 0 ++ [1])) swaps
-- [("z20","mjm"),("z20","cqr")]
--
-- looks like ("z20","cqr") is a winner!
getsWrong ops = [i | i <- [0..nBits], let x = replicate (i-1) 0 ++ [1], candidates ops x x /= []]
-- *Day24> (_,ops) <- input
-- *Day24> let ops' = swap "z20" "cqr" ops
-- *Day24> getsWrong ops
-- [15,16,20,21,28,37]
-- *Day24> getsWrong ops'
-- [15,16,28,37]
-- *Day24> lookup "z15" $ traces ops'
-- Just ["z15","dnn","rjm","x15","y15","ctg","dqg","gnc","mrm"]
-- *Day24> lookup "z16" $ traces ops'
-- Just ["z16","kdf","y16","x16","qnw"]
-- *Day24> swaps = [(a,b) | a <- ["z15","dnn","rjm","ctg","dqg","gnc","mrm"], b <- ["z16","kdf","qnw"], canSwap ops' a b]
-- *Day24> helps ops' (replicate 14 0 ++ [1], replicate 14 0 ++ [1]) swaps
-- [("z15","z16"),("z15","qnw"),("dnn","z16"),("dnn","qnw"),("mrm","z16"),("mrm","qnw")]
-- *Day24> helps ops' (replicate 15 0 ++ [1], replicate 15 0 ++ [1]) swaps
-- [("z15","z16"),("z15","kdf"),("z15","qnw"),("mrm","z16"),("mrm","kdf"),("mrm","qnw")]
-- *Day24> helps ops' (replicate 14 0 ++ [1,1], replicate 14 0 ++ [1]) swaps
-- [("z15","z16"),("z15","kdf"),("z15","qnw"),("dnn","z16"),("dnn","kdf"),("dnn","qnw")]
-- the intersection of the above lists: [("z15","z16"),("z15","qnw")]
-- mapM_ print $ traces (swap "z15" "qnw" ops')
-- => looks better than the alternative
-- let ops'' = swap "z15" "qnw" ops'
-- *Day24> getsWrong ops''
-- [28,37]
-- *Day24> lookup "z28" $ traces ops''
-- Just ["z28","ndd","ncd","hrn","brm","y28","x28"]
-- *Day24> swaps = [(a,b) | a <- ["z28","ndd","ncd","hrn","brm"], b <- ["z28","ndd","ncd","hrn","brm"], a/=b, canSwap ops'' a b]
-- *Day24> swaps
-- [("ndd","brm"),("ncd","hrn"),("ncd","brm"),("hrn","ncd"),("hrn","brm"),("brm","ndd"),("brm","ncd"),("brm","hrn")]
-- none of these seem to help!
-- *Day24> opsAsFunction ops'' [1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1] [1]
-- [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]
-- *Day24>
-- *Day24> toBits (fromBits [1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1] + 1)
-- [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1]
-- already bit 27 is wrong!
-- *Day24> lookup "z27" $ traces ops''
-- Just ["z27","trt","mmj","nsh","nfj","y27","x27"]
-- *Day24> lookup "z28" $ traces ops''
-- Just ["z28","ndd","ncd","hrn","brm","y28","x28"]
-- *Day24> pins = ["z28","ndd","ncd","hrn","brm","z27","trt","mmj","nsh","nfj"]
-- *Day24> swaps = [(a,b) | a<-pins, b<-pins, a/=b, canSwap ops'' a b]
-- *Day24> helps ops'' ([1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1],[1]) swaps
-- [("ncd","nfj"),("hrn","z27"),("z27","hrn"),("nfj","ncd")]
-- *Day24> helps ops'' ([1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1],[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1]) swaps
-- [("ncd","trt"),("ncd","nsh"),("ncd","nfj"),("brm","trt"),("brm","nsh"),("brm","nfj"),("trt","ncd"),("trt","brm"),("nsh","ncd"),("nsh","brm"),("nfj","ncd"),("nfj","brm")]
-- => intersection is [("ncd","nfj"),("nfj","ncd")]
-- *Day24> let ops''' = swap "ncd" "nfj" ops''
-- *Day24> getsWrong ops'''
-- [37]
-- *Day24> findError ops'''
-- ([1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1],[1])
-- *Day24> filter ((==1).snd) $ outputPins $ evalOn ops''' (replicate 35 1) [1]
-- [("z35",1)]
-- *Day24> filter ((==1).snd) $ outputPins $ evalOn ops''' (replicate 36 1) [1]
-- [("z36",1)]
-- *Day24> filter ((==1).snd) $ outputPins $ evalOn ops''' (replicate 37 1) [1]
-- [("z38",1)]
-- *Day24> filter ((==1).snd) $ outputPins $ evalOn ops''' (replicate 38 1) [1]
-- [("z37",1)]
-- something wrong with 37&38
-- *Day24> lookup "z37" $ traces ops'''
-- Just ["z37","dnt","y37","x37","fcm","crj","dvm"]
-- *Day24> lookup "z38" $ traces ops'''
-- Just ["z38","hbt","x38","y38","bvv","vkg","jbg"]
-- swaps = [(a,b) | a<-["z38","hbt","bvv","vkg","jbg"], b<-["z37","dnt","fcm","crj","dvm"], canSwap ops''' a b]
-- *Day24> intersect (helps ops''' (replicate 37 1, [1]) swaps) (helps ops''' (replicate 40 1, [1]) swaps)
-- [("bvv","z37"),("vkg","z37")]
-- *Day24> getsWrong (swap "bvv" "z37" ops''')
-- [38]
-- *Day24> getsWrong (swap "vkg" "z37" ops''')
-- []
-- Solution!
-- let ops' = swap "z20" "cqr" ops
-- let ops'' = swap "z15" "qnw" ops'
-- let ops''' = swap "ncd" "nfj" ops''
-- let ops'''' = swap "vkg" "z37" ops'''
-- *Day24> intercalate "," $ sort ["z20","cqr","z15","qnw","ncd","nfj","vkg","z37"]
-- "cqr,ncd,nfj,qnw,vkg,z15,z20,z37"