diff --git a/src/AI.hs b/src/AI.hs index 6f92045..3acd028 100644 --- a/src/AI.hs +++ b/src/AI.hs @@ -6,14 +6,13 @@ module AI ( import Data.List (sortOn) import Data.Map ((!), delete, findMin) import Data.Ord (Down(..)) -import Data.Set (Set, member) -import qualified Data.Set as Set (fromList, intersection, unions) +import Data.Set (member) +import qualified Data.Set as Set (fromList) import Hanafuda ( Card(..), Flower(..), Pack , cardsOf, cardsOfPack, contains, empty,flower, packOfCards, sameMonth, size, union ) -import Hanafuda.Player (Player(..), Players(..)) -import Hanafuda.KoiKoi (Move(..), PlayerID, Step(..), Score) +import Hanafuda.KoiKoi (Move(..), PlayerID, Step(..)) import Hanafuda.Message (PublicGame(..), PublicState(..), PublicPlayer) move :: PlayerID -> PublicGame -> Move @@ -32,9 +31,11 @@ move me (PublicGame {playerHand, public = PublicState {step = ToPlay, month, pla move me (PublicGame {public = PublicState {step = Turned card, month, players, river}}) = Choose . bestFor month (players ! me) . cardsOfPack $ sameMonth card river -move me (PublicGame {playerHand, public = PublicState {step = Scored}}) = +move _ (PublicGame {playerHand, public = PublicState {step = Scored}}) = KoiKoi $ playerHand /= empty +move _ _ = error "Nothing to play on ended game" + capture :: Card -> Card -> Pack -> Move capture card caught river = if size (sameMonth card river) == 1 diff --git a/src/Automaton.hs b/src/Automaton.hs index 98ea890..c7a2b4e 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -4,38 +4,23 @@ module Automaton ( start ) where -import AI (move) +import qualified AI (move) import Control.Concurrent (forkIO, threadDelay) import Data.Aeson (encode, eitherDecode') import Data.ByteString.Lazy.Char8 (ByteString, append, pack, putStrLn) import qualified Data.ByteString.Lazy.Char8 as ByteString (concat) -import Data.Map (Map, empty) -import Data.Text (Text) -import Control.Concurrent (threadDelay) +import Data.Map ((!)) +import qualified Data.Map as Map (delete, empty, member) import Control.Monad.Reader (ReaderT, ask) -import Control.Monad.State (StateT) import Control.Monad.Trans (lift) -import Hanafuda.KoiKoi (PlayerID, Step(..)) -import qualified Hanafuda.Message as Message (T(..), FromClient(..), PublicGame(..), PublicState(..)) +import Hanafuda.KoiKoi (Step(..)) +import Hanafuda.Message (T(..), FromClient(..)) +import qualified Hanafuda.Message as Message ( + T(..), FromClient, PublicGame(..), PublicState(..) + ) import Network.WebSockets (Connection, receiveData, sendTextData) import Prelude hiding (error, putStrLn) -import System.Exit (exitSuccess) - -data State = - Initial - | Connected { - key :: PlayerID - } - | LoggedIn { - key :: PlayerID - , name :: Text - } - | Playing { - key :: PlayerID - , name :: Text - , against :: PlayerID - } - deriving Show +import Session (State(..), initial, store) type App a = ReaderT Connection IO a @@ -61,54 +46,58 @@ receive = do debug :: ByteString -> App () debug message = lift $ putStrLn message -answer :: Message.T -> State -> App State -answer welcome@(Message.Welcome {}) Initial = do - send $ Message.LogIn {Message.name = "Hannah"} - return $ Connected {key = Message.key welcome} +answer :: State -> Message.T -> App State +answer New (Welcome {key}) = do + lift $ Session.store key + lift $ putStrLn "Stored" + return $ Connected {playerID = key, games = Map.empty} + +{- answer (Message.Relay {Message.from, Message.message = Message.LogIn {Message.name}}) (Connected {key}) | from == key = return $ LoggedIn {key, name} +-} -answer (Message.Relay {Message.from, Message.message = Message.Invitation {}}) (LoggedIn {key, name}) = do - send $ Message.Answer {Message.accept = True, Message.to = from} - return $ Playing {key, name, against = from} +answer state@(Connected {games}) (Relay {from, message = Invitation {}}) = + -- policy : one game per player only + send (Answer {accept = not $ Map.member from games, to = from}) + >> return state -answer (Message.Relay {Message.from, Message.message = Message.Invitation {}}) state = do - send $ Message.Answer {Message.accept = False, Message.to = from} - return state - -answer message@(Message.Game {Message.logs}) state@(Playing {key, name}) = do +answer state@(Connected {playerID, games}) message@(Game {}) = do case Message.step $ Message.public game of - Over -> send Message.Quit >> return (LoggedIn {key, name}) + Over -> + let opponentID = Message.nextPlayer (Message.public game) ! playerID in + return $ state {games = Map.delete opponentID games} _ -> - if Message.playing (Message.public game) == key + if Message.playing (Message.public game) == playerID then - send (Message.Play {Message.move = AI.move key game, Message.onGame = game}) - >> return state + send (Play {move = AI.move playerID game, onGame = game}) >> return state else return state where game = Message.state message -answer (Message.Relay {Message.from, Message.message = Message.LogOut}) (Playing {key, name, against}) - | from == against = send Message.Quit >> return (LoggedIn {key, name}) +answer state Pong = ping >> return state -answer (Message.Relay {}) state = return state - -answer Message.Pong state = ping >> return state - -answer (Message.Error {Message.error}) state = do +answer state (Error {error}) = do debug $ "Received error from server : " `append` pack error return state -answer message state = do +{- + - Ignore + -} +answer state@(Connected {}) (Okaeri {}) = return state +answer state (Relay {}) = return state + +answer state message = do debug $ ByteString.concat [ "Unexpected message : ", encode message, " in state ", pack $ show state ] return state +ping :: App () ping = do connection <- ask - setTimeout (20*s) (sendIO Message.Ping connection) + setTimeout (20*s) (sendIO Ping connection) where setTimeout delay callback = const () <$> (lift $ forkIO (threadDelay delay >> callback)) @@ -116,8 +105,12 @@ ping = do s = 1000 * ms start :: App () -start = ping >> loop Initial +start = do + ping + initialState <- lift Session.initial + case initialState of + New -> send $ Hello {name = "Hannah"} + Connected {playerID} -> send $ Tadaima {myID = playerID, name = "Hannah"} + loop initialState where - loop state = do - newMessage <- receive - answer newMessage state >>= loop + loop state = receive >>= answer state >>= loop diff --git a/src/Config.hs b/src/Config.hs index 04a7c4a..bf9ab11 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -6,10 +6,10 @@ module Config ( ) where host :: String -host = "koikoi.menf.in" +host = "koikoi.local" libDir :: FilePath -libDir = "/var/lib/hannah" +libDir = "/home/alice/Documents/Atelier/hanafuda/hannah/lib" path :: String path = "/play/" diff --git a/src/Main.hs b/src/Main.hs index 92238a4..87cc828 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,7 +2,6 @@ module Main where import Network.WebSockets (ClientApp, runClient) import Control.Monad.Reader (runReaderT) -import Control.Monad.State (runStateT) import Config (host, port, path) import Automaton (start)