6bcc534677027557562d7b234259d00571263a77
[advent-of-code-19.git] / advent23 / src / advent23.hs
1 import Debug.Trace
2
3 import Intcode
4
5 import qualified Data.Text.IO as TIO
6
7 import qualified Data.Map.Strict as M
8 import Data.Map.Strict ((!))
9 import Data.List
10 -- import Data.Foldable
11 -- import Data.Function (on)
12 import Control.Lens
13 import Control.Monad.RWS.Strict
14
15
16 data EncapsulatedMacine = EncapsulatedMacine
17 { _machine :: Machine
18 , _executionState :: ExecutionState
19 , _currentInput :: [Integer]
20 , _machineOutput :: [Integer]
21 } deriving (Eq)
22 makeLenses ''EncapsulatedMacine
23
24 instance Show EncapsulatedMacine where
25 show e = "EncapsulatedMacine {_machine = <>, _executionState = " ++ show (e ^. executionState) ++ ", _currentInput = " ++ show (e ^. currentInput) ++ ", _machineOutput = " ++ show (e ^. machineOutput) ++ "}"
26
27 type Network = M.Map Integer EncapsulatedMacine
28
29 data Packet = Packet
30 { _destination :: Integer
31 , _packetX :: Integer
32 , _packetY :: Integer
33 } deriving (Show, Eq, Ord)
34 makeLenses ''Packet
35
36 data NatNetwork = NatNetwork
37 { _natNetwork :: Network
38 , _natPacket :: Packet
39 , _natPreviousY :: Integer
40 } deriving (Show, Eq)
41 makeLenses ''NatNetwork
42
43
44 main :: IO ()
45 main = do
46 text <- TIO.readFile "data/advent23.txt"
47 let mem = parseMachineMemory text
48 print $ part1 mem
49 print $ part2 mem
50
51
52 part1 mem = (runNetworkUntil255 net) ^. packetY
53 where net = buildNetwork mem
54
55
56 part2 mem = runNetworkUntilTermination natNet
57 where natNet = buildNatNetwork mem
58
59
60 runNetworkUntil255 :: Network -> Packet
61 runNetworkUntil255 net0
62 | not $ null goalPackets = head goalPackets
63 | otherwise = runNetworkUntil255 net3
64 where net1 = runNetworkStep net0
65 (net2, packets) = extractPackets net1
66 net3 = enqueuePackets net2 packets
67 goalPackets = filter isNatPacket packets
68
69 runNetworkUntilTermination :: NatNetwork -> Integer
70 -- runNetworkUntilTermination natNet | trace ("Nat: " ++ show (natNet ^. natPacket) ++ " last = " ++ show (natNet ^. natPreviousY)) False = undefined
71 runNetworkUntilTermination natNet
72 | part2Termination natNet1 = natNet1 ^. natPacket . packetY
73 | otherwise = runNetworkUntilTermination natNet2
74 where natNet1 = runNetworkUntilIdle natNet
75 np = (natNet1 ^. natPacket) & destination .~ 0
76 net = natNet1 ^. natNetwork
77 net2 = enqueuePacket net np
78 natNet2 = natNet1 & natNetwork .~ net2
79 & natPreviousY .~ (np ^. packetY)
80 & natPacket .~ emptyPacket
81
82 part2Termination :: NatNetwork -> Bool
83 -- part2Termination natNet | trace ("Term. this: " ++ (show (natNet ^. natPacket)) ++ " prev: " ++ (show (natNet ^. natPreviousY))) False = undefined
84 part2Termination natNet = thisY == prevY
85 where thisY = natNet ^. natPacket . packetY
86 prevY = natNet ^. natPreviousY
87
88
89 runNetworkUntilIdle :: NatNetwork -> NatNetwork
90 runNetworkUntilIdle natNet
91 | isIdle net0 = natNet
92 | otherwise = runNetworkUntilIdle natNet'
93 where net0 = natNet ^. natNetwork
94 net1 = runNetworkStep net0
95 (net2, packets) = extractPackets net1
96 net3 = enqueuePackets net2 packets
97 natPackets = filter isNatPacket packets
98 np = if null natPackets
99 then natNet ^. natPacket
100 else head natPackets
101 natNet' = natNet & natNetwork .~ net3
102 & natPacket .~ np
103
104
105 emptyPacket :: Packet
106 emptyPacket = Packet {_destination = 0, _packetX = 0, _packetY = 0}
107
108 isNatPacket :: Packet -> Bool
109 isNatPacket packet = (packet ^. destination) == 255
110
111 isIdle :: Network -> Bool
112 isIdle net = inputBlocked && noOutput
113 where inputBlocked = all (\e -> (last $ e ^. currentInput) == -1 && (last $ init $ e ^. currentInput) == -1) $ M.elems net
114 noOutput = all (\e -> null $ e ^. machineOutput) $ M.elems net
115
116
117 buildNatNetwork :: [Integer] -> NatNetwork
118 buildNatNetwork mem = NatNetwork
119 { _natNetwork = buildNetwork mem
120 , _natPacket = emptyPacket
121 , _natPreviousY = -1
122 }
123
124 buildNetwork :: [Integer] -> Network
125 buildNetwork mem = M.fromList $ map (\i -> (i, encapsulate mem i)) [0..49]
126
127
128 encapsulate :: [Integer] -> Integer -> EncapsulatedMacine
129 encapsulate mem input = EncapsulatedMacine
130 { _machine = makeMachine mem
131 , _executionState = Runnable
132 , _machineOutput = []
133 , _currentInput = [input]
134 }
135
136
137
138 runNetworkStep :: Network -> Network
139 runNetworkStep net = M.map runEncapsulatedMachine net
140
141 extractPackets :: Network -> (Network, [Packet])
142 extractPackets net = (net', packets)
143 where packets = concat $ M.elems $ M.map extractPacket net
144 net' = M.map stripPacket net
145
146 extractPacket :: EncapsulatedMacine -> [Packet]
147 extractPacket e = if length output >= 3
148 then [Packet { _destination = fromIntegral $ output!!0
149 , _packetX = output!!1
150 , _packetY = output!!2} ]
151 else []
152 where output = (e ^. machineOutput)
153
154 stripPacket :: EncapsulatedMacine -> EncapsulatedMacine
155 stripPacket e = if length (e ^. machineOutput) >= 3
156 then e & machineOutput %~ (drop 3)
157 else e
158
159 enqueuePackets :: Network -> [Packet] -> Network
160 enqueuePackets net packets = foldl' enqueuePacket net packets
161
162 enqueuePacket :: Network -> Packet -> Network
163 -- enqueuePacket _ packet | trace ("Enqueue " ++ show packet) False = undefined
164 enqueuePacket net packet
165 | d `M.member` net = M.insert d e' net
166 | otherwise = net
167 where d = packet ^. destination
168 e = net!d
169 e' = e & currentInput %~ (++ [packet ^. packetX, packet ^. packetY])
170
171
172 runEncapsulatedMachine :: EncapsulatedMacine -> EncapsulatedMacine
173 runEncapsulatedMachine e = e & machine .~ m''
174 & executionState .~ halted'
175 & currentInput .~ input'
176 & machineOutput %~ ( ++ output' )
177 where (halted, m', output) = runRWS runNetworkMachineStep (e ^. currentInput) (e ^. machine)
178 input' = if halted == Blocked
179 then (e ^. currentInput) ++ [-1]
180 else e ^. currentInput
181 (halted', m'', output') = if halted == Blocked
182 then runRWS runNetworkMachineStep input' (e ^. machine)
183 else (halted, m', output)
184
185
186 runNetworkMachineStep :: ProgrammedMachine ExecutionState
187 runNetworkMachineStep = do
188 mem <- gets _memory
189 ip <- gets _ip
190 input <- ask
191 iIndex <- gets _inputIndex
192 let acutalInputLength = length input
193 let requiredInputLength = iIndex + 1
194 if (mem!ip == 99)
195 then return Terminated
196 else if (mem!ip == 3 && requiredInputLength > acutalInputLength)
197 then return Blocked
198 else do
199 runStep
200 return Runnable