{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -- | This module provides the core data and functionality for handling the game. module Thock where import Brick.Forms (Form) import qualified Brick.Widgets.Edit as E import qualified Brick.Widgets.List as L import Control.Applicative (Applicative (liftA2)) import Control.Lens ( makeFieldsNoPrefix, makeLenses, (%~), (&), (?~), (^.), ) import Data.Aeson (FromJSON, ToJSON) import Data.Char (isAlphaNum, isAscii) import Data.Function (on) import qualified Data.Text as T import Data.Text.Zipper ( TextZipper, clearZipper, currentLine, cursorPosition, getText, moveLeft, moveRight, textZipper, ) import Data.Time (UTCTime, diffUTCTime) import qualified Data.Vector as Vec import GHC.Generics (Generic) import Quotes (Quote, numChars, text) import System.Random (Random (randoms), getStdGen) -- | Unique identifiers to describe cursor locations data ResourceName = UsernameField | RoomIdField | Ordinary deriving (Eq, Ord, Show) -- | The state that tracks a player's progress data GameState = GameState { -- | Current word the player is on, as well as previous and future words _prompt :: TextZipper T.Text, -- | Player input for the current word _input :: E.Editor T.Text ResourceName, -- | The quote being typed _quote :: Quote, -- | The time the game started if it has started _start :: Maybe UTCTime, -- | The last time the game was updated if it has started _lastUpdated :: Maybe UTCTime, -- | The number of keyboard strokes made _strokes :: Int } makeLenses ''GameState type MenuList = L.List ResourceName T.Text newtype Username = Username {_value :: T.Text} deriving (Generic) makeLenses ''Username instance FromJSON Username instance ToJSON Username type RoomId = T.Text -- | The data needed to join an online room data RoomFormData = RoomFormData { _username :: Username, _roomId :: RoomId } deriving (Generic) makeFieldsNoPrefix ''RoomFormData instance FromJSON RoomFormData instance ToJSON RoomFormData type RoomForm a = Form a () ResourceName -- | The current status of the game data Game = MainMenu MenuList | OnlineSelect MenuList | CreateRoomMenu (RoomForm Username) | JoinRoomMenu (RoomForm RoomFormData) | Practice GameState | ErrorOverlay Game T.Text makeLenses ''Game -- | Produces the decimal amount the player has completed correctly calculateProgress :: GameState -> Float calculateProgress g = ((/) `on` fromIntegral) correct total where correct = numCorrectChars g total = g ^. (quote . numChars) -- | Produces the total number of correct characters the player has typed numCorrectChars :: GameState -> Int numCorrectChars g = correctBefore + col where correctBefore = T.length . foldMap (`T.snoc` ' ') . take row $ getText tz (row, col) = cursorPosition tz tz = g ^. prompt -- | Updates the prompt to be in sync with the user's input movePromptCursor :: GameState -> GameState movePromptCursor g = if currentWordFinished then g & prompt %~ moveRight & input %~ E.applyEdit clearZipper -- move onto the next word and clear the input box else g & prompt %~ movePromptByN moveAmount where currentWordFinished = currentInput == T.snoc currentWord ' ' moveAmount = numCorrectCurrentWord g - col (_, col) = cursorPosition (g ^. prompt) currentInput = head $ E.getEditContents (g ^. input) currentWord = currentLine (g ^. prompt) -- | Moves the prompt by n spaces right if positive and left if negative movePromptByN :: Int -> TextZipper T.Text -> TextZipper T.Text movePromptByN n tz | n < 0 = movePromptByN (n + 1) (moveLeft tz) | n > 0 = movePromptByN (n - 1) (moveRight tz) | otherwise = tz -- | Produces the number of correct characters the player has typed in the current word numCorrectCurrentWord :: GameState -> Int numCorrectCurrentWord g = length . takeWhile (uncurry (==)) $ T.zip currentWord currentInput where currentWord = currentLine (g ^. prompt) currentInput = head $ E.getEditContents (g ^. input) -- | Produces the number of incorrect characters the player has typed numIncorrectChars :: GameState -> Int numIncorrectChars g = T.length currentInput - numCorrectCurrentWord g where currentInput = head $ E.getEditContents (g ^. input) -- | Starts the timer if it hasn't started already and sets lastUpdated to t updateTime :: UTCTime -> GameState -> GameState updateTime t g = g' & lastUpdated ?~ t where g' = case g ^. start of Nothing -> g & start ?~ t _ -> g -- | Calculates typing speed in words per minute where a word is 5 characters calculateWpm :: GameState -> Double calculateWpm g = if s == 0 then 0 else cps * (60 / 5) where cps = fromIntegral (numCorrectChars g) / s s = secondsElapsed g -- | Calculates decimal amount of correct typed / total typed characters accuracy :: GameState -> Double accuracy g = ((/) `on` fromIntegral) (g ^. (quote . numChars)) (g ^. strokes) -- | The number of seconds from start to lastUpdated secondsElapsed :: GameState -> Double secondsElapsed g = maybe 0 realToFrac (liftA2 diffUTCTime (g ^. lastUpdated) (g ^. start)) -- | Produces true if the game is done, false otherwise isDone :: GameState -> Bool isDone g = numCorrectChars g == g ^. (quote . numChars) -- | Creates an initial game with the given quote initializeGameState :: Quote -> GameState initializeGameState q = GameState { _prompt = textZipper (T.words (q ^. text)) Nothing, _input = E.editor Ordinary (Just 1) "", _quote = q, _start = Nothing, _lastUpdated = Nothing, _strokes = 0 } -- | Creates an initial 'Game' starting at the main menu initialGame :: Game initialGame = MainMenu (L.list Ordinary (Vec.fromList ["Practice", "Online"]) 2) -- | Creates a 'Game' for the online select menu with options to create or join a room onlineSelectState :: Game onlineSelectState = OnlineSelect (L.list Ordinary (Vec.fromList ["Create room", "Join room"]) 2) -- | Initializes a 'Practice' game with the given quote startPracticeGame :: Quote -> Game startPracticeGame q = Practice (initializeGameState q) -- | Randomly generates an alphanumeric 'RoomId' generateRoomId :: IO RoomId generateRoomId = T.pack . take 10 . filter (\c -> isAscii c && isAlphaNum c) . randoms <$> getStdGen