2013-12-10-gloss.hs

import Control.Applicative
import Control.Concurrent (threadDelay, forkIO)
import Control.Concurrent.MVar (MVar, newMVar, tryTakeMVar, putMVar, newEmptyMVar)
import Control.Lens (ix, (.~))
import Control.Monad
import Data.Monoid ((<>), mconcat, mempty)
import Graphics.Gloss.Interface.IO.Game
import System.Random

data Play = X | O deriving Eq

type Board = [[Maybe Play]]

initialBoard :: Board
initialBoard = replicate 3 (replicate 3 Nothing)

--------------------------------------------------------------------------------
main :: IO ()
main = do
  aiMove <- newEmptyMVar

  playIO
    (InWindow "Tic-tac-toe" (1, 1) (500, 500))
    azure
    10
    (initialBoard, X)
    drawBoard
    (handleInput aiMove)
    (stepGame aiMove)

--------------------------------------------------------------------------------
drawBoard :: (Board, Play) -> IO Picture
drawBoard (board, _) = return (grid <> plays)
 where
  grid = 
    color black (line [ (-100, -300), (-100,  300) ]) <>
    color black (line [ ( 100, -300), ( 100,  300) ]) <>
    color black (line [ (-300,  100), ( 300,  100) ]) <>
    color black (line [ (-300, -100), ( 300, -100) ])

  plays = mconcat
    [ translate (fromIntegral $ (x - 1) * 200)
                (fromIntegral $ (y - 1) * 200) $
        case play of
          X -> color white (thickCircle 1 50)
          O -> color black (thickCircle 1 50)
    | x <- [0..2]
    , y <- [0..2]
    , Just play <- [ (board !! x) !! y ]
    ]

--------------------------------------------------------------------------------
handleInput :: MVar Board -> Event -> (Board, Play) -> IO (Board, Play)
handleInput aiMove (EventKey (MouseButton LeftButton) Up _ (x, y)) (board, X) =
    let snap = (+1) . min 1 . max (-1) .
                 fromIntegral . floor . (/ 100) . (+ 50)
        gridX = snap x
        gridY = snap y
        
    in case (board !! gridX) !! gridY of
      -- Someone has already played here, try again!
      Just _ -> return (board, X)
   
      -- It's a valid move, update the board and let the AI
      -- play
      Nothing -> do
        let newBoard = (ix gridX . ix gridY .~ (Just X)) board
   
        forkAi aiMove newBoard
        return (newBoard, O)

handleInput _ _ (board, play) = return (board, play)

--------------------------------------------------------------------------------
forkAi :: MVar Board -> Board -> IO ()
forkAi aiMove board = void $ forkIO $ do
  -- Pause while we think what to do
  randomRIO (100000, 1000000) >>= threadDelay

  -- Choose a random move
  let plays = [ (ix x . ix y .~ Just O) board
              | x <- [0..2]
              , y <- [0..2]
              , Nothing <- [ (board !! x) !! y ]
              ]

  case plays of
    [] -> do
      -- There are no more moves!
      putMVar aiMove board

    _ -> do
      -- Respond with the move chosen at random
      newBoard <- (plays !!) <$> randomRIO (0, length plays - 1)
      putMVar aiMove newBoard


--------------------------------------------------------------------------------
stepGame :: MVar Board -> Float -> (Board, Play) -> IO (Board, Play)
stepGame aiMove _ (board, O) =
  tryTakeMVar aiMove >>=
    return .
      maybe (board, O)
            (\newBoard -> (newBoard, X))

stepGame _ _ state = return state