67 lines
2.0 KiB
Haskell
67 lines
2.0 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
module Hanafuda.Month where
|
|
|
|
import Hanafuda.Card (Card, Flower(Pine), cards, shuffle, packOfCards)
|
|
import Hanafuda.Day (Day(..))
|
|
import qualified Hanafuda.Day as Day (Step(Over), next, new)
|
|
import Hanafuda.Game (Game(..), Move, Player, Players, PlayerState(..), initPlayers)
|
|
import qualified Hanafuda.Game as Game (next)
|
|
import Data.Map ((!), insert)
|
|
import Control.Monad.State (replicateM, runState, state)
|
|
|
|
data On = On {
|
|
flower :: Flower
|
|
, players :: Players
|
|
, day :: Day
|
|
, playing :: Player
|
|
, lastScored :: Player
|
|
, oyake :: Player
|
|
, stock :: [Card]
|
|
}
|
|
data Over = Over {
|
|
winner :: Player
|
|
, score :: Int
|
|
}
|
|
|
|
type Month = Either Over On
|
|
|
|
new :: Player -> [Card] -> On
|
|
new playing shuffled =
|
|
On {
|
|
flower = Pine
|
|
, players
|
|
, day = Day.new (packOfCards river) (players ! playing) next
|
|
, playing
|
|
, lastScored = playing
|
|
, oyake = playing
|
|
, stock
|
|
}
|
|
where
|
|
take8 = state $ splitAt 8
|
|
([hand1, hand2, river], next:stock) = runState (replicateM 3 take8) shuffled
|
|
players = initPlayers hand1 hand2
|
|
|
|
next :: On -> IO On
|
|
next month@(On {flower, oyake}) = do
|
|
shuffled <- shuffle cards
|
|
return $ (new (Game.next oyake) cards) {flower = succ flower}
|
|
|
|
instance Game On Month where
|
|
play month@(On {flower, day, playing, players, stock = next : moreStock}) move =
|
|
fmap after $ play day move
|
|
where
|
|
after (Day {step = Day.Over True, player = PlayerState {yakus}}) =
|
|
Left $ Over {winner = playing, score = foldl (+) 0 yakus}
|
|
after (Day {step = Day.Over False, player, river}) =
|
|
let otherPlayer = Game.next playing in
|
|
Right $ month {
|
|
players = insert playing player players
|
|
, playing = otherPlayer
|
|
, day = (Day.new river (players ! otherPlayer) next) { month = flower }
|
|
, stock = moreStock
|
|
}
|
|
after newDay = Right $ month {day = newDay}
|