Example of Haskell's state monad (after the Monday Morning Haskell blog post)

StateMonad.hs

module Main where

import qualified Control.Monad.State as M
import qualified Data.Array as A
import System.Random (StdGen, mkStdGen, randomR)


-- In a tic-tac-toe game, there is an 'X' player, and an 'O' player
data Player = PlayerO | PlayerX deriving (Eq, Show)

-- The index of a tile on a tic-tac-toe board is a pair (row, and column).
type TileIndex = (Int, Int)

-- The state of a tile on a tic-tac-toe board is that the
-- tile is empty, that it has an 'X' in it, or that it has an 'O' in it.
data TileState = Empty | HasO | HasX deriving (Eq, Show)

-- State of a tic-tac-toe game
data GameState = GameState
  { board :: A.Array TileIndex TileState
  , player :: Player
  , generator :: StdGen
  } deriving (Eq, Show)

-- A starting state for the game
startState :: GameState
startState = GameState
  { board = A.listArray ((0,0), (2,2)) (replicate 9 Empty)
  , player = PlayerO
  , generator = mkStdGen 143
  }

-- The state of the tile after a player writes their 'X' or 'O' in the tile.
playerMark :: Player -> TileState
playerMark PlayerO = HasO
playerMark PlayerX = HasX

-- Get the next player.
nextPlayer :: Player -> Player
nextPlayer PlayerO = PlayerX
nextPlayer PlayerX = PlayerO

-- This will randomly pick an empty tile in the game.
-- To do that, we need to use the random generator, which we've stored in
-- the game state (sensibly). Since this is Haskell, we use the generator
-- by generating a new generator when we use it, which we then stash
-- back in the program state. So, although the returned value of this
-- computation is a tile, we have in fact also updated the internal game
-- state (we have generated a new random number generator).
chooseEmptyTile :: M.State GameState TileIndex
chooseEmptyTile = do

  -- Retrieve the current game state, and call it 'game'.
  game <- M.get

  -- Get all the board indices that have no X or O in them (they're empty).
  let b = board game
  let empties = [ fst pair | pair <- A.assocs b, snd pair == Empty ]

  -- Get the random generator stored in our game state.
  let gen = generator game

  -- Generate a new generator (i.e., gen'), and
  -- pick one of the open spots (i.e., i).
  let (i, gen') = randomR (0, length empties - 1) gen

  -- Update our state with the new generator (i.e., gen').
  M.put (game { generator = gen' })

  -- In the open spots, pick the 'i' tile, and wrap it up in the
  -- monad. So, return the updated game state, with the selected tile
  -- and hence the type is 'M GameState TileIndex'
  return (empties !! i)

-- Given a tile on the board, apply the current player's move to it.
-- In other words, write that player's symbol on the tile, update
-- the board with this new tile, and then we're done.
applyMove :: TileIndex -> M.State GameState ()
applyMove i = do

  -- Retrieve the current game state.
  game <- M.get

  -- Get the current board state, the current player, from the game state.
  let b = board game
  let p = player game

  -- Add the current player's move to the board at the given tile index.
  let theMove = [(i, playerMark p)]
  let newBoard = b A.// theMove

  -- Get the next player
  let nextP = nextPlayer p

  -- Update the game state
  let newGame = game { board = newBoard, player = nextP }

  -- Stash the new state. There's no computed value here that we care
  -- to return, so we just return the state and unit, hence the return
  -- type of 'M.State GameState ()'.
  M.put newGame

-- Check if the game is done
isGameDone :: M.State GameState Bool
isGameDone = do

  -- Get the current game state.
  game <- M.get

  -- Get all open spots on the board.
  let b = board game
  let empties = [ fst pair | pair <- A.assocs b, snd pair == Empty ]

  -- Are there any empty spots left?
  let result = length empties == 0

  -- Return this computation (which is of type 'Bool'), along with the state.
  -- Hence, the type of this computation: 'M.State GameState Bool'
  return result

-- This will run one turn of the player, and see if we're done.
playTurn :: M.State GameState Bool
playTurn = do

  -- Randomly pick an empty tile.
  i <- chooseEmptyTile

  -- Have the current player write their mark on this tile.
  applyMove i

  -- Check if the game is done.
  isGameDone

playGame :: M.State GameState Bool
playGame = do
  isDone <- playTurn
  if isDone == False then playGame
  else return isDone

runTheGame :: (Bool, GameState)
runTheGame = M.runState playGame startState

main :: IO ()
main = do
  putStrLn "Running game..."
  let (_, state) = runTheGame
  putStrLn (show state)