66 lines
2.2 KiB
Haskell
66 lines
2.2 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Hanafuda.Player where
|
|
|
|
import Hanafuda (Card, Pack, contains, packOfCards, remove)
|
|
import qualified Hanafuda.ID as Hanafuda (ID, IDType(..), Prefix(..))
|
|
import Data.Map ((!), Map, elemAt, insert, keys, size)
|
|
import qualified Data.Map as Map (fromList, keys)
|
|
import Control.Monad.IO.Class (MonadIO(..))
|
|
import Control.Monad.Except (MonadError(..))
|
|
import System.Random (Random(..))
|
|
|
|
type ID yakus = Hanafuda.ID (Player yakus)
|
|
instance Hanafuda.IDType (Player yakus) where
|
|
prefix = Hanafuda.Prefix "Player"
|
|
|
|
data Player yakus = Player {
|
|
hand :: Pack
|
|
, meld :: Pack
|
|
, yakus :: yakus
|
|
} deriving (Show)
|
|
newtype Players yakus = Players (Map (ID yakus) (Player yakus)) deriving (Show)
|
|
|
|
new :: Monoid yakus => [Card] -> Player yakus
|
|
new cards = Player {
|
|
hand = packOfCards cards
|
|
, meld = packOfCards []
|
|
, yakus = mempty
|
|
}
|
|
|
|
players :: Monoid yakus => [ID yakus] -> Players yakus
|
|
players = Players . Map.fromList . fmap (\playerID -> (playerID, new []))
|
|
|
|
random :: MonadIO m => Players yakus -> m (ID yakus)
|
|
random (Players playersByID) =
|
|
fst . ($ playersByID) . elemAt <$> randomIndex
|
|
where
|
|
randomIndex = liftIO $ randomRIO (0, size playersByID - 1)
|
|
|
|
get :: (ID yakus) -> Players yakus -> Player yakus
|
|
get playerID (Players playersByID) = playersByID ! playerID
|
|
|
|
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 playersByID) hands =
|
|
Players . Map.fromList . zipWith setHand hands $ Map.keys playersByID
|
|
where
|
|
setHand cards playerID = (playerID, new cards)
|
|
|
|
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 yakus = Map (ID yakus) Points
|
|
|
|
score :: (yakus -> Points) -> Player yakus -> Points
|
|
score rater = rater . yakus
|
|
|
|
scores :: Players yakus -> [Points] -> Scores yakus
|
|
scores (Players playersByKey) = Map.fromList . zip (keys playersByKey)
|