Day 16 b

1 files changed, 48 insertions, 18 deletions

diff --git a/2017/16.hs b/2017/16.hs
index 9469d71..7f343b2 100644
--- a/2017/16.hs
+++ b/2017/16.hs
@@ -2,6 +2,7 @@ import Control.Monad
 import Data.Char
 import Data.List
 import Data.Maybe
+import Data.Monoid
 
 
 splitOn :: Eq a => a -> [a] -> [[a]]
@@ -12,37 +13,66 @@ splitOn c xs = case break (== c) xs of
 strip :: String -> String
 strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
 
-swap :: Int -> Int -> [a] -> [a]
-swap i j (hd:tl) = case (i, j) of
-    (0, _) -> uncurry (:) (go (j-1) hd tl)
-    (_, 0) -> uncurry (:) (go (i-1) hd tl)
-    (_, _) -> hd : swap (i-1) (j-1) tl
-  where
-    go 0 v (hd:tl) = (hd, v : tl)
-    go k v (hd:tl) = fmap (hd :) (go (k-1) v tl)
-
 data Ins = Spin Int | Exch Int Int | Part Int Int
   deriving Show
 
 newtype State = State [Int]
+  deriving Eq
 
 instance Show State where
     show (State ar) = map (chr . (+ ord 'a')) ar
 
 parse :: String -> Ins
 parse ('s' : s) = Spin (read s)
-parse ('x' : s) = let [a, b] = splitOn '/' s in Exch (read a) (read b)
+parse ('x' : s) | [a, b] <- splitOn '/' s = Exch (read a) (read b)
 parse ['p', a, '/', b] = Part (ord a - ord 'a') (ord b - ord 'a')
 
-exec :: State -> Ins -> State
-exec (State ar) (Spin n) = State $ take 16 (drop (16 - n) (cycle ar))
-exec (State ar) (Exch i j) = State $ swap i j ar
-exec (State ar) (Part a b) =
-    let i = fromMaybe (-1) (findIndex (== a) ar)
-        j = fromMaybe (-1) (findIndex (== b) ar)
-    in State $ swap i j ar
+newtype Permutation = Permutation [Int]
+  deriving Show
+
+permute :: Permutation -> [a] -> [a]
+permute (Permutation p) ar = [ar !! i | i <- p]
+
+instance Monoid Permutation where
+    mempty = Permutation [0..15]
+    mappend a (Permutation b) = Permutation (permute a b)
+
+mtimes :: Monoid a => Int -> a -> a
+mtimes 0 _ = mempty
+mtimes 1 m = m
+mtimes n m
+    | even n = let m' = mtimes (n `quot` 2) m in m' <> m'
+    | odd n = m <> mtimes (pred n) m
+
+permExch :: Int -> Int -> Permutation
+permExch i j
+    | i > j = permExch j i
+    | otherwise = Permutation ([0..i-1] ++ [j] ++ [i+1..j-1] ++ [i] ++ [j+1..15])
+
+data Dance = Dance Permutation {- place permutation -}
+                   Permutation {- name permutation -}
+  deriving Show
+
+instance Monoid Dance where
+    mempty = Dance mempty mempty
+    mappend (Dance pp1 np1) (Dance pp2 np2) = Dance (pp1 <> pp2) (np2 <> np1)
+
+makeDance :: [Ins] -> Dance
+makeDance = foldl add (Dance (Permutation [0..15]) (Permutation [0..15]))
+  where
+    add (Dance pp np) (Spin n) = Dance (Permutation ([16-n..15] ++ [0..15-n]) <> pp) np
+    add (Dance pp np) (Exch i j) = Dance (permExch i j <> pp) np
+    add (Dance pp np) (Part i j) = Dance pp (np <> permExch i j)  -- for some reason, these are inverted.
+
+dance :: Dance -> State -> State
+dance (Dance pp np) (State ar) =
+    let names = permute np [0..15]
+    in State (map (names !!) (permute pp ar))
 
 main :: IO ()
 main = do
     input <- liftM (map parse . splitOn ',' . strip) (readFile "16.in")
-    print (foldl exec (State [0..15]) input)
+    let d = makeDance input
+    print (dance d (State [0..15]))
+
+    print (dance (mtimes 1000000000 (makeDance input)) (State [0..15]))