Othello AI in Haskell

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
        redLeading = redCount > blueCount
        blueLeading = blueCount > redCount

        (redCount, blueCount) = pieceCount board

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

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

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 }

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

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 :: Int
centreAdjustmentX = -1 * (resolutionX `div` 2)
centreAdjustmentY :: Int
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
 -- Radius of the circle
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