packages feed

SoccerFunGL (empty) → 0.4

raw patch · 5 files changed

+284/−0 lines, 5 filesdep +GLUTdep +OpenGLdep +SoccerFunsetup-changed

Dependencies added: GLUT, OpenGL, SoccerFun, base, base-unicode-symbols, binary, random

Files

+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2010, Jan Rochel+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+* Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+* Neither the name of the University of Utrecht nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks autoconfUserHooks
+ SoccerFun/UI/GL.hs view
@@ -0,0 +1,224 @@+{-# 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)++setupMatch ∷ (Home → Field → Team) → (Home → Field → Team) → IO Match+setupMatch t1 t2 = let+		field = Field 70 105+		team1 = t1 West field+		team2 = t2 East field+	in liftM (setMatchStart team1 team2 field (ivanovReferee field team1 team2) 1) newStdGen++--	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+		writeIORef tape tape'+		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} ← 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.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+		colorRGB (1,1,1) -- white+		mapM_ renderPole [(x,y) | let (n,s) = goalPoles field, y ← [n,s], x ← [0,l]] -- goal poles+		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+		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
+ SoccerFun/UI/GL/PlayTape.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE UnicodeSyntax #-}+-- | Usage: Hit /q/ to abort the match+module Main where++import SoccerFun.UI.GL+import Control.Monad+import System.Exit+import Prelude.Unicode+import Data.Binary++main ∷ IO ()+main = do+	(prog,args) ← initialise+	let file = case args of+		[file] → file+		notOne → error $ "Usage: " ⧺ prog ⧺ " <file.sft>"+	playTape =<< decodeFile file
+ SoccerFunGL.cabal view
@@ -0,0 +1,31 @@+Name:           SoccerFunGL+Version:        0.4+Copyright:      (c) 2010, Jan Rochel+License:        BSD3+License-File:   LICENSE+Author:         Jan Rochel+Maintainer:     jan@rochel.info+Stability:      experimental+Build-Type:     Simple+Synopsis:       OpenGL UI for the SoccerFun framework+Homepage:       http://www.cs.ru.nl/~peter88/SoccerFun/SoccerFun.html+Description:	This provides an 2D user interface for the SoccerFun framework implemented in OpenGL/GLUT.+Category:       Game, Education, AI+Cabal-Version:  >= 1.6++Library+  Extensions:+    UnicodeSyntax+  Build-Depends:+    base >= 4 && < 4.3,+    base-unicode-symbols >= 0.2 && < 0.3,+    random >= 1.0 && < 1.1,+    binary >= 0.5 && < 0.6,+    GLUT >= 2.2 && < 2.3,+    OpenGL >= 2.4 && < 2.5,+    SoccerFun >= 0.4 && < 0.5+  Exposed-Modules:+    SoccerFun.UI.GL++Executable sfPlayTape+  Main-Is: SoccerFun/UI/GL/PlayTape.hs