-
Notifications
You must be signed in to change notification settings - Fork 0
/
Day17.hs
194 lines (175 loc) · 5.98 KB
/
Day17.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
module Javran.AdventOfCode.Y2019.Day17 (
breakIntoRoutines,
Move (..),
) where
import Control.Lens hiding (universe)
import Control.Monad
import Control.Monad.Writer.CPS
import Data.Char
import Data.List
import Data.List.Split hiding (sepBy)
import Data.Monoid
import qualified Data.Set as S
import Javran.AdventOfCode.GridSystem.RowThenCol.Uldr
import Javran.AdventOfCode.Prelude
import Javran.AdventOfCode.Y2019.IntCode
data Day17 deriving (Generic)
type Robot = (Dir, Coord)
data MapInfo = MapInfo
{ miScaffolds :: S.Set Coord
, miRobot :: Robot
}
deriving (Show)
parseRawMap :: String -> MapInfo
parseRawMap rawMap = MapInfo {miScaffolds, miRobot}
where
(miScaffolds, Data.Monoid.Last (Just miRobot)) = mconcat do
(r, row) <- zip [0 ..] (lines rawMap)
(c, x) <- zip [0 ..] row
-- We assume that map always starts with robot on scaffolds.
guard $ x `notElemS` ".X"
let coord = (r, c)
let mRobot = case x of
'^' -> pure (U, coord)
'v' -> pure (D, coord)
'<' -> pure (L, coord)
'>' -> pure (R, coord)
_ -> Nothing
pure (S.singleton coord, Data.Monoid.Last mRobot)
data Move
= Forward Int
| TurnLeft
| TurnRight
deriving (Eq)
instance Show Move where
show = \case
Forward v -> show v
TurnLeft -> "L"
TurnRight -> "R"
{-
Completes one segment of the scaffolding line by an optional turn followed
by moving forward.
-}
nextMoves :: MapInfo -> Robot -> WriterT [Move] Maybe Robot
nextMoves MapInfo {miScaffolds} (dir, coord) = do
let frontCoord = applyDir dir coord
leftCoord = applyDir (turnLeft dir) coord
rightCoord = applyDir (turnRight dir) coord
{-
If can't move forward, try left or right, `Nothing` if neither is available.
-}
dirMod <-
if
| S.member frontCoord miScaffolds ->
pure id
| S.member leftCoord miScaffolds -> do
tell [TurnLeft]
pure turnLeft
| S.member rightCoord miScaffolds -> do
tell [TurnRight]
pure turnRight
| otherwise -> lift Nothing
let dir' = dirMod dir
frontCoords = takeWhile (`S.member` miScaffolds) $ tail $ iterate (applyDir dir') coord
tell [Forward (length frontCoords)]
pure (dir', last frontCoords)
computeMoves :: MapInfo -> Robot -> [Move]
computeMoves mi miRobot =
{-
This is technically incorrect if droid starts facing the opposite direction of
scaffolding. But so far that has never been the case.
-}
concat $
unfoldr
( \robot -> do
(robot', w) <- runWriterT (nextMoves mi robot)
pure (w, robot')
)
miRobot
{-
A program after some replacements:
- A Left element is a sequence of moves not translated into any subroutine
- A Right element `Right x` is the result of replacing that sequence of movements with
subroutine x.
-}
type ReplacedProgram = [Either [Move] Char]
type ProgList = [(Char, [Move])]
replaceWithMoveFn :: Char -> [Move] -> [Move] -> ReplacedProgram
replaceWithMoveFn fnName fnBody xs = concatMap handleChunk $ split (onSublist fnBody) xs
where
handleChunk ys
| null ys = []
| ys == fnBody = [Right fnName]
| otherwise = [Left ys]
encodeMoves :: [Move] -> String
encodeMoves = intercalate "," . fmap show
type AllRoutines =
( [] Char -- the main routine
, ProgList
)
breakIntoRoutines :: [] Char -> [Move] -> [] AllRoutines
breakIntoRoutines progNames xs = breakIntoRoutinesAux progNames [] [Left xs]
withinLengthLimit :: String -> Bool
withinLengthLimit = (<= 20) . length
breakIntoRoutinesAux ::
[] Char ->
ProgList ->
ReplacedProgram ->
[AllRoutines]
breakIntoRoutinesAux newProgNames progList xs0 = case findLeft xs0 of
Nothing -> do
-- all translated to main routine.
let (_, mainProg) = partitionEithers xs0
-- verify length limit for main routine
guard $ withinLengthLimit $ intercalate "," (fmap (: []) mainProg)
pure (mainProg, reverse progList)
Just sub0 -> do
-- get a new name or the name list is exhausted (in which case we fail)
(progName : newProgNames') <- pure newProgNames
progBody <- reverse . takeWhile (withinLengthLimit . encodeMoves) $ inits sub0
let xs1 :: ReplacedProgram
xs1 =
concatMap
( either
(replaceWithMoveFn progName progBody)
((: []) . Right)
)
xs0
breakIntoRoutinesAux newProgNames' ((progName, progBody) : progList) xs1
where
findLeft ys = case partitionEithers ys of
([], _) -> Nothing
(x : _, _) -> Just x
encodeVaccumRobotInput :: AllRoutines -> String
encodeVaccumRobotInput (mainRoutine, progList) =
if length progList > 3
then error "program list is too long"
else
let getAndEncode i = encodeMoves (maybe [] snd (progList ^? ix i))
in unlines $
intercalate "," (fmap (: []) mainRoutine)
: fmap getAndEncode [0, 1, 2] <> ["n"]
instance Solution Day17 where
solutionRun _ SolutionContext {getInputS, answerShow, answerS} = do
(ex, rawInput) <- consumeExtraLeadingLines <$> getInputS
case ex of
Nothing -> do
let xs = parseCodeOrDie rawInput
(_, out) <- runProgram xs []
let rawMap = fmap chr out
mi@MapInfo {miScaffolds, miRobot} = parseRawMap rawMap
intersections = do
coord <- S.toList miScaffolds
guard $ all (`S.member` miScaffolds) (udlrOfCoord coord)
pure coord
answerShow (sum $ fmap (uncurry (*)) intersections)
let originalMainMoves = computeMoves mi miRobot
allRoutines : _ = breakIntoRoutines "ABC" originalMainMoves
ys = 2 : tail xs
(_, out2) <- runProgram ys (fmap ord (encodeVaccumRobotInput allRoutines))
answerShow (last out2)
Just _ -> do
let mi@MapInfo {miRobot} = parseRawMap rawInput
moves = computeMoves mi miRobot
answerS (encodeMoves moves)
answerS (encodeVaccumRobotInput $ head $ breakIntoRoutines "ABC" moves)