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
  53     where   net = buildNetwork mem
  54
  55
  56 part2 mem = runNetworkUntilTermination natNet
  57     where natNet = buildNatNetwork mem
  58
  59
  60 runNetworkUntil255 :: Network -> Integer
  61 runNetworkUntil255 net0
  62     | not $ null goalPackets = (head goalPackets) ^. packetY
  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 = 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