lib/src/Hanafuda/Player.hs

{-# LANGUAGE NamedFieldPuns #-}
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 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 :: Players key yakus -> IO key
random (Players playersByKey) =
  fst . ($ playersByKey) . elemAt <$> 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 :: Player key yakus -> Card -> Either String (Player key yakus)
plays player@(Player {hand}) card =
  if hand `contains` card
    then Right $ player {hand = remove hand card}
    else Left "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)