hannah.cabal

@@ -21,19 +21,15 @@ executable hannah
   other-modules:       AI
                      , Automaton
                      , Config
-                     , Session
   -- other-extensions:    
   build-depends:       aeson
                      , base >=4.9 && <4.13
                      , bytestring
                      , containers
-                     , directory
-                     , filepath
                      , hanafuda
-                     , hanafuda-protocol
+                     , hanafuda-APILanguage
                      , mtl
                      , text
                      , websockets
   hs-source-dirs:      src
-  ghc-options:         -Wall
   default-language:    Haskell2010

src/AI.hs

@@ -4,41 +4,34 @@ module AI (
   ) where
 
 import Data.List (sortOn)
-import Data.Map ((!), delete, findMin)
+import Data.Map ((!))
 import Data.Ord (Down(..))
-import Data.Set (member)
-import qualified Data.Set as Set (fromList)
+import Data.Set (Set, member)
+import qualified Data.Set as Set (fromList, intersection, unions)
 import Hanafuda (
       Card(..), Flower(..), Pack
     , cardsOf, cardsOfPack, contains, empty,flower, packOfCards, sameMonth, size, union
   )
-import Hanafuda.KoiKoi (Move(..), PlayerID, Step(..))
-import Hanafuda.Message (PublicGame(..), PublicState(..), PublicPlayer)
-import qualified Hanafuda.Message as Message (Coordinates(..))
+import Hanafuda.Player (Player(..), Players(..))
+import Hanafuda.KoiKoi (GameBlueprint(..), Move(..), PlayerID, Step(..), Score)
+import Hanafuda.Message (PublicGame)
 
 move :: PlayerID -> PublicGame -> Move
 
-move me (PublicGame {playerHand, public = PublicState {coordinates, step = ToPlay, players, river}}) =
-  case getAvailableCards hand (cardsOfPack river) of
-    [] -> Play $ worstFor month opponent hand
+move me (Game {step = ToPlay, month, players = Players p, river}) =
+  case getAvailableCards myHand (cardsOfPack river) of
+    [] -> Play $ worstFor month (p ! (nextPlayer $ p ! me)) myHand
     available ->
-      let riverCard = bestFor month (players ! me) available in
-      let matchingCards = cardsOfPack . sameMonth riverCard $ playerHand in
-      capture (bestFor month (players ! me) matchingCards) riverCard river
+      let riverCard = bestFor month (p ! me) available in
+      let matchingCards = cardsOfPack . sameMonth riverCard . hand $ p ! me in
+      capture (bestFor month (p ! me) matchingCards) riverCard river
   where
-    month = Message.month $ coordinates
-    hand = cardsOfPack playerHand
-    opponent = snd . findMin $ delete me players
+    myHand = cardsOfPack . hand $ p ! me
 
-move me (PublicGame {public = PublicState {coordinates, step = Turned card, players, river}}) =
-  Choose . bestFor month (players ! me) . cardsOfPack $ sameMonth card river
-  where
-    month = Message.month $ coordinates
+move me (Game {step = Turned card, month, players = Players p, river}) =
+  Choose . bestFor month (p ! me) . cardsOfPack $ sameMonth card river
 
-move _ (PublicGame {playerHand, public = PublicState {step = Scored}}) =
-  KoiKoi $ playerHand /= empty
-
-move _ _ = error "Nothing to play on ended game"
+move me (Game {players = Players p}) = KoiKoi $ hand (p ! me) /= empty
 
 capture :: Card -> Card -> Pack -> Move
 capture card caught river =
@@ -55,13 +48,13 @@ getAvailableCards hand =
 choose :: Ord a => (Card -> a) -> [Card] -> Card
 choose sortCriterion = head . sortOn sortCriterion
 
-bestFor :: Flower -> PublicPlayer -> [Card] -> Card
+bestFor :: Flower -> Player Score -> [Card] -> Card
 bestFor monthFlower player = choose (Down . rank monthFlower player)
 
-worstFor :: Flower -> PublicPlayer -> [Card] -> Card
+worstFor :: Flower -> Player Score -> [Card] -> Card
 worstFor monthFlower player = choose (rank monthFlower player)
 
-rank :: Flower -> PublicPlayer -> Card -> Int
+rank :: Flower -> Player Score -> Card -> Int
 rank monthFlower _ card
   | isTrueLight card = 5
   | card == RainMan = 2

src/Automaton.hs

