lib/src/Hanafuda/KoiKoi.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Hanafuda.KoiKoi (
      Action(..)
    , Card(..)
    , Game(..)
    , Environment
    , Mode(..)
    , Move(..)
    , On(..)
    , Over(..)
    , 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(..), On(..), Over(..), 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 -> On player -> m (Game player)
play move on@(On_ {river, step}) =
  case (step, move) of
    (ToPlay, Play card) ->
      either throwError (Turn.catch on card) $ match card river
    (ToPlay, Capture (card, caught)) ->
      if card `canCatch` caught
        then Turn.catch on 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 on card (remove river caught, [card, caught])
        else throwError "You can't choose that card"
    (Scored, KoiKoi keepOn) -> (if keepOn then Turn.next else Round.next) on
    (_, _) -> 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 (On player)
new playersList mode = do
  playing <- Player.random players
  Round.deal $ On_ {
        mode
      , scores = Player.scores players [0, 0]
      , month = Pine
      , players
      , playing
      , winning = playing
      , oyake = playing
      , deck = undefined
      , river = undefined
      , step = ToPlay
      , trick = []
    }
  where
    players = Player.players playersList