SoccerFunGL-0.5.3: SoccerFun/UI/GL.hs

{-# LANGUAGE UnicodeSyntax #-}
-- | Usage: Hit /q/ to abort the match
module SoccerFun.UI.GL where

import qualified Graphics.UI.GLUT as GL
import Graphics.UI.GLUT (($=), get)
import Data.IORef
import Control.Monad
import Unsafe.Coerce
import System.Exit

import Prelude.Unicode
import SoccerFun.MatchControl
import SoccerFun.Types
import SoccerFun.Geometry
import SoccerFun.Referee.Ivanov
import SoccerFun.RefereeAction
import System.Random
import SoccerFun.MatchGame
import SoccerFun.Player
import SoccerFun.Team (Team)
import SoccerFun.Tape
import Data.Maybe
import SoccerFun.Field
import SoccerFun.Ball

gameLength ∷ TimeUnit
gameLength = 1

initialise ∷ IO (String,[String])
initialise = GL.getArgsAndInitialize

runMatch ∷ (Home → Field → Team) → (Home → Field → Team) → IO ()
runMatch t1 t2 = do
	initialise
	playTape =<< liftM recordMatch (setupMatch t1 t2)

--	GL.initialDisplayCapabilities $= [GL.With GL.DisplayDouble, GL.With GL.DisplaySamples]
--	GL.multisample $= GL.Enabled

playTape ∷ Tape → IO ()
playTape (Tape tape) = do
	GL.initialDisplayMode $= [GL.DoubleBuffered, GL.Multisampling]
	p ← get GL.displayModePossible
	when (not p) $ do
		GL.initialDisplayMode $= [GL.DoubleBuffered]
		p ← get GL.displayModePossible
		when (not p) $ GL.initialDisplayMode $= []
	window ← GL.createWindow "SoccerFun"
	GL.clearColor $= (GL.Color4 0 0.5 0 0 ∷ GL.Color4 GL.GLclampf) -- green
	aspect ← newIORef 1
	registerCallbacks window aspect =<< newIORef tape
	GL.cursor $= GL.LeftArrow
	GL.mainLoop
	GL.exit

registerCallbacks ∷ GL.Window → IORef GL.GLdouble → IORef [Step] → IO ()
registerCallbacks window aspect tape = do
	GL.displayCallback $= display
	GL.reshapeCallback $= Just reshape
	GL.keyboardMouseCallback $= Just inputCallback
	gameLoop
--	GL.keyboardMouseCallback $= Just inputCallback
	where

	inputCallback ∷ GL.Key → GL.KeyState → GL.Modifiers → GL.Position → IO ()
	inputCallback (GL.Char 'q') _ _ _ = exitSuccess
	inputCallback _ _ _ _ = return ()

	gameLoop = do
		((refereeActions,playerWithActions),match) : tape' ← readIORef tape
		when (null tape') GL.exit
		writeIORef tape tape'
		GL.postRedisplay $ Just window
		let actions = mapMaybe logRefereeAction refereeActions
		when (not $ GameOver `elem` refereeActions) $ GL.addTimerCallback 30 gameLoop
		mapM_ putStrLn actions

	reshape s@(GL.Size w h) = do
		writeIORef aspect newAspect
		GL.viewport $= (GL.Position 0 0, s)
		GL.matrixMode $= GL.Projection
		GL.loadIdentity
		GL.perspective 0 newAspect (-1) 1
		GL.matrixMode $= GL.Modelview 0
		where newAspect = fromIntegral w / fromIntegral (max 1 h)

	display = do
		m@Match {theField = field, team1 = t1, team2 = t2, theBall = ball, score = score, playingTime = time} ← liftM (snd ∘ head) $ readIORef tape
		GL.clear [GL.ColorBuffer]
		GL.loadIdentity
		a ← readIORef aspect
		if a < 1 then GL.ortho2D (-1) 1 (-1/a) (1/a) else GL.ortho2D (-1*a) (1*a) (-1) 1
		let zoom = convertFloat $ 2.1 / flength field
		GL.scale zoom zoom 1
		GL.translate $ vector2 (-flength field/2,-fwidth field/2)

		renderStatus m
		GL.lineWidth $= 3
		renderField field
		GL.lineWidth $= 2
		renderBall ball m
		colorRGB (1,0,0) -- red
		mapM_ renderPlayer t1
		colorRGB (0,0,1) -- blue
		mapM_ renderPlayer t2

		GL.swapBuffers

	renderStatus Match {theField = field, team1 = t1, team2 = t2, theBall = ball, score = score, playingTime = time} = do
		colorRGB (0,0,0) -- black
		GL.preservingMatrix $ do
			GL.translate $ vector2 (0, fwidth field + 2)
			GL.lineWidth $= 2
			drawStatus $ show (fst score) ++ ":" ++ show (snd score) ++ "   " ++ show (round $ (1 - time) * 90) ++ ":00"

	renderField field@Field {flength = l, fwidth = w} = do
		colorRGB (0.8,1,0.8) -- green-white
		GL.renderPrimitive GL.LineLoop $ do -- side line
			vertex2 (0,0)
			vertex2 (l,0)
			vertex2 (l,w)
			vertex2 (0,w)
		GL.renderPrimitive GL.LineStrip $ do -- middle line
			vertex2 (l/2,0)
			vertex2 (l/2,w)
		GL.renderPrimitive GL.LineStrip $ do -- west penalty area
			vertex2 (0, w/2 + radiusPenaltyArea)
			vertex2 (penaltyAreaDepth, w/2 + radiusPenaltyArea)
			vertex2 (penaltyAreaDepth, w/2 - radiusPenaltyArea)
			vertex2 (0, w/2 - radiusPenaltyArea)
		GL.renderPrimitive GL.LineStrip $ do -- east penalty area
			vertex2 (l, w/2 + radiusPenaltyArea)
			vertex2 (l - penaltyAreaDepth, w/2 + radiusPenaltyArea)
			vertex2 (l - penaltyAreaDepth, w/2 - radiusPenaltyArea)
			vertex2 (l, w/2 - radiusPenaltyArea)
		GL.preservingMatrix $ do -- centre circle and centre spot
			GL.translate $ vector2 (l/2,w/2)
			GL.renderPrimitive GL.LineLoop $ circle radiusCentreCircle 23
			GL.renderPrimitive GL.Polygon $ circle radiusCentreSpot 7
		GL.preservingMatrix $ do
			GL.translate $ vector2 (penaltySpotDepth, w/2)
			GL.renderPrimitive GL.Polygon $ circle radiusPenaltySpot 7
		GL.preservingMatrix $ do
			GL.translate $ vector2 (l - penaltySpotDepth, w/2)
			GL.renderPrimitive GL.Polygon $ circle radiusPenaltySpot 7
		colorRGB (1,1,1) -- white
		mapM_ renderPole [(x,y) | let (n,s) = goalPoles field, y ← [n,s], x ← [0,l]] -- goal poles

	renderPole pos = GL.preservingMatrix $ do
		colorRGB (0.3,0.3,0.3)
		GL.translate $ vector2 pos
		GL.renderPrimitive GL.Polygon (circle goalPoleWidth 7)

	renderBall ball match = do
		let p = case ball of
			GainedBy pid → toPosition3D $ pos $ fromJust $ lookupPlayer pid match
			Free Ball {ballPos = p} → p
		colorRGB (1,1,1) -- white
		drawAt3D p $ GL.renderPrimitive GL.Polygon (circle radiusBall 7)

	renderPlayer Player {pos = p, playerID = id} = drawAt p $ do
		square
		drawString $ show $ playerNo id

colorRGB ∷ (GL.GLfloat,GL.GLfloat,GL.GLfloat) → IO ()
colorRGB (r,g,b) = GL.color $ GL.Color3 r g b

--dot3D ∷ Position3D → IO ()
--dot3D pos3D = dot $ pxy pos3D

drawAt3D ∷ Position3D → IO () → IO ()
drawAt3D pos = drawAt (pxy pos)

drawAt ∷ Position → IO () → IO ()
drawAt pos draw = GL.preservingMatrix $ do
	GL.translate $ vector2 (px pos, py pos)
	draw

square ∷ IO ()
square = GL.preservingMatrix $ do
	GL.renderPrimitive GL.LineLoop $ do
		vertex2 (-0.7,-0.7)
		vertex2 (0.7,-0.7)
		vertex2 (0.7,0.7)
		vertex2 (-0.7,0.7)

vector2 ∷ (Float,Float) → GL.Vector3 GL.GLfloat
vector2 (x,y) = GL.Vector3 (convertFloat x) (convertFloat y) 0

vertex2 ∷ (Float,Float) → IO ()
vertex2 (x,y) = GL.vertex $ GL.Vertex2 (convertFloat x) (convertFloat y)

circle r = oval r r

oval r1 r2 step = mapM_ vertex2 vs where
	is = take (truncate step + 1) [0, i' .. ]
	i' = 2 * pi / step
	vs = [ (r1 * cos i, r2 * sin i) | i <- is ]

{-
drawPort pos = GL.preservingMatrix $ do
	GL.translate $ vector pos
	GL.renderPrimitive GL.Polygon (circle 0.15 0.15 10)

drawNode label = do
	GL.renderPrimitive GL.LineLoop (circle 1 1 20)
	drawString label
-}

drawString label = GL.preservingMatrix $ do
	GL.translate $ GL.Vector3 (-0.3) (-0.3) (0 ∷ GL.GLfloat)
	GL.scale 0.007 0.007 (0 ∷ GL.GLdouble)
	GL.renderString GL.MonoRoman label

drawStatus label = GL.preservingMatrix $ do
	GL.translate $ GL.Vector3 (-0.3) (-0.3) (0 ∷ GL.GLfloat)
	GL.scale 0.03 0.03 (0 ∷ GL.GLdouble)
	GL.renderString GL.MonoRoman label

convertDouble ∷ Double → GL.GLdouble
convertDouble = unsafeCoerce

convertFloat ∷ Float → GL.GLfloat
convertFloat = unsafeCoerce