125 lines
4.8 KiB
Haskell
125 lines
4.8 KiB
Haskell
{-# LANGUAGE DataKinds, DeriveFunctor, TypeOperators, TypeFamilies, ScopedTypeVariables #-}
|
|
|
|
import System.IO
|
|
import Control.Applicative
|
|
import Control.Arrow (first, second, (&&&))
|
|
import Control.Monad
|
|
import Data.Function
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Proxy
|
|
import Debug.Trace
|
|
import GHC.TypeLits
|
|
|
|
newtype Circular (n :: Nat) a = Cycle [a] deriving (Eq,Show,Functor)
|
|
newtype Rune = Rune Char deriving (Eq,Show)
|
|
type Zones = Circular 30 Rune
|
|
|
|
main :: IO ()
|
|
main = do
|
|
hSetBuffering stdout NoBuffering -- DO NOT REMOVE
|
|
putStrLn =<< solveIt . map Rune <$> getLine
|
|
|
|
solveIt :: [Rune] -> String
|
|
solveIt 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 $
|
|
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'
|
|
|
|
simulate :: String -> Zones -> Zones
|
|
simulate [] zs = zs
|
|
simulate (c:cs) zs = simulate cs $ case c of
|
|
'.' -> zs
|
|
'<' -> rotateLeft zs
|
|
'>' -> rotateRight zs
|
|
'+' -> mapC succ zs
|
|
'-' -> mapC pred zs
|
|
|
|
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
|
|
|
|
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
|
|
|
|
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
|
|
|
|
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 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)
|
|
|
|
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) |