after-pairing.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module TicTacToe where

import Control.Monad (forever, join)
import Data.List (intersperse, nub, transpose)
import Data.Maybe (fromMaybe, mapMaybe)
import System.Exit (exitSuccess)
import System.IO (getLine)
import System.Random (randomRIO)
import Text.ParserCombinators.ReadP

-- | There are two players in a game of Tic-Tac-Toe.
data Player = X | O deriving (Show, Eq)

-- | Our game is made of cells. Every cell can be empty or occupied.
data Cell where
  -- | Cells can be Occupied by a specific Player.
  Occupied :: Player -> Cell
  -- | An Empty cell has no additional information.
  Empty :: Cell
  deriving (Show, Eq)

-- | State for the game, including the board and current player.
--
--  We use a nested list for the cells, which is not fixed-length.
--  TODO: Replace this with a fixed-length type (such as Vector)
data Board where
  Board ::
    { -- | size of the board (width / height)
      size :: Int,
      -- | current board state
      cells :: [[Cell]],
      -- | whose turn is it?
      turn :: Player
    } ->
    Board
  deriving (Show)

-- | Coordinates point to a cell, with the first cell at coordinate (0,0).
data Coord where
  Coord :: (Int, Int) -> Coord
  deriving (Show)

-- | Player-provided input after successful parsing.
data Input where
  Quit :: Input
  Help :: Input
  TryMove :: Coord -> Input
  deriving (Show)

-- | Moves can fail.
data MoveError where
  -- | If a coordinate isn't valid, the move fails.
  InvalidCoord :: MoveError
  -- | If a space is already occupied, the move fails.
  AlreadyOccupied :: MoveError
  deriving (Show)

-- | Class for values that can be displayed to console.
class Display a where
  -- | Render value as a string, for printing.
  display :: a -> String

-- | Cells are displayed as single characters.
instance Display Cell where
  display (Occupied X) = "X"
  display (Occupied O) = "O"
  display Empty = "."

-- | When displaying a board, we display every cell.
instance Display Board where
  display Board {cells} =
    let render :: [Cell] -> String
        render row = intersperse ' ' $ foldl1 (++) $ display <$> row

        raw :: [String]
        raw = render <$> cells
     in unlines raw

-- | Check if a coordinate is within bounds of a board.
inBounds :: Board -> Coord -> Bool
inBounds Board {cells, size} (Coord (x, y)) =
  (x >= 0) && (y >= 0) && (x < size) && (y < size)

-- | Check the value of a coordinate on a board.
-- Return the occupant of the cell at that coordinate.
-- This coordinate may be invalid, in which case we return Nothing.
lookupCell :: Board -> Coord -> Maybe Cell
lookupCell board@Board {cells, size} coord@(Coord (x, y))
  | inBounds board coord = Just (cells !! y !! x)
  | otherwise = Nothing

-- | Parse a coordinate, separated by a ','.
--
-- >>> last . readP_to_S coordP $ "12, 32"
-- (TryMove (Coord (12,32)),"")
coordP :: ReadP Input
coordP =
  let num :: ReadP Char
      num = choice $ char <$> "1234567890"
   in do
        x <- read @Int <$> many1 num
        char ',' >> optional (char ' ')
        y <- read @Int <$> many1 num

        return . TryMove $ Coord (x, y)

-- | Matches the string "quit".
quitP :: ReadP Input
quitP = string "quit" >> return Quit

-- | Matches the string "help".
helpP :: ReadP Input
helpP = string "help" >> return Help

-- | Try all Input parsers.
inputP :: ReadP Input
inputP = choice [quitP, helpP, coordP]

-- | Run ReadP parsers on a line of input.
parseInput :: String -> Maybe Input
parseInput line = case readP_to_S inputP line of
  -- empty list means all parsers failed
  [] -> Nothing
  -- no remaining tokens with a successful parse
  (last -> (parsedInput, "")) -> Just parsedInput
  -- anything else is failure (including partial success with extra tokens)
  _ -> Nothing

