diff --git a/hanafuda.cabal b/hanafuda.cabal index 7b54aa9..6324aa6 100644 --- a/hanafuda.cabal +++ b/hanafuda.cabal @@ -31,6 +31,7 @@ library exposed-modules: Hanafuda , Hanafuda.KoiKoi , Hanafuda.Player + , Hanafuda.Key other-modules: Hanafuda.KoiKoi.Game , Hanafuda.KoiKoi.Round , Hanafuda.KoiKoi.Turn diff --git a/src/Hanafuda/Key.hs b/src/Hanafuda/Key.hs new file mode 100644 index 0000000..7154c3a --- /dev/null +++ b/src/Hanafuda/Key.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hanafuda.Key ( + Key(..) + , getKey + ) where + +newtype Key a = Key Int deriving (Eq, Ord, Enum, Read, Show) + +getKey :: Key a -> String +getKey (Key n) = show n diff --git a/src/Hanafuda/KoiKoi.hs b/src/Hanafuda/KoiKoi.hs index 07749b3..02760cb 100644 --- a/src/Hanafuda/KoiKoi.hs +++ b/src/Hanafuda/KoiKoi.hs @@ -5,8 +5,10 @@ module Hanafuda.KoiKoi ( , Card(..) , Game(..) , Environment + , GameKey , Mode(..) , Move(..) + , PlayerKey , Score , Source(..) , Step(..) @@ -18,13 +20,16 @@ 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 (Action(..), Environment, Game(..), Mode(..), Move(..), Source(..), Step(..)) +import Hanafuda.KoiKoi.Game ( + Action(..), Environment, Game(..), GameKey, Mode(..), Move(..), PlayerKey + , 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 :: (Environment m, Ord player) => Move -> Game player -> m (Game player) +play :: Environment m => Move -> Game -> m Game play move game@(Game {river, step}) = case (step, move) of (ToPlay, Play card) -> @@ -43,7 +48,7 @@ play move game@(Game {river, step}) = where canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2 -new :: (MonadIO m, Ord player) => [player] -> Mode -> m (Game player) +new :: MonadIO m => [PlayerKey] -> Mode -> m Game new playersList mode = do playing <- Player.random players Round.deal $ Game { diff --git a/src/Hanafuda/KoiKoi/Game.hs b/src/Hanafuda/KoiKoi/Game.hs index 2b0a03b..8866030 100644 --- a/src/Hanafuda/KoiKoi/Game.hs +++ b/src/Hanafuda/KoiKoi/Game.hs @@ -5,8 +5,11 @@ module Hanafuda.KoiKoi.Game ( Action(..) , Game(..) , Environment + , GameKey + , Key , Mode(..) , Move(..) + , PlayerKey , Source(..) , Step(..) , end @@ -17,8 +20,10 @@ import Control.Monad.Except (MonadError) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Writer (MonadWriter) import Hanafuda (Card, Flower, Pack) +import Hanafuda.Key (Key) +import qualified Hanafuda.KoiKoi.Yaku as KoiKoi (Score) import Hanafuda.Player (Players, Player, Scores, set) -import Hanafuda.KoiKoi.Yaku (Score) +import qualified Hanafuda.Player as Player (Key) data Mode = FirstAt Int | WholeYear deriving (Show) data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool @@ -31,24 +36,26 @@ data Action = Action { } deriving (Show) type Environment m = (MonadIO m, MonadError String m, MonadWriter [Action] m) +type PlayerKey = Player.Key KoiKoi.Score +type GameKey = Key Game -data Game player = Game { +data Game = Game { mode :: Mode - , scores :: Scores player + , scores :: Scores KoiKoi.Score , month :: Flower - , players :: Players player Score - , playing :: player - , winning :: player - , oyake :: player + , players :: Players KoiKoi.Score + , playing :: PlayerKey + , winning :: PlayerKey + , oyake :: PlayerKey , deck :: [Card] , river :: Pack , step :: Step , trick :: [Card] - , rounds :: [(player, Score)] + , rounds :: [(PlayerKey, KoiKoi.Score)] } deriving (Show) -setPlayer :: Ord player => Game player -> Player player Score -> Game player +setPlayer :: Game -> Player KoiKoi.Score -> Game setPlayer game@(Game {players, playing}) player = game {players = set playing player players} -end :: Monad m => Game player -> m (Game player) +end :: Monad m => Game -> m Game end game = return $ game {step = Over} diff --git a/src/Hanafuda/KoiKoi/Round.hs b/src/Hanafuda/KoiKoi/Round.hs index 0d453d2..b898987 100644 --- a/src/Hanafuda/KoiKoi/Round.hs +++ b/src/Hanafuda/KoiKoi/Round.hs @@ -12,7 +12,7 @@ import Data.Map ((!), insert) import Control.Monad.IO.Class (MonadIO) import Control.Monad.State (runState, state) -deal :: (MonadIO m, Ord player) => Game player -> m (Game player) +deal :: MonadIO m => Game -> m Game deal game@(Game {players}) = do ((hand1, hand2, river), deck) <- runState getTriple <$> shuffle cards return game { @@ -24,7 +24,7 @@ deal game@(Game {players}) = do take8 = state $ splitAt 8 getTriple = (,,) <$> take8 <*> take8 <*> take8 -next :: (MonadIO m, Ord player) => Game player -> m (Game player) +next :: MonadIO m => Game -> m Game next game@(Game {mode, scores, month, players, oyake, winning, rounds}) = case mode of FirstAt n | n <= newScore -> end scored diff --git a/src/Hanafuda/KoiKoi/Turn.hs b/src/Hanafuda/KoiKoi/Turn.hs index aba4873..7192bc7 100644 --- a/src/Hanafuda/KoiKoi/Turn.hs +++ b/src/Hanafuda/KoiKoi/Turn.hs @@ -27,14 +27,14 @@ log source played cards = tell [ captures [_, captured] = Just captured captures _ = Nothing -catch :: (Environment m, Ord player) => Game player -> Card -> (Pack, [Card]) -> m (Game player) +catch :: Environment m => Game -> Card -> (Pack, [Card]) -> m Game catch game@(Game {players, playing}) card (river, trick) = do log Hand card trick (setPlayer (game {river, trick})) <$> played >>= popNextCard where played = (Player.get playing players) `plays` card -popNextCard :: (Environment m, Ord player) => Game player -> m (Game player) +popNextCard :: Environment m => Game -> m Game popNextCard (Game {deck = []}) = throwError "No more cards in the stack" popNextCard game@(Game {river, deck = turned : others}) = let pop = game {deck = others} in @@ -42,7 +42,7 @@ popNextCard game@(Game {river, deck = turned : others}) = Right (newRiver, newCaptured) -> end pop turned (newRiver, newCaptured) Left _ -> return $ pop {step = Turned turned} -end :: (MonadWriter [Action] m, MonadIO m, Ord player) => Game player -> Card -> (Pack, [Card]) -> m (Game player) +end :: (MonadWriter [Action] m, MonadIO m) => Game -> Card -> (Pack, [Card]) -> m Game end game@(Game {month, trick, playing, players}) card (river, newCaptured) = do log Deck card newCaptured let updatedGame = setPlayer (game {river, trick = []}) updatedPlayer @@ -55,7 +55,7 @@ end game@(Game {month, trick, playing, players}) card (river, newCaptured) = do (scored, newMeld) = runReader (newTrick `meldInto` (meld player)) month updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)} -next :: (MonadIO m, Ord player) => Game player -> m (Game player) +next :: MonadIO m => Game -> m Game next game@(Game {players, playing}) = let newPlaying = Player.next players playing in if hand (Player.get newPlaying players) == empty diff --git a/src/Hanafuda/Player.hs b/src/Hanafuda/Player.hs index 1744a78..cfcfc43 100644 --- a/src/Hanafuda/Player.hs +++ b/src/Hanafuda/Player.hs @@ -3,21 +3,23 @@ module Hanafuda.Player where import Hanafuda (Card, Pack, contains, packOfCards, remove) +import qualified Hanafuda.Key as Hanafuda (Key) import Data.Map ((!), Map, adjust, elemAt, empty, findMin, fromList, insert, keys, singleton, size) import qualified Data.Map as Map (filter) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Except (MonadError(..)) import System.Random (Random(..)) -data Player key yakus = Player { +type Key yakus = Hanafuda.Key (Player yakus) +data Player yakus = Player { hand :: Pack , meld :: Pack - , nextPlayer :: key + , nextPlayer :: Key yakus , yakus :: yakus } deriving (Show) -newtype Players key yakus = Players (Map key (Player key yakus)) deriving (Show) +newtype Players yakus = Players (Map (Key yakus) (Player yakus)) deriving (Show) -new :: Monoid yakus => key -> Player key yakus +new :: Monoid yakus => (Key yakus) -> Player yakus new nextPlayer = Player { hand = packOfCards [] , meld = packOfCards [] @@ -25,7 +27,7 @@ new nextPlayer = Player { , yakus = mempty } -players :: (Ord key, Monoid yakus) => [key] -> Players key yakus +players :: Monoid yakus => [Key yakus] -> Players yakus players [] = Players empty players [player] = Players $ singleton player $ new player players (alice:others@(bob:_)) = @@ -35,39 +37,39 @@ players (alice:others@(bob:_)) = where setNextPlayer nextPlayer player = player {nextPlayer} -next :: Ord key => Players key yakus -> key -> key +next :: Players yakus -> (Key yakus) -> (Key yakus) next (Players playersByKey) = nextPlayer . (playersByKey !) -random :: MonadIO m => Players key yakus -> m key +random :: MonadIO m => Players yakus -> m (Key yakus) random (Players playersByKey) = fst . ($ playersByKey) . elemAt <$> randomIndex where randomIndex = liftIO $ randomRIO (0, size playersByKey - 1) -get :: Ord key => key -> Players key yakus -> Player key yakus +get :: (Key yakus) -> Players yakus -> Player yakus get key (Players playersByKey) = playersByKey ! key -set :: Ord key => key -> Player key yakus -> Players key yakus -> Players key yakus +set :: (Key yakus) -> Player yakus -> Players yakus -> Players yakus set key player (Players playersByKey) = Players $ insert key player playersByKey -deal :: (Ord key, Monoid yakus) => Players key yakus -> [[Card]] -> Players key yakus +deal :: Monoid yakus => Players yakus -> [[Card]] -> Players yakus deal (Players playersByKey) hands = Players $ snd $ foldl dealTo (fst $ findMin playersByKey, playersByKey) hands where setHand cards (Player {nextPlayer}) = (new nextPlayer) {hand = packOfCards cards} dealTo (key, m) hand = (nextPlayer $ m ! key, adjust (setHand hand) key m) -plays :: MonadError String m => Player key yakus -> Card -> m (Player key yakus) +plays :: MonadError String m => Player yakus -> Card -> m (Player yakus) plays player@(Player {hand}) card = if hand `contains` card then return $ player {hand = remove hand card} else throwError "You don't have this card" type Points = Int -type Scores key = Map key Points +type Scores yakus = Map (Key yakus) Points -score :: (yakus -> Points) -> Player key yakus -> Points +score :: (yakus -> Points) -> Player yakus -> Points score rater = rater . yakus -scores :: Ord key => Players key yakus -> [Points] -> Scores key +scores :: Players yakus -> [Points] -> Scores yakus scores (Players playersByKey) = fromList . zip (keys playersByKey)