74 lines
2.7 KiB
Haskell
74 lines
2.7 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Hanafuda.Player where
|
|
|
|
import Hanafuda (Card, Pack, contains, packOfCards, remove)
|
|
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 {
|
|
hand :: Pack
|
|
, meld :: Pack
|
|
, nextPlayer :: key
|
|
, yakus :: yakus
|
|
} deriving (Show)
|
|
newtype Players key yakus = Players (Map key (Player key yakus)) deriving (Show)
|
|
|
|
new :: Monoid yakus => key -> Player key yakus
|
|
new nextPlayer = Player {
|
|
hand = packOfCards []
|
|
, meld = packOfCards []
|
|
, nextPlayer
|
|
, yakus = mempty
|
|
}
|
|
|
|
players :: (Ord key, Monoid yakus) => [key] -> Players key 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
|
|
where
|
|
setNextPlayer nextPlayer player = player {nextPlayer}
|
|
|
|
next :: Ord key => Players key yakus -> key -> key
|
|
next (Players playersByKey) = nextPlayer . (playersByKey !)
|
|
|
|
random :: MonadIO m => Players key yakus -> m key
|
|
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 (Players playersByKey) = playersByKey ! key
|
|
|
|
set :: Ord key => key -> Player key yakus -> Players key yakus -> Players key yakus
|
|
set key player (Players playersByKey) = Players $ insert key player playersByKey
|
|
|
|
deal :: (Ord key, Monoid yakus) => Players key yakus -> [[Card]] -> Players key 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 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
|
|
|
|
score :: (yakus -> Points) -> Player key yakus -> Points
|
|
score rater = rater . yakus
|
|
|
|
scores :: Ord key => Players key yakus -> [Points] -> Scores key
|
|
scores (Players playersByKey) = fromList . zip (keys playersByKey)
|