advent21.hs

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