lib/src/Hanafuda/KoiKoi/Turn.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
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 (Action(..), Environment, Game, GameBlueprint(..), Source(..), Step(..), setPlayer)
import qualified Hanafuda.KoiKoi.Round as Round (next)
import Control.Monad.Except (MonadError(..))
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (runReader)
import Control.Monad.Writer (MonadWriter(..))
import Prelude hiding (log)

log :: MonadWriter [Action] m => Source -> Card -> [Card] -> m ()
log source played cards = tell [
    Action { source, played, captures = captures cards }
  ]
  where
    captures [_, captured] = Just captured
    captures _ = Nothing

catch :: Environment m => Game -> Card -> (Pack, [Card]) -> m Game
catch game@(Game {players, playing}) card (river, trick) = do
  log Hand card trick
  (setPlayer (game {river, trick})) <$> played >>= popNextCard
  where
    played = (Player.get playing players) `plays` card

popNextCard :: Environment m => Game -> m Game
popNextCard (Game {deck = []}) = throwError "No more cards in the stack"
popNextCard game@(Game {river, deck = turned : others}) =
  let pop = game {deck = others} in
  case match turned river of
    Right (newRiver, newCaptured) -> end pop turned (newRiver, newCaptured)
    Left _ -> return $ pop {step = Turned turned}

end :: (MonadWriter [Action] m, MonadIO m) => Game -> Card -> (Pack, [Card]) -> m Game
end game@(Game {month, trick, playing, players}) card (river, newCaptured) = do
  log Deck card newCaptured
  let updatedGame = setPlayer (game {river, trick = []}) updatedPlayer
  if null scored
    then next updatedGame
    else return $ 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 :: MonadIO m => Game -> m Game
next game@(Game {players, playing}) =
  let newPlaying = Player.next players playing in
  if hand (Player.get newPlaying players) == empty
    then Round.next $ game
    else return $ game {playing = newPlaying, step = ToPlay}