112 lines
3 KiB
Haskell
112 lines
3 KiB
Haskell
#!/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
|