69 lines
2.1 KiB
Haskell
69 lines
2.1 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
module Hanafuda.KoiKoi.Round where
|
|
|
|
import Hanafuda (Card, Flower(Pine), cards, shuffle, packOfCards)
|
|
import Hanafuda.KoiKoi.Yaku (Score, sumYakus)
|
|
import Hanafuda.KoiKoi.Turn (Turn(..))
|
|
import qualified Hanafuda.KoiKoi.Turn as Turn (Step(Over), new, play)
|
|
import Hanafuda.Player (Move, Player, Players, deal)
|
|
import qualified Hanafuda.Player as Player (next, new, score)
|
|
import Data.Map ((!), empty, insert)
|
|
import Control.Monad.State (replicateM, runState, state)
|
|
|
|
data On = On {
|
|
flower :: Flower
|
|
, players :: Players Score
|
|
, turn :: Turn
|
|
, playing :: Player
|
|
, lastScored :: Player
|
|
, oyake :: Player
|
|
, stock :: [Card]
|
|
} deriving (Show)
|
|
data Over = Over {
|
|
winner :: Player
|
|
, score :: Int
|
|
}
|
|
|
|
newtype Round = Round (Either Over On)
|
|
|
|
go :: On -> Round
|
|
go = Round . Right
|
|
|
|
new :: Player -> IO On
|
|
new playing = do
|
|
([hand1, hand2, river], next:stock) <- fmap (runState (replicateM 3 take8)) $ shuffle cards
|
|
let players = fmap Player.new $ deal [hand1, hand2]
|
|
return On {
|
|
flower = Pine
|
|
, players
|
|
, turn = Turn.new (packOfCards river) (players ! playing) next
|
|
, playing
|
|
, lastScored = playing
|
|
, oyake = playing
|
|
, stock
|
|
}
|
|
where
|
|
take8 = state $ splitAt 8
|
|
|
|
next :: On -> IO On
|
|
next (On {flower, oyake}) = do
|
|
on <- new $ Player.next oyake
|
|
return $ on {flower = succ flower}
|
|
|
|
play :: On -> Move -> Either String Round
|
|
play on@(On {flower, turn, playing, players, stock = next : moreStock}) move =
|
|
fmap after $ Turn.play turn move
|
|
where
|
|
after (Turn {step = Turn.Over True, player}) =
|
|
Round . Left $ Over {winner = playing, score = Player.score sumYakus player}
|
|
after (Turn {step = Turn.Over False, player, river}) =
|
|
let otherPlayer = Player.next playing in
|
|
go $ on {
|
|
players = insert playing player players
|
|
, playing = otherPlayer
|
|
, turn = (Turn.new river (players ! otherPlayer) next) { month = flower }
|
|
, stock = moreStock
|
|
}
|
|
after newTurn = go $ on {turn = newTurn}
|