65 lines
2.2 KiB
Haskell
65 lines
2.2 KiB
Haskell
|
{-# LANGUAGE NamedFieldPuns #-}
|
||
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||
|
|
module Hanafuda.KoiKoi.Turn where
|
||
|
|
|
||
|
|
import Hanafuda (Card, Pack, Flower(Pine), contains, flower, match, remove)
|
||
|
|
import Hanafuda.KoiKoi.Yaku (Score, meldInto)
|
||
|
|
import Hanafuda.Player (Move(..), State(..), plays)
|
||
|
|
import Control.Monad.Reader (runReader)
|
||
|
|
|
||
|
|
data Step = ToPlay | Turned Card | Scored | Over Bool deriving (Show)
|
||
|
|
type Player = State Score
|
||
|
|
|
||
|
|
data Turn = Turn {
|
||
|
|
river :: Pack
|
||
|
|
, month :: Flower
|
||
|
|
, player :: Player
|
||
|
|
, next :: Card
|
||
|
|
, step :: Step
|
||
|
|
, trick :: [Card]
|
||
|
|
} deriving (Show)
|
||
|
|
|
||
|
|
new :: Pack -> Player -> Card -> Turn
|
||
|
|
new river player next = Turn {
|
||
|
|
river
|
||
|
|
, month = Pine
|
||
|
|
, player
|
||
|
|
, next
|
||
|
|
, step = ToPlay
|
||
|
|
, trick = []
|
||
|
|
}
|
||
|
|
|
||
|
|
play :: Turn -> Move -> Either String Turn
|
||
|
|
play turn@(Turn {river, step, next, trick, player}) move =
|
||
|
|
case (step, move) of
|
||
|
|
(ToPlay, Play card) -> match card river >>= play card
|
||
|
|
(ToPlay, Capture (card, caught)) ->
|
||
|
|
if card `canCatch` caught
|
||
|
|
then play card (remove river caught, [card, caught])
|
||
|
|
else Left "You can't choose that card"
|
||
|
|
(Turned card, Choose caught) ->
|
||
|
|
if card `canCatch` caught
|
||
|
|
then end $ turn {river = remove river caught, trick = [card, caught] ++ trick}
|
||
|
|
else Left "You can't choose that card"
|
||
|
|
(Scored, KoiKoi win) -> Right $ turn {step = Over win}
|
||
|
|
(_, _) -> Left "You can't play this move in that state"
|
||
|
|
where
|
||
|
|
canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
|
||
|
|
play card (river, trick) = do
|
||
|
|
played <- player `plays` card
|
||
|
|
turnOver $ turn {river, trick, player = played}
|
||
|
|
|
||
|
|
turnOver :: Turn -> Either String Turn
|
||
|
|
turnOver turn@(Turn {river, next, trick}) =
|
||
|
|
case match next river of
|
||
|
|
Right (newRiver, newCaptured) -> end $ turn {river = newRiver, trick = trick ++ newCaptured}
|
||
|
|
Left _ -> Right $ turn {step = Turned next}
|
||
|
|
|
||
|
|
end :: Turn -> Either String Turn
|
||
|
|
end turn@(Turn {month, trick, player}) =
|
||
|
|
let (scored, newMeld) = runReader (trick `meldInto` (meld player)) month in
|
||
|
|
let updatedPlayer = turn {player = player {meld = newMeld, yakus = scored `mappend` (yakus player)}} in
|
||
|
|
Right $ if null scored
|
||
|
|
then updatedPlayer {step = Over False}
|
||
|
|
else updatedPlayer {step = Scored}
|