State Monad - Jogo da Velha 👵 - Gabarito

-- 2024-09-09 - Emilio Francesquini <[email protected]>
-- Universidade Federal do ABC
-- CC-BY-SA 4.0

module Main (main) where
import Data.List (nub)
import Data.Maybe (fromJust)
import System.Random

-- A definição de State
newtype State s a = State (s -> (a, s))

-- Definições de Functor, Applicative e Monad para State
instance Functor (State s) where
  -- fmap :: (a -> b) -> State s a -> State s b
  fmap f (State g) = State (\s -> let (a, s') = g s
                                  in  (f a, s'))

instance Applicative (State s) where
  pure x = State (\s -> (x, s))
  -- (<*>) :: State s (a -> b) -> State s a -> State s b
  sab <*> sa = State (\s -> let (f, s1) = runState sab s
                                (a, s2) = runState sa  s1
                            in  (f a, s2))

instance Monad (State s) where
  -- (>>=) :: State s a -> (a -> State s b) -> State s b
  sa >>= f = State (\s -> let (a, s1) = runState sa s
                              sb      = f a
                          in  runState sb s1)



-- Executa um State dado um contexto inicial
runState :: State s a -> s -> (a, s)
runState (State f) = f

-- State que, quando executado, devolve o seu estado interno
get :: State s s
get = State (\s -> (s, s))

-- State que, quando executado, aplica a função dada como parâmetro
-- ao estado  interno e devolve o valor calculado.
gets :: (s -> a) -> State s a
gets f =
  get >>= return . f

-- Dado um novo coontexto, coloca-o dentro do State
put :: s -> State s ()
put x = State (const ((), x))

-- Dada uma função, aplica-a ao contexto atual e coloca o resultaado
-- como novo contexto do State
modify :: (s -> s) -> State s ()
modify f = do
  s <- get
  put $ f s
  return ()

-- Semelhante ao runState mas devolve apenas o contexto final
exec :: State s a -> s -> s
exec st = snd . runState st

-- Semelhante ao runState mas devolve apenas o valor final
eval :: State s a -> s -> a
eval st = fst . runState st


-- =============================================================================
-- =============================================================================
-- =============================================================================


-- Vamos agora usar a State Monad para fazer um jogo da velha bem
-- simples

-- Coordenada de uma casa do tabuleiro
type Coord = (Int, Int)

-- Dicionário simples de pares chave/valor
type Dict k v = [(k, v)]

-- Consulta e devolve, caso exista, a entrada do dicionário cuja chave
-- corresponde à chave fornecida
dictGet :: Eq k => k -> Dict k v -> Maybe v
dictGet _ [] = Nothing
dictGet k ((k0,v0) : kvs)
  | k == k0 = Just v0
  | otherwise = dictGet k kvs

-- Coloca um novo valor no dicionário substituindo o valor já existe
-- pelo novo caso a chave já esteja presente
dictPut :: Eq k => k -> v -> Dict k v -> Dict k v
dictPut k v [] = [(k, v)]
dictPut k v ((k0, v0) : kvs)
  | k == k0 = (k, v) : kvs
  | otherwise = (k0, v0) : dictPut k v kvs


-- Repreesenta o tabuleiro do jogo da velha
data Tabuleiro = Tabuleiro {
  -- Armazena o dicionário com as casas do jogo
  casas :: Dict Coord ConteudoCasa,
  -- Armazena o jogador que tem a vez
  vez :: Jogador,
  -- Lista infinita de números aleatórios
  aleatorios :: [Int]
  }

-- Jogadodes podem usar o X ou o O para marcar as casas escolhidas
data Jogador = X | O deriving (Eq, Show)

-- Armazena cada casa que pode estar Vazia ou Preencida com a marca de
-- um Jogador
data ConteudoCasa = Vazia | Preenchida Jogador deriving Eq

-- Indica a situação atual do jogo.
data Situacao = EmJogo | Empate | Vitoria Jogador deriving Show

-- State sobre o Tabuleiro
type Jogo a = State Tabuleiro a

-- Dada uma lista de números aleatórios cria um tabuleiro com as casas
-- vazias e a vez do primeiro definida aleatóriamente
criaTabuleiro :: [Int] -> Tabuleiro
criaTabuleiro (r:rs) =
  Tabuleiro cs v (abs <$> rs)
  where
    v = if even r then X  else O
    cs = [((x,y), Vazia)| x <- [0..2], y <- [0..2]]

-- Dado o jogador atual, devolve o próximo jogador
proximoJogador :: Jogador -> Jogador
proximoJogador X = O
proximoJogador O = X

-- Dentro da mônada Jogo, devolve um número aleatório obtido da lista
-- infinita fornecida na criação do tabuleiro. Atualiza o estado do
-- tabuleiro para marcar o consumo do número aleatório.
getAleatorio :: Jogo Int
getAleatorio = do
  ~(n:ns) <- gets aleatorios
  modify (\tab -> tab{aleatorios = ns})
  return n

-- Pega uma casa vazia aleatoriamente, caso exista.
getCasaVaziaAleatoria :: Jogo (Maybe Coord)
getCasaVaziaAleatoria = do
  casasVazias <- filter (\c -> Vazia == snd c) <$> gets casas
  if null casasVazias
    then return Nothing
    else do
      n <- fmap (`rem` length casasVazias) getAleatorio
      return . Just $ fst (casasVazias !! n)

-- Passa a vez para o próximo jogador
passaAVez :: Jogo ()
passaAVez = do
  j <- gets vez
  modify (\tab -> tab{vez  = proximoJogador j})


-- Dada uma coordenada de uma casa vazia, faz uma jogada naquela
-- posição para o jogador atualmente com a vez
fazJogada :: Coord -> Jogo ()
fazJogada coord = do
  jog <- gets vez
  modify (\tab -> tab{casas = dictPut coord (Preenchida jog) (casas tab)})
  passaAVez

-- Devolve a situação atual do jogo seja ela empate, em jogo ou
-- vitória de um dos jogadores. Neste último caso, indica o vencedor.
vencedor :: Jogo Situacao
vencedor = do
  dic <- gets casas
  let vencs =
        ganha (linhas dic)    <>
        ganha (colunas dic)   <>
        ganha (diagonais dic)
  return $ case vencs of
    ((Preenchida x:_):_) -> Vitoria x
    _ -> EmJogo
  where
    cs xss dic = fmap (fmap (\c -> fromJust $ dictGet c dic)) xss
    ganha      = filter (\xs -> length (nub xs) == 1)
    linhas     = cs [[(i, j) | j <- [0..2]] | i <- [0..2]]
    colunas    = cs [[(i, j) | i <- [0..2]] | j <- [0..2]]
    diagonais  = cs [[(0,0), (1, 1), (2, 2)], [(0,2), (1, 1), (2, 0)]]

-- Efetua umaa única jogada aleatória, caso possível.
jogaUmaVez :: Jogo Situacao
jogaUmaVez = do
  mc <- getCasaVaziaAleatoria
  case mc of
    Nothing -> return Empate
    Just c  -> do
      fazJogada c
      vencedor

-- Joga o tabuleiro atual até o fim do jogo
jogaAteOFim :: Jogo Situacao
jogaAteOFim = do
  sit <- jogaUmaVez
  case sit of
    EmJogo -> jogaAteOFim
    _      -> return sit

main :: IO ()
main = do
  -- Obtem uma lista infinita de números aleatórios
  gen <- getStdGen
  let rns = randoms gen
  -- Usa essa lista para criar tabuleiro inicial, rodar o jogo e
  -- imprimir o vencedor (ou se houve empate) ao final
  let v = eval jogaAteOFim (criaTabuleiro rns)
  print v