{-# 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}