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 Data.Maybe
import SoccerFun.MatchControl
import SoccerFun.Types
import SoccerFun.Geometry
import SoccerFun.Referee.Ivanov
import System.Random
import SoccerFun.MatchGame
import SoccerFun.Player
import SoccerFun.Team (Team)
import Data.Maybe
import SoccerFun.Field
import SoccerFun.Ball
gameLength ∷ TimeUnit
gameLength = 1
runMatch ∷ (Home → Field → Team) → (Home → Field → Team) → IO ()
runMatch t1 t2 = do
let
field = Field 70 105
team1 = t1 West field
team2 = t2 East field
match ← liftM (setMatchStart team1 team2 field (ivanovReferee field team1 team2) 1) newStdGen
(prog,args) ← GL.getArgsAndInitialize
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)
aspect ← newIORef 1
registerCallbacks window aspect =<< newIORef match
GL.cursor $= GL.LeftArrow
GL.mainLoop
GL.exit
registerCallbacks ∷ GL.Window → IORef GL.GLdouble → IORef Match → IO ()
registerCallbacks window aspect match = do
GL.displayCallback $= display
GL.reshapeCallback $= Just reshape
gameLoop
where
gameLoop = do
((refereeActions,playerWithActions),match') ← liftM stepMatch $ readIORef match
writeIORef match match'
GL.postRedisplay $ Just window
let actions = mapMaybe logRefereeAction refereeActions
when (not $ GameOver `elem` refereeActions) $ do
if null actions
then GL.addTimerCallback 30 gameLoop
else GL.addTimerCallback 1000 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} ← readIORef match
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)
mapM_ renderPlayer t1
colorRGB (0,0,1)
mapM_ renderPlayer t2
GL.swapBuffers
renderStatus Match {theField = field, team1 = t1, team2 = t2, theBall = ball, score = score, playingTime = time} = do
colorRGB (0,0,0)
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)
GL.renderPrimitive GL.LineLoop $ do
vertex2 (0,0)
vertex2 (l,0)
vertex2 (l,w)
vertex2 (0,w)
GL.renderPrimitive GL.LineStrip $ do
vertex2 (l/2,0)
vertex2 (l/2,w)
GL.preservingMatrix $ do
GL.translate $ vector2 (l/2,w/2)
GL.renderPrimitive GL.LineLoop $ circle radiusCentreCircle 23
GL.renderPrimitive GL.Polygon $ circle radiusCentreSpot 7
colorRGB (1,1,1)
mapM_ renderPole [(x,y) | let (n,s) = goalPoles field, y ← [n,s], x ← [0,l]]
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
renderPole pos = GL.preservingMatrix $ do
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)
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
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 ]
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