later edit: I made certain changes to my code. If you are curious, see Link

Here is my implementation with Gloss.

• Is the best way to implement the scorePosition using the state monad? See Line 63 in Position.hs
• In general, is there a better way to implement the mechanism to pick the next move?
• Is there a better way to implement the main UI loop in GlossUI.hs? Or is the way of marking explicit points in the state space the best way?
• Is it a better idea to define the board in some other way in Board.hs?
• Anything else that is worth changing?

Here is my implementation with Gloss.Gist Link for convenience

module Board where
import Data.Map (Map, (!))
import qualified Data.Map as Map
import Data.List (intercalate)
data Player = X | O
 deriving (Eq, Ord, Show)
newtype Board = Board (Map (Int, Int) (Maybe Player))
 deriving (Eq, Ord)
initBoard :: Board
initBoard = Board $ Map.fromList [((x, y), Nothing) | x <- [0..2], y <- [0..2]]
getMark :: Board -> (Int, Int) -> Maybe Player
getMark (Board board) (x, y)
 | x < 0 || x > 2 || y < 0 || y > 2 = error "Invalid coordinates"
 | otherwise = board ! (x, y)
putMark :: Board -> Player -> (Int, Int) -> Maybe Board
putMark (Board board) player (x, y)
 | x < 0 || x > 2 || y < 0 || y > 2 = error $ "Invalid coordinates" ++ show (x, y)
 | board ! (x, y) /= Nothing = Nothing
 | otherwise = Just $ Board $ Map.insert (x, y) (Just player) board
emptySquares :: Board -> [(Int, Int)]
emptySquares (Board board) = [(x, y) | x <- [0..2], y <- [0..2], board ! (x, y) == Nothing]
instance Show Board where
 show (Board board) = 
 intercalate "\n- - - \n" 
 [ ( intercalate "|" [prettyShow $ board ! (x, y) | y <- [0..2]] ) 
 | x <- [0..2]]
 where
 prettyShow Nothing = " "
 prettyShow (Just X) = "X"
 prettyShow (Just O) = "O"
allX :: Board
allX = Board $ Map.fromList [((x, y), Just X) | x <- [0..2], y <- [0..2]]
allO :: Board
allO = Board $ Map.fromList [((x, y), Just O) | x <- [0..2], y <- [0..2]]

module Position where
import Control.Applicative
import Control.Monad.State
import Data.Maybe 
import Data.Map (Map)
import Data.List (minimumBy)
import qualified Data.Map as Map
import Board 
data Position = Position { curBoard :: Board, curPlayer :: Player }
 deriving (Eq, Ord, Show)
type Line = [(Int, Int)]
winningLines :: [Line]
winningLines = [ [(x, y) | x <- [0..2]] | y <- [0..2]] ++ -- vertical lines
 [ [(x, y) | y <- [0..2]] | x <- [0..2]] ++ -- horizontal lines
 [[(0, 0), (1, 1), (2, 2)], -- main diagonal
 [(0, 2), (1, 1), (2, 0)]] -- off diagonal 
lineWinner :: Board -> Line -> Maybe Player
lineWinner b l
 | all (== Just X) marks = Just X
 | all (== Just O) marks = Just O
 | otherwise = Nothing 
 where 
 marks = map (getMark b) l 
boardWinner :: Board -> Maybe Player
boardWinner b = foldr (<|>) Nothing $ map (lineWinner b) winningLines
nextPlayer :: Player -> Player
nextPlayer X = O
nextPlayer O = X
succPositions :: Position -> [Position]
succPositions (Position b p) = newPosition . fromJust . markSquare <$> (emptySquares b)
 where
 newPosition b' = Position { curBoard = b', curPlayer = nextPlayer p }
 markSquare = putMark b p
isDraw :: Board -> Bool
isDraw b = null (emptySquares b) && isNothing (boardWinner b)
data Label = Win | Lose | Draw
 deriving (Show, Eq)
data Score = Score { label :: Label, height :: Int }
 deriving (Show, Eq)
instance Ord Score where
 (Score Win i) <= (Score Win j) = i >= j
 (Score Win _) <= _ = False
 (Score Lose i) <= (Score Lose j) = i <= j
 (Score Lose _) <= _ = True
 (Score Draw i) <= (Score Draw j) = i >= j
 (Score Draw _) <= (Score Win _) = True 
 (Score Draw _) <= (Score Lose _) = False
type KnowledgeBase = Map Position Score
scorePosition :: Position -> State KnowledgeBase Score
scorePosition pos@(Position b p)
 | isDraw b = pure $ Score { label = Draw, height = 0 }
 | (boardWinner b) == Just p = pure $ Score { label = Win, height = 0 }
 | Just _ <- (boardWinner b) = pure $ Score { label = Lose, height = 0 }
scorePosition pos@(Position b p) = 
 do
 knowledge <- gets (Map.lookup pos)
 case knowledge of
 Just s -> return s
 Nothing -> do
 let nextPositions = succPositions pos
 nextScores <- mapM scorePosition nextPositions
 let bestSuccScore = minimum nextScores
 let score = curScore bestSuccScore
 modify (Map.insert pos score)
 return score
bestResponse :: Position -> State KnowledgeBase Position
bestResponse pos@(Position b p) = 
 do
 let nextPositions = succPositions pos
 nextScores <- mapM scorePosition nextPositions
 let bestSucc = snd $ minimumBy (\(s1, p1) (s2, p2) -> compare s1 s2) $ zip nextScores nextPositions
 return bestSucc
