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