{-# Language QuasiQuotes, OverloadedStrings #-}
{-|
Module      : Main
Description : Day 21 solution
Copyright   : (c) Eric Mertens, 2021
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2016/day/21>

-}
module Main where

import Control.Applicative ((<|>))
import Data.Char (isDigit)
import Data.List (elemIndex)
import Text.ParserCombinators.ReadP (ReadP, get, munch1)

import Advent (format)
data Scramble
  = RotateRight Int
  | RotateLeft Int
  | SwapPosition Int Int
  | SwapLetter Char Char
  | RotateChar Char
  | ReversePositions Int Int
  | MovePosition Int Int
  deriving Int -> Scramble -> ShowS
[Scramble] -> ShowS
Scramble -> [Char]
(Int -> Scramble -> ShowS)
-> (Scramble -> [Char]) -> ([Scramble] -> ShowS) -> Show Scramble
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Scramble -> ShowS
showsPrec :: Int -> Scramble -> ShowS
$cshow :: Scramble -> [Char]
show :: Scramble -> [Char]
$cshowList :: [Scramble] -> ShowS
showList :: [Scramble] -> ShowS
Show

number :: ReadP Int
number :: ReadP Int
number = [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> ReadP [Char] -> ReadP Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP [Char]
munch1 Char -> Bool
isDigit

s :: ReadP Scramble
s :: ReadP Scramble
s =
  Int -> Scramble
RotateRight Int
1    Scramble -> ReadP [Char] -> ReadP Scramble
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP [Char]
"rotate right 1 step"                 ReadP Scramble -> ReadP Scramble -> ReadP Scramble
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Int -> Scramble
RotateRight      (Int -> Scramble) -> ReadP [Char] -> ReadP (Int -> Scramble)
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP [Char]
"rotate right "                       ReadP (Int -> Scramble) -> ReadP Int -> ReadP Scramble
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Int
number ReadP Scramble -> ReadP [Char] -> ReadP Scramble
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
" steps" ReadP Scramble -> ReadP Scramble -> ReadP Scramble
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Int -> Scramble
RotateLeft Int
1     Scramble -> ReadP [Char] -> ReadP Scramble
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP [Char]
"rotate left 1 step"                  ReadP Scramble -> ReadP Scramble -> ReadP Scramble
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Int -> Scramble
RotateLeft       (Int -> Scramble) -> ReadP [Char] -> ReadP (Int -> Scramble)
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP [Char]
"rotate left "                        ReadP (Int -> Scramble) -> ReadP Int -> ReadP Scramble
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Int
number ReadP Scramble -> ReadP [Char] -> ReadP Scramble
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
" steps" ReadP Scramble -> ReadP Scramble -> ReadP Scramble
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Int -> Int -> Scramble
SwapPosition     (Int -> Int -> Scramble)
-> ReadP [Char] -> ReadP (Int -> Int -> Scramble)
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP [Char]
"swap position "                      ReadP (Int -> Int -> Scramble)
-> ReadP Int -> ReadP (Int -> Scramble)
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Int
number ReadP (Int -> Scramble) -> ReadP [Char] -> ReadP (Int -> Scramble)
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
" with position " ReadP (Int -> Scramble) -> ReadP Int -> ReadP Scramble
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Int
number ReadP Scramble -> ReadP Scramble -> ReadP Scramble
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Char -> Char -> Scramble
SwapLetter       (Char -> Char -> Scramble)
-> ReadP [Char] -> ReadP (Char -> Char -> Scramble)
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP [Char]
"swap letter "                        ReadP (Char -> Char -> Scramble)
-> ReadP Char -> ReadP (Char -> Scramble)
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Char
get    ReadP (Char -> Scramble)
-> ReadP [Char] -> ReadP (Char -> Scramble)
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
" with letter "   ReadP (Char -> Scramble) -> ReadP Char -> ReadP Scramble
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Char
get ReadP Scramble -> ReadP Scramble -> ReadP Scramble
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Char -> Scramble
RotateChar       (Char -> Scramble) -> ReadP [Char] -> ReadP (Char -> Scramble)
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP [Char]
"rotate based on position of letter " ReadP (Char -> Scramble) -> ReadP Char -> ReadP Scramble
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Char
get ReadP Scramble -> ReadP Scramble -> ReadP Scramble
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Int -> Int -> Scramble
ReversePositions (Int -> Int -> Scramble)
-> ReadP [Char] -> ReadP (Int -> Int -> Scramble)
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP [Char]
"reverse positions "                  ReadP (Int -> Int -> Scramble)
-> ReadP Int -> ReadP (Int -> Scramble)
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Int
number ReadP (Int -> Scramble) -> ReadP [Char] -> ReadP (Int -> Scramble)
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
" through "       ReadP (Int -> Scramble) -> ReadP Int -> ReadP Scramble
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Int
number ReadP Scramble -> ReadP Scramble -> ReadP Scramble
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Int -> Int -> Scramble
MovePosition     (Int -> Int -> Scramble)
-> ReadP [Char] -> ReadP (Int -> Int -> Scramble)
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP [Char]
"move position "                      ReadP (Int -> Int -> Scramble)
-> ReadP Int -> ReadP (Int -> Scramble)
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Int
number ReadP (Int -> Scramble) -> ReadP [Char] -> ReadP (Int -> Scramble)
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
" to position "   ReadP (Int -> Scramble) -> ReadP Int -> ReadP Scramble
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Int
number

part1, part2 :: String
part1 :: [Char]
part1 = [Char]
"abcdefgh"
part2 :: [Char]
part2 = [Char]
"fbgdceah"

-- | >>> :main
-- dbfgaehc
-- aghfcdeb
main :: IO ()
IO ()
main =
 do [Scramble]
inp <- [format|2016 21 (@s%n)*|]
    [Char] -> IO ()
putStrLn (([Char] -> Scramble -> [Char]) -> [Char] -> [Scramble] -> [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Scramble -> ShowS) -> [Char] -> Scramble -> [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Scramble -> ShowS
forward) [Char]
part1 [Scramble]
inp)
    [Char] -> IO ()
putStrLn ((Scramble -> ShowS) -> [Char] -> [Scramble] -> [Char]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Scramble -> ShowS
backward [Char]
part2 [Scramble]
inp)

rotateRight :: Int -> [a] -> [a]
rotateRight :: forall a. Int -> [a] -> [a]
rotateRight Int
n [a]
xs = [a]
b [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
a
  where
    n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
    ([a]
a,[a]
b) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n') [a]
xs

rotateLeft :: Int -> [a] -> [a]
rotateLeft :: forall a. Int -> [a] -> [a]
rotateLeft Int
n [a]
xs = [a]
b [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
a
  where
    n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
    ([a]
a,[a]
b) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n' [a]
xs

set :: Int -> a -> [a] -> [a]
set :: forall a. Int -> a -> [a] -> [a]
set Int
i a
x [a]
xs = [a]
a [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
b
  where
    ([a]
a,a
_:[a]
b) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
xs

forward :: Scramble -> String -> String
forward :: Scramble -> ShowS
forward Scramble
scram =
  case Scramble
scram of
    RotateRight Int
i -> Int -> ShowS
forall a. Int -> [a] -> [a]
rotateRight Int
i
    RotateLeft  Int
i -> Int -> ShowS
forall a. Int -> [a] -> [a]
rotateLeft Int
i
    SwapPosition Int
i Int
j -> \[Char]
xs -> Int -> Char -> ShowS
forall a. Int -> a -> [a] -> [a]
set Int
i ([Char]
xs[Char] -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!Int
j)
                             ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> ShowS
forall a. Int -> a -> [a] -> [a]
set Int
j ([Char]
xs[Char] -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!Int
i) [Char]
xs
    SwapLetter Char
x Char
y -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> ShowS) -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> a -> b
$ \Char
a -> if Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x then Char
y else if Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
y then Char
x else Char
a
    RotateChar Char
e -> Char -> ShowS
forall p. Eq p => p -> [p] -> [p]
rotatePositionOf Char
e
    ReversePositions Int
i Int
j -> Int -> Int -> ShowS
forall a. Int -> Int -> [a] -> [a]
reverseRange Int
i Int
j
    MovePosition Int
i Int
j -> Int -> Int -> ShowS
forall a. Int -> Int -> [a] -> [a]
movePosition Int
i Int
j

backward :: Scramble -> String -> String
backward :: Scramble -> ShowS
backward Scramble
scram =
  case Scramble
scram of
    RotateRight Int
i -> Int -> ShowS
forall a. Int -> [a] -> [a]
rotateLeft Int
i
    RotateLeft  Int
i -> Int -> ShowS
forall a. Int -> [a] -> [a]
rotateRight Int
i
    SwapPosition Int
i Int
j -> \[Char]
xs -> Int -> Char -> ShowS
forall a. Int -> a -> [a] -> [a]
set Int
i ([Char]
xs[Char] -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!Int
j)
                             ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> ShowS
forall a. Int -> a -> [a] -> [a]
set Int
j ([Char]
xs[Char] -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!Int
i) [Char]
xs
    SwapLetter Char
x Char
y -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> ShowS) -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> a -> b
$ \Char
a -> if Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x then Char
y else if Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
y then Char
x else Char
a
    RotateChar Char
e -> \[Char]
xs ->
        case [[Char]
a | Int
i <- [Int
0..[Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
xsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], let a :: [Char]
a = Int -> ShowS
forall a. Int -> [a] -> [a]
rotateRight Int
i [Char]
xs, Char -> ShowS
forall p. Eq p => p -> [p] -> [p]
rotatePositionOf Char
e [Char]
a [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
xs] of
          [[Char]
x] -> [Char]
x
          [[Char]]
_   -> ShowS
forall a. HasCallStack => [Char] -> a
error [Char]
"not unique"
    ReversePositions Int
i Int
j -> Int -> Int -> ShowS
forall a. Int -> Int -> [a] -> [a]
reverseRange Int
i Int
j
    MovePosition Int
i Int
j -> Int -> Int -> ShowS
forall a. Int -> Int -> [a] -> [a]
movePosition Int
j Int
i

rotatePositionOf :: Eq p => p -> [p] -> [p]
rotatePositionOf :: forall p. Eq p => p -> [p] -> [p]
rotatePositionOf p
e [p]
xs = Int -> [p] -> [p]
forall a. Int -> [a] -> [a]
rotateRight Int
j [p]
xs
  where
    Just Int
i = p -> [p] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex p
e [p]
xs
    j :: Int
j | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
4     = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
      | Bool
otherwise = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

reverseRange :: Int -> Int -> [a] -> [a]
reverseRange :: forall a. Int -> Int -> [a] -> [a]
reverseRange Int
i Int
j [a]
xs = [a]
a [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
c [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
d
  where
    ([a]
a,[a]
b) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
xs
    ([a]
c,[a]
d) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [a]
b

movePosition :: Int -> Int -> [a] -> [a]
movePosition :: forall a. Int -> Int -> [a] -> [a]
movePosition Int
i Int
j [a]
xs = [a]
c [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
d
  where
    ([a]
a,a
x:[a]
b) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
xs
    ([a]
c,[a]
d) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
j ([a]
a[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
b)