{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Hanafuda.Day where

import Hanafuda.Card (Card, Pack, Flower(Pine), contains, flower, pair, remove)
import Hanafuda.Yaku (rate)
import Hanafuda.Game (Game(..), Move(..), PlayerState(..), plays)
import Data.Map (union)
import Control.Monad.Reader (runReader)

data Step = ToPlay | Turned Card | Scored | Over Bool

data Day = Day {
      river :: Pack
    , month :: Flower
    , player :: PlayerState
    , next :: Card
    , step :: Step
    , trick :: [Card]
  }

new :: Pack -> PlayerState -> Card -> Day
new river player next = Day {
      river
    , month = Pine
    , player
    , next
    , step = ToPlay
    , trick = []
  }

instance Game Day Day where
  play day@(Day {river, step, next, trick, player}) move =
    case (step, move) of
      (ToPlay, Play card) -> pair card river >>= play card
      (ToPlay, Capture (card, caught)) ->
        if card `canCatch` caught
          then play card (remove river caught, [card, caught])
          else Left "You can't choose that card"
      (Turned card, Choose caught) ->
        if card `canCatch` caught
          then end $ day {river = remove river caught, trick = [card, caught] ++ trick}
          else Left "You can't choose that card"
      (Scored, KoiKoi win) -> Right $ day {step = Over win}
      (_, _) -> Left "You can't play this move in that state"
    where
      canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
      play card (river, trick) = do
        played <- player `plays` card
        turnOver $ day {river, trick, player = played}

turnOver :: Day -> Either String Day
turnOver day@(Day {river, next, trick}) =
  case pair next river of
    Right (newRiver, newCaptured) -> end $ day {river = newRiver, trick = trick ++ newCaptured}
    Left _ -> Right $ day {step = Turned next}

end :: Day -> Either String Day
end day@(Day {month, trick, player}) =
  let (scored, newMeld) = runReader (rate (meld player) trick) month in
  let updatedPlayer = day {player = player {meld = newMeld, yakus = scored `union` (yakus player)}} in
  Right $ if null scored
    then updatedPlayer {step = Over False}
    else updatedPlayer {step = Scored}