57 lines
1.6 KiB
Haskell
57 lines
1.6 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
module Hanafuda.Year where
|
|
|
|
import Hanafuda.Card (Flower(Paulownia), cards, shuffle)
|
|
import Hanafuda.Month (flower, next, score, winner)
|
|
import qualified Hanafuda.Month as Month (On(..), Over(..), new)
|
|
import Hanafuda.Game (Game(..), Player(Player1), Scores)
|
|
import Data.Map (Map, empty, 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
|
|
}
|
|
|
|
type Year = IO (Either Over On)
|
|
|
|
new :: Mode -> Year
|
|
new mode = do
|
|
shuffled <- shuffle cards
|
|
return . Right $ On {
|
|
mode
|
|
, month = Month.new Player1 shuffled
|
|
, scores = empty
|
|
}
|
|
|
|
consolidate :: On -> Player -> Int -> Year
|
|
consolidate year@(On {mode, month, scores}) winner score =
|
|
case mode of
|
|
FirstAt n | n <= newScore -> over
|
|
FirstAt n -> continue
|
|
WholeYear | flower month == Paulownia -> over
|
|
WholeYear -> continue
|
|
where
|
|
newScore = scores ! winner + score
|
|
newScores = insert winner newScore scores
|
|
over = return . Left $ Over {finalScores = newScores}
|
|
continue = do
|
|
nextMonth <- next month
|
|
return . Right $ year {scores = newScores, month = nextMonth}
|
|
|
|
instance Game On Year where
|
|
play year@(On {mode, month}) move =
|
|
fmap after $ play month move
|
|
where
|
|
after (Left (Month.Over {winner, score})) = consolidate year winner score
|
|
after (Right newMonth) = return . Right $ year {month = newMonth}
|