adventofcode1621/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