diff --git a/ChangeLog.md b/ChangeLog.md index 7db2e17..4019f31 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for hanafuda +## 0.3.1.0 -- 2019-01-08 + +* Generalize the output monad of basic functions by only expressing constraints on it +* Remove constructor for errors to handle them in a MonadError instead and add a MonadWriter for logs + ## 0.3.0.2 -- 2018-08-27 * Remove WillowRed accidentally present in plains' set diff --git a/hanafuda.cabal b/hanafuda.cabal index 3a6699e..2aa2ea6 100644 --- a/hanafuda.cabal +++ b/hanafuda.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hanafuda -version: 0.3.0.2 +version: 0.3.1.0 synopsis: A game of Hanafuda (a family of japanese card games) description: This is a library to represent the cards and the players of games in this family. It also implements one such game diff --git a/src/Hanafuda/KoiKoi.hs b/src/Hanafuda/KoiKoi.hs index f281e8a..eee5092 100644 --- a/src/Hanafuda/KoiKoi.hs +++ b/src/Hanafuda/KoiKoi.hs @@ -1,12 +1,16 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} module Hanafuda.KoiKoi ( - Card(..) + Action(..) + , Card(..) , Game(..) + , Environment , Mode(..) , Move(..) , On(..) , Over(..) , Score + , Source(..) , Step(..) , Yaku(..) , new @@ -16,29 +20,31 @@ module Hanafuda.KoiKoi ( import Hanafuda (Card(..), Flower(Pine), contains, flower, match, remove) import qualified Hanafuda.Player as Player (players, random, scores) import Hanafuda.KoiKoi.Yaku (Yaku(..), Score) -import Hanafuda.KoiKoi.Game (Game(..), Mode(..), Move(..), On(..), Over(..), Step(..), raise) +import Hanafuda.KoiKoi.Game (Action(..), Environment, Game(..), Mode(..), Move(..), On(..), Over(..), Source(..), Step(..)) import qualified Hanafuda.KoiKoi.Round as Round (deal, next) import qualified Hanafuda.KoiKoi.Turn as Turn (catch, end, next) +import Control.Monad.Except (MonadError(..)) +import Control.Monad.IO.Class (MonadIO) -play :: Ord player => Move -> On player -> IO (Game player) +play :: (Environment m, Ord player) => Move -> On player -> m (Game player) play move on@(On_ {river, step}) = case (step, move) of (ToPlay, Play card) -> - either raise (Turn.catch on card) $ match card river + either throwError (Turn.catch on card) $ match card river (ToPlay, Capture (card, caught)) -> if card `canCatch` caught then Turn.catch on card (remove river caught, [card, caught]) - else raise "You can't choose that card" + else throwError "You can't choose that card" (Turned card, Choose caught) -> if card `canCatch` caught - then Turn.end on (remove river caught, [card, caught]) - else raise "You can't choose that card" + then Turn.end on card (remove river caught, [card, caught]) + else throwError "You can't choose that card" (Scored, KoiKoi keepOn) -> (if keepOn then Turn.next else Round.next) on - (_, _) -> raise "You can't play this move in that state" + (_, _) -> throwError "You can't play this move in that state" where canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2 -new :: Ord player => [player] -> Mode -> IO (On player) +new :: (MonadIO m, Ord player) => [player] -> Mode -> m (On player) new playersList mode = do playing <- Player.random players Round.deal $ On_ { diff --git a/src/Hanafuda/KoiKoi/Game.hs b/src/Hanafuda/KoiKoi/Game.hs index 3f79ed2..eb01c4b 100644 --- a/src/Hanafuda/KoiKoi/Game.hs +++ b/src/Hanafuda/KoiKoi/Game.hs @@ -1,17 +1,24 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} module Hanafuda.KoiKoi.Game ( - Game(..) + Action(..) + , Game(..) + , Environment , Mode(..) , Move(..) , On(..) , Over(..) + , Source(..) , Step(..) , end - , raise , setPlayer , stop ) where +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Writer (MonadWriter) import Hanafuda (Card, Flower, Pack) import Hanafuda.Player (Players, Player, Scores, set) import Hanafuda.KoiKoi.Yaku (Score) @@ -19,6 +26,14 @@ import Hanafuda.KoiKoi.Yaku (Score) data Mode = FirstAt Int | WholeYear deriving (Show) data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool data Step = ToPlay | Turned Card | Scored deriving (Show) +data Source = Hand | Deck deriving (Show) +data Action = Action { + source :: Source + , played :: Card + , captures :: Maybe Card + } deriving (Show) + +type Environment m = (MonadIO m, MonadError String m, MonadWriter [Action] m) data On player = On_ { mode :: Mode @@ -37,16 +52,13 @@ data Over player = Over_ { finalScores :: Scores player } deriving (Show) -data Game player = Error String | Over (Over player) | On (On player) deriving (Show) +data Game player = Over (Over player) | On (On player) deriving (Show) setPlayer :: Ord player => On player -> Player player Score -> On player setPlayer on@(On_ {players, playing}) player = on {players = set playing player players} -end :: Ord player => On player -> IO (Game player) +end :: Monad m => On player -> m (Game player) end (On_ {scores}) = return . Over $ Over_ {finalScores = scores} -stop :: Ord player => On player -> IO (Game player) +stop :: Monad m => On player -> m (Game player) stop = return . On - -raise :: String -> IO (Game player) -raise = return . Error diff --git a/src/Hanafuda/KoiKoi/Round.hs b/src/Hanafuda/KoiKoi/Round.hs index 9f1c422..415ebc9 100644 --- a/src/Hanafuda/KoiKoi/Round.hs +++ b/src/Hanafuda/KoiKoi/Round.hs @@ -9,9 +9,10 @@ import Hanafuda.KoiKoi.Yaku (sumYakus) import Hanafuda.KoiKoi.Game (Game, Mode(..), On(..), Step(..), end, stop) import qualified Hanafuda.Player as Player (deal, get, next, score) import Data.Map ((!), insert) +import Control.Monad.IO.Class (MonadIO) import Control.Monad.State (replicateM, runState, state) -deal :: Ord player => On player -> IO (On player) +deal :: (MonadIO m, Ord player) => On player -> m (On player) deal on@(On_ {players}) = do ([hand1, hand2, river], deck) <- fmap (runState (replicateM 3 take8)) $ shuffle cards return on { @@ -22,7 +23,7 @@ deal on@(On_ {players}) = do where take8 = state $ splitAt 8 -next :: Ord player => On player -> IO (Game player) +next :: (MonadIO m, Ord player) => On player -> m (Game player) next on@(On_ {mode, scores, month, players, oyake, winning}) = case mode of FirstAt n | n <= newScore -> end scored diff --git a/src/Hanafuda/KoiKoi/Turn.hs b/src/Hanafuda/KoiKoi/Turn.hs index 6e32eef..a9ffb53 100644 --- a/src/Hanafuda/KoiKoi/Turn.hs +++ b/src/Hanafuda/KoiKoi/Turn.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} module Hanafuda.KoiKoi.Turn ( catch , end @@ -10,26 +11,40 @@ import Hanafuda (Card, Pack, empty, match) import Hanafuda.Player (Player(..), plays) import qualified Hanafuda.Player as Player (get, next) import Hanafuda.KoiKoi.Yaku (meldInto) -import Hanafuda.KoiKoi.Game (Game, On(..), Step(..), raise, setPlayer, stop) +import Hanafuda.KoiKoi.Game (Action(..), Environment, Game, On(..), Source(..), Step(..), setPlayer, stop) import qualified Hanafuda.KoiKoi.Round as Round (next) +import Control.Monad.Except (MonadError(..)) +import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (runReader) +import Control.Monad.Writer (MonadWriter(..)) +import Prelude hiding (log) -catch :: Ord player => On player -> Card -> (Pack, [Card]) -> IO (Game player) -catch on@(On_ {players, playing}) card (river, trick) = - either raise (popNextCard . setPlayer (on {river, trick})) played +log :: MonadWriter [Action] m => Source -> Card -> [Card] -> m () +log source played cards = tell [ + Action { source, played, captures = captures cards } + ] + where + captures [_, captured] = Just captured + captures _ = Nothing + +catch :: (Environment m, Ord player) => On player -> Card -> (Pack, [Card]) -> m (Game player) +catch on@(On_ {players, playing}) card (river, trick) = do + log Hand card trick + (setPlayer (on {river, trick})) <$> played >>= popNextCard where played = (Player.get playing players) `plays` card -popNextCard :: Ord player => On player -> IO (Game player) -popNextCard (On_ {deck = []}) = raise "No more cards in the stack" +popNextCard :: (Environment m, Ord player) => On player -> m (Game player) +popNextCard (On_ {deck = []}) = throwError "No more cards in the stack" popNextCard on@(On_ {river, deck = turned : others}) = let pop = on {deck = others} in case match turned river of - Right (newRiver, newCaptured) -> end pop (newRiver, newCaptured) + Right (newRiver, newCaptured) -> end pop turned (newRiver, newCaptured) Left _ -> stop $ pop {step = Turned turned} -end :: Ord player => On player -> (Pack, [Card]) -> IO (Game player) -end on@(On_ {month, trick, playing, players}) (river, newCaptured) = do +end :: (MonadWriter [Action] m, MonadIO m, Ord player) => On player -> Card -> (Pack, [Card]) -> m (Game player) +end on@(On_ {month, trick, playing, players}) card (river, newCaptured) = do + log Deck card newCaptured let updatedGame = setPlayer (on {river, trick = []}) updatedPlayer if null scored then next updatedGame @@ -40,7 +55,7 @@ end on@(On_ {month, trick, playing, players}) (river, newCaptured) = do (scored, newMeld) = runReader (newTrick `meldInto` (meld player)) month updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)} -next :: Ord player => On player -> IO (Game player) +next :: (MonadIO m, Ord player) => On player -> m (Game player) next on@(On_ {players, playing}) = let newPlaying = Player.next players playing in if hand (Player.get newPlaying players) == empty