-- given the minimum score among the successors,
-- compute the current score
curScore :: Score -> Score
curScore (Score Win i) = Score Lose (i + 1)
curScore (Score Lose i) = Score Win (i + 1)
curScore (Score Draw i) = Score Draw (i + 1)

module GlossUI where
import Data.Map (Map)
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.State
import Control.Applicative
import Graphics.Gloss
import Graphics.Gloss.Interface.Pure.Game
import Debug.Trace
import Board
import Position
-- copying some code from https://gist.github.com/gallais/0d61677fe97aa01a12d5
data GameState = GameState {
 pos :: Position
 , kb :: KnowledgeBase
 , playersTurn :: Bool
 , needToEval :: Bool
 }
 deriving Show
type Size = Float
resize :: Size -> Path -> Path
resize k = fmap (\ (x, y) -> (x * k, y * k))
drawO :: Size -> (Int, Int) -> Picture
drawO k (i, j) =
 let x' = k * (fromIntegral j - 1)
 y' = k * (1 - fromIntegral i)
 in color (greyN 0.8) $ translate x' y' $ thickCircle (0.1 * k) (0.3 * k)
drawX :: Size -> (Int, Int) -> Picture
drawX k (i, j) =
 let x' = k * (fromIntegral j - 1)
 y' = k * (1 - fromIntegral i)
 in color black $ translate x' y' $ Pictures
 $ fmap (polygon . resize k)
 [ [ (-0.35, -0.25), (-0.25, -0.35), (0.35,0.25), (0.25, 0.35) ]
 , [ (0.35, -0.25), (0.25, -0.35), (-0.35,0.25), (-0.25, 0.35) ]
 ]
drawBoard :: Size -> Board -> Picture
drawBoard k b = Pictures $ grid : markPics where
 markPics = [drawAt (i, j) (getMark b (i, j)) | i <- [0..2], j <- [0..2]]
 drawAt :: (Int, Int) -> (Maybe Player) -> Picture
 drawAt (_, _) Nothing = Blank
 drawAt (i, j) (Just X) = drawX k (i, j)
 drawAt (i, j) (Just O) = drawO k (i, j)
 grid :: Picture
 grid = color black $ Pictures $ fmap (line . resize k)
 [ [(-1.5, -0.5), (1.5 , -0.5)]
 , [(-1.5, 0.5) , (1.5 , 0.5)]
 , [(-0.5, -1.5), (-0.5, 1.5)]
 , [(0.5 , -1.5), (0.5 , 1.5)]
 ]
checkCoordinateY :: Size -> Float -> Maybe Int
checkCoordinateY k f' =
 let f = f' / k
 in 2 <$ guard (-1.5 < f && f < -0.5)
 <|> 1 <$ guard (-0.5 < f && f < 0.5)
 <|> 0 <$ guard (0.5 < f && f < 1.5)
checkCoordinateX :: Size -> Float -> Maybe Int
checkCoordinateX k f' =
 let f = f' / k
 in 0 <$ guard (-1.5 < f && f < -0.5)
 <|> 1 <$ guard (-0.5 < f && f < 0.5)
 <|> 2 <$ guard (0.5 < f && f < 1.5)
getCoordinates :: Size -> (Float, Float) -> Maybe (Int, Int)
getCoordinates k (x, y) =
 (,) <$> checkCoordinateY k y <*> checkCoordinateX k x
gameUpdate' :: Size -> Event -> GameState -> GameState
gameUpdate' _ e gs
 | playersTurn gs == False || needToEval gs = gs
gameUpdate' k (EventKey (MouseButton LeftButton) Down _ (x', y')) gs =
 let newBoard = do 
 (i, j) <- getCoordinates k (x', y')
 putMark (curBoard $ pos gs) (curPlayer $ pos gs) (i, j)
 in case newBoard of
 Nothing -> gs
 Just b' -> gs { pos = Position { 
 curBoard = b'
 , curPlayer = nextPlayer (curPlayer $ pos gs) 
 }
 , playersTurn = False
 , needToEval = True
 }
gameUpdate' _ _ gs = gs
gameTime :: Float -> GameState -> GameState
-- let the player move
gameTime _ gs
 | playersTurn gs && not (needToEval gs) = gs
-- check if player has won
gameTime t gs
 | (needToEval gs) =
 case (boardWinner $ curBoard $ pos gs) of
 Just X -> gs { pos = (pos gs) { curBoard = allX } }
 Just O -> gs { pos = (pos gs) { curBoard = allO } }
 Nothing -> gs { needToEval = False }
-- make computers move
gameTime _ gs =
 let (pos', kb') = runState (bestResponse $ pos gs) (kb gs)
 in GameState {pos = pos', kb = kb', playersTurn = True, needToEval = True}
initGameState :: GameState
initGameState = 
 GameState {
 pos = Position {
 curBoard = initBoard
 , curPlayer = X
 }
 , kb = Map.empty
 , playersTurn = True
 , needToEval = False
 }
main :: IO ()
main =
 let window = InWindow "Tic Tac Toe" (300, 300) (10, 10)
 size = 100.0
 in play 
 window 
 white 
 1 
 initGameState
 (\ gs -> drawBoard size $ curBoard $ pos gs) 
 (gameUpdate' size) 
 gameTime

• Is the best way to implement the scorePosition using the state monad? See [Line 63 in Position.hs]
• In general, is there a better way to implement the mechanism to pick the next move?
• Is there a better way to implement the main UI loop in GlossUI.hs? Or is the way of marking explicit points in the state space the best way?
• Is it a better idea to define the board in some other way in Board.hs?
• Anything else that is worth changing?