2018-03-15 22:32:24 +01:00
|
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
2019-01-08 22:37:09 +01:00
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE ConstraintKinds #-}
|
2018-03-15 22:32:24 +01:00
|
|
|
module Hanafuda.KoiKoi.Game (
|
2019-01-08 22:37:09 +01:00
|
|
|
Action(..)
|
|
|
|
, Game(..)
|
|
|
|
, Environment
|
2018-03-15 22:32:24 +01:00
|
|
|
, Mode(..)
|
|
|
|
, Move(..)
|
|
|
|
, On(..)
|
|
|
|
, Over(..)
|
2019-01-08 22:37:09 +01:00
|
|
|
, Source(..)
|
2018-03-15 22:32:24 +01:00
|
|
|
, Step(..)
|
|
|
|
, end
|
|
|
|
, setPlayer
|
|
|
|
, stop
|
|
|
|
) where
|
|
|
|
|
2019-01-08 22:37:09 +01:00
|
|
|
import Control.Monad.Except (MonadError)
|
|
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
|
|
import Control.Monad.Writer (MonadWriter)
|
2018-03-15 22:32:24 +01:00
|
|
|
import Hanafuda (Card, Flower, Pack)
|
2018-07-24 22:19:04 +02:00
|
|
|
import Hanafuda.Player (Players, Player, Scores, set)
|
2018-03-15 22:32:24 +01:00
|
|
|
import Hanafuda.KoiKoi.Yaku (Score)
|
|
|
|
|
|
|
|
data Mode = FirstAt Int | WholeYear deriving (Show)
|
|
|
|
data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
|
|
|
|
data Step = ToPlay | Turned Card | Scored deriving (Show)
|
2019-01-08 22:37:09 +01:00
|
|
|
data Source = Hand | Deck deriving (Show)
|
|
|
|
data Action = Action {
|
|
|
|
source :: Source
|
|
|
|
, played :: Card
|
|
|
|
, captures :: Maybe Card
|
|
|
|
} deriving (Show)
|
|
|
|
|
|
|
|
type Environment m = (MonadIO m, MonadError String m, MonadWriter [Action] m)
|
2018-03-15 22:32:24 +01:00
|
|
|
|
2018-07-24 22:19:04 +02:00
|
|
|
data On player = On_ {
|
2018-03-15 22:32:24 +01:00
|
|
|
mode :: Mode
|
2018-07-24 22:19:04 +02:00
|
|
|
, scores :: Scores player
|
2018-03-15 22:32:24 +01:00
|
|
|
, month :: Flower
|
2018-07-24 22:19:04 +02:00
|
|
|
, players :: Players player Score
|
|
|
|
, playing :: player
|
|
|
|
, winning :: player
|
|
|
|
, oyake :: player
|
|
|
|
, deck :: [Card]
|
2018-03-15 22:32:24 +01:00
|
|
|
, river :: Pack
|
|
|
|
, step :: Step
|
|
|
|
, trick :: [Card]
|
|
|
|
} deriving (Show)
|
2018-07-24 22:19:04 +02:00
|
|
|
data Over player = Over_ {
|
|
|
|
finalScores :: Scores player
|
2018-03-15 22:32:24 +01:00
|
|
|
} deriving (Show)
|
|
|
|
|
2019-01-08 22:37:09 +01:00
|
|
|
data Game player = Over (Over player) | On (On player) deriving (Show)
|
2018-03-15 22:32:24 +01:00
|
|
|
|
2018-07-24 22:19:04 +02:00
|
|
|
setPlayer :: Ord player => On player -> Player player Score -> On player
|
|
|
|
setPlayer on@(On_ {players, playing}) player = on {players = set playing player players}
|
2018-03-15 22:32:24 +01:00
|
|
|
|
2019-01-08 22:37:09 +01:00
|
|
|
end :: Monad m => On player -> m (Game player)
|
2018-03-15 22:32:24 +01:00
|
|
|
end (On_ {scores}) = return . Over $ Over_ {finalScores = scores}
|
|
|
|
|
2019-01-08 22:37:09 +01:00
|
|
|
stop :: Monad m => On player -> m (Game player)
|
2018-03-15 22:32:24 +01:00
|
|
|
stop = return . On
|