Devising game AIs can be fun and educational for programmers of all skill levels. What if.. we did it in Haskell this time? 👉👈

This post was originally published in its initial form in 2017. This latest version has been extended and updated with new information. Nevertheless, being one of my first blog posts ever, it is a product of its time and I should not be mistaken for a professional Haskell developer ;)

## Prelude

I’m certain many of the readers play, or have played at least one board game against a computer AI. However, it isn’t nearly as common to consider how the AI has been implemented. What exactly makes them tick?

It is surprisingly easy to build a simple yet possibly quite powerful AI. Depending on the game, even such a naïve strategy as brute force can be surprisingly effective. Brute forcing in game AI essentially means calculating all possible turns to the end (or at least to a sufficiently distant future).

However, this only works on games where the average amount of choices per turn is reasonably small (in other words, the branching factor for the game tree is small enough). In other games, the branching factor can grow so high as to render a brute force strategy unviable - examples include Go with 2501, and Arimaa with staggering 17,2812 average possibilities per turn!

The game we’re examining in this particular post has the branching factor of approximately 10, a much more reasonable value. And it is…

## Othello!

Before we get started, a simplified primer on rules3

1. Game is set on a 8x8 grid. Two colors of pieces are used (in this example, red and blue)
2. Initial state is with red discs on d5, e4, and blue discs on d4, e5 (assuming notation where letter indicates the column, number the row)
3. Players take turns placing discs on the board. For a placement to be valid, it must trigger a flip of at least one opponent’s disc. If no such moves can be valid, the player skips their turn. If possible, a move must be made.
4. A flip is triggered by “sandwiching” opponent’s discs between your newly placed disc and any existing disc of your color in a horizontal, vertical or a diagonal row, with no gaps. All discs matching this criteria must be flipped.
5. The game ends once the board has been completely filled, or neither player can make a valid move. The winner of the game is the one with more discs of their color on the board - if amounts match, game is a draw.

I’ll be showing you steps implementing a simple single-player (you vs AI) variant of the game with these rules. In particular, we’ll be implementing a minimax AI - aim for the maximum score for AI, minimum for the opposing player. Some familiarity with Haskell basics will be assumed.

## Time to code

### Environment

Initialize a new project via a method of your choice; for this example, Cabal as is has been used, but one should also consider Stack for its benefits

We will also require gloss and array as dependencies for the library part of the project; former for graphics, latter for elegant 2-dimensional arrays

Something like this:

1
2
library
build-depends:  base ^>=4.14.3.0, gloss >= 1.13.2.2, array >= 0.5.4.0


### AI and game logic

We’ll start by declaring a single module, Othello.GameLogic, which will contain primary game logic and types

#### Data types

