diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,15 @@ +# Changelog for thock + +## 0.2.0.0 + +Fixes: + +- [#4](https://github.com/rmehri01/thock/issues/4) Server now generates a random quote for each online game. + +Improvements + +- [#1](https://github.com/rmehri01/thock/issues/1) Binary size is now around 5 times smaller thanks to [@dpwiz](https://github.com/dpwiz) and [@soywod](https://github.com/soywod). + +## 0.1.0.0 + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2020 Ryan Mehri + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,23 @@ +# thock + +![An example of an online game](resources/demo.gif) + +## Installation + +### Binary + +Right now there are only binaries for Ubuntu and macOS under [releases](https://github.com/rmehri01/thock/releases). Unfortunately there is no support for Windows but the Ubuntu binary will still work in [WSL](https://docs.microsoft.com/en-us/windows/wsl/about). + +To use the binary you will have to put it on your PATH and may have to change permissions using `chmod` or allowing it in system preferences. + +### From Source + +```console +git clone https://github.com/rmehri01/thock.git +cd thock +stack install thock +``` + +## Credit + +The terminal UI is made using the amazing [brick](https://github.com/jtdaugherty/brick/) library and the online functionality was done using [websockets](https://github.com/jaspervdj/websockets). I also took a great amount of inspiration from other great projects such as [hascard](https://github.com/Yvee1/hascard), [monkeytype](https://github.com/Miodec/monkeytype), and [gotta-go-fast](https://github.com/callum-oakley/gotta-go-fast). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/app/server/Main.hs b/app/server/Main.hs new file mode 100644 --- /dev/null +++ b/app/server/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Server (runServer) +import System.Environment (getEnv) + +main :: IO () +main = do + port <- read <$> getEnv "PORT" + runServer port diff --git a/app/thock/Main.hs b/app/thock/Main.hs new file mode 100644 --- /dev/null +++ b/app/thock/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import qualified Brick.Main as M +import Thock (initialGame) +import UI.Offline (localApp) + +main :: IO () +main = do + _ <- M.defaultMain localApp initialGame + return () diff --git a/src/Client.hs b/src/Client.hs new file mode 100644 --- /dev/null +++ b/src/Client.hs @@ -0,0 +1,62 @@ +-- | This module allows a client to connect to and interact with the websocket server. +module Client + ( runClient, + ) +where + +import Brick (customMain) +import Brick.BChan (newBChan, writeBChan) +import Control.Concurrent (forkFinally) +import Control.Monad (forever) +import qualified Data.Text as T +import qualified Graphics.Vty as V +import Network.Socket (withSocketsDo) +import qualified Network.WebSockets as WS +import Online + ( ConnectionTick (ConnectionTick), + Online (WaitingRoom), + RoomClientState (RoomClientState), + WaitingRoomState (WaitingRoomState), + receiveJsonData, + sendJsonData, + ) +import Thock (RoomFormData (RoomFormData), Username (Username)) +import UI.Online (onlineApp) + +-- | Sets up the initial state of the 'Online' state using the formData +-- based on if the player is creating the room. +createClientApp :: Bool -> RoomFormData -> WS.ClientApp (Maybe T.Text) +createClientApp isCreating formData@(RoomFormData (Username user) room) conn = do + _ <- sendJsonData conn (formData, isCreating) + + if isCreating + then startRoom [] + else do + res <- receiveJsonData conn + case res of + Right others -> startRoom others + Left msg -> return (Just msg) -- Stop connection due to error message received from server + where + localSt = RoomClientState user False + startRoom others = do + connChan <- newBChan 10 + -- fork a thread that writes custom events when received from server + _ <- + forkFinally + ( forever $ do + serverMessage <- receiveJsonData conn + writeBChan connChan (ConnectionTick serverMessage) + ) + (const $ return ()) -- terminate when connection is closed and ignore any exceptions + let buildVty = V.mkVty V.defaultConfig + initialVty <- buildVty + let w = WaitingRoom (WaitingRoomState room localSt conn others) + _ <- customMain initialVty buildVty (Just connChan) onlineApp w + WS.sendClose conn ("Bye!" :: T.Text) + return Nothing -- Online connection finished successfully with no errors + +-- | Connects to the websocket server and runs the client app +runClient :: Bool -> RoomFormData -> IO (Maybe T.Text) +runClient isCreating formData = + withSocketsDo $ + WS.runClient "thock-server.herokuapp.com" 80 "/" (createClientApp isCreating formData) diff --git a/src/Online.hs b/src/Online.hs new file mode 100644 --- /dev/null +++ b/src/Online.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module has shared types and functions for communication between the websocket client and server. +module Online where + +import Control.Lens (makeFieldsNoPrefix) +import Data.Aeson (FromJSON, ToJSON, decode, encode) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import GHC.Generics (Generic) +import qualified Network.WebSockets as WS +import Quotes (Quote) +import Thock (GameState, HasRoomId (..), HasUsername (..), RoomId) + +-- | The state of a client in a waiting room +data RoomClientState = RoomClientState + { _username :: T.Text, + _isReady :: Bool + } + deriving (Generic) + +makeFieldsNoPrefix ''RoomClientState + +instance FromJSON RoomClientState + +instance ToJSON RoomClientState + +-- | The state of a client in an online game +data GameClientState = GameClientState + { _username :: T.Text, + _progress :: Float, + _wpm :: Double + } + deriving (Generic) + +makeFieldsNoPrefix ''GameClientState + +instance FromJSON GameClientState + +instance ToJSON GameClientState + +-- | A waiting room client with a state and connection to the server +data RoomClient = RoomClient + { _state :: RoomClientState, + _connection :: WS.Connection + } + +makeFieldsNoPrefix ''RoomClient + +-- | An in-game client with a state and connection to the server +data GameClient = GameClient + { _state :: GameClientState, + _connection :: WS.Connection + } + +makeFieldsNoPrefix ''GameClient + +-- | A message that a client sends to the server to update their state +data ClientMessage + = RoomClientUpdate RoomClientState + | GameClientUpdate GameClientState + | BackToLobby T.Text + deriving (Generic) + +instance FromJSON ClientMessage + +instance ToJSON ClientMessage + +-- | A message from the server that updates a client on the state of other clients +data ServerMessage + = RoomUpdate [RoomClientState] + | GameUpdate [GameClientState] + | StartGame Quote [GameClientState] + deriving (Generic) + +instance FromJSON ServerMessage + +instance ToJSON ServerMessage + +-- | Custom event that triggers when the client receives a 'ServerMessage' +newtype ConnectionTick = ConnectionTick ServerMessage + +-- | The state of a player waiting to start an online game +data WaitingRoomState = WaitingRoomState + { -- | Which room the player is in + _roomId :: RoomId, + -- | Information about the player + _localState :: RoomClientState, + -- | The player's connection to the server + _connection :: WS.Connection, + -- | The states of other players + _otherPlayers :: [RoomClientState] + } + +makeFieldsNoPrefix ''WaitingRoomState + +-- | The state of a player's online game +data OnlineGameState = OnlineGameState + { -- | The state of the player's personal game + _localGame :: GameState, + -- | Room to return to after the game is done + _roomId :: RoomId, + -- | The player's username + _username :: T.Text, + -- | The player's connection to the server + _connection :: WS.Connection, + -- | The states of other players + _otherPlayers :: [GameClientState] + } + +makeFieldsNoPrefix ''OnlineGameState + +-- | The current status of the online connection +data Online + = WaitingRoom WaitingRoomState + | OnlineGame OnlineGameState + +-- | Sends the given data over the connection as text using 'encode' +sendJsonData :: ToJSON a => WS.Connection -> a -> IO () +sendJsonData conn a = WS.sendTextData conn (encode a) + +-- | Receives JSON text data from the connection and tries to 'decode' it into the given type. +-- Produces an error if the JSON fails to decode (malformed or wrong type). +receiveJsonData :: FromJSON a => WS.Connection -> IO a +receiveJsonData conn = fromMaybe (error "could not decode JSON message into desired type") . decode <$> WS.receiveData conn diff --git a/src/Quotes.hs b/src/Quotes.hs new file mode 100644 --- /dev/null +++ b/src/Quotes.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module provides a way to deal with quotes which are used as prompts. +module Quotes where + +import Control.Lens (makeLenses) +import Data.Aeson + ( FromJSON (parseJSON), + Options (fieldLabelModifier), + ToJSON (toJSON), + decodeStrict, + defaultOptions, + genericParseJSON, + genericToJSON, + ) +import Data.FileEmbed (embedFile) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import GHC.Generics (Generic) +import System.Random (Random (randomRIO)) + +data Quote = Quote + { -- | The quote text itself + _text :: T.Text, + -- | Where the quote came from + _source :: T.Text, + -- | The number of characters in the quote + _numChars :: Int + } + deriving (Generic) + +makeLenses ''Quote + +instance FromJSON Quote where + parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = drop 1} + +instance ToJSON Quote where + toJSON = genericToJSON defaultOptions {fieldLabelModifier = drop 1} + +-- | Produces a random 'Quote' using a JSON file +generateQuote :: IO Quote +generateQuote = randomElem qs + where + qs = fromMaybe (error "could not decode JSON into quote") mqs + mqs = decodeStrict $(embedFile "resources/quotes.json") + +-- | Produces a random element in the given list +randomElem :: [a] -> IO a +randomElem xs = (xs !!) <$> randomRIO (0, length xs - 1) diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 --- /dev/null +++ b/src/Server.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module deals with maintaining the state of the server when receiving updates. +module Server where + +import Control.Concurrent + ( MVar, + modifyMVar, + modifyMVar_, + newMVar, + readMVar, + ) +import Control.Exception (finally) +import Control.Lens (makeLenses, (%~), (&), (.~), (^.)) +import Control.Monad (forM_, forever) +import Data.Aeson (ToJSON) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isNothing) +import qualified Data.Text as T +import GHC.Generics (Generic) +import qualified Network.WebSockets as WS +import Online + ( ClientMessage + ( BackToLobby, + GameClientUpdate, + RoomClientUpdate + ), + GameClient (GameClient), + GameClientState (GameClientState), + HasConnection (..), + HasIsReady (isReady), + HasState (..), + RoomClient (RoomClient), + RoomClientState (RoomClientState), + ServerMessage (GameUpdate, RoomUpdate, StartGame), + receiveJsonData, + sendJsonData, + ) +import Quotes (generateQuote) +import Thock + ( HasUsername (..), + RoomFormData (RoomFormData), + RoomId, + Username (Username), + ) + +data ServerState = ServerState + { _rooms :: Map RoomId [RoomClient], + _activeGames :: Map RoomId [GameClient] + } + deriving (Generic) + +makeLenses ''ServerState + +-- | Runs the websocket server with a random quote and initial state +runServer :: Int -> IO () +runServer port = do + st <- newMVar newServerState + WS.runServer "0.0.0.0" port $ serverApp st + +-- | Handles interacting with incoming client connections +serverApp :: MVar ServerState -> WS.ServerApp +serverApp mState pending = do + conn <- WS.acceptRequest pending + WS.withPingThread conn 30 (return ()) $ do + (RoomFormData (Username user) room, isCreating) <- receiveJsonData conn + + let client = RoomClient (RoomClientState user False) conn + disconnect = do + s <- modifyMVar mState $ \s -> + let s' = removeRoomClient room user s + in return (s', s') + roomBroadcastExceptSending room user s + + if isCreating + then flip finally disconnect $ do + modifyMVar_ mState $ \s -> + return (createRoom room client s) + talk conn mState room + else do + ss <- readMVar mState + let response + | not $ Map.member room (ss ^. rooms) = sendJsonData conn (Left "room does not exist" :: Either T.Text [RoomClientState]) + | clientExists room user ss = sendJsonData conn (Left "username already exists in that room" :: Either T.Text [RoomClientState]) + | otherwise = flip finally disconnect $ do + modifyMVar_ mState $ \s -> do + let s' = addRoomClient room client s + let m = (s' ^. rooms) Map.! room + let rsExceptUser = deleteFirstEqualUsername user m + sendJsonData conn (Right (map (^. state) rsExceptUser) :: Either T.Text [RoomClientState]) + roomBroadcastExceptSending room user s' + return s' + talk conn mState room + response + +-- | Communicates with a single client by receiving and sending updates through conn +talk :: WS.Connection -> MVar ServerState -> RoomId -> IO () +talk conn mState room = forever $ do + cMessage <- receiveJsonData conn + case cMessage of + RoomClientUpdate r -> do + ss <- modifyMVar mState $ \s -> + let s' = updateRoomClient room r s in return (s', s') + -- if can start and game not already in progress, send start game, else just update + if canStart (map (^. state) $ (ss ^. rooms) Map.! room) + && isNothing (Map.lookup room (ss ^. activeGames)) + then do + newS <- modifyMVar mState $ \s -> do + let s' = makeActive room s in return (s', s') + q <- generateQuote + broadcastTo id room (StartGame q) (newS ^. activeGames) + else roomBroadcastExceptSending room (r ^. username) ss + GameClientUpdate g -> do + s <- modifyMVar mState $ \s -> + let s' = updateGameClient room g s in return (s', s') + gameBroadcastExceptSending room (g ^. username) s + BackToLobby user -> do + s <- modifyMVar mState $ \s -> + let client = RoomClient (RoomClientState user False) conn + leftGame = removeGameClient room user s + s' = addRoomClient room client leftGame + in return (s', s') + let m = (s ^. rooms) Map.! room + let rsExceptUser = deleteFirstEqualUsername user m + sendJsonData conn (RoomUpdate $ map (^. state) rsExceptUser) + gameBroadcastExceptSending room user s + roomBroadcastExceptSending room user s + +-- | Creates the initial 'ServerState' with empty rooms and games +newServerState :: ServerState +newServerState = ServerState {_rooms = Map.empty, _activeGames = Map.empty} + +-- | Adds a 'RoomClient' into the given waiting room +addRoomClient :: RoomId -> RoomClient -> ServerState -> ServerState +addRoomClient room client ss = ss & rooms %~ Map.adjust (client :) room + +-- | Produces true if the given user is in either the waiting room or an active game +clientExists :: RoomId -> T.Text -> ServerState -> Bool +clientExists room user ss = case Map.lookup room (ss ^. activeGames) of + Nothing -> inRoom + Just cs -> inRoom || any (equalOnStateUsername user) cs + where + inRoom = any (equalOnStateUsername user) ((ss ^. rooms) Map.! room) + +-- | Removes a user from the given waiting room. +-- Deletes the room if it is empty and there is no active game for that room. +removeRoomClient :: RoomId -> T.Text -> ServerState -> ServerState +removeRoomClient room user ss = + case Map.lookup room (ss ^. activeGames) of + Nothing -> ss & rooms %~ removeClient room user + _ -> ss & rooms %~ Map.adjust (deleteFirstEqualUsername user) room + +-- | Removes a user from the active game and deletes it if empty +removeGameClient :: RoomId -> T.Text -> ServerState -> ServerState +removeGameClient room user ss = ss & activeGames %~ removeClient room user + +-- | Remove a user from the room in m and delete the room if it is empty +removeClient :: (Ord k, HasState s a2, HasUsername a2 a1, Eq a1) => k -> a1 -> Map k [s] -> Map k [s] +removeClient room user m = + if null (withoutUser Map.! room) + then Map.delete room withoutUser + else withoutUser + where + withoutUser = Map.adjust (deleteFirstEqualUsername user) room m + +-- | Updates the state of a 'RoomClient' based on username in the given waiting room +updateRoomClient :: RoomId -> RoomClientState -> ServerState -> ServerState +updateRoomClient room client ss = ss & rooms %~ updateClient room client + +-- | Updates the state of a 'GameClient' based on username in the given active game room +updateGameClient :: RoomId -> GameClientState -> ServerState -> ServerState +updateGameClient room client ss = ss & activeGames %~ updateClient room client + +-- | Updates the state of a client based on username in the given room in a Map +updateClient :: (Ord k, HasState b a1, HasUsername a1 a2, Eq a2) => k -> a1 -> Map k [b] -> Map k [b] +updateClient room client = Map.adjust (map updateIfClient) room + where + updateIfClient other = + if equalOnStateUsername (client ^. username) other + then other & state .~ client + else other + +-- | Creates a new waiting room with the given client in it +createRoom :: RoomId -> RoomClient -> ServerState -> ServerState +createRoom room client ss = ss & rooms %~ Map.insert room [client] + +-- | Moves all the players in a waiting room to an active game, leaving the waiting room empty. +makeActive :: RoomId -> ServerState -> ServerState +makeActive room ss = + ss & rooms %~ Map.insert room [] + & activeGames %~ Map.insert room clients + where + clients = map (\(RoomClient (RoomClientState user _) conn) -> GameClient (GameClientState user 0 0) conn) states + states = (ss ^. rooms) Map.! room + +-- | Sends an update of the 'ServerState' to everyone in a waiting room +-- except the one who triggered the update +roomBroadcastExceptSending :: RoomId -> T.Text -> ServerState -> IO () +roomBroadcastExceptSending room sending ss = + broadcastTo (deleteFirstEqualUsername sending) room RoomUpdate (ss ^. rooms) + +-- | Sends an update of the 'ServerState' to everyone in an active game +-- except the one who triggered the update +gameBroadcastExceptSending :: RoomId -> T.Text -> ServerState -> IO () +gameBroadcastExceptSending room sending ss = + broadcastTo (deleteFirstEqualUsername sending) room GameUpdate (ss ^. activeGames) + +-- | Sends an update of the 'ServerState' to everyone in a room +broadcastTo :: + ( Eq a1, + HasConnection b WS.Connection, + ToJSON d, + HasState a c, + HasState b a4, + HasUsername c a1, + HasUsername a4 a1, + Ord k + ) => + -- | Function to filter who to send the updates to + ([a] -> [b]) -> + -- | Room to send to + k -> + -- | Constructor for creating the desired type to send + ([c] -> d) -> + -- | All of the rooms + Map k [a] -> + IO () +broadcastTo f room ctr m = + forM_ + csFiltered + $ \a -> + sendJsonData + (a ^. connection) + (ctr . map (^. state) $ deleteFirstEqualUsername (a ^. (state . username)) cs) + where + csFiltered = f cs + cs = fromMaybe [] (Map.lookup room m) + +-- | Removes the first in the given list where the inner state's username is equal to user +deleteFirstEqualUsername :: (Eq a1, HasState s a2, HasUsername a2 a1) => a1 -> [s] -> [s] +deleteFirstEqualUsername user = deleteFirstWhere (equalOnStateUsername user) + +-- | Removes the first value from the list where the predicate p is satisfied +deleteFirstWhere :: (a -> Bool) -> [a] -> [a] +deleteFirstWhere _ [] = [] +deleteFirstWhere p (a : as) = if p a then as else a : deleteFirstWhere p as + +-- | Produces true if the inner state's username is equal to the given user +equalOnStateUsername :: (Eq a1, HasState s a2, HasUsername a2 a1) => a1 -> s -> Bool +equalOnStateUsername user c = (c ^. (state . username)) == user + +-- | Produces true if there is more than one person in the room and they are all ready +canStart :: [RoomClientState] -> Bool +canStart rs = length rs > 1 && all (^. isReady) rs diff --git a/src/Thock.hs b/src/Thock.hs new file mode 100644 --- /dev/null +++ b/src/Thock.hs @@ -0,0 +1,206 @@ +{-# 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 diff --git a/src/UI/Attributes.hs b/src/UI/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/UI/Attributes.hs @@ -0,0 +1,50 @@ +-- | This module provides attributes and styling for use within the UI. +module UI.Attributes where + +import qualified Brick.AttrMap as A +import Brick.Util (bg, fg, on) +import qualified Brick.Widgets.List as L +import qualified Brick.Widgets.ProgressBar as P +import qualified Graphics.Vty as V + +-- | The main attribute used for styling the UI +primaryAttr :: A.AttrName +primaryAttr = A.attrName "primary" + +-- | The main color used for styling the UI +primaryColor :: V.Color +primaryColor = V.rgbColor 64 122 (82 :: Int) + +-- | The secondary attribute used for styling the UI +secondaryAttr :: A.AttrName +secondaryAttr = A.attrName "secondary" + +-- | The secondary color used for styling the UI +secondaryColor :: V.Color +secondaryColor = V.rgbColor 0 100 (66 :: Int) + +-- | The attribute for styling correctly typed text +correctAttr :: A.AttrName +correctAttr = A.attrName "correct" + +-- | The attribute for styling incorrectly typed text +incorrectAttr :: A.AttrName +incorrectAttr = A.attrName "incorrect" + +-- | Attribute for styling red text +redAttr :: A.AttrName +redAttr = A.attrName "red" + +-- | Map from an attribute to its corresponding styling for all attributes +attributeMap :: A.AttrMap +attributeMap = + A.attrMap + V.defAttr + [ (primaryAttr, fg primaryColor), + (secondaryAttr, fg secondaryColor), + (L.listSelectedAttr, fg secondaryColor `V.withStyle` V.bold), + (P.progressCompleteAttr, V.white `on` primaryColor), + (correctAttr, fg V.green), + (incorrectAttr, bg V.red), + (redAttr, fg (V.rgbColor 195 39 (43 :: Int))) + ] diff --git a/src/UI/Common.hs b/src/UI/Common.hs new file mode 100644 --- /dev/null +++ b/src/UI/Common.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module has common functionality that is used in both the offline and online UIs. +module UI.Common where + +import Brick + ( EventM, + Size (Fixed), + Widget (Widget, render), + availWidthL, + emptyWidget, + fill, + getContext, + hBox, + hLimit, + hLimitPercent, + handleEventLensed, + str, + txt, + txtWrap, + vBox, + vLimit, + withAttr, + withBorderStyle, + (<+>), + (<=>), + ) +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Border.Style as BS +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Edit as E +import qualified Brick.Widgets.ProgressBar as P +import Control.Lens ((^.)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.FileEmbed (embedFile) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Data.Time (getCurrentTime) +import Graphics.Vty (Event) +import Quotes (source, text) +import Text.Printf (PrintfArg, printf) +import Thock + ( GameState, + ResourceName, + accuracy, + calculateProgress, + calculateWpm, + input, + isDone, + movePromptCursor, + numCorrectChars, + numIncorrectChars, + quote, + secondsElapsed, + updateTime, + ) +import UI.Attributes + ( correctAttr, + incorrectAttr, + primaryAttr, + secondaryAttr, + ) + +-- | Produces a styled title widget based on the logo file +titleWidget :: Widget n +titleWidget = withAttr primaryAttr logo + where + logo = vBox . map txt . T.lines $ decodeUtf8 $(embedFile "resources/logo.txt") + +-- | Draws an element of a list based on if it is selected +listDrawElement :: Bool -> T.Text -> Widget n +listDrawElement sel t = C.hCenter $ txt symbol <+> txt t + where + symbol = + if sel + then "* " + else " " + +-- | Draws a widget with the player's stats and further +-- instructions if the game is done, otherwise is empty +drawFinished :: GameState -> T.Text -> Widget ResourceName +drawFinished g help = if isDone g then doneWidget else emptyWidget + where + doneWidget = C.centerLayer . hLimitPercent 90 $ addBorder "stats" (stats <=> B.hBorder <=> instructions) + stats = speedStat <=> accuracyStat <=> timeStat <=> sourceStat + speedStat = makeStatWidget "Speed: " (drawWpm (calculateWpm g)) + accuracyStat = makeStatWidget "Accuracy: " (drawFloatWithSuffix 1 "%" (accuracy g * 100)) + timeStat = makeStatWidget "Time elapsed: " (drawFloatWithSuffix 1 " seconds" (secondsElapsed g)) + sourceStat = makeStatWidget "Quote source: " (txtWrap $ g ^. (quote . source)) + instructions = C.hCenter (txt help) + makeStatWidget t w = vLimit 1 (hLimit 15 (withAttr secondaryAttr (txt t) <+> fill ' ') <+> w) + +-- | Draws a progress bar for a local game +drawProgressBarGameState :: GameState -> Widget ResourceName +drawProgressBarGameState g = drawProgressBar (calculateProgress g) (calculateWpm g) "your progress" + +-- | Creates a progress bar widget using the given decimal amount done and WPM +drawProgressBar :: Float -> Double -> T.Text -> Widget ResourceName +drawProgressBar decimalDone wpm label = progressWidget <+> wpmWidget + where + progressWidget = addBorder label (P.progressBar (Just percentStr) decimalDone) + percentStr = roundToStr 1 (decimalDone * 100) ++ "%" + wpmWidget = addBorder "" (drawWpm wpm) + +-- | Creates the WPM widget by rounding the given number to 0 decimal points +drawWpm :: Double -> Widget ResourceName +drawWpm = drawFloatWithSuffix 0 " WPM" + +-- | Rounds the given floating point number to n decimal points and attaches s as a suffix +drawFloatWithSuffix :: (PrintfArg a, Floating a) => Int -> String -> a -> Widget ResourceName +drawFloatWithSuffix n s = str . (++ s) . roundToStr n + +-- | Rounds the given floating point number to an integer number of decimal points +roundToStr :: (PrintfArg a, Floating a) => Int -> a -> String +roundToStr = printf "%0.*f" + +-- | Creates the prompt display for the 'GameState' with +-- highlighting based on correctly or incorrectly typed characters +drawPrompt :: GameState -> Widget ResourceName +drawPrompt g = addBorder "prompt" (C.center $ hLimitPercent 80 textWidget) + where + textWidget = Widget Fixed Fixed $ do + ctx <- getContext + render $ + drawTextBlock + (correctWidgets ++ incorrectWidgets ++ restWidgets) + (lineLengths g (ctx ^. availWidthL)) + correctWidgets = withAttr correctAttr . txt . T.singleton <$> T.unpack correctText + incorrectWidgets = withAttr incorrectAttr . txt . T.singleton <$> T.unpack incorrectText + restWidgets = txt . T.singleton <$> T.unpack restText' + (incorrectText, restText') = T.splitAt (numIncorrectChars g) restText + (correctText, restText) = T.splitAt (numCorrectChars g) allText + allText = g ^. (quote . text) + +-- | Produces a list of line lengths for the prompt that fit within the given lim +lineLengths :: GameState -> Int -> [Int] +lineLengths g lim = + let go [] acc = [acc | acc /= 0] + go allT@(t : ts) acc + | nextAcc < lim = go ts nextAcc + | otherwise = acc : go allT 0 + where + nextAcc = T.length t + acc + lenSpace + lenSpace = if null ts then 0 else 1 + in go (T.words $ g ^. (quote . text)) 0 + +-- | Uses a list of line lengths to combine single character widgets into +-- a single widget that is a block of text +drawTextBlock :: [Widget ResourceName] -> [Int] -> Widget ResourceName +drawTextBlock ws ls + | null ws || null ls = emptyWidget + | otherwise = hBox row <=> drawTextBlock rest (tail ls) + where + (row, rest) = splitAt (head ls) ws + +-- | Draws the user input space +drawInput :: GameState -> Widget ResourceName +drawInput g = addBorder "input" (E.renderEditor (txt . T.unlines) True (g ^. input)) + +-- | Adds a rounded border to a widget with the given label +addBorder :: T.Text -> Widget ResourceName -> Widget ResourceName +addBorder t = withBorderStyle BS.unicodeRounded . B.borderWithLabel (txt t) + +-- | Produces the next game state by applying an event and +-- updating the 'GameState' accordingly +updateGameState :: GameState -> Event -> EventM ResourceName GameState +updateGameState g ev = do + gEdited <- handleEventLensed g input E.handleEditorEvent ev + currentTime <- liftIO getCurrentTime + return . updateTime currentTime $ movePromptCursor gEdited diff --git a/src/UI/Offline.hs b/src/UI/Offline.hs new file mode 100644 --- /dev/null +++ b/src/UI/Offline.hs @@ -0,0 +1,222 @@ +-- | This module has deals with UI specific to the offline game and for transitioning to online. +module UI.Offline where + +import Brick + ( BrickEvent (VtyEvent), + EventM, + Next, + Padding (Max), + Widget, + fill, + hLimit, + hLimitPercent, + padBottom, + showFirstCursor, + txt, + txtWrap, + vLimit, + withAttr, + (<+>), + (<=>), + ) +import Brick.Forms + ( Form (formState), + editTextField, + handleFormEvent, + newForm, + renderForm, + (@@=), + ) +import qualified Brick.Main as M +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.List as L +import Client (runClient) +import Control.Lens ((&), (+~), (^.)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Text as T +import qualified Graphics.Vty as V +import Quotes (generateQuote) +import Thock + ( Game (..), + GameState, + HasRoomId (roomId), + HasUsername (username), + MenuList, + ResourceName (RoomIdField, UsernameField), + RoomForm, + RoomFormData (RoomFormData), + Username (Username), + generateRoomId, + initialGame, + isDone, + onlineSelectState, + quote, + startPracticeGame, + strokes, + value, + ) +import UI.Attributes (attributeMap, redAttr, secondaryAttr) +import UI.Common + ( addBorder, + drawFinished, + drawInput, + drawProgressBarGameState, + drawPrompt, + listDrawElement, + titleWidget, + updateGameState, + ) + +-- | Brick app for handling an offline 'Game' +localApp :: M.App Game () ResourceName +localApp = + M.App + { M.appDraw = drawGame, + M.appChooseCursor = showFirstCursor, + M.appHandleEvent = handleKeyGame, + M.appStartEvent = return, + M.appAttrMap = const attributeMap + } + +-- | Draws the given 'Game' based on its current state +drawGame :: Game -> [Widget ResourceName] +drawGame g = case g of + MainMenu l -> drawList l + OnlineSelect l -> drawList l + CreateRoomMenu form -> drawForm form + JoinRoomMenu form -> drawForm form + Practice gs -> drawPractice gs + ErrorOverlay prev t -> drawError prev t + +-- | Renders a list widget under the logo +drawList :: MenuList -> [Widget ResourceName] +drawList l = [drawMenu listWidget] + where + listWidget = L.renderList listDrawElement True l + +-- | Renders a form widget under the logo +drawForm :: RoomForm a -> [Widget ResourceName] +drawForm form = [drawMenu formWidget] + where + formWidget = vLimit 6 $ hLimitPercent 80 (renderForm form) + +-- | Draws the title over another widget w +drawMenu :: Widget ResourceName -> Widget ResourceName +drawMenu w = addBorder "" (C.center titleWidget <=> padBottom Max (C.hCenter w)) + +-- | Draw a practice game based on its 'GameState' +drawPractice :: GameState -> [Widget ResourceName] +drawPractice g = + [ drawFinished g "Back: Esc | Retry: ^r | Next: ^n", + drawProgressBarGameState g <=> drawPrompt g <=> drawInput g + ] + +-- | Draws an error popup over the 'Game' +drawError :: Game -> T.Text -> [Widget ResourceName] +drawError g t = errorPopup : drawGame g + where + errorPopup = C.centerLayer . hLimitPercent 80 . addBorder "error" $ withAttr redAttr (txtWrap t) + +-- | Handles events based on the current state of the 'Game' +handleKeyGame :: Game -> BrickEvent ResourceName () -> EventM ResourceName (Next Game) +handleKeyGame gs ev = case gs of + MainMenu l -> handleKeyMainMenu l ev + OnlineSelect l -> handleKeyOnlineSelect l ev + CreateRoomMenu form -> handleKeyForm CreateRoomMenu (\u -> generateRoomId >>= runClient True . RoomFormData u) (^. value) form ev + JoinRoomMenu form -> handleKeyForm JoinRoomMenu (runClient False) (^. (username . value)) form ev + Practice g -> handleKeyPractice g ev + ErrorOverlay prev _ -> M.continue prev -- after receiving any event, remove the error overlay + +-- | Handles key events for navigating the 'MainMenu' +handleKeyMainMenu :: MenuList -> BrickEvent ResourceName e -> EventM ResourceName (Next Game) +handleKeyMainMenu l (VtyEvent e) = case e of + V.EvKey V.KEsc [] -> M.halt (MainMenu l) + V.EvKey V.KEnter [] + | Just i <- L.listSelected l -> + if i == 0 + then liftIO generateQuote >>= M.continue . startPracticeGame + else M.continue onlineSelectState + ev -> L.handleListEvent ev l >>= M.continue . MainMenu +handleKeyMainMenu l _ = M.continue (MainMenu l) + +-- | Handles key events for creating or joining an online room +handleKeyOnlineSelect :: MenuList -> BrickEvent ResourceName e -> EventM ResourceName (Next Game) +handleKeyOnlineSelect l (VtyEvent e) = case e of + V.EvKey V.KEsc [] -> M.continue initialGame + V.EvKey V.KEnter [] + | Just i <- L.listSelected l -> + M.continue + ( if i == 0 + then CreateRoomMenu (makeCreateRoomForm emptyUsername) + else JoinRoomMenu (makeJoinRoomForm emptyRoomFormData) + ) + where + emptyUsername = Username "" + emptyRoomFormData = RoomFormData emptyUsername "" + ev -> L.handleListEvent ev l >>= M.continue . OnlineSelect +handleKeyOnlineSelect l _ = M.continue (OnlineSelect l) + +-- | Handles a key event for a form and its validation +handleKeyForm :: + -- | Function to construct a Game from the given form + (RoomForm a -> Game) -> + -- | Action to run when the form is submitted, returns a possible error + (a -> IO (Maybe T.Text)) -> + -- | Function to get the username from the given form + (a -> T.Text) -> + RoomForm a -> + BrickEvent ResourceName () -> + EventM ResourceName (Next Game) +handleKeyForm ctr onEnter getUser form ev@(VtyEvent e) = case e of + V.EvKey V.KEsc [] -> M.continue initialGame + V.EvKey V.KEnter [] -> + if not . T.null $ getUser (formState form) + then + M.suspendAndResume + (maybe initialGame (ErrorOverlay (ctr form)) <$> onEnter (formState form)) + else M.continue (ErrorOverlay (ctr form) "username cannot be empty") + _ -> handleFormEvent ev form >>= M.continue . ctr +handleKeyForm ctr _ _ form _ = M.continue (ctr form) + +-- | Construct a 'RoomForm' with the given 'Username' as the initial state +makeCreateRoomForm :: Username -> RoomForm Username +makeCreateRoomForm = + newForm + [ formLabel "Username" + @@= addBorder "" + @@= editTextField value UsernameField (Just 1) + ] + +-- | Construct a 'RoomForm' with the given 'RoomFormData' as the initial state +makeJoinRoomForm :: RoomFormData -> RoomForm RoomFormData +makeJoinRoomForm = + newForm + [ formLabel "Username" + @@= addBorder "" + @@= editTextField (username . value) UsernameField (Just 1), + formLabel "Room ID" + @@= addBorder "" + @@= editTextField roomId RoomIdField (Just 1) + ] + +-- | Label a widget using the given text in the style of a form +formLabel :: T.Text -> Widget n -> Widget n +formLabel t w = C.vCenter label <+> C.vCenter w + where + label = vLimit 1 (hLimit 15 $ withAttr secondaryAttr $ txt t <+> fill ' ') + +-- | Handles key events for updating the 'GameState' in a 'Practice' game +handleKeyPractice :: GameState -> BrickEvent ResourceName e -> EventM ResourceName (Next Game) +handleKeyPractice g (VtyEvent ev) = + case ev of + V.EvKey V.KEsc [] -> M.continue initialGame + V.EvKey (V.KChar 'r') [V.MCtrl] -> M.continue (startPracticeGame (g ^. quote)) + V.EvKey (V.KChar 'n') [V.MCtrl] -> liftIO generateQuote >>= M.continue . startPracticeGame + V.EvKey (V.KChar _) [] -> nextState (g & strokes +~ 1) + _ -> nextState g + where + nextState g' = + if isDone g' + then M.continue (Practice g') + else updateGameState g' ev >>= M.continue . Practice +handleKeyPractice g _ = M.continue (Practice g) diff --git a/src/UI/Online.hs b/src/UI/Online.hs new file mode 100644 --- /dev/null +++ b/src/UI/Online.hs @@ -0,0 +1,159 @@ +-- | This module provides the UI for a game once an online connection is established. +module UI.Online where + +import Brick + ( BrickEvent (AppEvent, VtyEvent), + EventM, + Next, + Widget, + showFirstCursor, + txt, + txtWrap, + vBox, + withAttr, + (<+>), + (<=>), + ) +import qualified Brick.Main as M +import qualified Brick.Widgets.Center as C +import Control.Lens ((%~), (&), (+~), (.~), (^.)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Graphics.Vty as V +import Online + ( ClientMessage (BackToLobby, GameClientUpdate, RoomClientUpdate), + ConnectionTick (..), + GameClientState (GameClientState), + HasConnection (connection), + HasIsReady (isReady), + HasLocalGame (localGame), + HasOtherPlayers (otherPlayers), + HasProgress (progress), + HasWpm (wpm), + Online (..), + OnlineGameState (OnlineGameState), + RoomClientState (RoomClientState), + ServerMessage (GameUpdate, RoomUpdate, StartGame), + WaitingRoomState (WaitingRoomState), + sendJsonData, + ) +import Thock + ( HasRoomId (roomId), + HasUsername (username), + ResourceName, + calculateProgress, + calculateWpm, + initializeGameState, + isDone, + strokes, + ) +import UI.Attributes (attributeMap, redAttr, secondaryAttr) +import UI.Common + ( addBorder, + drawFinished, + drawInput, + drawProgressBar, + drawProgressBarGameState, + drawPrompt, + updateGameState, + ) + +-- | Brick app for handling an 'Online' game +onlineApp :: M.App Online ConnectionTick ResourceName +onlineApp = + M.App + { M.appDraw = drawOnline, + M.appChooseCursor = showFirstCursor, + M.appHandleEvent = handleKeyOnline, + M.appStartEvent = return, + M.appAttrMap = const attributeMap + } + +-- | Draws given 'Online' based on current state +drawOnline :: Online -> [Widget ResourceName] +drawOnline s = case s of + WaitingRoom w -> drawWaitingRoom w + OnlineGame o -> drawOnlineState o + +-- | Creates a waiting room widget which displays the 'RoomId', +-- all connected players and their status, as well as a help section +drawWaitingRoom :: WaitingRoomState -> [Widget ResourceName] +drawWaitingRoom (WaitingRoomState room localSt _ ps) = + [roomIdWidget <=> (playersDisplay <+> statusDisplay) <=> helpWidget] + where + roomIdWidget = addBorder "room id" $ C.hCenter (txt room) + playersDisplay = + addBorder "players" . C.center . vBox $ + map (txt . (^. username)) allStates + statusDisplay = + addBorder "status" . C.center . vBox $ + map (makeReadyTxt . (^. isReady)) allStates + helpWidget = addBorder "help" $ C.hCenter (txtWrap "Press 'r' to ready up! Once everyone is ready, the match will begin.") + makeReadyTxt ready = + if ready + then withAttr secondaryAttr (txt "ready") + else withAttr redAttr (txt "not ready") + allStates = localSt : ps + +-- | Creates a display with the local game state and the progress of other players +drawOnlineState :: OnlineGameState -> [Widget ResourceName] +drawOnlineState o = + [ drawFinished g "Back to lobby: Esc", + drawProgressBarGameState g <=> otherProgressBars <=> drawPrompt g <=> drawInput g + ] + where + otherProgressBars = + vBox $ + map + (\gs -> drawProgressBar (gs ^. progress) (gs ^. wpm) (gs ^. username)) + (o ^. otherPlayers) + g = o ^. localGame + +-- | Handles an event based on current 'Online' state +handleKeyOnline :: Online -> BrickEvent ResourceName ConnectionTick -> EventM ResourceName (Next Online) +handleKeyOnline s ev = case s of + WaitingRoom w -> handleKeyWaitingRoom w ev + OnlineGame o -> handleKeyOnlineState o ev + +-- | Handles both local and 'ConnectionTick' events when the player is in a 'WaitingRoom' +handleKeyWaitingRoom :: WaitingRoomState -> BrickEvent ResourceName ConnectionTick -> EventM ResourceName (Next Online) +handleKeyWaitingRoom (WaitingRoomState room localSt conn _) (AppEvent (ConnectionTick csReceived)) = + case csReceived of + RoomUpdate rs -> M.continue (WaitingRoom $ WaitingRoomState room localSt conn rs) + StartGame q gs -> M.continue (OnlineGame (OnlineGameState (initializeGameState q) room (localSt ^. username) conn gs)) + _ -> undefined +handleKeyWaitingRoom (WaitingRoomState room localSt conn ps) (VtyEvent ev) = + case ev of + V.EvKey V.KEsc [] -> M.halt (WaitingRoom $ WaitingRoomState room localSt conn ps) + V.EvKey (V.KChar 'r') [] -> do + let newSt = localSt & isReady %~ not + liftIO (sendJsonData conn (RoomClientUpdate newSt)) + M.continue (WaitingRoom $ WaitingRoomState room newSt conn ps) + _ -> M.continue (WaitingRoom $ WaitingRoomState room localSt conn ps) +handleKeyWaitingRoom (WaitingRoomState room localSt conn ps) _ = M.continue (WaitingRoom $ WaitingRoomState room localSt conn ps) + +-- | Handles both local and 'ConnectionTick' events when the player is in an 'OnlineGame' +handleKeyOnlineState :: OnlineGameState -> BrickEvent ResourceName ConnectionTick -> EventM ResourceName (Next Online) +handleKeyOnlineState o (AppEvent (ConnectionTick csReceived)) = + case csReceived of + RoomUpdate rs -> M.continue (WaitingRoom $ WaitingRoomState (o ^. roomId) (RoomClientState (o ^. username) False) (o ^. connection) rs) + GameUpdate gs -> M.continue (OnlineGame $ o & otherPlayers .~ gs) + _ -> undefined +handleKeyOnlineState o (VtyEvent ev) = + case ev of + V.EvKey V.KEsc [] -> liftIO (sendJsonData (o ^. connection) (BackToLobby $ o ^. username)) >> M.continue (OnlineGame o) + V.EvKey (V.KChar _) [] -> nextState (o & (localGame . strokes) +~ 1) + _ -> nextState o + where + nextState o' = + if isDone (o' ^. localGame) + then M.continue (OnlineGame o') + else do + updatedGame <- updateGameState (o' ^. localGame) ev + let newClientState = GameClientState (o ^. username) (calculateProgress updatedGame) (calculateWpm updatedGame) + _ <- + liftIO $ + sendJsonData + (o ^. connection) + (GameClientUpdate newClientState) + M.continue (OnlineGame $ o' & localGame .~ updatedGame) +handleKeyOnlineState o _ = M.continue (OnlineGame o) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/thock.cabal b/thock.cabal new file mode 100644 --- /dev/null +++ b/thock.cabal @@ -0,0 +1,134 @@ +cabal-version: 1.12 +name: thock +version: 0.2.0.0 +license: MIT +license-file: LICENSE +copyright: Copyright (c) 2020 Ryan Mehri +maintainer: ryan.mehri1@gmail.com +author: Ryan Mehri +homepage: https://github.com/rmehri01/thock#readme +bug-reports: https://github.com/rmehri01/thock/issues +synopsis: + A modern TUI typing game featuring online racing against friends. + +description: + Please see the README on GitHub at + +category: Game +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/rmehri01/thock + +library + exposed-modules: + Client + Online + Quotes + Server + Thock + UI.Attributes + UI.Common + UI.Offline + UI.Online + + hs-source-dirs: src + other-modules: Paths_thock + default-language: Haskell2010 + default-extensions: OverloadedStrings + build-depends: + aeson >=1.4.7.1 && <1.5, + base >=4.7 && <5, + brick >=0.52.1 && <0.53, + containers >=0.6.2.1 && <0.7, + file-embed >=0.0.11.2 && <0.1, + lens >=4.18.1 && <4.19, + mtl >=2.2.2 && <2.3, + network >=3.1.1.1 && <3.2, + random ==1.1.*, + text >=1.2.4.0 && <1.3, + text-zipper >=0.10.1 && <0.11, + time >=1.9.3 && <1.10, + vector >=0.12.1.2 && <0.13, + vty >=5.28.2 && <5.29, + websockets >=0.12.7.1 && <0.13 + +executable server + main-is: server/Main.hs + hs-source-dirs: app + other-modules: Paths_thock + default-language: Haskell2010 + default-extensions: OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + aeson >=1.4.7.1 && <1.5, + base >=4.7 && <5, + brick >=0.52.1 && <0.53, + containers >=0.6.2.1 && <0.7, + file-embed >=0.0.11.2 && <0.1, + lens >=4.18.1 && <4.19, + mtl >=2.2.2 && <2.3, + network >=3.1.1.1 && <3.2, + random ==1.1.*, + text >=1.2.4.0 && <1.3, + text-zipper >=0.10.1 && <0.11, + thock -any, + time >=1.9.3 && <1.10, + vector >=0.12.1.2 && <0.13, + vty >=5.28.2 && <5.29, + websockets >=0.12.7.1 && <0.13 + +executable thock + main-is: thock/Main.hs + hs-source-dirs: app + other-modules: Paths_thock + default-language: Haskell2010 + default-extensions: OverloadedStrings + ghc-options: -O3 -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + aeson >=1.4.7.1 && <1.5, + base >=4.7 && <5, + brick >=0.52.1 && <0.53, + containers >=0.6.2.1 && <0.7, + file-embed >=0.0.11.2 && <0.1, + lens >=4.18.1 && <4.19, + mtl >=2.2.2 && <2.3, + network >=3.1.1.1 && <3.2, + random ==1.1.*, + text >=1.2.4.0 && <1.3, + text-zipper >=0.10.1 && <0.11, + thock -any, + time >=1.9.3 && <1.10, + vector >=0.12.1.2 && <0.13, + vty >=5.28.2 && <5.29, + websockets >=0.12.7.1 && <0.13 + +test-suite thock-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: Paths_thock + default-language: Haskell2010 + default-extensions: OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + aeson >=1.4.7.1 && <1.5, + base >=4.7 && <5, + brick >=0.52.1 && <0.53, + containers >=0.6.2.1 && <0.7, + file-embed >=0.0.11.2 && <0.1, + lens >=4.18.1 && <4.19, + mtl >=2.2.2 && <2.3, + network >=3.1.1.1 && <3.2, + random ==1.1.*, + text >=1.2.4.0 && <1.3, + text-zipper >=0.10.1 && <0.11, + thock -any, + time >=1.9.3 && <1.10, + vector >=0.12.1.2 && <0.13, + vty >=5.28.2 && <5.29, + websockets >=0.12.7.1 && <0.13