-- | See if the game has a winner.
--
-- If there is no winner yet, return Nothing.
-- If there is a winner, return the winning Player.
--
-- There are (2n + 2) sequences to check each turn:
-- * horizontal: n to check (each row)
-- * vertical:   n to check (each column)
-- * diagonal:   2 to check (two pairs of opposite angles)
winner :: Board -> Maybe Player
winner board@Board {cells, size} =
  let horizontals :: [[Cell]]
      horizontals = cells

      verticals :: [[Cell]]
      verticals = transpose cells

      diagonals :: [[Cell]]
      diagonals =
        let up :: [Int]
            up = [0, 1 .. size - 1]

            down :: [Int]
            down = [size - 1, size - 2 .. 0]

            left :: [Coord]
            left = Coord <$> zip up up

            right :: [Coord]
            right = Coord <$> zip down down

            hardLookup :: Coord -> Cell
            hardLookup coord =
              let result = lookupCell board coord
               in fromMaybe (error "failed lookup on diagonal") result
         in [hardLookup <$> left, hardLookup <$> right]

      checkWin :: [Cell] -> Maybe Player
      checkWin cells
        | all (== Occupied X) cells = Just X
        | all (== Occupied O) cells = Just O
        | otherwise = Nothing

      winners :: [Player]
      winners =
        mapMaybe checkWin $
          horizontals ++ verticals ++ diagonals
   in case nub winners of
        [] -> Nothing
        [winner] -> Just winner
        _ -> error "more than one winner"

-- | Generate a square grid of empty cells.
emptyGrid :: Int -> [[Cell]]
emptyGrid size = replicate size $ replicate size Empty

-- | Generate an empty board of a certain size, setting which player goes first.
emptyBoard :: Int -> Player -> Board
emptyBoard size turn =
  let cells :: [[Cell]]
      cells = emptyGrid size
   in Board {size, cells, turn}

-- | Replace a cell at a certain index.
-- Unsafe, validate that the index is in bounds to avoid exceptions.
replace :: [a] -> Int -> a -> [a]
replace seq index replacement =
  let (head, _ : tail) = splitAt index seq
   in head ++ [replacement] ++ tail

-- | Try to make a move in a space. Return a new board if successful.
move :: Board -> Coord -> Either MoveError Board
move board@Board {cells, turn} coord@(Coord (x, y)) =
  let target :: Maybe Cell
      target = lookupCell board coord

      try :: Maybe Cell -> Either MoveError Board
      try Nothing = Left InvalidCoord
      try (Just (Occupied _)) = Left AlreadyOccupied
      try (Just Empty) =
        let replacementRow :: [Cell]
            replacementRow = replace (cells !! y) x (Occupied turn)

            replacementGrid :: [[Cell]]
            replacementGrid = replace cells y replacementRow

            flip :: Player -> Player
            flip X = O
            flip O = X
         in Right board {cells = replacementGrid, turn = flip turn}
   in try target

-- | Main game loop for an initialized board.
-- Assumes two human players, alternating turns.
loop :: Board -> IO Player
loop board@Board {size, cells, turn} = do
  -- display + prompt
  putStr $ unlines ["---", unwords ["current turn:", show turn], display board]
  putStr "> "
  input <- getLine

  case parseInput input of
    Nothing -> do
      putStrLn "failed to parse input, try again?"
      loop board
    Just Help -> do
      putStr $
        unlines
          [ "Insert your move with a pair of coordinates: > 0,1",
            "",
            "Rows and columns start at 0.",
            "",
            "To exit: > quit"
          ]
      loop board
    Just Quit -> do
      putStrLn "bye!"
      exitSuccess
    Just (TryMove coord) -> case move board coord of
      Left InvalidCoord -> do
        putStrLn "invalid coordinate!"
        loop board
      Left AlreadyOccupied -> do
        putStrLn "already occupied!"
        loop board
      Right next -> do
        case winner next of
          Nothing -> loop next
          Just player -> do
            putStr $ display next
            return player

-- | Main game loop for an initialized board.
-- One human player as X, CPU player making random moves.
aiLoop :: Board -> IO Player
aiLoop board@Board {size, cells, turn} = do
  -- display + prompt
  putStr $ unlines ["---", unwords ["current turn:", show turn], display board]
  putStr "> "
  input <- getLine

  case parseInput input of
    Nothing -> do
      putStrLn "failed to parse input, try again?"
      aiLoop board
    Just Help -> do
      putStr $
        unlines
          [ "Insert your move with a pair of coordinates: > 0,1",
            "",
            "Rows and columns start at 0.",
            "",
            "To exit: > quit"
          ]
      aiLoop board
    Just Quit -> do
      putStrLn "bye!"
      exitSuccess
    Just (TryMove coord) -> case move board coord of
      Left InvalidCoord -> do
        putStrLn "invalid coordinate!"
        aiLoop board
      Left AlreadyOccupied -> do
        putStrLn "already occupied!"
        aiLoop board
      Right next -> do
        case winner next of
          Nothing -> do
            -- instead of moving onto the next player, the CPU makes a move
            -- once the CPU is done making a move, we switch back to the other player
            -- we need to check to see if the CPU won the game before we switch back

            -- first we need to figure out what coordinates are valid
            let possibleMoves = emptySquares next :: [Coord]
                genIndex = randomRIO (0, (size - 1)) :: IO Int
             in do
                  index <- genIndex
                  case (move next (possibleMoves !! index)) of
                    Right cpuMoved -> aiLoop cpuMoved
                    other -> error $ "cpu failed to move, sorry! " ++ show other
          Just player -> do
            -- this code stays the same, because if the player submits a move and they win,
            -- we don't need to make another move
            putStr $ display next
            return player