##### Things to look for
• Observe language extensions declared at the top of the file. These add useful new syntactical constructs to baseline Haskell, and can be quite useful
• Derivation can be done for several common typeclasses, and is useful for reducing boilerplate code
• A custom score type has been declared for conveniently defining win/loss as values above/below any numeric score value. For ordering (requisite for sorting to take place), Ord instance has been defined
##### Code
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
{-#LANGUAGE InstanceSigs#-} -- Permit type declarations in instance definitions
{-# LANGUAGE TupleSections #-} -- Partial tuple constructors as functions
{-# LANGUAGE NamedFieldPuns #-} -- Allow more elegant construction of data

module Othello.GameLogic where
import Data.Array ( Array, array, elems, inRange, bounds, (//) )
import qualified Data.Array ((!))
import Data.Foldable (maximumBy, minimumBy)

-- Score is an integer, and coordinate is a pair of integers
type UnitScore = Int
type Coordinate = (Int, Int)

-- A player is either Red, or Blue. Derive comparison and Show
data Player = Red | Blue deriving (Eq, Show)

-- Each spot on a board is either empty, or placed with some player
data DiscState = Empty | Placed Player deriving (Eq, Show)

-- Board is essentially a grid of disc states, with the size attached
data Board = Board {
grid :: Array Coordinate DiscState,
boardDim :: Int
} deriving (Show)

-- For purposes of Minimax AI, we will need to measure the score of a given state. It will be either a win, indeterminate with score of some kind (from the view of who is requesting it), or a loss
data BoardScore = Win | Indeterminate UnitScore | Lose deriving (Eq, Show)

-- Define a order for a board score. For least complexity, define ordering as a set of comparative properties between different scores
instance Ord BoardScore where
(<=) :: BoardScore -> BoardScore -> Bool
(<=) Lose _ = True -- Lose is the smallest and definitely equal
(<=) (Indeterminate _) Lose = False -- Indeterminate is never less or equal to a win
(<=) (Indeterminate _) Win = True -- Indeterminate is always less than a win
(<=) (Indeterminate a) (Indeterminate b) = a <= b -- For two indeterminates, their respective ordering depends on their scores
(<=) Win Win = True -- Win is equal with a win
(<=) Win _ = False -- Otherwise, no

-- Define a scoring function; given a player and a board, what is their score?
score :: Player -> Board -> BoardScore
score player board
| not (movesPossibleOnBoard board) && redLeading = if player == Red then Win else Lose
| not (movesPossibleOnBoard board) && blueLeading = if player == Blue then Win else Lose
| otherwise = Indeterminate (if player == Red then redCount else blueCount)
where

(redCount, blueCount) = pieceCount board

data GameSetup = GameSetup {
board :: Board, -- Board
aiPlays :: [Player], -- Which turns AI plays?
searchDepth :: Int -- Search depth
} deriving (Show)


#### Basic functions

##### Things to look for
• Observe @ for assigning a name to a pattern-matched parameter as a whole. It is very useful for cases where no alterations to the data itself need to be made
• Infix operators can be declared; here they are used for accessors and checking for index validity
• Do not forget that Haskell functions are curried. This allows for convenient transformation definitions, if two functions have substantially similar parameters they expect. Look at comprehensionByBoard
##### Code
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
-- Count of pieces, per color, for the board
pieceCount :: Board -> (Int, Int)
pieceCount board = foldr adder (0,0) (elems $grid board) -- Add element by element, start with zero scores for both where adder :: DiscState -> (Int, Int) -> (Int, Int) adder state count@(red, blue) = case state of Empty -> count Placed Red -> (red+1, blue) Placed Blue -> (red, blue+1) -- Definition of the opposing player for a given player opposingPlayer :: Player -> Player opposingPlayer Red = Blue opposingPlayer Blue = Red -- Calculating which player is winning by their score; this does not consider if there are more turns remaining playerWithBestScore :: Board -> Maybe Player playerWithBestScore board | red == blue = Nothing | otherwise = if red > blue then Just Red else Just Blue where (red, blue) = pieceCount board -- Define an indexing operation for a board, quite alike what Arrays have (!) :: Board -> Coordinate -> DiscState board ! coordinate = (Data.Array.!) (grid board) coordinate -- Define a validity check operator for indexes; this will return true if the index is acceptable (!?) :: Board -> Coordinate -> Bool board !? coord = inRange (bounds$ grid board) coord

-- Define a grid comprehension function; mapping over coordinates of a grid, construct some array of data
comprehensionByBoard :: Board -> (Coordinate -> x) -> [x]
comprehensionByBoard board = comprehensionByDim size
where
size = boardDim board

comprehensionByDim :: Int -> (Coordinate -> x) -> [x]
comprehensionByDim size func = [ func (a,b) | a <- [0..size-1], b <- [0..size-1]]

initialGameState :: Int -> [Player] -> Int -> GameSetup
initialGameState dim aiPlays searchDepth = GameSetup { aiPlays, searchDepth, board }
where
board = Board { boardDim = dim, grid = array ((0, 0), (dim-1,dim-1)) (comprehensionByDim dim (\p -> (p, startPieces p))) }

startPieces :: Coordinate -> DiscState
startPieces (cx,cy)
| cx == dim div 2-1 && cy == dim div 2-1 = Placed Blue
| cx == dim div 2 && cy == dim div 2 = Placed Blue
| cx == dim div 2-1 && cy == dim div 2 = Placed Red
| cx == dim div 2 && cy == dim div 2-1 = Placed Red
| otherwise = Empty



#### Move logic

##### Things to look for
• Observe the usage of a self-recursive function to walk through the grid, and once a suitable condition is found, either returning what was walked on (acceptable move) or returning nothing (unacceptable move)
• Applying a move then is quite straightforward - take the list of coordinates returned, and to each assign a placed value in player’s color
##### Code
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
-- For a given board, player and coordinate, determine what coordinates should be changed to player's color. If an empty list is returned, move is not valid
-- This also includes the starting point given
getMovesOnPoint :: Board -> Player -> Coordinate -> [Coordinate]
getMovesOnPoint board player startCoord@(sx, sy)
| not (board !? startCoord) = [] -- Coordinate is not a valid position
| startPiece /= Empty = [] -- Starting piece is not empty
| null resultSteps = [] -- No valid steps exist
| otherwise = startCoord : resultSteps
where
resultSteps = concatMap walkAndMark directions -- Valid steps are a concatenation of walked directions - per rules, we can and must mark all branched paths

walkAndMark :: Coordinate -> [Coordinate] -- If stepping from a given direction, what can we mark (excluding start position)?
walkAndMark dir@(dx, dy) = walkAndMark' (sx+dx, sy+dy) dir []

walkAndMark' :: Coordinate -> Coordinate -> [Coordinate] -> [Coordinate] -- Current position, direction, found already
walkAndMark' cur@(cx, cy) dir@(dx, dy) found
| isEndPiece = found -- End piece, terminate here
| isValidTraversalPiece = walkAndMark' (cx+dx, cy+dy) dir (cur:found) -- Can traverse, step forward
| otherwise = [] -- No valid way to travel nor end, return nothing
where
isEndPiece = isValidPos && (board ! cur) == Placed player
isValidTraversalPiece = isValidPos && (board ! cur) == Placed (opposingPlayer player)
isValidPos = board !? cur

directions = [(-1,-1), (-1,0), (-1,1), (0,-1), (0,1), (1,-1), (1,0), (1,1)] -- Which directions need to be checked. As defined in the rules, we work on either horizontal, vertical or diagonal lines
startPiece = board ! startCoord

movesForPlayer :: Board -> Player -> [[Coordinate]]  -- Return all movesets that are nonempty, for a given player?
movesForPlayer board player = filter (not . null) mappedCoords
where
mappedCoords = comprehensionByBoard board (getMovesOnPoint board player)

movesPossibleOnBoard :: Board -> Bool -- Are there any moves possible on board?
movesPossibleOnBoard board = not (null (movesForPlayer board Red) && null (movesForPlayer board Blue))

applyMove :: Board -> Player -> [Coordinate] -> Board
applyMove board player moveList = board { grid = grid board // map (, Placed player) moveList }


#### AI

##### Algorithm graph

Before proceeding, please observe this graph.

This graph attempts to visualize the logic used by the AI, assuming we are trying to get the ideal move for the red player. As Red aims to win the game, they want the move with the largest score as the end result. However, knowing their opponent would rather prefer they win, it is assumed that Blue, given multiple choices, will always pick the move with smallest score from Red’s point of view.

As such, we end up with the move resulting in 8 as the score - we cannot reach the one with WIN as Blue will put stop to such an attempt, and we certainly will not want a move resulting in guaranteed LOSS.

##### Code
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
getAIMove :: GameSetup -> Player -> [Coordinate] -- Determine the best move for AI; it is assumed some move will exist for the targeted player
getAIMove gameSetup' targetPlayer' = fst $maximumBy boardScoreTupleComparer$ map (\coord -> (coord, getAIMoveScore (applyMove (board gameSetup') targetPlayer' coord) targetPlayer' (searchDepth gameSetup') True)) (movesForPlayer (board gameSetup') targetPlayer')
where
boardScoreTupleComparer :: ([Coordinate], BoardScore) -> ([Coordinate], BoardScore) -> Ordering
boardScoreTupleComparer = \a b -> compare (snd a) (snd b)
-- Helper function for ideality - maximal score for maximizing, minimal score for minimizing
idealBy' :: Ord s => Bool -> (s -> s -> Ordering) -> [s] -> s
idealBy' maximize fn set = ordering fn set
where
ordering = if maximize then maximumBy else minimumBy

getAIMoveScore :: Board -> Player -> Int -> Bool -> BoardScore -- Board, player to search moves for, allowed further search depth (recursion steps allowed), maximize (true)/minimize (false) - returns the calculated score which this move should result in ideal circumstances, from the viewpoint of the *maximizing* player
getAIMoveScore board targetPlayer searchDepth maximize
| searchDepth == 0 || not (movesPossibleOnBoard board) = -- Ran out of search depth, or is there a case that no moves are just possible anymore?
if maximize then score targetPlayer board else getAIMoveScore board (opposingPlayer targetPlayer) 0 True -- If we are maximizing, return score as we currently have it - otherwise, shift to maximization
| null possibleMoves = getAIMoveScore board (opposingPlayer targetPlayer) searchDepth (not maximize) -- No possible moves for us, but other party has some? Skip over to next step - as this doesn't branch, do not reduce search depth
| otherwise = snd
$idealBy boardScoreTupleComparer$ map (\coord -> (coord, getAIMoveScore (applyMove board targetPlayer coord) (opposingPlayer targetPlayer) (if length possibleMoves > 1 then searchDepth - 1 else searchDepth) (not maximize))) possibleMoves
-- Otherwise, select the ideal (either minimum or maximum) score for the player, as judged by nested scores (calculated for opposing players and max/min). This is always guaranteed to return the best possible path for the maximizing player, assuming the opponent will try their best to negate it
where
idealBy :: Ord s => (s -> s -> Ordering) -> [s] -> s
idealBy = idealBy' maximize
possibleMoves = movesForPlayer board targetPlayer


### UI

#### Things to look for

• Many of the parameters have been set as constants. A more advanced game perhaps could let them to be user-configured - but that is out of scope for this small project
• A substantial part of the code is dealing with GLOSS’s origin-based coordinates. This is (a bit unfortunately) an intristic characteristic of the library, so no easier way to do it
• The unusual case () of _ is actually mentioned in the Haskell wiki

#### Code

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
module Main where

import Othello.GameLogic (GameSetup (..), Player (..), initialGameState, Coordinate, DiscState (..), movesPossibleOnBoard, playerWithBestScore, movesForPlayer, Board (..), comprehensionByBoard, opposingPlayer, applyMove, getMovesOnPoint, getAIMove)
import Graphics.Gloss
-- We need access to events, so we use the game mode.
import Graphics.Gloss.Interface.Pure.Game
import GHC.Arr (assocs)

-- The resolution of the window
resolutionX :: Int
resolutionX = 800
resolutionY :: Int
resolutionY = 800

-- As the rendering is from the centre, in what way the coordinates should be translated to return them back to left lower edge-based positioning
centreAdjustmentX = -1 * (resolutionX div 2)
centreAdjustmentY = -1 * (resolutionY div 2)

gridAbsoluteLeftX :: Int
gridAbsoluteLeftX = 100 -- From left edge
gridAbsoluteLeftY :: Int
gridAbsoluteLeftY = 100 -- From bottom
gridBoxSize :: Int
gridBoxSize = 75 -- How large a single square is?

circleSize :: Float
circleSize = 20

-- From which coordinate the text is rendered, X
textBottomLeftX :: Float
textBottomLeftX = 50
-- From which coordinate the text is rendered, Y
textBottomLeftY :: Float
textBottomLeftY = 100

-- Assumed grid size for UI and state construction purposes
gameGridSize :: Int
gameGridSize = 8

data GameWorld = World {
worldSetup :: GameSetup, -- Current game state
playerTurn :: Player, -- Whose turn it is
passedOnLastTurn :: Bool, -- Was there a pass on the last turn?
bothStalled :: Bool, -- Has the game stalled, AKA two passes in a row, meaning game over
ticks :: Float -- Ticks counter to count how long to wait until AI kicks into action
}

-- Declare an initial world, starting on Red, no passes or stall and starting at zero ticks.
initialWorld = World (initialGameState gameGridSize [Blue] 4) Red False False 0.0

-- Try to locate the coordinates the mouse did click. If available, return Just it, otherwise Nothing
getClickTarget :: (Float, Float) -> Maybe Coordinate
getClickTarget (clickX, clickY)
| dividedX < 0 || dividedX >= gameGridSize = Nothing -- Invalid coordinates
| dividedY < 0 || dividedY >= gameGridSize = Nothing

| otherwise = Just (dividedX, dividedY)

where
-- As GLOSS uses center-based coordinates, we need to translate them to start from left, bottom origin
translatedClickX :: Int
translatedClickX = round clickX - centreAdjustmentX - gridAbsoluteLeftX
translatedClickY :: Int
translatedClickY = round clickY - centreAdjustmentY - gridAbsoluteLeftY

-- dividedX, dividedY should directly correspond to grid coordinates
dividedX :: Int
-- Div is an integer division; Haskell is remarkably strict about types, so we need to explicitly accept the loss of precision associated
dividedX = translatedClickX div gridBoxSize

dividedY :: Int
dividedY = gameGridSize-1 - translatedClickY div gridBoxSize

-- Rendering is a bit tricky, as the render is centered to the center of the window and not to the sides! Adjustment calculations need to be made
renderWorld :: GameWorld -> Picture
renderWorld world = Translate (fromIntegral centreAdjustmentX) (fromIntegral centreAdjustmentY) (Pictures (concat [boardRender, gridList, [textRender]])) where

playerWithBestScoreText :: Maybe Player -> String
playerWithBestScoreText (Just Red) = "Red wins"
playerWithBestScoreText (Just Blue) = "Blue wins"
playerWithBestScoreText Nothing = "Draw"

-- Text render, for status text
textRender = Scale 0.15 0.15 (Translate textBottomLeftX textBottomLeftY $Color white (Text ( case () of _ | not (movesPossibleOnBoard (board$ worldSetup world)) -> playerWithBestScoreText (playerWithBestScore (board $worldSetup world)) | null (movesForPlayer (board$ worldSetup world) (playerTurn world)) -> "No possible positions for you, " ++ show (playerTurn world) ++ ", passing"
| playerTurn world == Blue -> "Turn for Blue"
| playerTurn world == Red -> "Turn for Red"
| otherwise -> ""
)))

-- Board state, essentially grid
boardRender = [uncurry Translate (gridPosForAssoc placedButton) $Color (colorForAssoc placedButton) (Circle circleSize) | placedButton <- placedButtons] where gridPosForAssoc :: (Coordinate, DiscState) -> (Float, Float) gridPosForAssoc assoc = (actualX, actualY) where (coordX, coordY) = fst assoc actualX :: Float actualX = fromIntegral$ gridAbsoluteLeftX + (coordX*gridBoxSize + gridBoxSize div 2)
actualY :: Float
actualY = fromIntegral $gridAbsoluteLeftY + ((gameGridSize-1-coordY)*gridBoxSize + gridBoxSize div 2) colorForAssoc :: (Coordinate, DiscState) -> Color colorForAssoc assoc = if snd assoc == Placed Red then red else blue placedButtons = filter (\asc -> snd asc /= Empty) (assocs (grid$ board $worldSetup world)) -- List comprehension to form the drawings for the grid gridDrawingFunction (gridX, gridY) = whiteBox (fromIntegral$ gridAbsoluteLeftX+gridBoxSize*gridX,fromIntegral $gridAbsoluteLeftY + gridBoxSize*gridY) (fromIntegral$ gridAbsoluteLeftX+gridBoxSize*(gridX+1),fromIntegral $gridAbsoluteLeftY+gridBoxSize*(gridY+1)) gridList = (comprehensionByBoard$ board $worldSetup world) gridDrawingFunction -- A helper function for rendering a white box whiteBox startPoint endPoint = Color white (Line points) where (endX, endY) = endPoint (startX, startY) = startPoint points = [(startX, startY), (endX, startY), (endX, endY), (startX, endY), (startX, startY)] -- Handle events taking place on the game world; this is essentially mouse handling only here handleEvent :: Event -> GameWorld -> GameWorld handleEvent (EventKey (MouseButton RightButton) Down _ _) _ = initialWorld handleEvent (EventKey (MouseButton LeftButton) Down _ clickPos) world -- Both players have passed, so the game's over | bothStalled world = world -- AI plays this turn | playerTurn world elem aiPlays (worldSetup world) = world -- No valid position | Nothing <- possibleClickPos = world -- We have a position, evaluate it | Just coordinate <- possibleClickPos = evaluatePlayerTurn world coordinate where evaluatePlayerTurn :: GameWorld -> Coordinate -> GameWorld evaluatePlayerTurn world coord -- No valid moves | null moveOnPoint = world -- Apply a move and change the turn to the opposing player; also reset any pass counters and the ticker | otherwise = World (setup {board = appliedBoard}) (opposingPlayer (playerTurn world)) False False 0 where setup = worldSetup world appliedBoard = applyMove (board$ worldSetup world) (playerTurn world) moveOnPoint
moveOnPoint = getMovesOnPoint (board \$ worldSetup world) (playerTurn world) coord
possibleClickPos = getClickTarget clickPos
-- Rest do not affect the world
handleEvent _ world = world

-- Timer ticks, some actions cause an intentional delay which is handled here
timerTick :: Float -> GameWorld -> GameWorld
timerTick tick_diff world@(World setup turn passedOnLast bothStalled curTicks)
| tick_diff+curTicks < 1.0 = world { ticks = curTicks+tick_diff}
| otherwise = evaluateTickTurn
where
evaluateTickTurn
-- Both have stalled, do not do anything
| bothStalled = tickResetWorld
-- Pass, unable to make a turn
| null (movesForPlayer (board setup) turn) = World setup (opposingPlayer turn) True passedOnLast 0
-- AI does not play this turn
| turn notElem aiPlays setup = tickResetWorld
-- AI plays this turn and resets the ticks
| otherwise = World (setup {board = applyMove (board setup) turn aiTurn}) (opposingPlayer turn) False False 0

-- No changes apart from the ticks resetting to zero, adding a delay
tickResetWorld = world { ticks = 0 }

-- AI turn
aiTurn = getAIMove setup turn

main = play -- This program is a GLOSS game..
(InWindow "Haskell Othello" (resolutionX,resolutionY) (20,20)) -- In a window of a suitable size
black -- With a black background
24 -- 24fps
initialWorld -- Initial state
renderWorld -- Render images using renderWorld
handleEvent -- Handle events using handleEvent
timerTick -- Timer effects via timerTick


## Conclusion

You should, finally, get something like this

And that’s it! You’ve followed along, and now you have a working Othello AI. If you wish to evolve it, consider these

• Would it perhaps be possible to utilize memoization or some other optimization (e.g. alpha-beta pruning). It could improve performance and power of the AI
• What happens if you “cross the wires”, and make the AI play as poorly as possible (hint: it is easier than you might think)? How does that look?
• What other extensions could be devised? We currently assume a pure world, but what if we, say, brought network I/O into mix? Online multiplayer, perhaps?

A full copy of work is available to download as a ZIP file