63 lines
2.2 KiB
Haskell
63 lines
2.2 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
module Hanafuda.Day where
|
|
|
|
import Hanafuda.Card (Card, Pack, Flower(Pine), contains, flower, packOfCards, pair, remove)
|
|
import Hanafuda.Yaku (rate)
|
|
import Hanafuda.Game (Game(..), Move(..), PlayerState, meld, yakus)
|
|
import Data.Map (Map, adjust, empty, fromList, insert, union, (!))
|
|
import Control.Monad.Reader (runReader)
|
|
|
|
data Step = ToPlay | ToChoose (Maybe 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}) move =
|
|
case (step, move) of
|
|
(ToPlay, Play card) ->
|
|
case pair card river of
|
|
Just (newRiver, newCaptured) -> turnOver $ day {river = newRiver, trick = newCaptured}
|
|
Nothing -> Right $ day {step = ToChoose (Just card)}
|
|
(ToChoose maybeCard, Choose caught) ->
|
|
let (continue, card) = maybe (end, next) ((,) turnOver) maybeCard in
|
|
if card `canCatch` caught
|
|
then turnOver $
|
|
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
|
|
|
|
turnOver :: Day -> Either String Day
|
|
turnOver day@(Day {river, next, trick}) =
|
|
case pair next river of
|
|
Just (newRiver, newCaptured) -> end $ day {river = newRiver, trick = trick ++ newCaptured}
|
|
Nothing -> Right $ day {step = ToChoose Nothing}
|
|
|
|
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}
|