gistfile1.txt

module Main where

import Control.Monad.Random.Strict
import Data.Array.MArray
import Data.Array.IO
import Data.Char

-- | Swap two elements in an array
swap :: (MArray a e m, Ix i) => a i e -> i -> i -> m ()
swap arr i j = do
  a <- readArray arr i
  b <- readArray arr j
  writeArray arr i b
  writeArray arr j a

-- | Shuffle an array range
shuffleRange :: (MonadRandom m, MArray a e m, Ix i, Random i, Num i, Enum i)
              => a i e -> (i, i) -> m ()
shuffleRange arr (start, end) = flip mapM_ [start..end] $
    \a -> getRandomR (start, end) >>= swap arr a

-- | Convert a list to a mutable array
toArray :: (MArray a e m, Ix i, Num i) => [e] -> m (a i e)
toArray str = newListArray (fromIntegral 1, fromIntegral $ length str) str

-- | Scramble the inside of a word (preserving the first and last characters)
scrambleWord :: String -> IO String
scrambleWord str
  | len <= 2  = pure str
  | otherwise = do
      arr <- toArray str :: IO (IOArray Int Char)
      shuffleRange arr (2, len-1)
      getElems arr
  where len = length str

-- | Get all word ranges in string
accumWords :: (Char -> Bool) -> String -> [String]
accumWords pred str = allWords
  where (last, others, _) = foldl accumWords' ("", [], True) str
        allWords = others ++ [last]
        accumWords' (cur, all, wasWordChar) c
          | pred c == wasWordChar = (cur ++ [c], all, pred c)
          | otherwise             = ([c], all ++ [cur], pred c)

-- | Scramble all the words in a string
scrambleWords :: (Char -> Bool) -> String -> IO String
scrambleWords pred str = do
  let isWord = foldr (&&) True . map pred
  let scrambleOnlyWords w = if isWord w then scrambleWord w else pure w
  concat <$> mapM scrambleOnlyWords (accumWords pred str)

-- | The sample text
sampleText :: String
sampleText =
  unlines [ "Humpty Dumpty sat on a wall,"
          , "Humpty Dumpty had a great fall."
          , "All the king's horses and all the king's men"
          , "Couldn't put Humpty together again."
          ]

-- | Test whether a character is part of a word
-- Change this to include other characters in words
isWordChar :: Char -> Bool
isWordChar c = isAlpha c || isDigit c || c == '\''

-- | Usage
main :: IO ()
main = putStrLn =<< scrambleWords isWordChar sampleText

-- ghci> main
-- Hmupty Dmputy sat on a wall,
-- Htmpuy Dmputy had a gaert flal.
-- All the k'ngis heorss and all the k'gnis men
-- C'uolndt put Htumpy tethgoer agian.