59 lines
1.6 KiB
Haskell
59 lines
1.6 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
module Hanafuda.Year where
|
|
|
|
import Hanafuda.Card (Flower(Paulownia), cards, shuffle)
|
|
import Hanafuda.Month (Month(..), flower, next, score, winner)
|
|
import qualified Hanafuda.Month as Month (On(..), Over(..), new)
|
|
import Hanafuda.Game (Game(..), Player(Player1), Scores, deal)
|
|
import Data.Map (Map, insert, (!))
|
|
import System.Random (StdGen)
|
|
|
|
data Mode = FirstAt Int | WholeYear
|
|
|
|
data On = On {
|
|
mode :: Mode
|
|
, month :: Month.On
|
|
, scores :: Scores
|
|
}
|
|
data Over = Over {
|
|
finalScores :: Scores
|
|
}
|
|
|
|
newtype Year = Year (Either Over On)
|
|
|
|
go :: On -> IO Year
|
|
go = return . Year . Right
|
|
|
|
new :: Mode -> IO Year
|
|
new mode = do
|
|
shuffled <- shuffle cards
|
|
go $ On {
|
|
mode
|
|
, month = Month.new Player1 shuffled
|
|
, scores = deal $ cycle [0]
|
|
}
|
|
|
|
consolidate :: On -> Player -> Int -> IO Year
|
|
consolidate on@(On {mode, month, scores}) winner score =
|
|
case mode of
|
|
FirstAt n | n <= newScore -> stop
|
|
FirstAt n -> continue
|
|
WholeYear | flower month == Paulownia -> stop
|
|
WholeYear -> continue
|
|
where
|
|
newScore = scores ! winner + score
|
|
newScores = insert winner newScore scores
|
|
stop = return . Year . Left $ Over {finalScores = newScores}
|
|
continue = do
|
|
nextMonth <- next month
|
|
go $ on {scores = newScores, month = nextMonth}
|
|
|
|
instance Game On (IO Year) where
|
|
play on@(On {mode, month}) move =
|
|
fmap after $ play month move
|
|
where
|
|
after (Month (Left (Month.Over {winner, score}))) = consolidate on winner score
|
|
after (Month (Right newMonth)) = go $ on {month = newMonth}
|