64 lines
2.4 KiB
Haskell
64 lines
2.4 KiB
Haskell
{-# 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}
|