allCoordinates :: Board -> [Coord]
allCoordinates (Board {size}) =
  [Coord (x, y) | x <- [0 .. (size - 1)], y <- [0 .. (size - 1)]]

hardLookup :: Board -> Coord -> Cell
hardLookup board cell = fromMaybe (error "invalid coordinate") (lookupCell board cell)

emptySquares :: Board -> [Coord]
emptySquares board =
  let all :: [Coord]
      all = allCoordinates board

      values :: [(Coord, Cell)]
      values = map (\coord -> (coord, hardLookup board coord)) all

      empty :: [(Coord, Cell)]
      empty = filter (\(coord, cell) -> cell == Empty) values
   in map fst empty

-- | Run game loop with an empty board of size 3.
main :: IO ()
main = forever $ do
  winner <- aiLoop $ emptyBoard 3 X
  putStrLn $ unwords ["congratulations, the winner is:", show winner]

original-submission.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module TicTacToe where

import Control.Monad (forever, join)
import Data.List (intersperse, nub, transpose)
import Data.Maybe (mapMaybe, fromMaybe)
import System.Exit (exitSuccess)
import System.IO (getLine)
import Text.ParserCombinators.ReadP

-- | There are two players in a game of Tic-Tac-Toe.
data Player = X | O deriving (Show, Eq)

-- | Our game is made of cells. Every cell can be empty or occupied.
data Cell where
  -- | Cells can be Occupied by a specific Player.
  Occupied :: Player -> Cell
  -- | An Empty cell has no additional information.
  Empty :: Cell
  deriving (Show, Eq)

-- | State for the game, including the board and current player.
--
--  We use a nested list for the cells, which is not fixed-length.
--  TODO: Replace this with a fixed-length type (such as Vector)
data Board where
  Board ::
    { -- | size of the board (width / height)
      size :: Int,
      -- | current board state
      cells :: [[Cell]],
      -- | whose turn is it?
      turn :: Player
    } ->
    Board
  deriving (Show)

-- | Coordinates point to a cell, with the first cell at coordinate (0,0).
data Coord where
  Coord :: (Int, Int) -> Coord
  deriving (Show)

-- | Player-provided input after successful parsing.
data Input where
  Quit :: Input
  Help :: Input
  TryMove :: Coord -> Input
  deriving (Show)

-- | Moves can fail.
data MoveError where
  -- | If a coordinate isn't valid, the move fails.
  InvalidCoord :: MoveError
  -- | If a space is already occupied, the move fails.
  AlreadyOccupied :: MoveError
  deriving (Show)

-- | Class for values that can be displayed to console.
class Display a where
  -- | Render value as a string, for printing.
  display :: a -> String

-- | Cells are displayed as single characters.
instance Display Cell where
  display (Occupied X) = "X"
  display (Occupied O) = "O"
  display Empty = "."

-- | When displaying a board, we display every cell.
instance Display Board where
  display Board {cells} =
    let render :: [Cell] -> String
        render row = intersperse ' ' $ foldl1 (++) $ display <$> row

        raw :: [String]
        raw = render <$> cells
     in unlines raw

-- | Check if a coordinate is within bounds of a board.
inBounds :: Board -> Coord -> Bool
inBounds Board {cells, size} (Coord (x, y)) =
  (x >= 0) && (y >= 0) && (x < size) && (y < size)

-- | Check the value of a coordinate on a board.
-- Return the occupant of the cell at that coordinate.
-- This coordinate may be invalid, in which case we return Nothing.
lookupCell :: Board -> Coord -> Maybe Cell
lookupCell board@Board {cells, size} coord@(Coord (x, y))
  | inBounds board coord = Just (cells !! y !! x)
  | otherwise = Nothing

