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 (get, 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 Control.Monad.Reader (runReader)

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

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

end :: Ord player => On player -> (Pack, [Card]) -> IO (Game player)
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 = Player.get playing players
    (scored, newMeld) = runReader (newTrick `meldInto` (meld player)) month
    updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)}

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