@@ -4,23 +4,38 @@ module Automaton (
     start
   ) where
 
-import qualified AI (move)
+import 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 ((!))
-import qualified Data.Map as Map (empty, filter, lookup)
+import Data.Map (Map, empty)
+import Data.Text (Text)
+import Control.Concurrent (threadDelay)
 import Control.Monad.Reader (ReaderT, ask)
+import Control.Monad.State (StateT)
 import Control.Monad.Trans (lift)
-import Hanafuda.KoiKoi (Step(..))
-import Hanafuda.Message (FromClient(..), T(..), orderCoordinates)
-import qualified Hanafuda.Message as Message (
-    Coordinates(..), FromClient, PublicGame(..), PublicState(..), T(..)
-  )
+import Hanafuda.KoiKoi (Game, GameBlueprint(..), PlayerID, Step(..))
+import qualified Hanafuda.Message as Message (T(..), FromClient(..), PublicGame)
 import Network.WebSockets (Connection, receiveData, sendTextData)
 import Prelude hiding (error, putStrLn)
-import Session (State(..), deleteGame, initial, storeID, storeGame)
+import System.Exit (exitSuccess)
+
+data State =
+    Initial
+  | Connected {
+        key :: PlayerID
+    }
+  | LoggedIn {
+        key :: PlayerID
+      , name :: Text
+    }
+  | Playing {
+        key :: PlayerID
+      , name :: Text
+      , against :: PlayerID
+    }
+  deriving Show
 
 type App a = ReaderT Connection IO a
 
@@ -46,76 +61,50 @@ receive = do
 debug :: ByteString -> App ()
 debug message = lift $ putStrLn message
 
-answer :: State -> Message.T -> App State
+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 New (Welcome {key}) = do
-  lift $ Session.storeID 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 state@(Connected {}) (Relay {from, message = Invitation {}}) =
-  send (Answer {accept = True, to = from}) >> return state
+answer (Message.Relay {Message.from, Message.message = Message.Invitation {}}) (LoggedIn {key, name}) = do
+  send $ Message.Answer {Message.accept = True}
+  return $ Playing {key, name, against = from}
 
-answer state@(Connected {playerID}) message@(Game {}) = do
-  case Message.step $ Message.public game of
-    Over -> deleteGame gameID state
+answer (Message.Relay {Message.message = Message.Invitation {}}) state = do
+  send $ Message.Answer {Message.accept = False}
+  return state
+
+answer (Message.Game {Message.game, Message.logs}) state@(Playing {key, name}) = do
+  case step game of
+    Over -> send Message.Quit >> return (LoggedIn {key, name})
     _ -> do
-      if Message.playing (Message.public game) == playerID
-      then
-        send (Play {move = AI.move playerID game, onGame = game})
-      else return ()
-      storeGame gameID game state
-  where
-    game = Message.state message
-    gameID = Message.gameID . Message.coordinates $ Message.public game
+      if playing game == key
+      then send (Message.Play {Message.move = AI.move key game}) >> return state
+      else return state
 
-answer state Pong = ping >> return state
+answer (Message.Relay {Message.from, Message.message = Message.LogOut}) (Playing {key, name, against})
+  | from == against = send Message.Quit >> return (LoggedIn {key, name})
 
-answer state (Error {error}) = do
+answer (Message.Relay {}) state = return state
+
+answer Message.Pong state = ping >> return state
+
+answer (Message.Error {Message.error}) state = do
   debug $ "Received error from server : " `append` pack error
   return state
 
-answer state@(Connected {playerID, games}) (LogIn {from}) =
-  (mapM_ sync . Map.filter isAgainst $ Message.public <$> games) >> return state
-  where
-    isAgainst publicState = Message.nextPlayer publicState ! playerID == from
-    sync publicState =
-      send $ Sync {latestKnown = Message.coordinates $ publicState, to = from}
-
-answer state@(Connected {games}) (Relay {from, message = Sync {latestKnown}}) =
-  case Map.lookup gameID games of
-    Nothing -> send $ Yield {onGameID = gameID, to = from}
-    Just game ->
-      let latestKnownHere = Message.coordinates $ Message.public game in
-      case orderCoordinates latestKnown latestKnownHere of
-        Just LT -> send $ Share {gameSave = game}
-        Just GT -> send $ Yield {onGameID = gameID, to = from}
-        _ -> return ()
-  >> return state
-  where
-    gameID = Message.gameID latestKnown
-
-answer state@(Connected {games}) (Relay {message = Yield {onGameID}}) =
-  send (Share {gameSave = games ! onGameID}) >> return state
-
-{-
- - Ignore
- -}
-answer state@(Connected {}) (Okaeri {}) = return state
-answer state (LogIn {}) = return state
-answer state (LogOut {}) = return state
-answer state (Relay {}) = return state
-
-answer state message = do
+answer message state = 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 Ping connection)
+  setTimeout (20*s) (sendIO Message.Ping connection)
   where
     setTimeout delay callback =
       const () <$> (lift $ forkIO (threadDelay delay >> callback))
