{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}

import Control.Lens
import Control.Lens.TH
import Data.Kind (Type)
import Data.List
import System.Random.Stateful
import Control.Monad.State

-- fake shuffle because System.Random version on this playground
-- does not seem to have this yet
uniformShuffleListM :: StatefulGen g m => [a] -> g -> m [a]
uniformShuffleListM xs gen = pure xs

data Card = Card { _val :: Int } deriving (Read, Show, Eq)
$(makeLenses ''Card)

type Deck = [Card]
type Hand = [Card]
type Discard = [Card]

data Player = Player
     { _deck :: Deck
     , _hand :: Hand
     , _discard :: Discard
     } deriving (Read, Show, Eq)
$(makeLenses ''Player)

type PlayerId = Int

data Game = Game
     { _players :: [Player]
     , _playerId :: PlayerId
     , _randomGen :: StdGen  -- the underlying /pure/ random generator
     } deriving (Show, Eq)
$(makeLenses ''Game)

-- It's usually neater to make a custom monad a newtype instead of
-- a type synonym. This allows you to, for example, attach custom
-- instances to it without fearing for overlapping with existing or
-- future instances for the underlying 'State' type.
newtype GameM a = GameM (State Game a)
  deriving (Functor, Applicative, Monad, MonadState Game)

data GameRandomHandle = GameRandomHandle

-- Such as this one! This is a manual instance of StatefulGen for
-- our monad. I chose () as the handle type because there is only
-- one generator in this monad, so there is no need for multiple
-- handles.
-- For more performance it is advisable to overload more than just
-- uniformWord64 here. But this is sufficient.
instance StatefulGen GameRandomHandle GameM where
  uniformWord64 GameRandomHandle = do
    state <- get
    let (x, g') = uniform (state ^. randomGen)
    modify (\s -> s & randomGen .~ g')
    pure x
  -- This override of uniformShortByteString is for stupid reasons
  -- that the default implementation requires IO, and there is no
  -- IO here. The implementation for 'State' uses genShortByteString,
  -- so I did too.
  uniformShortByteString n GameRandomHandle = do
    state <- get
    let (bs, g') = genShortByteString n (state ^. randomGen)
    modify (\s -> s & randomGen .~ g')
    pure bs

instance FrozenGen StdGen GameM where {
  type MutableGen StdGen GameM = GameRandomHandle;
  freezeGen _ = gets (^. randomGen);
  thawGen gen = modify (\s -> s & randomGen .~ gen);
}

-- Run the GameM monad.
runGameM :: GameM a -> Game -> (a, Game)
runGameM (GameM m) initGame = runState m initGame

makeDeck :: Deck
makeDeck = [Card x | x <- [1..100]]

newPlayer :: (StatefulGen g m) => g -> m Player
newPlayer gen = do
  d <- uniformShuffleListM makeDeck gen
  -- start with three cards in hand
  let player = Player (drop 3 d) (take 4 d) []
  pure player

-- Make a new game. This is non-monadic, because it takes a pure generator
-- and returns the new pure generator in the returned Game.
makeGame :: StdGen -> Game
makeGame gen =
  -- Use a local small runStateGen to more conveniently generate a bunch of
  -- things.
  let (mostOfGame, gen') = runStateGen gen $ \handle -> do
        p1 <- newPlayer handle
        p2 <- newPlayer handle
        pid <- uniformRM (0, 1) handle
        pure $ Game [p1, p2] pid
  in mostOfGame gen'

getPlayer :: PlayerId -> GameM Player
getPlayer playerId = do
  state <- get
  pure $ (state ^. players) !! playerId

modifyPlayer :: PlayerId -> (Player -> Player) -> GameM ()
modifyPlayer playerId func = modify $ over (players . element playerId) func

-- shuffle discards into the deck
shuffleDiscards :: PlayerId -> GameM ()
shuffleDiscards playerId = do
  player <- getPlayer playerId
  let newdeck = (player ^. deck) ++ (player ^. discard)
  shuffledDeck <- uniformShuffleListM newdeck ()
  modifyPlayer playerId $ over deck (\_ -> shuffledDeck) . over discard (\_ -> [])

-- draw a card from the deck, shuffling if necessary.
drawFromDeck :: PlayerId -> GameM ()
drawFromDeck playerId = do
  player <- getPlayer playerId
  let dsize = length $ player ^. deck
  if dsize > 0
    then
      draw
    else do
      shuffleDiscards playerId
      draw
  where
    draw = do
      player <- getPlayer playerId
      let drawnCards = take 1 (player ^. deck)
      modifyPlayer playerId $ over deck (drop 1) . over hand ((++) drawnCards)

runGame :: GameM ()
runGame = do
  drawFromDeck 0
  drawFromDeck 1

makeAndRunGame :: StdGen -> Game
makeAndRunGame gen =
  let startState = makeGame gen
      -- the returned () here is the () that runGame returns.
      ((), newState) = runGameM runGame startState
  in newState

main :: IO ()
main = do
  let seed = 12345
  let gen = mkStdGen seed
  let finalState = makeAndRunGame gen
  print finalState