Handle the end of games

ChangeLog.md

@@ -1,5 +1,13 @@
 # Revision history for hanafudapi
 
+## 0.2.2.0  -- 2019-08-12
+
+* Handle the end of games
+
+## 0.2.1.0  -- 2019-01-08
+
+* Use latest changes in the lib to send a log of what happened during a turn
+
 ## 0.2.0.1  -- 2018-08-26
 
 * Games are now playable

hanafuda-webapp.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                hanafuda-webapp
-version:             0.2.1.0
+version:             0.2.2.0
 synopsis:            A webapp for the Haskell hanafuda library
 -- description:         
 homepage:            https://framagit.org/hanafuda

src/Automaton.hs

@@ -7,29 +7,28 @@ import Control.Monad.Except (runExceptT)
 import Control.Monad.Reader (asks, lift)
 import Control.Monad.Writer (runWriterT)
 import qualified Data (RW(..))
-import qualified Game (new, play)
+import Data.Map (Map, (!?))
-import qualified Hanafuda.KoiKoi as KoiKoi (Game(..))
+import qualified Game (Key, T, new, play)
+import qualified Hanafuda.KoiKoi as KoiKoi (Game(..), Step(..))
 import qualified Session (Status(..), T(..), Update)
-import qualified Server (get, logIn, logOut, update, register)
+import qualified Server (endGame, get, logIn, logOut, update, register)
 import qualified App (Context(..), T, current, debug, get, server, try, update, update_)
 import qualified Message (FromClient(..), T(..), broadcast, get, notifyPlayers, relay, send, sendTo, update)
 
-type Vertex = Session.Status
+receive :: Session.Status -> Message.FromClient -> App.T ()
 
-edges :: Vertex -> Message.FromClient -> App.T Vertex
+receive (Session.LoggedIn False) logIn@(Message.LogIn login) =
-
-edges (Session.LoggedIn False) logIn@(Message.LogIn login) =
   asks App.key >>= App.try . (Server.logIn login)
   >>= maybe
-   (Message.relay logIn Message.broadcast >> return (Session.LoggedIn True))
+   (Message.relay logIn Message.broadcast >> setSessionStatus (Session.LoggedIn True))
-   (withError $ Session.LoggedIn False)
+   sendError
 
-edges (Session.LoggedIn True) logOut@Message.LogOut = do
+receive (Session.LoggedIn True) logOut@Message.LogOut = do
   Message.relay logOut Message.broadcast
   asks App.key >>= App.update_ . Server.logOut
-  return (Session.LoggedIn False)
+  setSessionStatus (Session.LoggedIn False)
 
-edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
+receive (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
   session <- App.get to
   case Session.status session of
     Session.LoggedIn True -> do
@@ -37,10 +36,10 @@ edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
       App.update_ (Server.update to (Data.set $ Session.Answering key :: Session.Update))
       Message.broadcast $ Message.update {Message.paired = [key, to]}
       (Message.relay invitation $ Message.sendTo [to])
-      return (Session.Waiting to)
+      setSessionStatus (Session.Waiting to)
-    _ -> Session.LoggedIn True `withError` "They just left"
+    _ -> sendError "They just left"
 
-edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
+receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do
   session <- App.get to
   key <- asks App.key
   case Session.status session of
@@ -57,42 +56,52 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
             Message.broadcast $ Message.update {Message.alone = [key, to]}
             return $ Session.LoggedIn True
       App.update_ $ Server.update to (Data.set newStatus :: Session.Update)
-      return newStatus
+      setSessionStatus newStatus
-    _ -> (Session.LoggedIn True) `withError` "They're not waiting for your answer"
+    _ -> sendError "They're not waiting for your answer"
 
-edges status@(Session.Playing gameKey) (Message.Play {Message.move}) = do
+receive (Session.Playing gameKey) played@(Message.Play {}) = do
   key <- asks App.key
   game <- Server.get gameKey <$> App.server
-  (result, logs) <- lift . runWriterT . runExceptT $ Game.play key move game
+  (result, logs) <- lift . runWriterT . runExceptT $ Game.play key (Message.move played) game
   case result of
-    Left message -> status `withError` message
+    Left message -> sendError message
-    Right newGame ->
+    Right newGame -> do
-      case newGame of
+      Message.notifyPlayers newGame logs
-        KoiKoi.Over _ -> undefined
+      case KoiKoi.step newGame of
-        KoiKoi.On on -> do
+        KoiKoi.Over -> do
-          App.update_ $ Server.update gameKey (const on)
+          App.debug $ "Game " ++ show gameKey ++ " ended"
-          Message.notifyPlayers on logs
+          App.update_ $ Server.endGame gameKey
-          return status
+        _ -> App.update_ $ Server.update gameKey (const newGame)
 
-edges state _ =
+receive (Session.Playing gameKey) Message.Quit = do
-  state `withError` ("Invalid message in state " ++ show state)
+  games <- (Data.get <$> App.server :: App.T (Map Game.Key Game.T))
+  case games !? gameKey of
+    Nothing -> do
+      key <- asks App.key
+      Message.broadcast $ Message.update {Message.alone = [key]}
+      setSessionStatus (Session.LoggedIn True)
+    _ -> sendError "Game is still running"
 
-withError :: Vertex -> String -> App.T Vertex
+receive state _ = sendError $ "Invalid message in state " ++ show state
-withError vertex message = 
-  (Message.send $ Message.Error message) >> return vertex
 
-run :: App.T ()
+sendError :: String -> App.T ()
-run = do
+sendError = Message.send . Message.Error
-  message <- Message.get
+
-  status <- Session.status <$> App.current
+setSessionStatus :: Session.Status -> App.T ()
-  newStatus <- edges status message
+setSessionStatus newStatus = do
   key <- asks App.key
   App.update_ $ Server.update key $ (Data.set newStatus :: Session.Update)
   App.debug $ show newStatus
-  run
+
+loop :: App.T ()
+loop = do
+  message <- Message.get
+  status <- Session.status <$> App.current
+  status `receive` message
+  loop
 
 start :: App.T ()
 start = do
   App.debug "Initial state"
   Message.Welcome <$> App.server <*> asks App.key >>= Message.send
-  run
+  loop

src/Game.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Game (
       Key
-    , View
     , T
     , export
     , new
@@ -26,7 +25,7 @@ import qualified Data (Key)
 import qualified Player (Key)
 import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty)
 import qualified Hanafuda.Player (Player(..), Players(..))
-import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), On(..), Over(..), Score, Source(..), Step(..), Yaku(..), new, play)
+import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..), new, play)
 import GHC.Generics
 
 deriving instance Generic Hanafuda.Card
