78 lines
2.8 KiB
Haskell
78 lines
2.8 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Hanafuda.Player where
|
|
|
|
import Hanafuda (Card, Pack, contains, packOfCards, remove)
|
|
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 ID yakus = Hanafuda.ID (Player yakus)
|
|
data Player yakus = Player {
|
|
hand :: Pack
|
|
, meld :: Pack
|
|
, nextPlayer :: ID yakus
|
|
, yakus :: yakus
|
|
} deriving (Show)
|
|
newtype Players yakus = Players (Map (ID yakus) (Player yakus)) deriving (Show)
|
|
|
|
new :: Monoid yakus => (ID yakus) -> Player yakus
|
|
new nextPlayer = Player {
|
|
hand = packOfCards []
|
|
, meld = packOfCards []
|
|
, nextPlayer
|
|
, yakus = mempty
|
|
}
|
|
|
|
players :: Monoid yakus => [ID yakus] -> Players yakus
|
|
players [] = Players empty
|
|
players [player] = Players $ singleton player $ new player
|
|
players (alice:others@(bob:_)) =
|
|
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 -> (ID yakus) -> (ID yakus)
|
|
next (Players playersByID) = nextPlayer . (playersByID !)
|
|
|
|
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 $ snd $ foldl dealTo (fst $ findMin playersByID, playersByID) hands
|
|
where
|
|
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 =
|
|
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) = fromList . zip (keys playersByKey)
|