m,n,k-game (i.e. generalized tic-tac-toe)

Question

I'm back after Tic-Tac-Toe in Haskell with a new version.

I added Haddock documentation and wrote a generalized version known as the m,n,k-game. By doing so, I had to redefine Game and getSeqs. getSeqs as of now contains two annoyingly-long list comprehensions which I'd like to get rid of.

I tried to integrate gameState into Game so that the client won't need to check the game state all the time. However, this makes move rather messy.

Also, I wrote a test client for it (under the main function). I wrote the startGame function which seems extremely long. Is there a way to simplify it?

I'd appreciate any other comments on this code.

{-|
  m,n,k-game implementation in Haskell.
  Two players take turns in placing a stone of their color on an m×n board,
  the winner being the player who first gets k stones of their own color in a
  row, horizontally, vertically, or diagonally.

  For example, tic-tac-toe is a 3,3,3-game and gomuku is a 19,19,5-game.
-}

module MNKGame (
    newGame,
    move,
    moves
) where

import Control.Lens (set, ix)
import Data.List (tails, transpose)
import Data.Maybe (catMaybes)
import Text.Read (readMaybe)

data Player = X | O
    deriving (Show, Read, Eq)

type Marking = Maybe Player
newtype Grid = Grid [[Marking]]

instance Show Grid where
    show (Grid grid) = (unlines . map showRow) grid
        where showRow = unwords . map showMarking
              showMarking (Nothing) = "_"
              showMarking (Just a) = show a

data GameState = Won Player | Draw | Running
    deriving (Show, Read, Eq)

data Game = Game {
    grid :: Grid,
    m :: Int,
    n :: Int,
    k :: Int,
    curTurn :: Player,
    gameState :: GameState
} deriving Show


-- Basic Definitions

nextPlayer :: Player -> Player
nextPlayer X = O
nextPlayer O = X

emptyGrid :: Int -- ^ number of rows
          -> Int -- ^ number of cols
          -> Grid
emptyGrid m n = Grid $ replicate m $ replicate n Nothing

chop :: Int -> [a] -> [[a]]
chop k xs = [take k ys | ys <- zipWith const (tails xs) (drop (k - 1) xs)]

-- |The 'getSeqs' function returns a list of sequences.
-- A sequence is a row, column or diagonal.
-- This utility function returns all sequences.
getSeqs :: Grid
        -> Int -- ^ number of rows
        -> Int -- ^ number of cols
        -> Int -- ^ number of marks in a row to win
        -> [[Marking]] -- ^ list of sequences
getSeqs (Grid marks) m n k =
    rows ++ cols ++ fDiags ++ bDiags
    where
        rows = concatMap (chop k) marks
        cols = concatMap (chop k) $ transpose marks
        fDiags = [[marks !! p !! q | (p, q) <- zip [i .. i + k - 1] [j .. j + k - 1]] | i <- [0 .. m - k], j <- [0 .. n - k]]
        bDiags = [[marks !! p !! q | (p, q) <- zip [i, i - 1 .. i - k] [j .. j + k - 1]] | i <- [k - 1 .. m - 1], j <- [0 .. n - k]]

-- |Returns the current game state of a game.
getGameState :: Grid
             -> Int -- ^ number of rows
             -> Int -- ^ number of cols
             -> Int -- ^ number of marks in a row to win
             -> GameState
getGameState grid@(Grid marks) m n k
    | isWin X = Won X
    | isWin O = Won O
    | isDraw = Draw
    | otherwise = Running
    where
        isWin player = any (all (== Just player)) $ getSeqs grid m n k
        isDraw = all (notElem Nothing) marks

-- |Creates a new m,n,k-game.
newGame :: Int -- ^ number of rows
        -> Int -- ^ number of cols
        -> Int -- ^ number of marks in a row to win
        -> Game -- ^ Game data type
newGame m n k = Game {
    grid = emptyGrid m n,
    m = m,
    n = n,
    k = k,
    curTurn = X,
    gameState = Running
}

-- |The `move` function makes a move given the row and column index.
-- It returns 'Nothing' if the move is invalid.
-- Otherwise, it returns the new game.
move :: Int -- ^ row index
     -> Int -- ^ column index
     -> Game
     -> Maybe Game