@@ -40,13 +39,12 @@ deriving instance Generic Hanafuda.KoiKoi.Step
 deriving instance Generic1 (Hanafuda.Player.Player Player.Key)
 deriving instance Generic1 (Hanafuda.Player.Players Player.Key)
 
-type On = Hanafuda.KoiKoi.On Player.Key
+type T = Hanafuda.KoiKoi.Game Player.Key
-type Over = Hanafuda.KoiKoi.Over Player.Key
-type View = Hanafuda.KoiKoi.Game Player.Key
 
-deriving instance Generic On
+deriving instance Generic T
-deriving instance Generic Over
+
-deriving instance Generic View
+instance ToJSON T where
+  toEncoding = genericToEncoding JSON.defaultOptions
 
 instance FromJSON Hanafuda.Card
 instance ToJSON Hanafuda.Card
@@ -90,29 +88,25 @@ instance ToJSON (Hanafuda.Player.Players Player.Key Hanafuda.KoiKoi.Score) where
   toJSON = toJSON1
   toEncoding = toEncoding1
 
-type T = Hanafuda.KoiKoi.On Player.Key
-
-instance ToJSON T
-
 type Key = Data.Key T
 
 new :: Player.Key -> Player.Key -> IO T
 new p1 p2 = do
-  Hanafuda.KoiKoi.new [p1, p2] Hanafuda.KoiKoi.WholeYear
+  Hanafuda.KoiKoi.new [p1, p2] $ Hanafuda.KoiKoi.WholeYear
 
 export :: Player.Key -> T -> Value
-export key on = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck on) $ ast
+export key game = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck game) $ ast
   where
-    Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players on
+    Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players game
     maskOpponentsHand k player
       | k == key = player
       | otherwise = player {Hanafuda.Player.hand = Hanafuda.empty}
-    Object ast = toJSON $ on {
+    Object ast = toJSON $ game {
         Hanafuda.KoiKoi.players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered
       }
 
 play :: Hanafuda.KoiKoi.Environment m => Player.Key -> Hanafuda.KoiKoi.Move -> T -> m (Hanafuda.KoiKoi.Game Player.Key)
-play key move on
+play key move game
-  | Hanafuda.KoiKoi.playing on == key =
+  | Hanafuda.KoiKoi.playing game == key =
-    Hanafuda.KoiKoi.play move on
+    Hanafuda.KoiKoi.play move game
   | otherwise = throwError "Not your turn"

src/Message.hs

@@ -27,7 +27,7 @@ import qualified Game (T, export)
 import qualified Session (T(..))
 import qualified Server (T(..), get)
 import qualified App (Context(..), T, connection, debug, server)
-import qualified Hanafuda.KoiKoi as KoiKoi (Action, On(..), Move(..))
+import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), Move(..))
 import GHC.Generics (Generic)
 
 data FromClient =
@@ -36,6 +36,7 @@ data FromClient =
   | LogIn {name :: Text}
   | LogOut
   | Play {move :: KoiKoi.Move}
+  | Quit
   | Ping
   deriving (Generic)
 

src/Server.hs

