Initial commit

2017/16/day16.hs

@@ -0,0 +1,112 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-9.18 script
+
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Attoparsec.Text
+import Control.Applicative
+import Data.List
+import Data.Maybe
+import Data.Monoid
+
+data Move = Spin Int | Exchange Int Int | Partner Char Char
+  deriving (Eq, Show)
+
+isPartner :: Move -> Bool
+isPartner (Partner _ _) = True
+isPartner _ = False
+
+parseSpin :: Parser Move
+parseSpin = string "s" *> decimal >>= return . Spin
+
+parseExchange :: Parser Move
+parseExchange = do
+  string "x"
+  a <- decimal
+  string "/"
+  b <- decimal
+  return $ Exchange a b
+
+parsePartner :: Parser Move
+parsePartner = do
+  string "p"
+  a <- letter
+  string "/"
+  b <- letter
+  return $ Partner a b
+
+parseMove :: Parser Move
+parseMove = parseSpin <|> parseExchange <|> parsePartner
+
+parseMoves :: Parser [Move]
+parseMoves = parseMove `sepBy` (skipSpace *> string "," *> skipSpace)
+
+spin :: Int -> [a] -> [a]
+spin n xs = end ++ start
+  where (start, end) = splitAt (length xs - n) xs
+
+exchange :: Int -> Int -> [a] -> [a]
+exchange m n xs
+  | m == n = xs
+  | m > n = exchange n m xs
+  | otherwise = start ++ b:as ++ a:bs
+  where (start, end) = splitAt m xs
+        (a:as, b:bs) = splitAt (n-m) end
+
+partner :: Eq t => t -> t -> [t] -> [t]
+partner a b xs = exchange m n xs
+  where Just m = elemIndex a xs
+        Just n = elemIndex b xs
+
+move :: [Char] -> Move -> [Char]
+move xs (Spin n) = spin n xs
+move xs (Exchange m n) = exchange m n xs
+move xs (Partner a b) = partner a b xs
+
+findRepetition :: Eq a => [a] -> Maybe Int
+findRepetition [] = Nothing
+findRepetition (x:xs) = case elemIndices x xs of
+  [] -> Nothing
+  inds -> Just $ last inds
+
+moveMany 0 _ xs _ = xs
+moveMany n seen xs (m:ms) =
+  if xs `elem` seen
+  then concat $ intersperse "\n" seen-- !! (length seen - n `rem` length seen)
+  else let xs' = move xs m in
+         moveMany (n-1) (xs:seen) xs' ms
+
+newtype Perm16 = Perm16 [Int]
+  deriving (Show, Eq)
+
+toPermutation :: Move -> Perm16
+toPermutation (Spin n) = Perm16 $ spin n [0..15]
+toPermutation (Exchange m n) = Perm16 $ exchange m n [0..15]
+toPermutation (Partner _ _) = Perm16 [0..15]
+
+instance Monoid Perm16 where
+  mempty = Perm16 [0..15]
+  mappend (Perm16 p1) (Perm16 p2) = Perm16 $ map (p1 !!) p2
+
+applyPerm :: [b] -> Perm16 -> [b]
+applyPerm xs (Perm16 p) = map (xs !!) p
+
+main :: IO ()
+main = do
+  contents <- T.pack <$> getContents
+  let Right moves = parseOnly parseMoves contents
+  let start = ['a'..'p']
+  let partnerMoves = filter isPartner moves
+  -- print (length moves)
+  let positions = scanl' move start . concat $ replicate 1 moves
+  putStrLn $ last positions
+  let dance = mconcat . map toPermutation $  moves
+  putStrLn $ foldl' move (applyPerm start dance) partnerMoves
+  let thousanddance = iterate (<> dance) dance !! 1000
+  let milliondance = iterate (<> thousanddance) thousanddance !! 1000
+  let billiondance = iterate (<> milliondance) milliondance !! 1000
+  print billiondance
+  let billionPartnerMoves = concat $ replicate 1000000000 partnerMoves
+  putStrLn $ foldl' move (applyPerm start billiondance) billionPartnerMoves