-- | Parse a coordinate, separated by a ','.
--
-- >>> last . readP_to_S coordP $ "12, 32"
-- (TryMove (Coord (12,32)),"")
coordP :: ReadP Input
coordP =
  let num :: ReadP Char
      num = choice $ char <$> "1234567890"
   in do
        x <- read @Int <$> many1 num
        char ',' >> optional (char ' ')
        y <- read @Int <$> many1 num

        return . TryMove $ Coord (x, y)

-- | Matches the string "quit".
quitP :: ReadP Input
quitP = string "quit" >> return Quit

-- | Matches the string "help".
helpP :: ReadP Input
helpP = string "help" >> return Help

-- | Try all Input parsers.
inputP :: ReadP Input
inputP = choice [quitP, helpP, coordP]

-- | Run ReadP parsers on a line of input.
parseInput :: String -> Maybe Input
parseInput line = case readP_to_S inputP line of
  -- empty list means all parsers failed
  [] -> Nothing
  -- no remaining tokens with a successful parse
  (last -> (parsedInput, "")) -> Just parsedInput
  -- anything else is failure (including partial success with extra tokens)
  _ -> Nothing

-- | See if the game has a winner.
--
-- If there is no winner yet, return Nothing.
-- If there is a winner, return the winning Player.
--
-- There are (2n + 2) sequences to check each turn:
-- * horizontal: n to check (each row)
-- * vertical:   n to check (each column)
-- * diagonal:   2 to check (two pairs of opposite angles)
winner :: Board -> Maybe Player
winner board@Board {cells, size} =
  let horizontals :: [[Cell]]
      horizontals = cells

      verticals :: [[Cell]]
      verticals = transpose cells

      diagonals :: [[Cell]]
      diagonals =
        let up :: [Int]
            up = [0, 1 .. size - 1]

            down :: [Int]
            down = [size - 1, size - 2 .. 0]

            left :: [Coord]
            left = Coord <$> zip up up

            right :: [Coord]
            right = Coord <$> zip down up -- fixed less than an hour after submission, my bad!

            hardLookup :: Coord -> Cell
            hardLookup coord =
              let result = lookupCell board coord
               in fromMaybe (error "failed lookup on diagonal") result
         in [hardLookup <$> left, hardLookup <$> right]

      checkWin :: [Cell] -> Maybe Player
      checkWin cells
        | all (== Occupied X) cells = Just X
        | all (== Occupied O) cells = Just O
        | otherwise = Nothing

      winners :: [Player]
      winners =
        mapMaybe checkWin $
          horizontals ++ verticals ++ diagonals
   in case nub winners of
        [] -> Nothing
        [winner] -> Just winner
        _ -> error "more than one winner"

-- | Generate a square grid of empty cells.
emptyGrid :: Int -> [[Cell]]
emptyGrid size = replicate size $ replicate size Empty

-- | Generate an empty board of a certain size, setting which player goes first.
emptyBoard :: Int -> Player -> Board
emptyBoard size turn =
  let cells :: [[Cell]]
      cells = emptyGrid size
   in Board {size, cells, turn}

-- | Replace a cell at a certain index.
-- Unsafe, validate that the index is in bounds to avoid exceptions.
replace :: [a] -> Int -> a -> [a]
replace seq index replacement =
  let (head, _ : tail) = splitAt index seq
   in head ++ [replacement] ++ tail

-- | Try to make a move in a space. Return a new board if successful.
move :: Board -> Coord -> Either MoveError Board
move board@Board {cells, turn} coord@(Coord (x, y)) =
  let target :: Maybe Cell
      target = lookupCell board coord

      try :: Maybe Cell -> Either MoveError Board
      try Nothing = Left InvalidCoord
      try (Just (Occupied _)) = Left AlreadyOccupied
      try (Just Empty) =
        let replacementRow :: [Cell]
            replacementRow = replace (cells !! y) x (Occupied turn)

            replacementGrid :: [[Cell]]
            replacementGrid = replace cells y replacementRow

            flip :: Player -> Player
            flip X = O
            flip O = X
         in Right board {cells = replacementGrid, turn = flip turn}
   in try target

-- | Main game loop for an initialized board.
-- Assumes two human players, alternating turns.
loop :: Board -> IO Player
loop board@Board {size, cells, turn} = do
  -- display + prompt
  putStr $ unlines ["---", unwords ["current turn:", show turn], display board]
  putStr "> "
  input <- getLine

  case parseInput input of
    Nothing -> do
      putStrLn "failed to parse input, try again?"
      loop board
    Just Help -> do
      putStr $
        unlines
          [ "Insert your move with a pair of coordinates: > 0,1",
            "",
            "Rows and columns start at 0.",
            "",
            "To exit: > quit"
          ]
      loop board
    Just Quit -> do
      putStrLn "bye!"
      exitSuccess
    Just (TryMove coord) -> case move board coord of
      Left InvalidCoord -> do
        putStrLn "invalid coordinate!"
        loop board
      Left AlreadyOccupied -> do
        putStrLn "already occupied!"
        loop board
      Right next -> do
        case winner next of
          Nothing -> loop next
          Just player -> do
            putStr $ display next
            return player

