5 import qualified Data.Text.IO as TIO
7 import qualified Data.Map.Strict as M
8 import Data.Map.Strict ((!))
10 -- import Data.Foldable
11 -- import Data.Function (on)
13 import Control.Monad.RWS.Strict
16 data EncapsulatedMacine = EncapsulatedMacine
18 , _executionState :: ExecutionState
19 , _currentInput :: [Integer]
20 , _machineOutput :: [Integer]
22 makeLenses ''EncapsulatedMacine
24 instance Show EncapsulatedMacine where
25 show e = "EncapsulatedMacine {_machine = <>, _executionState = " ++ show (e ^. executionState) ++ ", _currentInput = " ++ show (e ^. currentInput) ++ ", _machineOutput = " ++ show (e ^. machineOutput) ++ "}"
27 type Network = M.Map Integer EncapsulatedMacine
30 { _destination :: Integer
33 } deriving (Show, Eq, Ord)
36 data NatNetwork = NatNetwork
37 { _natNetwork :: Network
38 , _natPacket :: Packet
39 , _natPreviousY :: Integer
41 makeLenses ''NatNetwork
46 text <- TIO.readFile "data/advent23.txt"
47 let mem = parseMachineMemory text
52 part1 mem = (runNetworkUntil255 net) ^. packetY
53 where net = buildNetwork mem
56 part2 mem = runNetworkUntilTermination natNet
57 where natNet = buildNatNetwork mem
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
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
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
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
101 natNet' = natNet & natNetwork .~ net3
105 emptyPacket :: Packet
106 emptyPacket = Packet {_destination = 0, _packetX = 0, _packetY = 0}
108 isNatPacket :: Packet -> Bool
109 isNatPacket packet = (packet ^. destination) == 255
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
117 buildNatNetwork :: [Integer] -> NatNetwork
118 buildNatNetwork mem = NatNetwork
119 { _natNetwork = buildNetwork mem
120 , _natPacket = emptyPacket
124 buildNetwork :: [Integer] -> Network
125 buildNetwork mem = M.fromList $ map (\i -> (i, encapsulate mem i)) [0..49]
128 encapsulate :: [Integer] -> Integer -> EncapsulatedMacine
129 encapsulate mem input = EncapsulatedMacine
130 { _machine = makeMachine mem
131 , _executionState = Runnable
132 , _machineOutput = []
133 , _currentInput = [input]
138 runNetworkStep :: Network -> Network
139 runNetworkStep net = M.map runEncapsulatedMachine net
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
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} ]
152 where output = (e ^. machineOutput)
154 stripPacket :: EncapsulatedMacine -> EncapsulatedMacine
155 stripPacket e = if length (e ^. machineOutput) >= 3
156 then e & machineOutput %~ (drop 3)
159 enqueuePackets :: Network -> [Packet] -> Network
160 enqueuePackets net packets = foldl' enqueuePacket net packets
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
167 where d = packet ^. destination
169 e' = e & currentInput %~ (++ [packet ^. packetX, packet ^. packetY])
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)
186 runNetworkMachineStep :: ProgrammedMachine ExecutionState
187 runNetworkMachineStep = do
191 iIndex <- gets _inputIndex
192 let acutalInputLength = length input
193 let requiredInputLength = iIndex + 1
195 then return Terminated
196 else if (mem!ip == 3 && requiredInputLength > acutalInputLength)