lib/src/Hanafuda/KoiKoi.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Hanafuda.KoiKoi (
      Action(..)
    , Card(..)
    , Game(..)
    , Environment
    , Mode(..)
    , Move(..)
    , Score
    , Source(..)
    , Step(..)
    , Yaku(..)
    , new
    , play
  ) where

import Hanafuda (Card(..), Flower(Pine), contains, flower, match, remove)
import qualified Hanafuda.Player as Player (players, random, scores)
import Hanafuda.KoiKoi.Yaku (Yaku(..), Score)
import Hanafuda.KoiKoi.Game (Action(..), Environment, Game(..), Mode(..), Move(..), Source(..), Step(..))
import qualified Hanafuda.KoiKoi.Round as Round (deal, next)
import qualified Hanafuda.KoiKoi.Turn as Turn (catch, end, next)
import Control.Monad.Except (MonadError(..))
import Control.Monad.IO.Class (MonadIO)

play :: (Environment m, Ord player) => Move -> Game player -> m (Game player)
play move game@(Game {river, step}) =
  case (step, move) of
    (ToPlay, Play card) ->
      either throwError (Turn.catch game card) $ match card river
    (ToPlay, Capture (card, caught)) ->
      if card `canCatch` caught
        then Turn.catch game card (remove river caught, [card, caught])
        else throwError "You can't choose that card"
    (Turned card, Choose caught) ->
      if card `canCatch` caught
        then Turn.end game card (remove river caught, [card, caught])
        else throwError "You can't choose that card"
    (Scored, KoiKoi keepGame) -> (if keepGame then Turn.next else Round.next) game
    (Over, _) -> throwError "This game is over"
    (_, _) -> throwError "You can't play this move in that state"
  where
    canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2

new :: (MonadIO m, Ord player) => [player] -> Mode -> m (Game player)
new playersList mode = do
  playing <- Player.random players
  Round.deal $ Game {
        mode
      , scores = Player.scores players [0, 0]
      , month = Pine
      , players
      , playing
      , winning = playing
      , oyake = playing
      , deck = undefined
      , river = undefined
      , step = ToPlay
      , trick = []
      , rounds = []
    }
  where
    players = Player.players playersList