Tidying
[advent-of-code-16.git] / advent21.hs
1 import Text.Parsec hiding (State)
2 import Text.ParserCombinators.Parsec.Number
3 import Data.Maybe (fromJust)
4 import Data.List (elemIndex)
5
6 import Control.Monad.Identity
7 import Control.Monad.State
8 import Control.Monad.Writer
9
10 data Instruction = SwapPosition Int Int
11 | SwapLetter Char Char
12 | RotateSteps Int
13 | RotateLetter Char
14 | Reverse Int Int
15 | Move Int Int
16 deriving (Show, Eq)
17
18 data Log = Log {
19 action :: String
20 } deriving (Show)
21
22 data Password = Password {
23 password :: String
24 } deriving (Show)
25
26
27 type App = WriterT [Log] (StateT Password Identity)
28
29 infixl 9 ??
30
31 (??) :: Eq a => [a] -> a -> Int
32 (??) items item = fromJust $ elemIndex item items
33
34
35 initial = "abcdefgh"
36 final = "fbgdceah"
37
38 testInstructions = "\
39 \swap position 4 with position 0\n\
40 \swap letter d with letter b\n\
41 \reverse positions 0 through 4\n\
42 \rotate left 1 step\n\
43 \move position 1 to position 4\n\
44 \move position 3 to position 0\n\
45 \rotate based on position of letter b\n\
46 \rotate based on position of letter d\n"
47
48 main :: IO ()
49 main = do
50 -- let ti = successfulParse $ parseIfile testInstructions
51 -- part1 ti "abcde"
52 -- part2 (reverse ti) "decab"
53 text <- readFile "advent21.txt"
54 let instructions = successfulParse $ parseIfile text
55 part1 instructions initial
56 part2 (reverse instructions) final
57
58 part1 :: [Instruction] -> String -> IO ()
59 part1 instructions start =
60 let st = Password {password = start}
61 ((_, log), st') = runIdentity (runStateT (runWriterT (apply instructions)) st)
62 in do
63 -- putStrLn $ unlines $ map (action) log
64 putStrLn $ password st'
65
66 part2 :: [Instruction] -> String -> IO ()
67 part2 instructions end =
68 let st = Password {password = end}
69 ((_, log), st') = runIdentity (runStateT (runWriterT (unApply instructions)) st)
70 in do
71 -- putStrLn $ unlines $ map (action) log
72 putStrLn $ password st'
73
74
75 apply :: [Instruction] -> App ()
76 apply [] = return ()
77 apply (i:is) =
78 do st <- get
79 let p0 = password st
80 let p1 = applyInstruction i p0
81 put st {password = p1}
82 tell [Log (p0 ++ " -> " ++ p1 ++ " : " ++ (show i))]
83 apply is
84
85
86 applyInstruction :: Instruction -> String -> String
87 applyInstruction (SwapPosition from to) p0
88 | from == to = p0
89 | otherwise = prefix ++ [p0!!end] ++ midfix ++ [p0!!start] ++ suffix
90 where start = minimum [from, to]
91 end = maximum [from, to]
92 prefix = take start p0
93 midfix = take (end-start-1) $ drop (start+1) p0
94 suffix = drop (end+1) p0
95
96 applyInstruction (SwapLetter l0 l1) p0 = applyInstruction (SwapPosition (p0??l0) (p0??l1)) p0
97
98 applyInstruction (RotateSteps n) p0 = (drop n' p0) ++ (take n' p0)
99 where n' = if n < 0
100 then (-1 * n)
101 else (length p0) - n
102
103 applyInstruction (RotateLetter l) p0 = applyInstruction (RotateSteps n) p0
104 where n = (1 + (p0??l) + if (p0??l) >= 4 then 1 else 0) `mod` (length p0)
105
106 applyInstruction (Reverse from to) p0
107 | from == to = p0
108 | otherwise = prefix ++ (reverse midfix) ++ suffix
109 where start = minimum [from, to]
110 end = maximum [from, to]
111 prefix = take start p0
112 midfix = take (end-start+1) $ drop start p0
113 suffix = drop (end+1) p0
114
115 applyInstruction (Move from to) p0
116 | from == to = p0
117 | otherwise = prefix ++ [p0!!from] ++ suffix
118 where without = take from p0 ++ drop (from+1) p0
119 prefix = take to without
120 suffix = drop (to) without
121
122
123 unApply :: [Instruction] -> App ()
124 unApply [] = return ()
125 unApply (i:is) =
126 do st <- get
127 let p0 = password st
128 let p1 = unApplyInstruction i p0
129 put st {password = p1}
130 tell [Log (p1 ++ " <- " ++ p0 ++ " : " ++ (show i))]
131 unApply is
132
133 unApplyInstruction :: Instruction -> String -> String
134 unApplyInstruction (SwapPosition from to) p0 = applyInstruction (SwapPosition from to) p0
135 unApplyInstruction (SwapLetter l0 l1) p0 = applyInstruction (SwapLetter l0 l1) p0
136 unApplyInstruction (RotateSteps n) p0 = applyInstruction (RotateSteps (-1 * n)) p0
137 unApplyInstruction (Reverse from to) p0 = applyInstruction (Reverse from to) p0
138 unApplyInstruction (Move from to) p0 = applyInstruction (Move to from) p0
139 unApplyInstruction (RotateLetter l) p0 = applyInstruction (RotateSteps n) p0
140 where n = case (p0??l) of
141 0 -> -1
142 1 -> -1
143 2 -> 2
144 3 -> -2
145 4 -> 1
146 5 -> -3
147 6 -> 0
148 7 -> -4
149 -- where n = case (p0??l) of
150 -- 0 -> -1
151 -- 1 -> -1
152 -- 2 -> 1
153 -- 3 -> -2
154 -- 4 -> 1
155
156
157 instructionFile = instructionLine `endBy` newline
158 instructionLine = choice [ swapL
159 , rotateL
160 , reverseL
161 , moveL
162 ]
163
164 swapL = (try (string "swap ")) *> (swapPosL <|> swapLetterL)
165
166 swapPosL = SwapPosition <$> (string "position" *> spaces *> int)
167 <*> (spaces *> string "with position" *> spaces *> int)
168
169 swapLetterL = SwapLetter <$> (string "letter" *> spaces *> letter)
170 <*> (spaces *> string "with letter" *> spaces *> letter)
171
172 rotateL = (try (string "rotate ")) *> (rotateDirL <|> rotateLetterL)
173
174 rotateDirL = rotateStepify <$> ((string "left") <|> (string "right"))
175 <*> (spaces *> int <* spaces <* skipMany letter)
176 where rotateStepify dir n = case dir of
177 "left" -> (RotateSteps (-1 * n))
178 "right" -> (RotateSteps n)
179 rotateLetterL = RotateLetter <$> (string "based on position of letter " *> letter)
180
181 reverseL = Reverse <$> (string "reverse positions" *> spaces *> int)
182 <*> (spaces *> (string "through") *> spaces *> int)
183
184 moveL = Move <$> (string "move position" *> spaces *> int)
185 <*> (spaces *> (string "to position") *> spaces *> int)
186
187
188 parseIfile :: String -> Either ParseError [Instruction]
189 parseIfile input = parse instructionFile "(unknown)" input
190
191 parseIline :: String -> Either ParseError Instruction
192 parseIline input = parse instructionLine "(unknown)" input
193
194 successfulParse :: Either ParseError [a] -> [a]
195 successfulParse (Left _) = []
196 successfulParse (Right a) = a