{-
The MIT License
Copyright (c) 2010 Korcan Hussein.
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
-}
module Main where
import Prelude hiding (init)
import System.Environment
import System.Console.GetOpt
--import Data.Word
import Data.List hiding (init)
import Control.Monad
import Control.Monad.Trans
import Control.Exception
import Graphics.UI.SDL hiding (init, quit, flip)
--import qualified Graphics.UI.SDL as SDL (init, quit, flip)
import Graphics.UI.SDL.TTF hiding (init, quit)
import qualified Graphics.UI.SDL.TTF as TTFG (init, quit)
import Surface
import Grid
import GameState hiding (playerType, screen, font, winner, playerStart)
import GameEnv
import Draw
import Paths_HTicTacToe
type ProgramOptions = (PlayerTurn,TileType)
parseArgs :: IO (ProgramOptions, [String])
parseArgs = do
argv <- getArgs
case getOpt Permute options argv of
(o,n,[] ) -> return (foldl' (flip id) defaultOptions o, n)
(_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo header options
where header = "Usage: start player"
defaultOptions = (Player, Cross)
options :: [OptDescr (ProgramOptions -> ProgramOptions)]
options = [Option ['s'] ["start"] (ReqArg (\str (_,p) -> (pStart str, p)) "PlayerStart") "which players starts \"Player\" or \"Ai\" (default is \"Player\")",
Option ['p'] ["player"] (ReqArg (\str (s,_) -> (s, pType str)) "PlayerType") "player is \"x\" or \"o\" (default is \"x\")"]
--playerStart = Player
pType "o" = Nought
pType "O" = Nought
pType _ = Cross -- default playerType.
pStart "Ai" = Ai
pStart _ = Player -- default playerStart.
init :: IO (AppConfig, AppData)
init = do
(playerStart, playerType) <- fst `liftM` parseArgs
xFileName <- getDataFileName "x.png"
oFileName <- getDataFileName "o.png"
xWinFileName <- getDataFileName "xWin.png"
oWinFileName <- getDataFileName "oWin.png"
fontFileName <- getDataFileName "Alice_in_WonderLand_3.ttf"
screen <- setVideoMode screenWidth screenHeight sceenBpp [HWSurface, DoubleBuf]
setCaption "tic-tac-toe" []
enableUnicode True
font <- openFont fontFileName 24
xSprite <- loadImage xFileName colorKey
oSprite <- loadImage oFileName colorKey
xWinSprite <- loadImage xWinFileName colorKey
oWinSprite <- loadImage oWinFileName colorKey
seed <- fromIntegral `liftM` getTicks
let wh = surfaceGetWidth xSprite * 6
let gridX = (screenWidth `div` 2) - (wh `div` 2)
return (AppConfig screen font oSprite xSprite oWinSprite xWinSprite (Rect gridX 5 wh wh) playerStart playerType, appData seed playerStart)
where colorKey = Just (0, 0, 0)
initGame :: AppEnv ()
initGame = do
putGrid newGrid
putWinner (Nobody, [])
playerTurn <- getTurn
case playerTurn of
Ai -> aiPlayGame
_ -> return ()
aiPlayGame :: AppEnv ()
aiPlayGame = do
playerTurn <- getTurn
case playerTurn of
Ai -> randomCell >>= uncurry playGame
_ -> return ()
where randomCell = do
r <- rand 0 2
c <- rand 0 2
g <- getGrid
if isEmpty g r c
then return (r,c)
else randomCell
playGame :: Int -> Int -> AppEnv ()
playGame row col = do
g <- getGrid
when (isEmpty g row col) $ do
playerCell <- getPTurnCell
modifyGrid $ \gr -> takeTurn gr playerCell row col
winner <- whoWon `liftM` getGrid
putWinner winner
case fst winner of
Draw -> modifyStats $ \s@Stats{ tieCount=tc } -> s { tieCount=tc + 1 }
Nobody -> nextTurn
_ -> modifyPlayerCount (+1)
isOver <- isGameOver
unless isOver aiPlayGame
handleEvent :: Event -> AppEnv ()
handleEvent VideoExpose = render
handleEvent (MouseButtonDown mx my ButtonLeft) = do
gridBox@(Rect gx gy w h) <- getGridBounds
when (isInside gridBox x y) $ do
finished <- isGameOver
if finished
then do
initGame
pushEvent_ VideoExpose
else do
playerTurn <- getTurn
case playerTurn of
Player -> do
let (row, col) = ((x - gx) `div` (w `div` 3), (y - gy) `div` (h `div` 3))
playGame row col
pushEvent_ VideoExpose
_ -> return ()
where x = fromIntegral mx
y = fromIntegral my
pushEvent_ = liftIO . pushEvent
handleEvent _ = return ()
loop :: AppEnv ()
loop = do
event <- liftIO waitEvent
case event of
Quit -> return ()
_ -> do
handleEvent event
loop
main :: IO ()
main = withInit [InitEverything] $ -- withInit calls quit for us.
withTtfInit $ do
(config, state) <- init
runApp config state $ do
aiPlayGame -- if Ai was choosen to start first.
render -- initial render
loop
return ()
withTtfInit :: IO () -> IO ()
withTtfInit = bracket_ ttfInit TTFG.quit
where ttfInit :: IO ()
ttfInit = TTFG.init >>= \success -> when (not success) $ throwIO $ userError "Failed to init ttf\n"