@@ -8,6 +8,7 @@
 module Server (
       T(..)
     , disconnect
+    , endGame
     , get
     , logIn
     , logOut
@@ -96,6 +97,10 @@ disconnect :: Player.Key -> T -> T
 disconnect key =
   Data.update (delete key :: Sessions -> Sessions) . logOut key
 
+endGame :: Game.Key -> T -> T
+endGame key =
+  Data.update (delete key :: Games -> Games)
+
 logIn :: Text -> Player.Key -> T -> Either String T
 logIn name key server =
   Data.update (Set.insert name) .

www/game.js

@@ -48,8 +48,12 @@ function Game(modules) {
 	}
 
 	function handleGameMessage(o) {
-		if(o.game.deck == 24) {
+		if(o.game.deck == 24) { // deck is full, means new round
-			return o.logs.length > 0 ? modules.async.sequence(applyDiff(o), setGame(o)) : setGame(o);
+			if(o.logs.length > 0) { // but still some logs, from the previous round
+				return modules.async.sequence(applyDiff(o), setGame(o)); // so play the diff, then set the new round
+			} else {
+				return setGame(o); // directly set a whole new game
+			}
 		} else {
 			return applyDiff(o);
 		}
@@ -70,6 +74,22 @@ function Game(modules) {
 
 	function handleStep(o) {
 		return function(f) {
+			handleTurnedCard(o, f);
+			if(status.step == "Scored") {
+				if(status.playing) {
+					askKoikoi(o, f);
+				} else {
+					theyScored(o, f);
+				}
+			} else if (status.step == "Over") {
+				gameEnd(o, f);
+			} else {
+				f();
+			}
+		};
+	}
+
+	function handleTurnedCard(o, f) {
 		if(status.step == "Turned") {
 			setTurned(o.game.step.contents);
 		} else {
@@ -80,8 +100,9 @@ function Game(modules) {
 				deck.removeChild(deck.lastChild);
 			}
 		}
-    	if(status.step == "Scored") {
+	}
-    	  if(status.playing) {
+
+	function askKoikoi(o, f) {
 		modules.screen.dialog({
 			text: modules.i18n.get('youScored'),
 			answers: [
@@ -89,7 +110,10 @@ function Game(modules) {
 				{label: 'koikoi', action: function() {play({koiKoi: true}); f();}}
 			]
 		});
-    	  } else {
+
+	}
+
+	function theyScored(o, f) {
 		modules.screen.dialog({
 			text: modules.i18n.get('theyScored')(modules.room.name(o.game.playing)),
 			answers: [
@@ -97,10 +121,26 @@ function Game(modules) {
 			]
 		});
 	}
-    	} else {
+
+	function gameEnd(o, f) {
+		var winner, maxScore;
+		for(var key in o.game.scores) {
+			if(maxScore == undefined || o.game.scores[key] > maxScore) {
+				winner = key;
+				maxScore = o.game.scores[key];
+			}
+		}
+		modules.screen.dialog({
+			text: modules.i18n.get(modules.session.is(winner) ? 'won' : 'lost'),
+			answers: [{
+				label: 'endGame',
+				action: function() {
+					modules.messaging.send({tag: "Quit"});
+					modules.screen.select('reception');
 					f();
 				}
-		};
+			}]
+		});
 	}
 
 	function applyDiff(o) {

www/translations.js

@@ -17,6 +17,7 @@ function Translations() {
 			alone: "No one to play with yet ! Wait a little",
 			decline: "Decline",
 			endRound: "End the round",
+			endGame: "Return to main menu",
 			join: "Join",
 			invite: "Invite",
 			invited: function(name) {
@@ -24,6 +25,7 @@ function Translations() {
 			},
 			koikoi: "KoiKoi !!",
 			leave: "Leave",
+			lost: "You lost the game",
 			monthFlower: function(flower) {
 				return "This month's flower is the " + flower;
 			},
@@ -37,6 +39,7 @@ function Translations() {
 			theyScored: function(name) {
 				return name + " scored";
 			},
+			won: "You won !",
 			yourTurn: "Your turn",
 			youScored: "You scored ! Do you want to get your points and end the round or KoiKoi ?"
 		},
@@ -57,6 +60,7 @@ function Translations() {
 			alone: "Personne pour jouer pour l'instant ! Attendez un peu",
 			decline: "Refuser",
 			endRound: "Finir la manche",
+			endGame: "Retourner au menu principal",
 			join: "Entrer",
 			invite: "Inviter",
 			invited: function(name) {
@@ -64,6 +68,7 @@ function Translations() {
 			},
 			koikoi: "KoiKoi !!",
 			leave: "Partir",
+			lost: "Vous avez perdu",
 			monthFlower: function(flower) {
 				return "C'est le mois des " + flower;
 			},
@@ -77,6 +82,7 @@ function Translations() {
 			theyScored: function(name) {
 				return name + " a marqué";
 			},
+			won: "Vous avez gagné !",
 			yourTurn: "À vous",
 			youScored: "Vous avez marqué ! Voulez-vous empocher vos gains et terminer la manche ou faire KoiKoi ?"
 		}