lib/src/Hanafuda/KoiKoi/Turn.hs

{-# LANGUAGE NamedFieldPuns #-}
module Hanafuda.KoiKoi.Turn (
      catch
    , end
    , next
    , popNextCard
  ) where

import Hanafuda (Card, Pack, empty, match)
import Hanafuda.Player (Player(..), plays)
import qualified Hanafuda.Player as Player (next)
import Hanafuda.KoiKoi.Yaku (meldInto)
import Hanafuda.KoiKoi.Game (Game, On(..), Step(..), raise, setPlayer, stop)
import qualified Hanafuda.KoiKoi.Round as Round (next)
import Data.Map ((!))
import Control.Monad.Reader (runReader)

catch :: On -> Card -> (Pack, [Card]) -> IO Game
catch on@(On_ {players, playing}) card (river, trick) =
  either raise (popNextCard . setPlayer (on {river, trick})) played
  where
    played = (players ! playing) `plays` card

popNextCard :: On -> IO Game
popNextCard (On_ {stock = []}) = raise "No more cards in the stack"
popNextCard on@(On_ {river, stock = turned : others}) =
  let pop = on {stock = others} in
  case match turned river of
    Right (newRiver, newCaptured) -> end pop (newRiver, newCaptured)
    Left _ -> stop $ pop {step = Turned turned}

end :: On -> (Pack, [Card]) -> IO Game
end on@(On_ {month, trick, playing, players}) (river, newCaptured) = do
  let updatedGame = setPlayer (on {river, trick = []}) updatedPlayer
  if null scored
    then next updatedGame
    else stop $ updatedGame {step = Scored, winning = playing}
  where
    newTrick = newCaptured ++ trick
    player = players ! playing
    (scored, newMeld) = runReader (newTrick `meldInto` (meld player)) month
    updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)}

next :: On -> IO Game
next on@(On_ {players, playing}) =
  let newPlaying = Player.next playing in
  if hand (players ! newPlaying) == empty
    then Round.next $ on
    else stop $ on {playing = newPlaying, step = ToPlay}