123 lines
4.5 KiB
Haskell
123 lines
4.5 KiB
Haskell
{-# LANGUAGE DataKinds, DeriveFunctor, TypeOperators, TypeFamilies, ScopedTypeVariables, ViewPatterns, ConstraintKinds, FlexibleContexts #-}
|
|
|
|
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 Debug.Trace
|
|
|
|
main :: IO ()
|
|
main = do
|
|
hSetBuffering stdout NoBuffering -- DO NOT REMOVE
|
|
putStrLn =<< execBilbo . solveIt . map Rune <$> getLine
|
|
|
|
newtype Rune = Rune Char deriving (Eq,Show)
|
|
|
|
solveIt :: [Rune] -> Bilbo ()
|
|
solveIt rs = bindVar $ \dv -> clearRune dv *> solveIt' dv (Rune ' ') rs
|
|
|
|
solveIt' :: Int -> Rune -> [Rune] -> Bilbo ()
|
|
solveIt' dv dr [] = return ()
|
|
solveIt' dv dr [r] = atVar dv (incDecMoves dr r) *> triggerRune dv
|
|
solveIt' dv dr rs@(a:b:_) = let (_, (m, rst, dr')) = minimumBy (compare `on` fst) candidates in m *> solveIt' dv dr' rst
|
|
where
|
|
diff = incDecMoves a b
|
|
ls = (a:) $ map snd $ takeWhile ((== diff) . fst) $ zipWith (\h t -> (incDecMoves h t, t)) rs (tail rs)
|
|
rst1 = drop (length ls) rs
|
|
moves1 = [ (bindVar $ \v -> selectRune v a *> triggerRune v *> repFn (length ls - 1) (atVar v diff *> triggerRune v), rst1, dr)
|
|
| repFn <- [replicateM_, loopExpr] ]
|
|
moves2 = [ (atVar dv (incDecMoves dr a) *> triggerRune dv, tail rs, a) ]
|
|
moves3 = [ (loopExpr n $ solveIt xs, ys, dr) | (xs, n, ys) <- take 3 $ repeats rs ]
|
|
score (m, rst, dr) = length (execBilbo m) + (10 * length rst)
|
|
candidates = [ (score c, c) | c@(_, rst, _) <- moves1 ++ moves2 ++ moves3, rst /= rs ]
|
|
|
|
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)
|
|
|
|
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 = get >>= \n -> moveTo n *> tell cs
|
|
where moveTo n | v >= n = replicateM_ (v - n) moveRight
|
|
| otherwise = replicateM_ (n - v) moveLeft
|
|
|
|
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
|
|
atVar lv "["
|
|
m
|
|
decRune lv
|
|
atVar lv "]"
|
|
decRune lv
|
|
loopExpr n m = bindVar $ \lv -> do
|
|
selectRune lv $ toEnum n
|
|
atVar lv "["
|
|
m
|
|
decRune lv
|
|
atVar lv "]"
|
|
|
|
moveLeft, moveRight :: MonadBilbo m => m ()
|
|
moveLeft = modify (\n -> (n + 26) `mod` 27) *> tell "<"
|
|
moveRight = modify (\n -> (n + 28) `mod` 27) *> tell ">"
|
|
|
|
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 (fromEnum -> n)
|
|
| n <= 14 = clearRune v *> replicateM_ n (incRune v)
|
|
| otherwise = clearRune v *> replicateM_ n' (decRune v)
|
|
where n' = 27 - 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
|
|
|
|
instance Enum Rune where
|
|
toEnum 0 = Rune ' '
|
|
toEnum n | n >= 1 && n <= 26 = Rune (toEnum (fromEnum 'A' + (n - 1)))
|
|
| otherwise = error $ "Rune " ++ show n ++ " is out of range."
|
|
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) |