nybble
/
CodinGame
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
CodinGame/Contests/CodeOfTheRings/CodeOfTheRings4.hs

423 lines
16 KiB
Haskell
Raw Blame History

{-# LANGUAGE ConstraintKinds, DataKinds, TypeFamilies, TypeOperators, DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, BangPatterns, ViewPatterns #-}
import System.IO
import System.IO.Unsafe
import System.Timeout
import Control.Applicative
import Control.Arrow (first, second, (&&&), (***))
import Control.DeepSeq
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.State (StateT)
import Control.Monad.Trans.Writer (WriterT)
import Control.Monad.Trans.List
--import Control.Comonad
import Data.Function
import Data.List
import Data.Maybe
import Data.Tuple
import Debug.Trace
import Data.Proxy
import GHC.TypeLits
main :: IO ()
main = do
hSetBuffering stdout NoBuffering -- DO NOT REMOVE
phrase <- toRunes <$> getLine
sols <- mapM (\f -> timeout 400000 $ return $!! f phrase) [solveIt_1, solveIt_2]
putStrLn $ minimumBy (compare `on` length) $ catMaybes sols
tryIt :: ([Rune] -> String) -> String -> IO Bool
tryIt solveIt phrase = (result == phrase) <$ mapM_ print [program, result, show steps]
where
program = solveIt $ toRunes phrase
(result, Sum steps) = fst $ simulate program initZones
{------ Version 2 ------}
newtype Rune = Rune Char deriving (Eq,Show)
solveIt_2 :: [Rune] -> String
solveIt_2 = execBilbo . solveIt_2'
solveIt_2' :: [Rune] -> Bilbo ()
solveIt_2' [] = return ()
solveIt_2' [r] = putRune r
solveIt_2' rs@(a:b:_) = bestM *> solveIt_2' bestRst
where
diff = distance a b
ls = (a:) $ map snd $ takeWhile ((== diff) . fst) $ zipWith (\h t -> (distance h t, t)) rs (tail rs)
rst1 = drop (length ls) rs
moves1 = [ (bindVar $ \v -> selectRune v a *> triggerRune v *> repFn (length ls - 1) (changeRune v a b *> triggerRune v), rst1)
| repFn <- [replicateM_, loopExpr] ]
moves2 = [ (withRunes xs (\vs -> loopExpr n $ mapM_ triggerRune vs), ys) | (xs, n, ys) <- repeats rs, n > 2 * length xs, length xs < 16 ]
moves3 = [ (putPattern p, ys) | (p, ys) <- unsafeTimeoutList 100000 $ patterns rs ]
moves4 = [ (loopExpr n (solveIt_2' xs), ys) | (xs, n, ys) <- repeats rs ]
score (m, rst) = length (execBilbo m) + (10 * length rst)
candidates = [ (score c, c) | c@(_, rst) <- moves1 ++ moves2 ++ moves3 ++ moves4, rst /= rs ]
(_, (bestM, bestRst)) = minimumBy (compare `on` fst) candidates
-- If at any point it takes more than `t` microseconds to compute the next
-- element of the list (to WHNF), abandon the calculation and terminate
-- the list. Note that this causes the length of the result to depend
-- on timing and system load. Marked "unsafe" for a reason!
unsafeTimeoutList :: Int -> [a] -> [a]
unsafeTimeoutList t xs = unsafePerformIO $ do
r <- timeout t $ return $! case xs of
[] -> []
(a:as) -> a `seq` (a:as)
return $ case r of
Nothing -> []
Just [] -> []
Just (a:as) -> (a : unsafeTimeoutList t as)
type MonadBilbo m = (Applicative m, MonadWriter String m, MonadState Int m, MonadReader Int m)
type Bilbo a = ReaderT Int (StateT Int (Writer String)) a
execBilbo :: Bilbo a -> String
execBilbo m = execWriter $ runStateT (runReaderT m 0) 0
bindVar :: MonadBilbo m => (Int -> m a) -> m a
bindVar f = ask >>= \v -> local (+1) (f v)
atVar :: MonadBilbo m => Int -> String -> m ()
atVar v cs = moveTo v *> tell cs
loopAtVar :: MonadBilbo m => Int -> m a -> m a
loopAtVar v m = atVar v "[" *> m <* atVar v "]"
loopExpr :: MonadBilbo m => Int -> m () -> m ()
loopExpr 0 m = return ()
loopExpr 1 m = m
loopExpr n m | n >= 27 = bindVar $ \lv -> do
selectRune lv $ toEnum $ n `mod` 26
when (n `mod` 26 == 0) $ decRune lv
loopExpr (1 + ((n - 1) `div` 26)) $ do
loopAtVar lv (m *> decRune lv)
decRune lv
loopExpr n m | n >= 10 && n <= 17 = bindVar $ \lv -> do
selectRune lv $ toEnum (2 * n `mod` 27)
loopAtVar lv (m *> decRune lv *> decRune lv)
loopExpr n m = bindVar $ \lv -> do
selectRune lv $ toEnum n
loopAtVar lv (m *> decRune lv)
moveLeft, moveRight :: MonadBilbo m => m ()
moveLeft = modify (\n -> (n + 26) `mod` 27) *> tell "<"
moveRight = modify (\n -> (n + 28) `mod` 27) *> tell ">"
clearAllRunes :: MonadBilbo m => m ()
clearAllRunes = put 0 *> tell "[-]+++[>[-]>[-]<<[->>+<<]>>--]"
moveTo :: MonadBilbo m => Int -> m ()
moveTo v = get >>= moveFrom
where moveFrom n | v >= n = replicateM_ (v - n) moveRight
| otherwise = replicateM_ (n - v) moveLeft
clearRune, incRune, decRune, triggerRune :: MonadBilbo m => Int -> m ()
clearRune v = atVar v "[-]"
incRune v = atVar v "+"
decRune v = atVar v "-"
triggerRune v = atVar v "."
putRune :: MonadBilbo m => Rune -> m ()
putRune r = bindVar $ \v -> selectRune v r *> triggerRune v
selectRune :: MonadBilbo m => Int -> Rune -> m ()
selectRune v r = clearRune v *> changeRune v (Rune ' ') r
withRunes :: MonadBilbo m => [Rune] -> ([Int] -> m a) -> m a
withRunes [] f = f []
withRunes (r:rs) f = bindVar $ \v -> selectRune v r *> withRunes rs (f . (v:))
changeRune :: MonadBilbo m => Int -> Rune -> Rune -> m ()
changeRune v a b = if d1 < d2 then replicateM_ d1 (decRune v)
else replicateM_ d2 (incRune v)
where
d1 = ((fromEnum a - fromEnum b) + 27) `mod` 27
d2 = ((fromEnum b - fromEnum a) + 27) `mod` 27
simulate :: String -> Zones -> ((String, Sum Int), Zones)
simulate cs zs = swap $ runWriter $ execStateT (go cs) zs
where
go [] = return ()
go (c:cs) = tell ("", Sum 1) >> case c of
'.' -> do { Rune r <- extractC <$> get; tell ([r], Sum 0); go cs }
'<' -> modify rotateRight >> go cs
'>' -> modify rotateLeft >> go cs
'+' -> modify (modifyC succ) >> go cs
'-' -> modify (modifyC pred) >> go cs
'[' -> let (inside, after) = splitBrackets cs in
fix $ \loop -> get >>= \zs' ->
if extractC zs' /= Rune ' '
then go inside >> tell ("", Sum 1) >> loop
else go after
splitBrackets :: String -> (String, String)
splitBrackets cs = go cs 0
where
go [] _ = error "splitBrackets: unmatched brackets"
go (']':cs) 0 = ("", cs)
go (c:cs) n = first (c:) $ go cs $
case c of { '[' -> n+1; ']' -> n-1; _ -> n }
moveRune :: MonadBilbo m => Int -> [Int] -> m ()
moveRune s ts = mapM_ clearRune ts *> loopAtVar s (mapM_ incRune ts *> decRune s)
copyRune :: MonadBilbo m => Int -> [Int] -> m ()
copyRune s ts = bindVar $ \v -> moveRune s (v:ts) *> moveRune v [s]
switch :: MonadBilbo m => Int -> [m ()] -> m ()
switch cv [] = clearRune cv
switch cv ms = bindVar $ \fv -> clearRune fv *> incRune fv *> go fv ms
where
go fv [m] = m *> decRune fv *> clearRune cv
go fv (m:ms) = loopAtVar cv (decRune cv *> go fv ms)
*> loopAtVar fv (m *> decRune fv)
ifThenElse :: MonadBilbo m => Int -> m () -> m () -> m ()
ifThenElse cv t f = switch cv [f, t]
ifThen :: MonadBilbo m => Int -> m a -> m a
ifThen cv t = loopAtVar cv (t <* clearRune cv)
whileLoop :: MonadBilbo m => (Int -> m ()) -> m () -> m ()
whileLoop fc m = bindVar $ \v -> selectRune v (toEnum 1) *>
loopAtVar v (bindVar $ \v2 -> fc v2 *> ifThenElse v2 m (decRune v))
instance Enum Rune where
toEnum 0 = Rune ' '
toEnum n | n >= 1 && n <= 26 = Rune (toEnum (fromEnum 'A' + (n - 1)))
| otherwise = error $ "Rune.toEnum: bad argument: " ++ show n
fromEnum (Rune ' ') = 0
fromEnum (Rune c) = fromEnum c - fromEnum 'A' + 1
succ (Rune ' ') = Rune 'A'
succ (Rune 'Z') = Rune ' '
succ (Rune c ) = Rune (succ c)
pred (Rune ' ') = Rune 'Z'
pred (Rune 'A') = Rune ' '
pred (Rune c ) = Rune (pred c)
toRunes :: String -> [Rune]
toRunes = map Rune
fromRunes :: [Rune] -> String
fromRunes = map (\(Rune c) -> c)
{------ Version 1 ------}
type Zones = Circular 30 Rune
initZones :: Zones
initZones = pure $ Rune ' '
solveIt_1 :: [Rune] -> String
solveIt_1 phrase = loop phrase initZones
loop :: [Rune] -> Zones -> String
loop [] _ = ""
loop phrase zones = moves'
where
diff = if null (tail phrase) then "" else incDecMoves (phrase !! 0) (phrase !! 1)
seqn = head phrase : map snd (takeWhile ((== diff) . fst) (zipWith (\h t -> (incDecMoves h t, t)) phrase (tail phrase)))
(moves, zones') = findNearest (head seqn) zones
(rep, (setup, step, count)) =
if length seqn >= 15
then (3, setCounter (extractC $ rotateRight zones') $ length seqn `div` 3)
else (1, setCounter (extractC $ rotateRight zones') $ length seqn)
inner = concat $ replicate rep ('.':diff)
loopMoves = ">" ++ setup ++ "[<" ++ inner ++ ">" ++ step ++ "]"
zones'' = modifyC (const $ Rune ' ') $ rotateRight $ snd $
simulate (concat (replicate (count * rep) diff)) zones'
moves' = if length loopMoves < count * rep + (count * rep - 1) * length diff
then moves ++ loopMoves ++ loop (drop (count * rep) phrase) zones''
else moves ++ "." ++ loop (tail phrase) zones'
findNearest :: Rune -> Zones -> (String, Zones)
findNearest r zones = first (tail . reverse) $ head $ filter ((== r) . extractC . snd) bfs
where
bfs = ("$", zones) : concatMap next bfs
next :: (String, Zones) -> [(String, Zones)]
next (ms, zs) = case head ms of
'$' -> [ left, right, inc, dec ]
'<' -> [ left, inc, dec ]
'>' -> [ right, inc, dec ]
'+' -> [ inc ]
'-' -> [ dec ]
where
left = ('<':ms, rotateLeft zs)
right = ('>':ms, rotateRight zs)
inc = ('+':ms, modifyC succ zs)
dec = ('-':ms, modifyC pred zs)
setCounter :: Rune -> Int -> (String, String, Int)
setCounter c n
| n > 26 = setCounter c 26
| otherwise = minimumBy (compare `on` (\(x, y, _) -> length x + length y)) $ catMaybes $
[ (,,) <$> (incDecMoves c <$> fromCounter n '+') <*> pure "+" <*> pure n
, (,,) <$> (incDecMoves c <$> fromCounter n '-') <*> pure "-" <*> pure n
, (,,) <$> (incDecMoves c <$> fromCounter (2 * n2) '+') <*> pure "++" <*> pure n2
, (,,) <$> (incDecMoves c <$> fromCounter (2 * n2) '-') <*> pure "--" <*> pure n2
]
where
n2 = if even n then n else n - 1
fromCounter :: Int -> Char -> Maybe Rune
fromCounter 0 _ = Just $ toEnum 0
fromCounter n _ | n < 1 || n > 26 = Nothing
fromCounter n '+' = Just $ toEnum (27 - n)
fromCounter n '-' = Just $ toEnum n
distance :: Rune -> Rune -> (Int, Char)
distance a b = if d1 < d2 then (d1, '-') else (d2, '+')
where
d1 = ((fromEnum a - fromEnum b) + 27) `mod` 27
d2 = ((fromEnum b - fromEnum a) + 27) `mod` 27
incDecMoves :: Rune -> Rune -> String
incDecMoves from to = uncurry replicate $ distance from to
{----- Fixed-size cyclic lists -----}
data Circular (n :: Nat) a = Cycle [a] a [a] deriving (Eq,Show,Functor)
rotateLeft, rotateRight :: (KnownNat n, 1 <= n) => Circular n a -> Circular n a
rotateLeft (Cycle l x []) = let (x':r') = reverse l in Cycle [x] x' r'
rotateLeft (Cycle l x (x':r')) = Cycle (x:l) x' r'
rotateRight (Cycle [] x r) = let (x':l') = reverse r in Cycle l' x' [x]
rotateRight (Cycle (x':l') x r) = Cycle l' x' (x:r)
extractC :: (KnownNat n, 1 <= n) => Circular n a -> a
extractC (Cycle _ x _) = x
deleteC :: (KnownNat n, 1 <= n) => Circular (n+1) a -> (a, Circular n a)
deleteC (Cycle (x':l') x r) = (x, Cycle l' x' r)
deleteC (Cycle [] x (x':r')) = (x, Cycle [] x' r')
insertC :: (KnownNat n, 1 <= n) => a -> Circular n a -> Circular (n+1) a
insertC x' (Cycle l x r) = Cycle l x' (x:r)
modifyC :: (KnownNat n, 1 <= n) => (a -> a) -> Circular n a -> Circular n a
modifyC f (Cycle l x r) = Cycle l (f x) r
fillC :: (KnownNat n, 1 <= n) => [a] -> Circular n a -> Circular n a
fillC xs (Cycle l x r) = Cycle [] x' r'
where (x':r') = zipWith ($) (map const xs ++ repeat id) ((x:r) ++ reverse l)
instance (KnownNat n, 1 <= n) => Applicative (Circular n) where
pure x = Cycle [] x $ replicate (fromInteger (natVal (Proxy :: Proxy n)) - 1) x
(Cycle fl f fr) <*> (Cycle xl x xr) = Cycle [] (f x) (zipWith ($) fr' xr')
where fr' = fr ++ reverse fl
xr' = xr ++ reverse xl
{-
instance (KnownNat n, 1 <= n) => Comonad (Circular n) where
extract c = extractC c
duplicate c = Cycle [] c (take (fromInteger (natVal (Proxy :: Proxy n)) - 1) cs)
where cs = map rotateLeft (c:cs)
-}
{--------- Utility Functions --------}
repeats :: Eq a => [a] -> [([a], Int, [a])]
repeats as = go (length as `div` 2)
where
go 0 = []
go n = let (xs, ys) = splitAt n as
m = length (takeWhile id (zipWith (==) (cycle xs) as)) `div` n
in if m >= 2 then (xs, m, drop (m * length xs) as) : go (n - 1) else go (n - 1)
patterns :: [Rune] -> [([[[Rune]]], [Rune])]
patterns [] = []
patterns xs = do
n <- [1 .. length xs `div` 2]
let (cs, xs') = chunksOf n xs
take 1 $ do
ns <- takeWhile ((<= 4) . length) $ addsUpTo n
let cs' = map (fst . splitAts ns) cs
let m = countSame $ takeWhile (all isJust) $ map (map fullSeq) cs'
guard $ m >= 2
let (cs'', ncs) = splitAt m cs'
let xs'' = concat (map concat ncs) ++ xs'
let seqHeads = transpose $ map (map head) cs''
let m' = let ms = m : map seqLength (zipWith take ms seqHeads) in last ms
guard $ m' >= 2
let (cs''', ncs') = splitAt m' cs''
let xs''' = concat (map concat ncs') ++ xs''
return (cs''', xs''')
putPattern :: MonadBilbo m => [[[Rune]]] -> m ()
putPattern ps = withRunes (map head $ head ps) $ \vs -> do
loopExpr (length ps) $ do
forM_ (zip vs (zip (ps!!0) (ps!!1))) $ \(v, (rs, (c:_))) -> do
triggerRune v
loopExpr (length rs - 1) $ do
changeRune v (rs!!0) (rs!!1)
triggerRune v
changeRune v (last rs) c
chunksOf :: Int -> [a] -> ([[a]], [a])
chunksOf n xs = if length as < n then ([], as) else first (as:) (chunksOf n bs)
where (as, bs) = splitAt n xs
seqLength :: [Rune] -> Int
seqLength [] = 0
seqLength xs = (1+) $ countSame $ zipWith minusRune (tail xs) xs
countSame :: Eq a => [a] -> Int
countSame [] = 0
countSame [x] = 1
countSame (x:y:xs) = if x == y then 1 + countSame (y:xs) else 1
fullSeq :: [Rune] -> Maybe Int
fullSeq xs = if seqLength xs == length xs then Just (seqDiff xs) else Nothing
seqDiff :: [Rune] -> Int
seqDiff [] = 0
seqDiff [x] = 0
seqDiff (x:y:_) = y `minusRune` x
minusRune :: Rune -> Rune -> Int
a `minusRune` b = (27 + fromEnum a - fromEnum b) `mod` 27
-- All the list of numbers in [1..m] which add up to m, including permutations.
-- Sorted shortest to longest, then lexographically descending.
-- addsUpTo 3 ==> [[3],[2,1],[1,2],[1,1,1]]
addsUpTo :: (Integral a) => a -> [[a]]
addsUpTo m = concat [ go m n | n <- [1..m] ]
where go m 1 = [[m]]
go m n | n > 1 = concat [ map (x:) (go (m-x) (n-1)) | x <- [m-(n-1),m-n..1] ]
splitAts :: [Int] -> [a] -> ([[a]], [a])
splitAts [] xs = ([], xs)
splitAts (a:as) xs = (bs : ds, xs')
where (bs,cs) = splitAt a xs
(ds,xs') = splitAts as cs
sublists :: [a] -> [[[a]]]
sublists xs = map (fst . flip splitAts xs) $ addsUpTo (length xs)
dropLast, takeLast :: Int -> [a] -> [a]
dropLast n xs = zipWith const xs (drop n xs)
takeLast n xs = foldl' (\xs' _ -> tail xs') xs (drop n xs)
lengthGT :: Int -> [a] -> Bool
lengthGT n xs = (n < 0) || not (null (drop n xs))
accum :: (a -> b -> a) -> a -> [b] -> [a]
accum _ _ [] = []
accum f a (b:bs) = let a' = f a b in seq a' (a' : accum f a' bs)
accum1 :: (a -> a -> a) -> [a] -> [a]
accum1 f [] = []
accum1 f (a:as) = a : accum f a as
cumsum, cumproduct :: Num a => [a] -> [a]
cumsum = accum1 (+)
cumproduct = accum1 (*)
Reference in New Issue View Git Blame Copy Permalink