{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Control.Monad (filterM, when)
import Data.Char (isAscii, isPrint)
import Data.FileEmbed (embedStringFile)
import Data.List.Split (splitOn)
import qualified Data.Text as T
import Data.Word (Word8)
import System.Console.CmdArgs (Data, Typeable, args, cmdArgs, def,
details, help, name, program, summary,
typ, (&=))
import System.Directory (doesFileExist)
import System.Random (randomRIO)
import Text.Wrap (WrapSettings (..), defaultWrapSettings,
wrapText)
import UI (run)
data Config =
Config
{ fg_empty :: Word8
, fg_error :: Word8
, files :: [FilePath]
, height :: Int
, max_paragraph_len :: Int
, min_paragraph_len :: Int
, nonsense_len :: Int
, paragraph :: Bool
, reflow_ :: Bool
, tab :: Int
, width :: Int
}
deriving (Show, Data, Typeable)
toAscii :: Int -> String -> String
toAscii tabWidth = concatMap toAscii'
where
toAscii' c
| c == '\t' = replicate tabWidth ' '
| c == '‘' || c == '’' = "'"
| c == '“' || c == '”' = "\""
| c == '–' || c == '—' = "-"
| c == '…' = "..."
| isAscii c && (isPrint c || c == '\n') = [c]
| otherwise = ""
trimEmptyLines :: String -> String
trimEmptyLines = (++ "\n") . f . f
where
f = reverse . dropWhile (== '\n')
config :: Config
config =
Config
{ fg_empty =
8 &= typ "COLOUR" &=
help "The ANSI colour code for empty (not yet typed) text"
, fg_error = 1 &= typ "COLOUR" &= help "The ANSI colour code for errors"
, height =
20 &= typ "LINES" &=
help "The maximum number of lines to sample (default: 20)"
, max_paragraph_len =
750 &= typ "WORDS" &=
help "The maximum length of a sampled paragraph (default: 750)"
, min_paragraph_len =
250 &= typ "WORDS" &=
help "The minimum length of a sampled paragraph (default: 250)"
, nonsense_len =
500 &= name "l" &= typ "WORDS" &=
help "The length of nonsense to generate (default: 500)"
, paragraph = def &= help "Sample a paragraph from the input files"
, reflow_ = def &= help "Reflow paragraph to the target width"
, tab = 4 &= typ "SIZE" &= help "The size of a tab in spaces (default: 4)"
, width =
80 &= typ "CHARS" &=
help "The width at which to wrap lines (default: 80)"
, files = def &= args &= typ "FILES"
} &=
summary "Gotta Go Fast 0.3.0.6" &=
help "Practice typing and measure your WPM and accuracy." &=
program "gotta-go-fast" &=
details (lines $(embedStringFile "details.txt"))
wrap :: Int -> String -> String
wrap width = T.unpack . wrapText wrapSettings width . T.pack
wrapSettings = defaultWrapSettings {preserveIndentation = True, breakLongWords = True}
-- wordWeights.txt is taken from
-- https://en.wiktionary.org/wiki/Wiktionary:Frequency_lists#TV_and_movie_scripts
-- (and cleaned up a little with some throwaway sed)
wordWeights :: [(String, Int)]
wordWeights =
map ((\[w, f] -> (w, read f)) . words) . lines $
$(embedStringFile "wordWeights.txt")
totalWeight :: Int
totalWeight = sum . map snd $ wordWeights
weightedRandomWord :: IO String
weightedRandomWord = do
r <- randomRIO (0, totalWeight - 1)
return $ go r wordWeights
where
go r ((w, f):rest)
| r < f = w
| otherwise = go (r - f) rest
loopWhile :: Monad m => (a -> Bool) -> m a -> m a
loopWhile p mx = do
x <- mx
if p x
then loopWhile p mx
else return x
-- Generates nonsense which is superficially similar to English. Similar in the
-- sense that the frequency of words in the generated text is approximately the
-- same as the frequency of words in actual usage.
nonsense :: Config -> IO String
nonsense c = do
words <- go (nonsense_len c) Nothing
return $ (wrap (width c) . unwords $ words) ++ "\n"
where
go n lastWord
| n <= 0 = return []
| otherwise = do
word <- loopWhile ((== lastWord) . Just) weightedRandomWord
rest <- go (n - length word - 1) (Just word) -- extra 1 to count the space
return $ word : rest
sample :: Config -> String -> IO String
sample c file =
if paragraph c && not (null paragraphs)
then sampleParagraph
else sampleLines
where
sampleParagraph = do
r <- randomRIO (0, length paragraphs - 1)
return $
(if reflow_ c
then reflow
else wrap (width c))
(paragraphs !! r) ++
"\n"
sampleLines = do
r <- randomRIO (0, max 0 $ length (lines ascii) - height c)
return . trimEmptyLines . chop . wrap (width c) . chop . unlines . drop r $
lines ascii
paragraphs =
filter
((\l -> l >= min_paragraph_len c && l <= max_paragraph_len c) . length) .
map unlines . splitOn [""] . lines $
ascii
reflow =
wrap (width c) .
map
(\case
'\n' -> ' '
c -> c)
ascii = toAscii (tab c) file
chop = unlines . take (height c) . lines
main :: IO ()
main = do
c <- cmdArgs config
fs <- filterM doesFileExist $ files c
target <-
case fs of
[] -> nonsense c
_ -> do
r <- randomRIO (0, length fs - 1)
file <- readFile $ fs !! r
sample c file
loop <- run (fg_empty c) (fg_error c) target
when loop main