{-# 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 (*)