foo-1.0: Court.hs
-- ==================================
-- Module name: Court
-- Project: Foo
-- Copyright (C) 2007 Bartosz Wójcik
-- Created on: 01.10.2007
-- Last update: 07.04.2008
-- Version: %
{- This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
-}
-- ==================================
module Court where
-- This module is simply user interface to Foo Engine.
import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT
import Data.Either
import Data.IORef
import System.Exit
import List
import Foo
import FooField
import FooMove
import MyPrimitives
-- import FooState
-- List of predefined colours used in game
courtBckgdCol = Color4 0.1 0 0 1 -- black
courtCol = Color4 1 1 1 1 -- white
lastPointCol = Color4 1 0.5 0 1 -- orange
activePointCol = Color4 1 0 0 1 -- red
newMoveCol = Color4 1 0 0 1 -- red
fstMoveCol = Color4 1 1 1 1 -- white
sndMoveCol = Color4 0 1 0 1 -- green
lstMoveCol = Color4 1 1 0 1 -- yellow
-- Main graphical function.
-- Initializes screen and controls the current game until it's finished.
-- ======================================================================
court :: (Ord b, Num b) => Int -> Int -- size of field
-> (Bool, PlayingAlgorithm) -- whether algorithm is 1st player and which one
-> (Bool, PlayingAlgorithm) -- whether algorithm is 2nd player and which one
-> b -- number of games to be played
-> IO ()
court fL fW (fstPlayerComp,fstAlg) (sndPlayerComp,sndAlg) nbrGames = do
-- ======================================================================
(progname, _) <- getArgsAndInitialize
initialDisplayMode $= [DoubleBuffered]
w <- createWindow ("Foo Field (C) Bartosz Wojcik 2008")
windowSize $= Size 400 550
-- List of states of game -- screen size is adjusted to game
activeVertex <- newIORef (0,0) -- vertex, mouse cursor points on
activeFstPlayer <- newIORef True -- True - 1st player on move; False - 2nd one
fstPlayerBegins <- newIORef True -- True - 1st player begins current game; False - opposite
lastPositionVertex <- newIORef (fromIntegral fW / 2, fromIntegral fL / 2 + 1) -- vertex, last pass finished on
myScreenSize <- newIORef (Size 300 400) -- size of the visible screen
court <- newIORef (field fL fW) -- Foo.field - the Graph
rmdEdges <- newIORef [] -- list of removed edges for display purposes only
rmdLstMvEdges <- newIORef [] -- list of removed edges of last move for display purposes only
gameNumber <- newIORef (nbrGames,1) -- game lasts until snd gameResult == fst gameResult
gameResult <- newIORef (0,0)
-- main display
displayCallback $= display fL fW activeVertex lastPositionVertex court rmdEdges rmdLstMvEdges gameNumber gameResult (playerName fstPlayerComp fstAlg) (playerName sndPlayerComp sndAlg)
-- screen is renormalized from 0,0 at bottom left to fW,fL+4
projection (-0.1) (fromIntegral fW + 0.1) 0 (fromIntegral fL + 4) 0 1
-- mouse movement control
if not fstPlayerComp || not sndPlayerComp
then passiveMotionCallback $= Just (mousePosition activeVertex (fromIntegral fW) (fromIntegral fL + 4) myScreenSize)
else passiveMotionCallback $= Nothing
-- action when window gets reshaped
reshapeCallback $= Just (reshape myScreenSize)
-- action on mouse click
keyboardMouseCallback $= Just (keyboardMouse activeVertex lastPositionVertex court rmdEdges rmdLstMvEdges activeFstPlayer fL fW w gameNumber gameResult fstPlayerBegins)
-- computer plays
if fstPlayerComp || sndPlayerComp
then idleCallback $= Just (idle activeVertex lastPositionVertex court rmdEdges rmdLstMvEdges activeFstPlayer fL fW w fstPlayerComp fstAlg sndPlayerComp sndAlg gameResult)
else idleCallback $= Nothing
mainLoop
-- ======================================================================
-- Computer plays
-- ========================================================================
idle activeVertex lastPositionVertex court rmdEdges rmdLstMvEdges activeFstPlayer
fL fW win fstPlayerComp fstAlg sndPlayerComp sndAlg gameResult = do
-- ========================================================================
c <- readIORef court
lV <- readIORef lastPositionVertex
aV <- readIORef activeVertex
rmdE <- readIORef rmdEdges
rmdLME <- readIORef rmdLstMvEdges
aFP <- readIORef activeFstPlayer
if lVy lV == 0 || lVy lV == fromIntegral fL + 2 || vertices (vx lV) c == [] -- end of game
then postRedisplay Nothing
else if aFP && fstPlayerComp || not aFP && sndPlayerComp
then do
if aFP
then putStrLn $ "Player1. Nbr possible moves: " ++ (show $ sizeMove 0 $ nextMove aFP (vx lV) c fL fW 0)
else putStrLn $ "Player2. Nbr possible moves: " ++ (show $ sizeMove 0 $ nextMove aFP (vx lV) c fL fW 0)
-- Here starts computer's move
court $= (graphAfterPass c $ computerPlays (vx lV) c aFP)
lastPositionVertex $= ((\(x,y) -> (fromIntegral x,fromIntegral y)) $ head $ vOfMove $ computerPlays (vx lV) c aFP)
rmdEdges $= (lastMove2RmdEdges rmdLME aFP fstPlayerComp sndPlayerComp []) ++ rmdE
rmdLstMvEdges $= lOfP2lOfReEd (vOfMove $ computerPlays (vx lV) c aFP) [] lstMoveCol
-- Following line of code gives even 35% overhead!
-- Ther reason of this feature is not clear to me. The function that costs here is one that has been already called couple lines above.
-- I'd expect that its result is kept and can be applied with minimal overhead.
-- putStrLn $ show $ computerPlays (vx lV) c aFP
lV' <- readIORef lastPositionVertex
activeFstPlayer $= newActivePlayer aFP (active (vx lV') c)
-- Actualize result if end of game
c' <- readIORef court -- court after move
if lVy lV' == 0 || lVy lV' == fromIntegral fL + 2 || vertices (vx lV') c' == [] -- end of game
then readIORef gameResult >>= \gR -> gameResult $= actualizeResult gR lV' fL c' (not aFP)
else court $= c'
postRedisplay Nothing
else court $= c
where computerPlays v g aFP = bestMove $ mapSelectedMove (Play (alg aFP) aFP) (alg aFP) $ nextMove aFP v g fL fW 0
lOfP2lOfReEd (l1:[]) os col = os
lOfP2lOfReEd (l1:l2:ls) os col = lOfP2lOfReEd (l2:ls) ((l1,col):(l2,col):os) col
alg True = fstAlg
alg False = sndAlg
-- ========================================================================
-- Simple XOR.
-- ========================================================================
newActivePlayer True True = True
newActivePlayer False False = True
newActivePlayer _ _ = False
-- ========================================================================
-- To case Vertex of field into vertex of graph.
-- ========================================================================
vx (x,y) = (round x,round y)
-- ========================================================================
-- ========================================================================
lVy (x,y) = y
-- ========================================================================
-- ========================================================================
col True = fstMoveCol
col False = sndMoveCol
-- ========================================================================
-- When left button is down and the activeVertex has edge with lastPositionVertex, then this constitutes next pass.
-- ================================================================================
keyboardMouse activeVertex lastPositionVertex court rmdEdges rmdLstMvEdges activeFstPlayer
fL fW win gameNumber gameResult fstPlayerBegins (MouseButton LeftButton) Down _ _ = do
-- ================================================================================
c <- readIORef court
lV <- readIORef lastPositionVertex
aV <- readIORef activeVertex
rmdE <- readIORef rmdEdges
rmdLME <- readIORef rmdLstMvEdges
aFP <- readIORef activeFstPlayer
(gN,gI) <- readIORef gameNumber
if lVy lV == 0 || lVy lV == fromIntegral fL + 2 || vertices (vx lV) c == [] -- end of game
then if gN > gI
then do
putStrLn "End of Game"
renewGame activeVertex lastPositionVertex court rmdEdges rmdLstMvEdges activeFstPlayer fL fW gameNumber fstPlayerBegins
postRedisplay Nothing
else do
putStrLn "End of Tournament"
exitWith ExitSuccess
destroyWindow win
-- postRedisplay Nothing
else if activeV aV /= [] && chckEdge (vx lV) (vx aV) c -- if vertex belongs to field and there is an edge between it and last position one
then do
court $= rmEdge (vx lV) (vx aV) c -- remove just chosen edge from field
rmdEdges $= ((vx lV),col aFP):((vx aV),col aFP):rmdE -- add chosen edge to list of removed edges
lastPositionVertex $= aV -- change of last position vertes
activeFstPlayer $= newActivePlayer aFP (active (vx aV) c) -- check what player is on move afterwards
-- Actualize result if end of game
c' <- readIORef court -- court after move
if lVy aV == 0 || lVy aV == fromIntegral fL + 2 || vertices (vx aV) c' == [] -- end of game
then readIORef gameResult >>= \gR -> gameResult $= actualizeResult gR aV fL c' (not aFP)
else court $= c'
postRedisplay Nothing
else court $= c
where activeV aV = filter (== aV) (verticesOfField fL fW)
-- Other action with mouse click or keyboard usage are without effect.
-- ================================================================================
keyboardMouse _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = return ()
-- ================================================================================
-- ========================================================================
actualizeResult (gA,gB) (_,0) _ _ _ = (gA + 1,gB)
actualizeResult (gA,gB) (x,y) fL c aFP | y == fromIntegral fL + 2 = (gA,gB + 1)
| aFP = (gA + 0.5,gB)
| otherwise = (gA,gB + 0.5)
-- ========================================================================
-- Creates list of passes in trerms of vertives mixed with colour of pass.
-- ========================================================================
lastMove2RmdEdges :: [(a, b)]
-> Bool -- towards goal (_,0)
-> Bool -- 1st player is computer
-> Bool -- 2nd player is computer
-> [(a, Color4 GLfloat)] -- dragged output list
-> [(a, Color4 GLfloat)]
lastMove2RmdEdges [] _ _ _ os = reverse os
lastMove2RmdEdges ((v,c):ls) True True True os = lastMove2RmdEdges ls True True True ((v,sndMoveCol):os)
lastMove2RmdEdges ((v,c):ls) True _ _ os = lastMove2RmdEdges ls True False False ((v,fstMoveCol):os)
lastMove2RmdEdges ((v,c):ls) False True True os = lastMove2RmdEdges ls False True True ((v,fstMoveCol):os)
lastMove2RmdEdges ((v,c):ls) False _ _ os = lastMove2RmdEdges ls False False False ((v,sndMoveCol):os)
-- ========================================================================
-- Reaction on mouse movement.
-- If mouse cursor approaches vertex of field, it gets activated.
-- If there is edge between active vertex and last vertex, it will be displayed.
-- =========================================================
mousePosition activeV fW fL myScreenSize (Position x y) = do
-- =========================================================
s <- readIORef myScreenSize
if (dx s) <= 0.2 && (dy s) <= 0.2 -- mouse cursor close to a vertex
then activeV $= (x'' s,fL - y'' s)
else activeV $= (0,0)
postRedisplay Nothing
where x' (Size w h) = fW * fromIntegral x / fromIntegral w
y' (Size w h) = fL * fromIntegral y / fromIntegral h
x'' s = fromIntegral $ round (x' s)
y'' s = fromIntegral $ round (y' s)
dx s = abs $ x'' s - x' s
dy s = abs $ y'' s - y' s
-- =========================================================
-- Current game finished, new one starts.
-- =========================================================
renewGame activeVertex lastPositionVertex court rmdEdges rmdLstMvEdges activeFstPlayer fL fW gameNumber fstPlayerBegins = do
-- =========================================================
activeVertex $= (0,0) -- vertex, mouse cursor points on
fPB <- readIORef fstPlayerBegins
activeFstPlayer $= not fPB -- True - 1st player on move; False - 2nd one
fstPlayerBegins $= not fPB
lastPositionVertex $= (fromIntegral fW / 2, fromIntegral fL / 2 + 1) -- vertex, last pass finished on
court $= field fL fW -- Foo.field - the Graph
rmdEdges $= [] -- list of removed edges for display purposes only
rmdLstMvEdges $= []
(gN,gI) <- readIORef gameNumber
gameNumber $= (gN,gI + 1)
-- =========================================================
-- Size of screen has to be traced in order to show active vertex correctly.
-- =========================================================
reshape myScreenSize s@(Size w h) = do
-- =========================================================
myScreenSize $= s
viewport $= (Position 0 0, s)
-- =========================================================
-- List of vertices that have to be displayed.
-- =========================================================
verticesOfField :: Int -> Int -> [(GLfloat,GLfloat)]
verticesOfField fL fW = [(fromIntegral x,fromIntegral y) | x<-[0..fW], y<-[0..fL+2], y > 0 && y < fL+2 || x > 2 && x < 5 ]
-- =========================================================
-- Usual orthogonal projection
-- =========================================================
projection xl xu yl yu zl zu = do
matrixMode $= Projection
loadIdentity
ortho xl xu yl yu zl zu
matrixMode $= Modelview 0
-- =========================================================
-- =========================================================
playerName False _ = "Human"
playerName True algorithm = show algorithm
-- =========================================================
-- Displays nothing - sometimes required for if statement
-- =========================================================
dispNothing = renderPrimitive Points $ vertex $ Vertex2 0 (0::GLfloat)
-- =========================================================
-- Main display function
-- =========================================================
display fL fW activeVertex lastPositionVertex court rmdEdges rmdLstMvEdges gameNumber gameResult fstName sndName = do
-- =========================================================
clearColor $= courtBckgdCol
clear [ColorBuffer]
-- first display vertices inside field
loadIdentity
renderPrimitive Points $ do
currentColor $= courtCol
mapM_ (\(x,y) -> vertex$Vertex2 x y) (verticesOfField fL fW)
-- then display the court
loadIdentity
renderPrimitive LineLoop $ do
currentColor $= courtCol
vertex $ Vertex2 0 (1::GLfloat)
vertex $ Vertex2 (leftGoalLine::GLfloat) 1
vertex $ Vertex2 leftGoalLine 0
vertex $ Vertex2 rightGoalLine 0
vertex $ Vertex2 rightGoalLine 1
vertex $ Vertex2 fW' 1
vertex $ Vertex2 fW' (fL' + 1)
vertex $ Vertex2 rightGoalLine (fL' + 1)
vertex $ Vertex2 rightGoalLine (fL' + 2)
vertex $ Vertex2 leftGoalLine (fL' + 2)
vertex $ Vertex2 leftGoalLine (fL' + 1)
vertex $ Vertex2 0 (fL' + 1)
readIORef gameNumber >>= \x -> displayGameNumber x (fromIntegral fL)
readIORef gameResult >>= \x -> displayGameResult x (fromIntegral fL)
displayName fstName (fromIntegral fL + 1.5) fstMoveCol
displayName sndName 0.5 sndMoveCol
-- then display done movements
readIORef rmdEdges >>= \ls -> displayDoneMoves ls
readIORef rmdLstMvEdges >>= \ls -> displayDoneMoves ls
-- then display pass that finishes at mouse cursor - if there is such a pass
c <- readIORef court
lV <- readIORef lastPositionVertex
aV <- readIORef activeVertex
loadIdentity
currentColor $= newMoveCol
if activeV aV /= [] && chckEdge (vx lV) (vx aV) c
then displayPoints [lV,aV] Lines
else dispNothing
-- then emphasise vertex of end of last pass
loadIdentity
currentColor $= lastPointCol
filledCircleAtV lV (0.1::GLfloat)
-- then mark active vertex
loadIdentity
currentColor $= activePointCol
if activeV aV == []
then dispNothing
else filledCircleAtV (head $ activeV aV) (0.1::GLfloat)
swapBuffers
where leftGoalLine = fW' / 2 - 1
rightGoalLine = fW' / 2 + 1
fW' = fromIntegral fW
fL' = fromIntegral fL
activeV aV = filter (== aV) (verticesOfField fL fW)
vx (x,y) = (round x,round y)
-- =========================================================
-- Gets list of passes in terms of pair of vertices.
-- Renders lines that reflect given passes. Passes are in 3 possible predefined colors and are rendered separatelly.
-- ls == [((x,y),c)] where
-- (x,y) - vertex; c - color
-- =========================================================
displayDoneMoves :: (Integral b, Integral a) => [((a, b), Color4 GLfloat)] -> IO ()
-- =========================================================
displayDoneMoves ls = do
loadIdentity
renderPrimitive Lines $ do
currentColor $= fstMoveCol
mapM_ (\(x,y) -> vertex$Vertex2 (fromIntegral x::GLfloat) (fromIntegral y)) (map fst $ filter ((== fstMoveCol).snd) ls)
loadIdentity
renderPrimitive Lines $ do
currentColor $= sndMoveCol
mapM_ (\(x,y) -> vertex$Vertex2 (fromIntegral x::GLfloat) (fromIntegral y)) (map fst $ filter ((== sndMoveCol).snd) ls)
loadIdentity
renderPrimitive Lines $ do
currentColor $= lstMoveCol
mapM_ (\(x,y) -> vertex$Vertex2 (fromIntegral x::GLfloat) (fromIntegral y)) (map fst $ filter ((== lstMoveCol).snd) ls)
-- =========================================================
-- =========================================================
displayGameNumber (n,i) fL = do
-- =========================================================
loadIdentity
translate $ Vector3 0 (fL + 3.5) (0::GLfloat)
scale 0.003 0.003 (1::GLfloat)
renderString Roman ("Game " ++ show i ++ " out of " ++ show n)
-- =========================================================
-- =========================================================
displayGameResult (a,b) fL = do
-- =========================================================
loadIdentity
translate $ Vector3 0 (fL + 2.5) (0::GLfloat)
scale 0.003 0.003 (1::GLfloat)
renderString Roman ("Result " ++ show a ++ " : " ++ show b)
-- =========================================================
-- =========================================================
displayName name y col = do
-- =========================================================
loadIdentity
translate $ Vector3 0 y (0::GLfloat)
scale 0.0021 0.0025 (1::GLfloat)
currentColor $= col
renderString Roman name
-- =========================================================