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