From 5b78285303af1ce55a31aac37c5069b6f17e4827 Mon Sep 17 00:00:00 2001
From: Sasha <sasha+frama@marvid.fr>
Date: Wed, 7 Mar 2018 17:50:01 +0100
Subject: [PATCH] Optimize game states and moves to reduce client-server
 to-and-fro

---
 src/Hanafuda/Card.hs |  8 ++++----
 src/Hanafuda/Day.hs  | 28 +++++++++++++++-------------
 src/Hanafuda/Game.hs | 11 +++++++++--
 3 files changed, 28 insertions(+), 19 deletions(-)

diff --git a/src/Hanafuda/Card.hs b/src/Hanafuda/Card.hs
index daa21be..bb4d528 100644
--- a/src/Hanafuda/Card.hs
+++ b/src/Hanafuda/Card.hs
@@ -112,10 +112,10 @@ shuffle l =
       let (top, bottom) = splitAt cut shuffled
       return $ top ++ h : bottom
 
-pair :: Card -> Pack -> Maybe (Pack, [Card])
+pair :: Card -> Pack -> Either String (Pack, [Card])
 pair card pack =
   let sameMonthCards = sameMonth card `intersection` pack in
   case size sameMonthCards of
-    0 -> Just (add pack card, [])
-    1 -> Just (difference pack sameMonthCards, card : cardsOfPack sameMonthCards)
-    _ -> Nothing
+    0 -> Right (add pack card, [])
+    1 -> Right (difference pack sameMonthCards, card : cardsOfPack sameMonthCards)
+    _ -> Left "This card can pair with several others"
diff --git a/src/Hanafuda/Day.hs b/src/Hanafuda/Day.hs
index d07729c..3183735 100644
--- a/src/Hanafuda/Day.hs
+++ b/src/Hanafuda/Day.hs
@@ -4,11 +4,11 @@ module Hanafuda.Day where
 
 import Hanafuda.Card (Card, Pack, Flower(Pine), contains, flower, packOfCards, pair, remove)
 import Hanafuda.Yaku (rate)
-import Hanafuda.Game (Game(..), Move(..), PlayerState, meld, yakus)
+import Hanafuda.Game (Game(..), Move(..), PlayerState, meld, plays, yakus)
 import Data.Map (Map, adjust, empty, fromList, insert, union, (!))
 import Control.Monad.Reader (runReader)
 
-data Step = ToPlay | ToChoose (Maybe Card) | Scored | Over Bool
+data Step = ToPlay | Turned Card | Scored | Over Bool
 
 data Day = Day {
       river :: Pack
@@ -30,28 +30,30 @@ new river player next = Day {
   }
 
 instance Game Day Day where
-  play day@(Day {river, step, next, trick}) move =
+  play day@(Day {river, step, next, trick, player}) move =
     case (step, move) of
-      (ToPlay, Play card) ->
-        case pair card river of
-          Just (newRiver, newCaptured) -> turnOver $ day {river = newRiver, trick = newCaptured}
-          Nothing -> Right $ day {step = ToChoose (Just card)}
-      (ToChoose maybeCard, Choose caught) ->
-        let (continue, card) = maybe (end, next) ((,) turnOver) maybeCard in
+      (ToPlay, Play card) -> pair card river >>= play card
+      (ToPlay, Capture (card, caught)) ->
         if card `canCatch` caught
-          then turnOver $
-            day {river = remove river caught, trick = [card, caught] ++ trick}
+          then play card (remove river caught, [card, caught])
+          else Left "You can't choose that card"
+      (Turned card, Choose caught) ->
+        if card `canCatch` caught
+          then end $ day {river = remove river caught, trick = [card, caught] ++ trick}
           else Left "You can't choose that card"
       (Scored, KoiKoi win) -> Right $ day {step = Over win}
       (_, _) -> Left "You can't play this move in that state"
     where
       canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
+      play card (river, trick) = do
+        played <- player `plays` card
+        turnOver $ day {river, trick, player = played}
 
 turnOver :: Day -> Either String Day
 turnOver day@(Day {river, next, trick}) =
   case pair next river of
-    Just (newRiver, newCaptured) -> end $ day {river = newRiver, trick = trick ++ newCaptured}
-    Nothing -> Right $ day {step = ToChoose Nothing}
+    Right (newRiver, newCaptured) -> end $ day {river = newRiver, trick = trick ++ newCaptured}
+    Left _ -> Right $ day {step = Turned next}
 
 end :: Day -> Either String Day
 end day@(Day {month, trick, player}) =
diff --git a/src/Hanafuda/Game.hs b/src/Hanafuda/Game.hs
index f2d27d8..5c72131 100644
--- a/src/Hanafuda/Game.hs
+++ b/src/Hanafuda/Game.hs
@@ -1,8 +1,9 @@
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 module Hanafuda.Game where
 
 import Data.Map (Map, empty, fromList, (!))
-import Hanafuda.Card (Card, Pack, packOfCards)
+import Hanafuda.Card (Card, Pack, contains, packOfCards, remove)
 import Hanafuda.Yaku (Score, Points)
 
 data Player =
@@ -37,7 +38,13 @@ initPlayers =
       , yakus = empty
     }
 
-data Move = Play Card | Choose Card | KoiKoi Bool
+plays :: PlayerState -> Card -> Either String PlayerState
+plays player@(PlayerState {hand}) card =
+  if hand `contains` card
+    then Right $ player {hand = remove hand card}
+    else Left "You don't have this card"
+
+data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
 
 type Scores = Map Player Points