{-# 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)