299 lines
12 KiB
Haskell
299 lines
12 KiB
Haskell
{-# LANGUAGE ConstraintKinds, DataKinds, TypeFamilies, TypeOperators, DeriveFunctor #-}
|
|
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, BangPatterns, ViewPatterns #-}
|
|
|
|
import System.IO
|
|
import Control.Applicative
|
|
import Control.Arrow (first, second, (&&&), (***))
|
|
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 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 <- map Rune <$> getLine
|
|
let sol_1 = solveIt_1 phrase
|
|
let sol_2 = execBilbo (solveIt_2 phrase)
|
|
putStrLn $ minimumBy (compare `on` length) [sol_1, sol_2]
|
|
|
|
tryIt_1 :: String -> IO Bool
|
|
tryIt_1 phrase = (result == phrase) <$ mapM_ print [program, result]
|
|
where
|
|
program = solveIt_1 $ map Rune phrase
|
|
result = fst $ simulate program $ pure $ Rune ' '
|
|
|
|
tryIt_2 :: String -> IO Bool
|
|
tryIt_2 phrase = (result == phrase) <$ mapM_ print [program, result]
|
|
where
|
|
program = execBilbo $ solveIt_2 $ map Rune phrase
|
|
result = fst $ simulate program $ pure $ Rune ' '
|
|
|
|
{------ Version 2 ------}
|
|
|
|
newtype Rune = Rune Char deriving (Eq,Show)
|
|
|
|
solveIt_2 :: [Rune] -> Bilbo ()
|
|
solveIt_2 rs = bindVar $ \dv -> clearRune dv *> solveIt_2' dv (Rune ' ') rs
|
|
|
|
solveIt_2' :: Int -> Rune -> [Rune] -> Bilbo ()
|
|
solveIt_2' dv dr [] = return ()
|
|
solveIt_2' dv dr [r] = atVar dv (incDecMoves dr r) *> triggerRune dv
|
|
solveIt_2' dv dr rs@(a:b:_) = let (_, (m, rst, dr')) = minimumBy (compare `on` fst) candidates in m *> solveIt_2' dv dr' rst
|
|
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
|
|
dr1 = last ls
|
|
moves1 = [ (changeRune dv dr a *> triggerRune dv *> repFn (length ls - 1) (changeRune dv a b *> triggerRune dv), rst1, dr1)
|
|
| repFn <- [replicateM_, loopExpr] ]
|
|
moves2 = [ (bindVar $ \v -> selectRune v a *> triggerRune v *> repFn (length ls - 1) (changeRune v a b *> triggerRune v), rst1, dr)
|
|
| repFn <- [replicateM_, loopExpr] ]
|
|
moves3 = [ (loopExpr n $ solveIt_2 xs, ys, dr) | (xs, n, ys) <- repeats rs ]
|
|
score (m, rst, dr) = length (execBilbo m) + (10 * length rst)
|
|
candidates = [ (score c, c) | c@(_, rst, _) <- moves1 ++ moves2 ++ moves3, rst /= rs ]
|
|
|
|
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 <= 13 = bindVar $ \lv -> do
|
|
selectRune lv $ toEnum (2 * n)
|
|
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 ">"
|
|
|
|
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
|
|
|
|
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, Zones)
|
|
simulate cs zs = swap $ runWriter $ execStateT (go cs) zs
|
|
where
|
|
go [] = return ()
|
|
go (c:cs) = case c of
|
|
'.' -> do { Rune r <- extractC <$> get; tell [r]; go cs }
|
|
'<' -> modify rotateLeft >> go cs
|
|
'>' -> modify rotateRight >> go cs
|
|
'+' -> modify (mapC succ) >> go cs
|
|
'-' -> modify (mapC pred) >> go cs
|
|
'[' -> let (inside, after) = splitBrackets cs in
|
|
fix $ \loop -> get >>= \zs' ->
|
|
if extractC zs' /= Rune ' '
|
|
then go inside >> 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)
|
|
|
|
{------ Version 1 ------}
|
|
|
|
newtype Circular (n :: Nat) a = Cycle [a] deriving (Eq,Show,Functor)
|
|
type Zones = Circular 30 Rune
|
|
|
|
solveIt_1 :: [Rune] -> String
|
|
solveIt_1 phrase = loop phrase $ pure (Rune ' ')
|
|
|
|
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'' = mapC (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, mapC succ zs)
|
|
dec = ('-':ms, mapC 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
|
|
|
|
rotateLeft, rotateRight :: Circular n a -> Circular n a
|
|
rotateLeft (Cycle []) = Cycle []
|
|
rotateLeft (Cycle xs) = Cycle $ tail xs ++ [head xs]
|
|
rotateRight (Cycle []) = Cycle []
|
|
rotateRight (Cycle xs) = Cycle $ [last xs] ++ init xs
|
|
|
|
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
|
|
|
|
extractC :: (1 <= n) => Circular n a -> a
|
|
extractC (Cycle (x:_)) = x
|
|
|
|
mapC :: (1 <= n) => (a -> a) -> Circular n a -> Circular n a
|
|
mapC f (Cycle (x:xs)) = Cycle (f x : xs)
|
|
|
|
instance KnownNat n => Applicative (Circular n) where
|
|
pure x = Cycle $ replicate (fromInteger $ natVal (Proxy :: Proxy n)) x
|
|
(Cycle cf) <*> (Cycle cx) = Cycle (zipWith ($) cf cx)
|
|
|
|
{--------- 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)
|
|
|
|
dropLast, takeLast :: Int -> [a] -> [a]
|
|
dropLast n xs = zipWith const xs (drop n xs)
|
|
takeLast n xs = foldl' (\xs' ys' -> tail xs') xs (drop n xs)
|
|
|
|
accum :: (a -> b -> a) -> a -> [b] -> [a]
|
|
accum _ !a [] = [a]
|
|
accum f !a (b:bs) = a : accum f (f a b) bs
|
|
|
|
accum1 :: (a -> a -> a) -> [a] -> [a]
|
|
accum1 f [] = error "accum1: empty list"
|
|
accum1 f (a:as) = accum f a as
|
|
|
|
cumsum, cumproduct :: Num a => [a] -> [a]
|
|
cumsum = accum1 (+)
|
|
cumproduct = accum1 (*)
|