move i j (Game (Grid grid) m n k player gameState)
    | gameState == Draw = Nothing
    | gameState == Won X || gameState == Won O = Nothing
    | validCoord i j = case grid !! i !! j of
        Just _ -> Nothing
        Nothing -> let newGrid = Grid $ set (ix i . ix j) (Just player) grid in
            Just Game {
                grid = newGrid,
                m = m,
                n = n,
                k = k,
                curTurn = nextPlayer player,
                gameState = getGameState newGrid m n k
            }
    | otherwise = Nothing
    where validCoord i j = i >= 0 && j >= 0 && i < m && j < n

-- |Returns all possible moves from a game.
moves :: Game -> [Game]
moves game@(Game _ m n _ _ _) = catMaybes [move x y game | x <- [0 .. m - 1], y <- [0 .. n - 1]]

-- Testing Client

-- |This client is a 2-player version of Tic-Tac-Toe.
main :: IO ()
main = do
    putStrLn "Make a move by typing (i, j). i represents the row and j represents the column."
    let game = newGame 3 3 3
    putStrLn $ show $ grid game
    startGame game

startGame :: Game -> IO ()
startGame game = do
    line <- getLine
    case readMaybe line :: Maybe (Int, Int) of
        Just (i, j) -> case move i j game of
            Just newGame -> do
                putStrLn $ show $ grid newGame
                case gameState newGame of
                    Won a -> putStrLn $ "Player " ++ show a ++ " won!"
                    Draw -> putStrLn "It's a draw!"
                    Running -> startGame newGame
            Nothing -> do
                putStrLn "Invalid move. Please input a valid move."
                startGame game
        Nothing -> do
            putStrLn "Invalid move. Please input a valid move."
            startGame game

Answer 1

This is pretty slick.

You might want to add definitions and exports for tictactoe = newgame 3 3 3 and gomuku = newgame 19 19 5 for convenience.

The parentheses around Nothing in the local definition of showMarking for the Show Grid instance are unnecessary. You could also implement or replace showMarking with maybe "_" show. Why pattern match when you've got a handy higher order function?

Definitely add a comment to explain chop, it took me a moment to realize what it's doing (it's certainly very clever!).

Cleaning up getSeqs is a very interesting problem. The easiest portion is realizing that the back diagonals can be found by the same exact process as the forward diagonals if you just transform your matrix with map reverse. The next key step is realizing that if we can generate the full length (as opposed to k-length) diagonals, we can use chop again.

-- Find the main diagonal (↘) of a matrix
diagonal :: [[a]] -> [a]
diagonal []           = []
diagonal ((x:_):rows) = x : diagonal (map tail rows) -- 𝕄_0,0 : ↘ 𝕄(m-1 × n-1)

-- Find all ↘ diagonals of a matrix
diagonals :: [[a]] -> [[a]]
diagonals m =       map diagonal (init . tails $          m)  -- 𝚺(i=m  ,1) ↘ 𝕄(i×n)
           ++ tail (map diagonal (init . tails $ tranpose m)) -- 𝚺(j=n-1,1) ↘ 𝕄(m×j)

-- Thus (code fragment):
fdiag = concatMap (chop k) $ diagonals marks
bdiag = concatMap (chop k) $ diagonals (map reverse marks)

Don't use guards where pattern matching will do.

move i j (Game (Grid grid) m n k player Running)
    | validCoord i j = -- ...
    | otherwise      = Nothing
move _ _ _           = Nothing

I'm not sure that there are appreciable improvements left to make to move. You could use RecordWildCards and NamedFieldPuns, maybe record update notation, but I don't find it that bad to begin with.

Use even more do-notation in startGame to unify the Maybe handling, and extract the commonalities.

startGame :: Game -> IO ()
startGame game = do
    line <- getLine
    maybe retry next $ do
        (i, j) <- readMaybe line
        move i j game
  where
    retry = putStrLn "Invalid move. Please input a valid move." >> startGame game
    next newGame = do
        putStrLn $ show $ grid newGame
        case gameState newGame of
            Won a   -> putStrLn $ "Player " ++ show a ++ " won!"
            Draw    -> putStrLn   "It's a draw!"
            Running -> startGame newgame