65 lines
2.2 KiB
Haskell
65 lines
2.2 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
module Hanafuda.Day where
|
|
|
|
import Hanafuda.Card (Card, Pack, Flower(Pine), contains, flower, pair, remove)
|
|
import Hanafuda.Yaku (rate)
|
|
import Hanafuda.Game (Game(..), Move(..), PlayerState(..), plays)
|
|
import Data.Map (union)
|
|
import Control.Monad.Reader (runReader)
|
|
|
|
data Step = ToPlay | Turned Card | Scored | Over Bool
|
|
|
|
data Day = Day {
|
|
river :: Pack
|
|
, month :: Flower
|
|
, player :: PlayerState
|
|
, next :: Card
|
|
, step :: Step
|
|
, trick :: [Card]
|
|
}
|
|
|
|
new :: Pack -> PlayerState -> Card -> Day
|
|
new river player next = Day {
|
|
river
|
|
, month = Pine
|
|
, player
|
|
, next
|
|
, step = ToPlay
|
|
, trick = []
|
|
}
|
|
|
|
instance Game Day Day where
|
|
play day@(Day {river, step, next, trick, player}) move =
|
|
case (step, move) of
|
|
(ToPlay, Play card) -> pair 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 $ day {river = remove river caught, trick = [card, caught] ++ trick}
|
|
else Left "You can't choose that card"
|
|
(Scored, KoiKoi win) -> Right $ day {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 $ day {river, trick, player = played}
|
|
|
|
turnOver :: Day -> Either String Day
|
|
turnOver day@(Day {river, next, trick}) =
|
|
case pair next river of
|
|
Right (newRiver, newCaptured) -> end $ day {river = newRiver, trick = trick ++ newCaptured}
|
|
Left _ -> Right $ day {step = Turned next}
|
|
|
|
end :: Day -> Either String Day
|
|
end day@(Day {month, trick, player}) =
|
|
let (scored, newMeld) = runReader (rate (meld player) trick) month in
|
|
let updatedPlayer = day {player = player {meld = newMeld, yakus = scored `union` (yakus player)}} in
|
|
Right $ if null scored
|
|
then updatedPlayer {step = Over False}
|
|
else updatedPlayer {step = Scored}
|