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