@@ -123,12 +112,8 @@ ping = do
     s = 1000 * ms
 
 start :: App ()
-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
+start = ping >> loop Initial
   where
-    loop state = receive >>= answer state >>= loop
+    loop state = do
+      newMessage <- receive
+      answer newMessage state >>= loop

src/Config.hs

@@ -1,15 +1,11 @@
 module Config (
       host
-    , libDir
     , path
     , port
   ) where
 
 host :: String
-host = "koikoi.local"
-
-libDir :: FilePath
-libDir = "/home/alice/Documents/Atelier/hanafuda/hannah/lib"
+host = "koikoi.menf.in"
 
 path :: String
 path = "/play/"

src/Main.hs

@@ -2,6 +2,7 @@ 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)
 

src/Session.hs

@@ -1,83 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-module Session (
-      State(..)
-    , deleteGame
-    , initial
-    , storeID
-    , storeGame
-  ) where
-
-import Config (libDir)
-import Control.Monad (foldM)
-import Control.Monad.Except (MonadError(..), ExceptT(..), runExceptT)
-import Control.Monad.IO.Class (MonadIO(..))
-import Data.Aeson (encodeFile, eitherDecodeFileStrict')
-import Data.Map (Map)
-import qualified Data.Map as Map (delete, empty, insert)
-import Hanafuda.KoiKoi (GameID, PlayerID)
-import qualified Hanafuda.Message as Message (PublicGame)
-import System.Directory (
-    createDirectoryIfMissing, doesFileExist, listDirectory, removeFile
-  )
-import System.FilePath ((</>))
-import System.IO (stderr, hPutStrLn)
-import Text.Read (readEither)
-
-type Games = Map GameID Message.PublicGame
-data State =
-    New
-  | Connected {
-        playerID :: PlayerID
-      , games :: Games
-    }
-  deriving Show
-
-stateFile :: FilePath
-stateFile = libDir </> "state"
-
-gamesDir :: FilePath
-gamesDir = libDir </> "games"
-
-warn :: a -> String -> IO a
-warn defaultValue errorMessage =
-  hPutStrLn stderr errorMessage >> return defaultValue
-
-initial :: IO State
-initial = do
-  createDirectoryIfMissing True libDir
-  fileExists <- doesFileExist stateFile
-  runExceptT (if fileExists then loadFile else stateFileMissing)
-  >>= either (warn New) return
-  where
-    stateFileMissing = throwError $ "State file missing : " ++ stateFile
-    loadFile = do
-      playerID <- ExceptT $ readEither <$> readFile stateFile
-      Connected playerID <$> liftIO loadGames
-
-storeID :: Show a => a -> IO ()
-storeID = writeFile stateFile . show
-
-loadGames :: IO Games
-loadGames = do
-  createDirectoryIfMissing True gamesDir
-  listDirectory gamesDir >>= foldM loadGame Map.empty
-
-loadGame :: Games -> FilePath -> IO Games
-loadGame tmpGames fileName =
-  runExceptT exceptLoad >>= either (warn tmpGames) return
-  where
-    exceptLoad = do
-      gameID <- ExceptT . return $ readEither fileName
-      publicGame <- ExceptT . eitherDecodeFileStrict' $ gamesDir </> fileName
-      return $ Map.insert gameID publicGame tmpGames
-
-storeGame :: MonadIO m => GameID -> Message.PublicGame -> State -> m State
-storeGame gameID publicGame state = do
-  liftIO $ createDirectoryIfMissing True gamesDir
-           >> encodeFile (gamesDir </> show gameID) publicGame
-  return $ state {games = Map.insert gameID publicGame $ games state}
-
-deleteGame :: MonadIO m => GameID -> State -> m State
-deleteGame gameID state = do
-  liftIO $ removeFile (gamesDir </> show gameID)
-  return $ state {games = Map.delete gameID $ games state}