5 import qualified Data.Text.IO as TIO
7 import qualified Data.Set as S
12 type Position = (Integer, Integer) -- r, c
13 data Direction = North | East | South | West deriving (Show, Eq, Ord, Enum, Bounded)
14 data Step = F | ACW | CW deriving (Show, Eq, Ord)
15 data Command = FN Int | L | R | A | B | C deriving (Eq)
17 instance Show Command where
25 showList (c:[]) s = (show c) ++ s
26 showList (c:cs) s = (show c) ++ "," ++ (showList cs s)
28 type Routine = ([Command], [Command], [Command], [Command])
30 type Scaffold = S.Set Position
32 data ScaffoldBuilder = ScaffoldBuilder
33 { _scaffold :: Scaffold
36 , _droidPos :: Position
37 , _droidDirection :: Direction
43 text <- TIO.readFile "data/advent17.txt"
44 let mem = parseMachineMemory text
46 let sb = buildScaffold mem
48 let (scaff, num) = part2 sb mem
53 part1 sb = S.foldl (+) 0 $ S.map alignmentParam intersections
54 where scaffold = _scaffold sb
55 intersections = S.filter (isIntersection scaffold) scaffold
58 part2 sb mem = (scaff, last output)
59 where compressedCmds = findRoutine sb
60 inputs = encodeRoutine compressedCmds
62 (_, _, output) = runProgram inputs mem'
63 scaff = map (chr . fromIntegral) $ init output
66 buildScaffold :: [Integer] -> ScaffoldBuilder
67 buildScaffold mem = foldl' addGridChar emptyScaffoldBuilder output
68 where (_, _, output) = runProgram [] mem
69 emptyScaffoldBuilder = ScaffoldBuilder {_scaffold = S.empty, _r = 0, _c = 0,
70 _droidPos = (0, 0), _droidDirection = North }
72 addGridChar :: ScaffoldBuilder -> Integer -> ScaffoldBuilder
73 addGridChar sb 10 = sb { _r = _r sb + 1, _c = 0 }
74 addGridChar sb 46 = sb { _c = _c sb + 1 }
75 addGridChar sb 35 = sb { _scaffold = S.insert (_r sb, _c sb) $ _scaffold sb,
77 addGridChar sb 94 = sb { _scaffold = S.insert (_r sb, _c sb) $ _scaffold sb,
79 _droidPos = (_r sb, _c sb), _droidDirection = North }
80 addGridChar sb 118 = sb { _scaffold = S.insert (_r sb, _c sb) $ _scaffold sb,
82 _droidPos = (_r sb, _c sb), _droidDirection = South }
83 addGridChar sb 60 = sb { _scaffold = S.insert (_r sb, _c sb) $ _scaffold sb,
85 _droidPos = (_r sb, _c sb), _droidDirection = West }
86 addGridChar sb 61 = sb { _scaffold = S.insert (_r sb, _c sb) $ _scaffold sb,
88 _droidPos = (_r sb, _c sb), _droidDirection = East }
91 isIntersection :: Scaffold -> Position -> Bool
92 isIntersection scaffold (r, c) = neighbours `S.isSubsetOf` scaffold
93 where neighbours = [(r - 1, c), (r + 1, c), (r, c - 1), (r, c + 1)]
95 alignmentParam :: Position -> Integer
96 alignmentParam (r, c) = r * c
100 findRoutine :: ScaffoldBuilder -> Routine
101 findRoutine scaff = head $ compressedCmds
102 where path = findPath scaff
103 cmds = toCommands path
104 compressedCmds = compress cmds
106 encodeRoutine :: Routine -> [Integer]
107 encodeRoutine (abc, a, b, c) = map (fromIntegral . ord) $ unlines [show abc, show a, show b, show c, "n", ""]
110 findPath :: ScaffoldBuilder -> [Step]
111 findPath = unfoldr takeStep
113 takeStep :: ScaffoldBuilder -> Maybe (Step, ScaffoldBuilder)
114 takeStep visitedScaffold = step
115 where scaff = _scaffold visitedScaffold
116 here = _droidPos visitedScaffold
117 dir = _droidDirection visitedScaffold
118 fPos = ahead here dir
119 cwPos = ahead here $ succW dir
120 acwPos = ahead here $ predW dir
121 step = if canVisit scaff fPos
122 then Just (F, visitedScaffold {_droidPos = fPos})
123 else if canVisit scaff cwPos
124 then Just (CW, visitedScaffold {_droidDirection = succW dir})
125 else if canVisit scaff acwPos
126 then Just (ACW, visitedScaffold {_droidDirection = predW dir})
129 ahead :: Position -> Direction -> Position
130 ahead (r, c) North = (r - 1, c)
131 ahead (r, c) South = (r + 1, c)
132 ahead (r, c) West = (r, c - 1)
133 ahead (r, c) East = (r, c + 1)
135 canVisit :: Scaffold -> Position -> Bool
136 canVisit scaff here = (S.member here scaff)
138 toCommands :: [Step] -> [Command]
139 toCommands path = map toCommand segments
140 where segments = group path
142 toCommand :: [Step] -> Command
143 toCommand segment = case (head $ segment) of
144 F -> FN (length segment)
148 compress :: [Command] -> [Routine]
150 do a <- tail $ inits commands
151 guard $ length (show a) <= 20
152 let commandsA = replace a A commands
153 let commandsABase = dropWhile (not . isBase) commandsA
154 b <- tail $ inits commandsABase
156 guard $ length (show b) <= 20
157 let commandsAB = replace b B commandsA
158 let commandsABBase = dropWhile (not . isBase) commandsAB
159 c <- tail $ inits commandsABBase
161 guard $ length (show c) <= 20
162 let commandsABC = replace c C commandsAB
163 guard $ length (show commandsABC) <= 20
164 guard $ onlyNonBase commandsABC
165 return (commandsABC, a, b, c)
168 replace :: Eq a => [a] -> a -> [a] -> [a]
169 -- replace moves label commands | trace (show moves ++ " " ++ show label ++ " " ++ show commands) False = undefined
171 replace moves label commands =
172 if moves `isPrefixOf` commands
173 then (label:(replace moves label commands'))
174 else (head commands:(replace moves label (tail commands)))
175 where commands' = drop (length moves) commands
177 onlyBase :: [Command] -> Bool
178 onlyBase moves = all isBase moves
180 onlyNonBase :: [Command] -> Bool
181 onlyNonBase moves = all (not . isBase) moves
183 isBase :: Command -> Bool
190 -- | a `succ` that wraps
191 succW :: (Bounded a, Enum a, Eq a) => a -> a
192 succW dir | dir == maxBound = minBound
193 | otherwise = succ dir
195 -- | a `pred` that wraps
196 predW :: (Bounded a, Enum a, Eq a) => a -> a
197 predW dir | dir == minBound = maxBound
198 | otherwise = pred dir
202 -- showScaffold :: VisitedScaffold -> String
203 -- showScaffold scaff = unlines rows
204 -- where minR = S.findMin $ S.map fst $ _scaffold scaff
205 -- minC = S.findMin $ S.map snd $ _scaffold scaff
206 -- maxR = S.findMax $ S.map fst $ _scaffold scaff
207 -- maxC = S.findMax $ S.map snd $ _scaffold scaff
208 -- rows = [showScaffoldRow scaff minC maxC r | r <- [minR..maxR]]
210 -- showScaffoldRow :: VisitedScaffold -> Integer -> Integer -> Integer -> String
211 -- showScaffoldRow scaff minC maxC r = [showScaffoldCell scaff r c | c <- [minC..maxC]]
213 -- showScaffoldCell :: VisitedScaffold -> Integer -> Integer -> Char
214 -- showScaffoldCell scaff r c =
215 -- if S.member (r, c) (_scaffold scaff)