-- | Run game loop with an empty board of size 3.
main :: IO ()
main = forever $ do
  winner <- loop $ emptyBoard 3 X
  putStrLn $ unwords ["congratulations, the winner is:", show winner]

pairing.diff

--- old.hs	2022-06-11 10:49:28.860853216 -0400
+++ TicTacToe.hs	2022-03-10 18:18:17.575110995 -0500
@@ -8,9 +8,10 @@
 
 import Control.Monad (forever, join)
 import Data.List (intersperse, nub, transpose)
-import Data.Maybe (mapMaybe, fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
 import System.Exit (exitSuccess)
 import System.IO (getLine)
+import System.Random (randomRIO)
 import Text.ParserCombinators.ReadP
 
 -- | There are two players in a game of Tic-Tac-Toe.
@@ -160,7 +161,7 @@
             left = Coord <$> zip up up
 
             right :: [Coord]
-            right = Coord <$> zip down up -- fixed less than an hour after submission, my bad!
+            right = Coord <$> zip down down
 
             hardLookup :: Coord -> Cell
             hardLookup coord =
@@ -263,8 +264,81 @@
             putStr $ display next
             return player
 
+-- | Main game loop for an initialized board.
+-- One human player as X, CPU player making random moves.
+aiLoop :: Board -> IO Player
+aiLoop board@Board {size, cells, turn} = do
+  -- display + prompt
+  putStr $ unlines ["---", unwords ["current turn:", show turn], display board]
+  putStr "> "
+  input <- getLine
+
+  case parseInput input of
+    Nothing -> do
+      putStrLn "failed to parse input, try again?"
+      aiLoop board
+    Just Help -> do
+      putStr $
+        unlines
+          [ "Insert your move with a pair of coordinates: > 0,1",
+            "",
+            "Rows and columns start at 0.",
+            "",
+            "To exit: > quit"
+          ]
+      aiLoop board
+    Just Quit -> do
+      putStrLn "bye!"
+      exitSuccess
+    Just (TryMove coord) -> case move board coord of
+      Left InvalidCoord -> do
+        putStrLn "invalid coordinate!"
+        aiLoop board
+      Left AlreadyOccupied -> do
+        putStrLn "already occupied!"
+        aiLoop board
+      Right next -> do
+        case winner next of
+          Nothing -> do
+            -- instead of moving onto the next player, the CPU makes a move
+            -- once the CPU is done making a move, we switch back to the other player
+            -- we need to check to see if the CPU won the game before we switch back
+
+            -- first we need to figure out what coordinates are valid
+            let possibleMoves = emptySquares next :: [Coord]
+                genIndex = randomRIO (0, (size - 1)) :: IO Int
+             in do
+                  index <- genIndex
+                  case (move next (possibleMoves !! index)) of
+                    Right cpuMoved -> aiLoop cpuMoved
+                    other -> error $ "cpu failed to move, sorry! " ++ show other
+          Just player -> do
+            -- this code stays the same, because if the player submits a move and they win,
+            -- we don't need to make another move
+            putStr $ display next
+            return player
+
+allCoordinates :: Board -> [Coord]
+allCoordinates (Board {size}) =
+  [Coord (x, y) | x <- [0 .. (size - 1)], y <- [0 .. (size - 1)]]
+
+hardLookup :: Board -> Coord -> Cell
+hardLookup board cell = fromMaybe (error "invalid coordinate") (lookupCell board cell)
+
+emptySquares :: Board -> [Coord]
+emptySquares board =
+  let all :: [Coord]
+      all = allCoordinates board
+
+      values :: [(Coord, Cell)]
+      values = map (\coord -> (coord, hardLookup board coord)) all
+
+      empty :: [(Coord, Cell)]
+      empty = filter (\(coord, cell) -> cell == Empty) values
+   in map fst empty
+
 -- | Run game loop with an empty board of size 3.
 main :: IO ()
 main = forever $ do
-  winner <- loop $ emptyBoard 3 X
+  winner <- aiLoop $ emptyBoard 3 X
   putStrLn $ unwords ["congratulations, the winner is:", show winner]