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, On(..), Source(..), Step(..), setPlayer, stop)
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, Ord player) => On player -> Card -> (Pack, [Card]) -> m (Game player)
catch on@(On_ {players, playing}) card (river, trick) = do
  log Hand card trick
  (setPlayer (on {river, trick})) <$> played >>= popNextCard
  where
    played = (Player.get playing players) `plays` card

popNextCard :: (Environment m, Ord player) => On player -> m (Game player)
popNextCard (On_ {deck = []}) = throwError "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 turned (newRiver, newCaptured)
    Left _ -> stop $ pop {step = Turned turned}

end :: (MonadWriter [Action] m, MonadIO m, Ord player) => On player -> Card -> (Pack, [Card]) -> m (Game player)
end on@(On_ {month, trick, playing, players}) card (river, newCaptured) = do
  log Deck card newCaptured
  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 :: (MonadIO m, Ord player) => On player -> m (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}