diff --git a/hanafuda.cabal b/hanafuda.cabal index 6324aa6..ef75648 100644 --- a/hanafuda.cabal +++ b/hanafuda.cabal @@ -31,7 +31,7 @@ library exposed-modules: Hanafuda , Hanafuda.KoiKoi , Hanafuda.Player - , Hanafuda.Key + , Hanafuda.ID other-modules: Hanafuda.KoiKoi.Game , Hanafuda.KoiKoi.Round , Hanafuda.KoiKoi.Turn diff --git a/src/Hanafuda/ID.hs b/src/Hanafuda/ID.hs new file mode 100644 index 0000000..d9bb031 --- /dev/null +++ b/src/Hanafuda/ID.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hanafuda.ID ( + ID(..) + , getID + ) where + +newtype ID a = ID Int deriving (Eq, Ord, Enum, Read, Show) + +getID :: ID a -> String +getID (ID n) = show n diff --git a/src/Hanafuda/Key.hs b/src/Hanafuda/Key.hs deleted file mode 100644 index 7154c3a..0000000 --- a/src/Hanafuda/Key.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# 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 eadbb5a..9f4f42c 100644 --- a/src/Hanafuda/KoiKoi.hs +++ b/src/Hanafuda/KoiKoi.hs @@ -6,10 +6,10 @@ module Hanafuda.KoiKoi ( , Environment , Game , GameBlueprint(..) - , GameKey + , GameID , Mode(..) , Move(..) - , PlayerKey + , PlayerID , Score , Source(..) , Step(..) @@ -22,7 +22,7 @@ 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, GameBlueprint(..), GameKey, Mode(..), Move(..), PlayerKey + Action(..), Environment, Game, GameBlueprint(..), GameID, Mode(..), Move(..), PlayerID , Source(..), Step(..) ) import qualified Hanafuda.KoiKoi.Round as Round (deal, next) @@ -49,7 +49,7 @@ play move game@(Game {river, step}) = where canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2 -new :: MonadIO m => [PlayerKey] -> Mode -> m Game +new :: MonadIO m => [PlayerID] -> 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 1341330..3f45905 100644 --- a/src/Hanafuda/KoiKoi/Game.hs +++ b/src/Hanafuda/KoiKoi/Game.hs @@ -6,11 +6,11 @@ module Hanafuda.KoiKoi.Game ( , Environment , Game , GameBlueprint(..) - , GameKey - , Key + , GameID + , ID , Mode(..) , Move(..) - , PlayerKey + , PlayerID , Source(..) , Step(..) , end @@ -21,10 +21,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 Hanafuda.ID (ID) import qualified Hanafuda.KoiKoi.Yaku as KoiKoi (Score) import Hanafuda.Player (Players, Player, Scores, set) -import qualified Hanafuda.Player as Player (Key) +import qualified Hanafuda.Player as Player (ID) data Mode = FirstAt Int | WholeYear deriving (Show) data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool @@ -37,22 +37,22 @@ 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 +type PlayerID = Player.ID KoiKoi.Score +type GameID = ID Game data GameBlueprint deckType = Game { mode :: Mode , scores :: Scores KoiKoi.Score , month :: Flower , players :: Players KoiKoi.Score - , playing :: PlayerKey - , winning :: PlayerKey - , oyake :: PlayerKey + , playing :: PlayerID + , winning :: PlayerID + , oyake :: PlayerID , deck :: deckType , river :: Pack , step :: Step , trick :: [Card] - , rounds :: [(PlayerKey, KoiKoi.Score)] + , rounds :: [(PlayerID, KoiKoi.Score)] } deriving (Show) type Game = GameBlueprint [Card] diff --git a/src/Hanafuda/Player.hs b/src/Hanafuda/Player.hs index cfcfc43..779f05f 100644 --- a/src/Hanafuda/Player.hs +++ b/src/Hanafuda/Player.hs @@ -3,23 +3,23 @@ module Hanafuda.Player where import Hanafuda (Card, Pack, contains, packOfCards, remove) -import qualified Hanafuda.Key as Hanafuda (Key) +import qualified Hanafuda.ID as Hanafuda (ID) 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(..)) -type Key yakus = Hanafuda.Key (Player yakus) +type ID yakus = Hanafuda.ID (Player yakus) data Player yakus = Player { hand :: Pack , meld :: Pack - , nextPlayer :: Key yakus + , nextPlayer :: ID yakus , yakus :: yakus } deriving (Show) -newtype Players yakus = Players (Map (Key yakus) (Player yakus)) deriving (Show) +newtype Players yakus = Players (Map (ID yakus) (Player yakus)) deriving (Show) -new :: Monoid yakus => (Key yakus) -> Player yakus +new :: Monoid yakus => (ID yakus) -> Player yakus new nextPlayer = Player { hand = packOfCards [] , meld = packOfCards [] @@ -27,37 +27,39 @@ new nextPlayer = Player { , yakus = mempty } -players :: Monoid yakus => [Key yakus] -> Players yakus +players :: Monoid yakus => [ID yakus] -> Players yakus players [] = Players empty players [player] = Players $ singleton player $ new player players (alice:others@(bob:_)) = - let Players playersByKey = players others in - let (before, _) = findMin $ Map.filter ((== bob) . nextPlayer) playersByKey in - Players $ insert alice (new bob) $ adjust (setNextPlayer alice) before playersByKey + let Players playersByID = players others in + let (before, _) = findMin $ Map.filter ((== bob) . nextPlayer) playersByID in + Players $ insert alice (new bob) $ adjust (setNextPlayer alice) before playersByID where setNextPlayer nextPlayer player = player {nextPlayer} -next :: Players yakus -> (Key yakus) -> (Key yakus) -next (Players playersByKey) = nextPlayer . (playersByKey !) +next :: Players yakus -> (ID yakus) -> (ID yakus) +next (Players playersByID) = nextPlayer . (playersByID !) -random :: MonadIO m => Players yakus -> m (Key yakus) -random (Players playersByKey) = - fst . ($ playersByKey) . elemAt <$> randomIndex +random :: MonadIO m => Players yakus -> m (ID yakus) +random (Players playersByID) = + fst . ($ playersByID) . elemAt <$> randomIndex where - randomIndex = liftIO $ randomRIO (0, size playersByKey - 1) + randomIndex = liftIO $ randomRIO (0, size playersByID - 1) -get :: (Key yakus) -> Players yakus -> Player yakus -get key (Players playersByKey) = playersByKey ! key +get :: (ID yakus) -> Players yakus -> Player yakus +get playerID (Players playersByID) = playersByID ! playerID -set :: (Key yakus) -> Player yakus -> Players yakus -> Players yakus -set key player (Players playersByKey) = Players $ insert key player playersByKey +set :: (ID yakus) -> Player yakus -> Players yakus -> Players yakus +set playerID player (Players playersByID) = Players $ insert playerID player playersByID deal :: Monoid yakus => Players yakus -> [[Card]] -> Players yakus -deal (Players playersByKey) hands = - Players $ snd $ foldl dealTo (fst $ findMin playersByKey, playersByKey) hands +deal (Players playersByID) hands = + Players $ snd $ foldl dealTo (fst $ findMin playersByID, playersByID) hands where - setHand cards (Player {nextPlayer}) = (new nextPlayer) {hand = packOfCards cards} - dealTo (key, m) hand = (nextPlayer $ m ! key, adjust (setHand hand) key m) + setHand cards (Player {nextPlayer}) = + (new nextPlayer) {hand = packOfCards cards} + dealTo (playerID, m) hand = + (nextPlayer $ m ! playerID, adjust (setHand hand) playerID m) plays :: MonadError String m => Player yakus -> Card -> m (Player yakus) plays player@(Player {hand}) card = @@ -66,7 +68,7 @@ plays player@(Player {hand}) card = else throwError "You don't have this card" type Points = Int -type Scores yakus = Map (Key yakus) Points +type Scores yakus = Map (ID yakus) Points score :: (yakus -> Points) -> Player yakus -> Points score rater = rater . yakus