68 lines
2.0 KiB
Haskell
68 lines
2.0 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
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), new)
|
|
import Hanafuda.Game (Game(..), 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
|
|
}
|
|
|
|
newtype Month = Month (Either Over On)
|
|
|
|
go :: On -> Month
|
|
go = Month . Right
|
|
|
|
new :: Player -> IO On
|
|
new playing = do
|
|
([hand1, hand2, river], next:stock) <- fmap (runState (replicateM 3 take8)) $ shuffle cards
|
|
let players = initPlayers [hand1, hand2]
|
|
return On {
|
|
flower = Pine
|
|
, players
|
|
, day = Day.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 $ Game.next oyake
|
|
return $ on {flower = succ flower}
|
|
|
|
instance Game On Month where
|
|
play on@(On {flower, day, playing, players, stock = next : moreStock}) move =
|
|
fmap after $ play day move
|
|
where
|
|
after (Day {step = Day.Over True, player = PlayerState {yakus}}) =
|
|
Month . Left $ Over {winner = playing, score = foldl (+) 0 yakus}
|
|
after (Day {step = Day.Over False, player, river}) =
|
|
let otherPlayer = Game.next playing in
|
|
go $ on {
|
|
players = insert playing player players
|
|
, playing = otherPlayer
|
|
, day = (Day.new river (players ! otherPlayer) next) { month = flower }
|
|
, stock = moreStock
|
|
}
|
|
after newDay = go $ on {day = newDay}
|