Poker.hs

{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE KindSignatures            #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE NoImplicitPrelude         #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}

module Poker where

import Control.Lens        ( use )
import Data.Has            ( Has
                           , hasLens
                           , modifier
                           )
import Protolude    hiding ( state )

data CustomMonad a

type Parser a = StateT GameState CustomMonad a

data GameState = forall street. GameState { _board :: Board street }

data Rank = Ace | Two  | Three | Four | Five  | Six  | Seven | Eight
                | Nine | Ten   | Jack | Queen | King
  deriving (Eq, Ord, Read, Show)

data Suit = Spades | Hearts | Clubs | Diamonds
  deriving (Eq, Ord, Read, Show)

data Card = Card
  { rank :: Rank
  , suit :: Suit
  }

type Deck = [Card]

data Street
  = Initial
  | PreFlop
  | Flop
  | Turn
  | River
  | Final
  deriving (Read, Show)

data Board :: Street -> * where
  InitialTable :: Board 'Initial
  PreFlopBoard :: Board 'Initial                        -> Board 'PreFlop
  FlopBoard    :: (Card, Card, Card)  -> Board 'PreFlop -> Board 'Flop
  TurnBoard    :: Card                -> Board 'Flop    -> Board 'Turn
  RiverBoard   :: Card                -> Board 'Turn    -> Board 'River
  FinalBoard   :: Board 'River                          -> Board 'Final

cards :: Board street -> [Card]
cards = \case
  InitialTable             -> []
  PreFlopBoard _           -> []
  FlopBoard (c1, c2, c3) _ -> [c1, c2, c3]
  TurnBoard c flop         -> c:cards flop
  RiverBoard c turn        -> c:cards turn
  FinalBoard river         -> cards river

dealFlop :: (Card, Card, Card) -> Board 'PreFlop -> Board 'Flop
dealFlop cs = FlopBoard cs

dealTurn :: Card -> Board 'Flop -> Board 'Turn
dealTurn c = TurnBoard c

dealRiver :: Card -> Board 'Turn -> Board 'River
dealRiver c = RiverBoard c

type family Next a where
  Next 'Initial = 'PreFlop
  Next 'PreFlop = 'Flop
  Next 'Flop    = 'Turn
  Next 'Turn    = 'River
  Next 'River   = 'Final
  Next 'Final   = 'Final

getDeck :: forall m s. (MonadState s m, Has Deck s) => m Deck
getDeck = use hasLens

putDeck :: (MonadState s m, Has Deck s) => Deck -> m ()
putDeck d = put . modifier (const d) =<< get

getSomeGame :: forall m s. (MonadState s m, Has GameState s) => m GameState
getSomeGame = use hasLens

putSomeGame :: forall m s. (MonadState s m, Has GameState s) => GameState -> m ()
putSomeGame sg = put . modifier (const sg) =<< get

dealStreetSt :: (MonadState s m, Has Deck s, Has GameState s) => m ()
dealStreetSt = do
  d  <- getDeck
  sg <- getSomeGame
  let (d', sg') = dealSome d sg
  putSomeGame sg'
  putDeck d'

dealSome :: Deck -> GameState -> (Deck, GameState)
dealSome deck (GameState gs) = GameState <$> dealStreet deck gs

dealStreet :: Deck -> Board street -> (Deck, Board (Next street))
dealStreet deck b = case b of
  InitialTable   -> (deck, PreFlopBoard b)
  PreFlopBoard _ -> let (c1:c2:c3:rest) = deck
                    in (rest, FlopBoard (c1, c2, c3) b)
  FlopBoard _ _  -> let (c:rest) = deck
                    in (rest, TurnBoard c b)
  TurnBoard _ _  -> let (c:rest) = deck
                    in (rest, RiverBoard c b)
  RiverBoard _ _ -> (deck, FinalBoard b)
  FinalBoard _   -> (deck, b)