76 lines
2.7 KiB
Haskell
76 lines
2.7 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
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(..))
|
|
|
|
type Key yakus = Hanafuda.Key (Player yakus)
|
|
data Player yakus = Player {
|
|
hand :: Pack
|
|
, meld :: Pack
|
|
, nextPlayer :: Key yakus
|
|
, yakus :: yakus
|
|
} deriving (Show)
|
|
newtype Players yakus = Players (Map (Key yakus) (Player yakus)) deriving (Show)
|
|
|
|
new :: Monoid yakus => (Key yakus) -> Player yakus
|
|
new nextPlayer = Player {
|
|
hand = packOfCards []
|
|
, meld = packOfCards []
|
|
, nextPlayer
|
|
, yakus = mempty
|
|
}
|
|
|
|
players :: Monoid yakus => [Key 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
|
|
where
|
|
setNextPlayer nextPlayer player = player {nextPlayer}
|
|
|
|
next :: Players yakus -> (Key yakus) -> (Key yakus)
|
|
next (Players playersByKey) = nextPlayer . (playersByKey !)
|
|
|
|
random :: MonadIO m => Players yakus -> m (Key yakus)
|
|
random (Players playersByKey) =
|
|
fst . ($ playersByKey) . elemAt <$> randomIndex
|
|
where
|
|
randomIndex = liftIO $ randomRIO (0, size playersByKey - 1)
|
|
|
|
get :: (Key yakus) -> Players yakus -> Player yakus
|
|
get key (Players playersByKey) = playersByKey ! key
|
|
|
|
set :: (Key yakus) -> Player yakus -> Players yakus -> Players yakus
|
|
set key player (Players playersByKey) = Players $ insert key player playersByKey
|
|
|
|
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 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 (Key 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)
|