module Acme.LOLCAT (translate, KindaText()) where
import Data.Text (Text)
import qualified Data.Text as T
import Text.Parsec
import Text.Parsec.Text()
import Text.Parsec.Prim (runP)
import Control.Applicative ((<$>),(<*),(<*>))
import Control.Arrow
import Control.Monad
import Data.String (IsString(..))
import Data.Monoid
import Data.Char
import System.Random
import qualified System.Random.Shuffle as SHU (shuffle')
import Acme.LOLCAT.IO
shuffle :: [a] -> [a]
shuffle xs = do io <- OH HAI I CAN HAZ IO? THXBYE
SHU.shuffle' xs (length xs) (io newStdGen)
variants :: [a] -> [a]
variants xs = shuffle xs ++ variants xs
type Parser = Parsec Text ParserState
data ParserState = Word | Punct deriving Eq
type Pattern = Parser String
replaceOne :: Pattern -> Text -> Text -> Either Text Text
replaceOne pat to s | Right s' <- parsed = Right s'
| otherwise = Left s
where repl (pref,r) = pref <> to <> T.drop (T.length pref + length r) s
parsed = repl <$> myRun (find pat) s
myRun :: Parser a -> Text -> Either ParseError a
myRun p s = runP p Punct "" s
replace :: Pattern -> [Text] -> Text -> Text
replace pat tos str = repl (cycle tos) $ Right str
where repl (t:ts) (Right s) = repl ts $ replaceOne pat t s
repl _ (Left s) = s
translateT :: Text -> Text
translateT src
| n == 1 = base <> " THX"
| n == 2 = base <> " THXBYE."
| otherwise = base
where
Just n = OH HAI I CAN HAZ IO? THXBYE
<*> Just (randomRIO (1,10)) :: Maybe Int
base = T.toUpper . last . flip (scanl f) rules . T.toLower $ src
f s (pat,repls) = replace pat (variants repls) s
class KindaText a where
fromText :: Text -> a
toText :: a -> Text
instance KindaText Text where
fromText = id
toText = id
instance KindaText String where
fromText = T.unpack
toText = T.pack
translate :: KindaText s => s -> s
translate = fromText . translateT . toText
instance IsString (Parser String) where
fromString = string
find :: Pattern -> Parser (Text,String)
find pat = try (("",) <$> pat)
<|> do c <- anyChar
putState $ if isLetter c then Word else Punct
first (T.cons c) <$> find pat
word :: String -> Parser String
word s = do Punct <- getState
string s <* wordEnd
inside :: String -> Parser String
inside s = do Word <- getState
string s <* letter
wordPuncts :: String -> Parser String
wordPuncts w = (++) <$> word w <*> many1 space
wEnds :: String -> Parser String
wEnds s = string s <* wordEnd
wordEnd = notFollowedBy letter
main = forever $ getLine >>= putStrLn . translate
rules :: [(Parser String, [Text])]
rules = [
("what", ["wut", "whut"]),
(wEnds "you", ["yu", "yous", "yoo", "u"]),
("cture", ["kshur"]),
("unless", ["unles"]),
(wEnds "the", ["teh"]),
("more", ["moar"]),
("my", ["muh", "mah"]),
("are", ["r", "is", "ar"]),
(" a ", [" "]),
("eese", ["eez"]),
("catamorphi", ["cat-a-murrphi"]),
("morphi", ["murrphi"]),
("ph", ["f"]),
(wEnds "as", ["az"]),
("seriously", ["srsly"]),
(wEnds "er", ["r"]),
("sion", ["shun"]),
("just", ["jus"]),
(wEnds "ose", ["oze"]),
("eady", ["eddy"]),
(wEnds "om" <|> wEnds "ome", ["um"]),
(wEnds "of", ["of", "ov", "of"]),
("uestion", ["wesjun"]),
(word "want", ["wants"]),
(wEnds "ead", ["edd"]),
("ucke", ["ukki", "ukke"]),
("sion", ["shun"]),
("eak", ["ekk"]),
("age", ["uj"]),
("like", ["likes", "liek"]),
("love", ["loves", "lub", "lubs", "luv"]),
(word "is", ["ar teh","ar"]),
(wEnds "nd", ["n"]),
("who", ["hoo"]),
("'", [""]),
(wEnds "ese", ["eez"]),
("outh", ["owf"]),
("scio", ["shu"]),
("esque", ["esk"]),
("ture", ["chur"]),
(word "too" <|> word "to", ["to", "t", "2", "to", "t"]),
("tious", ["shus"]),
(wEnds "sure", ["shur"]),
(wEnds "tty", ["tteh"]),
("were", ["was"]),
(wEnds "ok", ["k", "kay"]),
("ym", ["im"]),
(wEnds "thy", ["fee"]),
(inside "ly", ["li"]),
("que" <* letter, ["kwe"]),
("oth", ["udd"]),
("ease", ["eez"]),
(wEnds "ing", ["in", "ins", "ng", "ing"]),
("your", ["yur", "ur", "yore", "yoar"]),
(wEnds "ove", ["oov", "ove", "uuv", "uv", "oove"]),
("for", ["for", "4", "fr", "fur", "for", "foar"]),
("thank", ["fank", "tank", "thx", "thnx"]),
("good", ["gud", "goed", "guud", "gude", "gewd"]),
("really", ["rly", "rily", "rilly", "rilley"]),
("world", ["wurrld", "whirld", "wurld", "wrld"]),
(word "i'm" <|> word "im", ["im"]),
("tion", ["shun"]),
("you're" <|> "youre" <|> "you are",
["yore", "yr"]),
(word "oh", ["o", "ohs"]),
(join<$>sequence [wordPuncts "can",
wordPuncts "i",
wordPuncts "have",
word "a"], ["i can has"]),
("have", ["has", "hav", "haz a"]),
(word "hello" <|> word "hi"
<|> word "hey" <|> word "howdy" <|> word "yo",
["oh hai"]),
(word "god", ["ceiling cat"])
]