diff --git a/gotta-go-fast.cabal b/gotta-go-fast.cabal --- a/gotta-go-fast.cabal +++ b/gotta-go-fast.cabal @@ -1,13 +1,13 @@ name: gotta-go-fast -version: 0.1.4.0 +version: 0.3.0.0 synopsis: A command line utility for practicing typing description: - A command line utility for practicing typing and measuring your WPM and accuracy. See the project for details. + A command line utility for practicing typing and measuring your WPM and accuracy. See the project for details. category: Application author: Callum Oakley -maintainer: c.oakley108@gmail.com -homepage: https://github.com/hot-leaf-juice/gotta-go-fast +maintainer: hello@callumoakley.net +homepage: https://github.com/callum-oakley/gotta-go-fast license: BSD3 license-file: LICENSE build-type: Simple @@ -19,7 +19,7 @@ , UI main-is: Main.hs ghc-options: -threaded - build-depends: base >=4.9 && <4.11 + build-depends: base >=4.7 && <5 , brick >= 0.21 , word-wrap >= 0.4.1 , text @@ -28,4 +28,6 @@ , random , time , vty + , split + , file-embed default-language: Haskell2010 diff --git a/src/GottaGoFast.hs b/src/GottaGoFast.hs --- a/src/GottaGoFast.hs +++ b/src/GottaGoFast.hs @@ -7,16 +7,14 @@ , applyBackspace , applyBackspaceWord , applyChar - , applyEnter - , applyTab + , applyWhitespace , atEndOfLine , cursor + , countChars , hasEnded , hasStarted , initialState , isComplete - , isErrorFree - , noOfChars , onLastLine , page , seconds @@ -25,36 +23,45 @@ , wpm ) where -import Data.List (isPrefixOf) -import Data.Maybe (isJust, fromJust) -import Data.Time (UTCTime, diffUTCTime) +import Data.Char (isSpace) +import Data.List (groupBy, isPrefixOf) +import Data.Maybe (fromJust, isJust) +import Data.Time (UTCTime, diffUTCTime) -- It is often useful to know whether the line / character etc we are -- considering is "BeforeCursor" or "AfterCursor". More granularity turns out -- to be unnecessary. -data Position = BeforeCursor | AfterCursor +data Position + = BeforeCursor + | AfterCursor -data State = State - { target :: String - , input :: String - , start :: Maybe UTCTime - , end :: Maybe UTCTime - , strokes :: Integer - , hits :: Integer - } +data State = + State + { target :: String + , input :: String + , start :: Maybe UTCTime + , end :: Maybe UTCTime + , strokes :: Integer + , hits :: Integer + } -- For ease of rendering a character in the UI, we tag it as a Hit, Miss, or -- Empty. Corresponding to the cases of being correctly typed, incorrectly -- typed (or skipped), or not yet typed. -data Character = Hit Char | Miss Char | Empty Char +data Character + = Hit Char + | Miss Char + | Empty Char + type Line = [Character] + type Page = [Line] startClock :: UTCTime -> State -> State -startClock now s = s { start = Just now } +startClock now s = s {start = Just now} stopClock :: UTCTime -> State -> State -stopClock now s = s { end = Just now } +stopClock now s = s {end = Just now} hasStarted :: State -> Bool hasStarted = isJust . start @@ -84,40 +91,54 @@ isErrorFree s = input s `isPrefixOf` target s applyChar :: Char -> State -> State -applyChar c s = s' { hits = hits s' + if isErrorFree s' then 1 else 0 } +applyChar c s = + s' + { hits = + hits s' + + if isErrorFree s' + then 1 + else 0 + } where - s' = s { input = input s ++ [c] , strokes = strokes s + 1 } - -applyEnter :: State -> State -applyEnter = applyTab . applyChar '\n' - -backspace :: String -> String -backspace "" = "" -backspace xs = init xs + s' = s {input = input s ++ [c], strokes = strokes s + 1} applyBackspace :: State -> State -applyBackspace s = s { input = backspace $ input s } - -backspaceWord :: String -> String -backspaceWord xs = reverse $ dropWhile (/= ' ') $ reverse $ backspace xs +applyBackspace s = s {input = reverse . drop n . reverse $ input s} + where + n = + case takeWhile (\(i, t) -> isSpace i && isSpace t) . reverse $ + zip (input s) (target s) of + [] -> 1 + ws -> length ws applyBackspaceWord :: State -> State -applyBackspaceWord s = s { input = backspaceWord $ input s } +applyBackspaceWord s = s {input = reverse . drop n . reverse $ input s} + where + n = toWordBeginning . reverse $ input s + toWordBeginning "" = 0 + toWordBeginning [c] = 1 + toWordBeginning (x:y:ys) + | not (isSpace x) && isSpace y = 1 + | otherwise = 1 + toWordBeginning (y : ys) -applyTab :: State -> State -applyTab s = s { input = input s ++ drop (cursorCol s) leadingSpaces } +applyWhitespace :: State -> State +applyWhitespace s = s {input = input s ++ whitespace} where - leadingSpaces = takeWhile (== ' ') $ lines (target s) !! cursorRow s + whitespace = + case takeWhile isSpace . drop (length $ input s) $ target s of + "" -> " " + ws -> ws initialState :: String -> State -initialState t = applyTab State - { target = t - , input = "" - , start = Nothing - , end = Nothing - , strokes = 0 - , hits = 0 - } +initialState t = + State + { target = t + , input = takeWhile isSpace t + , start = Nothing + , end = Nothing + , strokes = 0 + , hits = 0 + } character :: Position -> (Maybe Char, Maybe Char) -> Character character _ (Just t, Just i) @@ -147,12 +168,14 @@ -- The following functions are only safe to use when both hasStarted and -- hasEnded hold. - seconds :: State -> Rational seconds s = toRational $ diffUTCTime (fromJust $ end s) (fromJust $ start s) +countChars :: State -> Int +countChars = length . groupBy (\x y -> isSpace x && isSpace y) . target + wpm :: State -> Rational -wpm s = fromIntegral (length $ target s) / (5 * seconds s / 60) +wpm s = fromIntegral (countChars s) / (5 * seconds s / 60) accuracy :: State -> Rational accuracy s = fromIntegral (hits s) / fromIntegral (strokes s) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,27 +1,39 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} module Main where -import Control.Monad (filterM) -import Data.Word (Word8) -import Data.Char (isAscii, isPrint) -import System.Console.CmdArgs - (Data, Typeable, args, cmdArgs, def, help, program, summary, typ, (&=)) -import System.Directory (doesFileExist) -import System.Random (randomRIO) -import Text.Wrap (wrapText, WrapSettings(..)) -import qualified Data.Text as T +import Control.Monad (filterM) +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 (..), wrapText) -import UI (run) +import UI (run) -data Config = Config - { height :: Int - , width :: Int - , tab :: Int - , files :: [FilePath] - , fg_empty :: Word8 - , fg_error :: Word8 - } deriving (Show, Data, Typeable) +data Config = + Config + { fg_empty :: Maybe Word8 + , fg_error :: Maybe 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' @@ -41,42 +53,117 @@ f = reverse . dropWhile (== '\n') config :: Config -config = Config - { height = 20 &= typ "LINES" &= - help "The maximum number of lines to sample (default: 20)" - , width = 80 &= typ "CHARS" &= - help "The width at which to wrap lines (default: 80)" - , tab = 4 &= typ "SIZE" &= - help "The size of a tab in spaces (default: 4)" - , fg_empty = 8 &= typ "COLOUR" &= - help "The ISO colour code for empty (not yet typed) characters (default: 8)" - , fg_error = 1 &= typ "COLOUR" &= - help "The ISO colour code for errors (default: 1)" - , files = def &= args &= typ "FILES" - } - &= summary "Gotta Go Fast 0.1.4.0" - &= help "Practice typing and measure your WPM and accuracy" - &= program "gotta-go-fast" +config = + Config + { fg_empty = + def &= typ "COLOUR" &= + help "The ANSI colour code for empty (not yet typed) text" + , fg_error = def &= 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.0" &= + 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 = WrapSettings {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 + +-- 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 + return $ (wrap (width c) . unwords $ words) ++ "\n" + where + go :: Int -> IO [String] + go n + | n <= 0 = return [] + | otherwise = do + word <- weightedRandomWord + rest <- go (n - length word - 1) -- extra 1 to count the space + return $ word : rest + sample :: Config -> String -> IO String -sample c file = do - r <- randomRIO (0, max 0 $ length (lines ascii) - height c) - return $ trimEmptyLines $ chop $ wrap $ chop $ unlines $ drop r $ lines ascii - where - ascii = toAscii (tab c) file - chop = unlines . take (height c) . lines - wrap = T.unpack . wrapText wrapSettings (width c) . T.pack - wrapSettings = WrapSettings - { preserveIndentation = True - , breakLongWords = True - } +sample c file = + if paragraph c + 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 s = + wrap (width c) . + map + (\case + '\n' -> ' ' + c -> c) $ + s + ascii = toAscii (tab c) file + chop = unlines . take (height c) . lines main :: IO () main = do c <- cmdArgs config fs <- filterM doesFileExist $ files c case fs of - [] -> putStrLn "Requires at least one file path" + [] -> nonsense c >>= run (fg_empty c) (fg_error c) _ -> do r <- randomRIO (0, length fs - 1) file <- readFile $ fs !! r diff --git a/src/UI.hs b/src/UI.hs --- a/src/UI.hs +++ b/src/UI.hs @@ -1,32 +1,40 @@ -module UI (run) where +module UI + ( run + ) where -import Data.Word (Word8) +import Brick (App (..), AttrName, BrickEvent (..), + EventM, Location (..), Next, + Padding (..), Widget, attrMap, + attrName, continue, defaultMain, + emptyWidget, fg, halt, padAll, + padBottom, showCursor, showFirstCursor, + str, withAttr, (<+>), (<=>)) +import Brick.Widgets.Center (center) +import Control.Monad.IO.Class (liftIO) +import Data.Char (isSpace) +import Data.Maybe (fromMaybe) +import Data.Time (getCurrentTime) +import Data.Word (Word8) +import Graphics.Vty (Attr, Color (..), Event (..), Key (..), + Modifier (..), bold, defAttr, + withStyle) -import Brick - ( App(..), AttrName, BrickEvent(..), EventM, Location(..), Next, Widget - , attrMap, attrName, continue, defaultMain, emptyWidget, fg, halt, padAll - , showCursor, showFirstCursor, str, withAttr, (<+>), (<=>) - ) -import Brick.Widgets.Border (border, borderAttr) -import Brick.Widgets.Center (center) -import Control.Monad.IO.Class (liftIO) -import Data.Time (getCurrentTime) -import Graphics.Vty - (Attr, Color(..), Event(..), Key(..), Modifier(..), defAttr, withStyle) +import GottaGoFast -import GottaGoFast +emptyAttrName :: AttrName +emptyAttrName = attrName "empty" -emptyAttr :: AttrName -emptyAttr = attrName "target" +errorAttrName :: AttrName +errorAttrName = attrName "error" -missAttr :: AttrName -missAttr = attrName "error" +resultAttrName :: AttrName +resultAttrName = attrName "result" drawCharacter :: Character -> Widget () -drawCharacter (Hit c) = str [c] -drawCharacter (Miss ' ') = withAttr missAttr $ str ['_'] -drawCharacter (Miss c) = withAttr missAttr $ str [c] -drawCharacter (Empty c) = withAttr emptyAttr $ str [c] +drawCharacter (Hit c) = str [c] +drawCharacter (Miss ' ') = withAttr errorAttrName $ str ['_'] +drawCharacter (Miss c) = withAttr errorAttrName $ str [c] +drawCharacter (Empty c) = withAttr emptyAttrName $ str [c] drawLine :: Line -> Widget () -- We display an empty line as a single space so that it still occupies @@ -34,73 +42,86 @@ drawLine [] = str " " drawLine ls = foldl1 (<+>) $ map drawCharacter ls -drawPage :: State -> Widget () -drawPage s = foldl (<=>) emptyWidget $ map drawLine $ page s +drawText :: State -> Widget () +drawText s = padBottom (Pad 2) . foldl (<=>) emptyWidget . map drawLine $ page s drawResults :: State -> Widget () -drawResults s = str $ - "You typed " ++ x ++ " characters in " ++ y ++ " seconds.\n\n" ++ - "Words per minute: " ++ show (round $ wpm s) ++ "\n\n" ++ - "Accuracy: " ++ show (round $ accuracy s * 100) ++ "%" - where - x = show $ noOfChars s - y = show $ round $ seconds s +drawResults s = + withAttr resultAttrName . str $ + (show . round $ wpm s) ++ + " words per minute • " ++ (show . round $ accuracy s * 100) ++ "% accuracy" draw :: State -> [Widget ()] draw s - | hasEnded s = pure $ center $ drawResults s - | isErrorFree s = pure $ center p - | otherwise = pure $ center $ border p - where - p = padAll 1 $ showCursor () (Location $ cursor s) $ drawPage s - -handleEnter :: State -> EventM () (Next State) -handleEnter s - | hasEnded s = halt s - | not $ onLastLine s = continue $ applyEnter s - | isComplete $ applyChar '\n' s = do - now <- liftIO getCurrentTime - continue $ stopClock now s - | otherwise = continue s + | hasEnded s = pure . center . padAll 1 $ drawText s <=> drawResults s + | otherwise = + pure . center . padAll 1 . showCursor () (Location $ cursor s) $ + drawText s <=> str " " handleChar :: Char -> State -> EventM () (Next State) handleChar c s - | c == ' ' && atEndOfLine s = handleEnter s + | isSpace c && isComplete (applyWhitespace s) = do + now <- liftIO getCurrentTime + continue $ stopClock now s + | isSpace c = continue $ applyWhitespace s | hasStarted s = continue $ applyChar c s | otherwise = do now <- liftIO getCurrentTime - continue $ applyChar c $ startClock now s + continue . applyChar c $ startClock now s handleEvent :: State -> BrickEvent () e -> EventM () (Next State) -handleEvent s (VtyEvent (EvKey key [])) = - case key of - KChar '\t' -> continue $ applyTab s - KChar c -> handleChar c s - KEnter -> handleEnter s - KBS -> continue $ applyBackspace s - _ -> continue s handleEvent s (VtyEvent (EvKey key [MCtrl])) = case key of - KChar 'w' -> continue $ applyBackspaceWord s KChar 'c' -> halt s KChar 'd' -> halt s - _ -> continue s + KChar 'w' -> continue $ applyBackspaceWord s + KBS -> continue $ applyBackspaceWord s + _ -> continue s +handleEvent s (VtyEvent (EvKey key [MAlt])) = + case key of + KBS -> continue $ applyBackspaceWord s + _ -> continue s +handleEvent s (VtyEvent (EvKey key [MMeta])) = + case key of + KBS -> continue $ applyBackspaceWord s + _ -> continue s +handleEvent s (VtyEvent (EvKey key [])) + | hasEnded s = + case key of + KEnter -> halt s + KEsc -> halt s + _ -> continue s + | otherwise = + case key of + KChar c -> handleChar c s + KEnter -> handleChar '\n' s + KBS -> continue $ applyBackspace s + _ -> continue s handleEvent s _ = continue s -app :: Attr -> Attr -> App State e () -app fgEmpty fgError = App - { appDraw = draw - , appChooseCursor = showFirstCursor - , appHandleEvent = handleEvent - , appStartEvent = return - , appAttrMap = const $ attrMap defAttr - [(emptyAttr, fgEmpty), (missAttr, fgError), (borderAttr, fgError)] - } +app :: Attr -> Attr -> Attr -> App State e () +app emptyAttr errorAttr resultAttr = + App + { appDraw = draw + , appChooseCursor = showFirstCursor + , appHandleEvent = handleEvent + , appStartEvent = return + , appAttrMap = + const $ + attrMap + defAttr + [ (emptyAttrName, emptyAttr) + , (errorAttrName, errorAttr) + , (resultAttrName, resultAttr) + ] + } -run :: Word8 -> Word8 -> String -> IO () +run :: Maybe Word8 -> Maybe Word8 -> String -> IO () run fgEmptyCode fgErrorCode t = do - _ <- defaultMain (app fgEmpty fgError) $ initialState t + _ <- defaultMain (app emptyAttr errorAttr resultAttr) $ initialState t return () - where - fgEmpty = fg $ ISOColor fgEmptyCode - fgError = fg $ ISOColor fgErrorCode + where + emptyAttr = fg . ISOColor $ fromMaybe 8 fgEmptyCode + errorAttr = flip withStyle bold . fg . ISOColor $ fromMaybe 1 fgErrorCode + -- abusing the fgErrorCode to use as a highlight colour for the results here + resultAttr = fg . ISOColor $ fromMaybe 1 fgErrorCode