module Text.Zalgo
(
zalgo, zalgoWith, gradualZalgo, unZalgoWith, redact
, zalgoIO, zalgoIOWith, gradualZalgoIO, gradualZalgoIOWith, redactIO
, printZalgo, printZalgoWith, printGradualZalgo, printRedacted
, ZalgoSettings
, maxHeightAt, varianceAt, overlayProbabilityAt
, numOverlayCharsAt, overlayCharset
, defaultZalgoSettings, unreadableZalgoSettings
, defaultOverlayCharset
) where
import Data.Array (Array, listArray, bounds, elems, (!))
import Data.Char (ord, chr)
import Data.List (foldl', isSuffixOf, isPrefixOf)
import System.Random (RandomGen, StdGen, newStdGen, randomR, randomRs, split)
data ZalgoSettings = ZalgoSettings
{
maxHeightAt :: Int -> Int
, varianceAt :: Int -> Double
, overlayProbabilityAt :: Int -> Double
, numOverlayCharsAt :: Int -> Int
, overlayCharset :: Array Int Char
}
defaultZalgoSettings :: ZalgoSettings
defaultZalgoSettings = ZalgoSettings
{ maxHeightAt = const 5
, varianceAt = const 1
, overlayProbabilityAt = const 0.4
, numOverlayCharsAt = const 1
, overlayCharset = defaultOverlayCharset
}
unreadableZalgoSettings :: ZalgoSettings
unreadableZalgoSettings = defaultZalgoSettings
{ overlayProbabilityAt = const 1
, numOverlayCharsAt = const 7
}
minHeightAt :: ZalgoSettings -> Int -> Int
minHeightAt cfg n = floor $ maxH maxH * varianceAt cfg n
where
maxH = fromIntegral (maxHeightAt cfg n)
over :: Array Int Char
over = listArray (0, length list1) list
where
list = map chr $ concat
[ [768 .. 789]
, [829 .. 836]
, [842 .. 844]
, [848 .. 850]
, [867 .. 879]
, [794, 795, 836, 838, 855, 856, 859, 861, 862, 864, 865]
]
defaultOverlayCharset :: Array Int Char
defaultOverlayCharset = listArray (0, length list1) list
where
list = map chr $ [820 .. 824]
under :: Array Int Char
under = listArray (0, length list1) list
where
list = map chr $ concat
[ [x | x <- [790 .. 819], not $ x `elem` [794, 795]]
, [825 .. 828]
, [839 .. 841]
, [851 .. 854]
, [837, 845, 846, 857, 858, 860, 863]
]
combiners :: RandomGen g => Array Int Char -> (Int, Int) -> g -> (g, [Char])
combiners source numRange g =
(g1, take numMarks $ map (source !) indices)
where
(g0, g1) = split g
(numMarks, g0') = randomR numRange g0
indices = randomRs (bounds source) g0'
combineAll :: RandomGen g => Double -> (Int, Int) -> Int -> Array Int Char -> Char -> g -> (g, String)
combineAll overlayProb numRange ovrs overlay c gen
| o <= overlayProb =
case marks of
(g, marks') -> fmap ((c:marks')++) (combiners overlay (ovrs, ovrs) g)
| otherwise =
fmap (c:) marks
where
(o, gen') = randomR (0, 1) gen
marks = foldl' f (gen', "") [over, under]
f (g, s') src = fmap (s'++) (combiners src numRange g)
break1 :: Eq a => [a] -> [a] -> ([a], [a])
break1 [] xs = (xs, [])
break1 needle xs = go [] xs
where
go pre [] =
(reverse pre, [])
go pre xs
| needle `isPrefixOf` xs =
(reverse pre, drop (length needle) xs)
| otherwise =
go (head xs:pre) (tail xs)
breakAll :: Eq a => [a] -> [a] -> [[a]]
breakAll needle xs =
case break1 needle xs of
(_, []) | not (needle `isSuffixOf` xs) ->
[xs]
([], xs') ->
needle : breakAll needle xs'
(pre, xs') ->
pre : needle : breakAll needle xs'
redact :: RandomGen g => [String] -> String -> g -> (g, String)
redact needles haystack gen = foldl' f (gen, haystack) needles
where
f (g, xs) needle = redact' needle g (breakAll needle xs)
rot13 c = chr $ (ord c + 13 97) `mod` 26 + 97
redact' needle g (x:xs)
| needle == x =
case zalgoWith unreadableZalgoSettings (map rot13 x) g of
(g', x') -> fmap (x'++) (redact' needle g' xs)
| otherwise =
fmap (x++) (redact' needle g xs)
redact' _ g _ =
(g, "")
unZalgoWith :: ZalgoSettings -> String -> String
unZalgoWith cfg =
filter (not . (`elem` concat [elems over, elems under, elems (overlayCharset cfg)]))
unZalgo :: String -> String
unZalgo = unZalgoWith defaultZalgoSettings
zalgoWith :: RandomGen g => ZalgoSettings -> String -> g -> (g, String)
zalgoWith cfg s g0 = fmap (concat . reverse) $ snd $ foldl' f (0, (g0, [])) s
where
f (n, (g, s')) c = (n+1, fmap (:s') (combineAll o (lo, hi) novrs ovrs c g))
where
hi = maxHeightAt cfg n
lo = minHeightAt cfg n
o = overlayProbabilityAt cfg n
novrs = numOverlayCharsAt cfg n
ovrs = overlayCharset cfg
zalgo :: RandomGen g => String -> g -> (g, String)
zalgo = zalgoWith defaultZalgoSettings
gradualZalgoWith :: ZalgoSettings
-> (Double -> Double)
-> String
-> StdGen
-> (StdGen, String)
gradualZalgoWith cfg f s g = zalgoWith cfg' s g
where
len = fromIntegral $ length s
scale g n = f (fromIntegral n/len) * g n
cfg' = cfg
{ maxHeightAt = round . scale (fromIntegral . maxHeightAt cfg)
, overlayProbabilityAt = scale (overlayProbabilityAt cfg)
}
gradualZalgo :: Double -> String -> StdGen -> (StdGen, String)
gradualZalgo from = gradualZalgoWith defaultZalgoSettings f
where
f x | x >= from = (xfrom)*(1/(1from))
| otherwise = 0
zalgoIOWith :: ZalgoSettings -> String -> IO String
zalgoIOWith cfg s = do
g <- newStdGen
return $ snd $ zalgoWith cfg s g
redactIO :: [String] -> String -> IO String
redactIO needles s = do
g <- newStdGen
return $ snd $ redact needles s g
zalgoIO :: String -> IO String
zalgoIO = zalgoIOWith defaultZalgoSettings
gradualZalgoIOWith :: ZalgoSettings -> Double -> String -> IO String
gradualZalgoIOWith cfg from s = do
g <- newStdGen
return $ snd $ gradualZalgoWith cfg f s g
where
f x | x >= from = (xfrom)*(1/(1from))
| otherwise = 0
gradualZalgoIO :: Double -> String -> IO String
gradualZalgoIO = gradualZalgoIOWith defaultZalgoSettings
printZalgoWith :: ZalgoSettings -> String -> IO ()
printZalgoWith cfg s = zalgoIOWith cfg s >>= putStrLn
printZalgo :: String -> IO ()
printZalgo = printZalgoWith defaultZalgoSettings
printGradualZalgo :: Double -> String -> IO ()
printGradualZalgo from s = gradualZalgoIO from s >>= putStrLn
printRedacted :: [String] -> String -> IO ()
printRedacted needles s = redactIO needles s >>= putStrLn