diff --git a/SoccerFun.cabal b/SoccerFun.cabal --- a/SoccerFun.cabal +++ b/SoccerFun.cabal @@ -1,5 +1,5 @@ Name: SoccerFun -Version: 0.1 +Version: 0.1.1 Copyright: (c) 2010, Jan Rochel License: BSD3 License-File: LICENSE @@ -7,9 +7,10 @@ Maintainer: jan@rochel.info Stability: experimental Build-Type: Simple -Synopsis: Haskell port of a football simulation framework for teaching functional programming +Synopsis: Football simulation framework for teaching functional programming Homepage: http://www.cs.ru.nl/~peter88/SoccerFun/SoccerFun.html Description: + This is a Haskell port of the the SoccerFun framework originally implemented in Clean. From the website: Soccer-Fun is an educational project to stimulate functional programming by thinking about, designing, implementing, running, and competing with the brains of football players! It is open for participation by everybody who likes to contribute. It is not restricted to a particular functional programming language. Category: Game, Education, AI Cabal-Version: >= 1.6 diff --git a/SoccerFun/Ball.hs b/SoccerFun/Ball.hs --- a/SoccerFun/Ball.hs +++ b/SoccerFun/Ball.hs @@ -41,10 +41,13 @@ ------------------------------------------------------------------------------ radiusBall ∷ Float -- officially it should be 0.113m, but that turns out to be too small for rendering -radiusBall = 0.3 +radiusBall = 0.4 + surfaceResistance ∷ Float -- ^ maximum speed of ball when moving over surface surfaceResistance = 0.85 + airResistance ∷ Float -- ^ maximum speed of ball when moving through air (should depend on velocity) airResistance = 0.95 + accellerationSec ∷ Float -- ^ acceleration difference per square second accellerationSec = 9.81 diff --git a/SoccerFun/Field.hs b/SoccerFun/Field.hs --- a/SoccerFun/Field.hs +++ b/SoccerFun/Field.hs @@ -4,9 +4,6 @@ import SoccerFun.Geometry import SoccerFun.Types (Other (other)) -defaultField ∷ Field -defaultField = Field { fwidth = 75.0, flength = 110.0 } - data Field = Field {fwidth ∷ FieldWidth, -- ^ width of ball field (64m <=width <=75m) flength ∷ FieldLength -- ^ height of ball field (100m<=height<=110m) @@ -15,6 +12,9 @@ type FieldWidth = Metre type FieldLength = Metre +defaultField ∷ Field +defaultField = Field { fwidth = 75.0, flength = 110.0 } + inPenaltyArea ∷ Field → Home → Position → Bool inPenaltyArea field home pos = northEdge <= py pos && py pos <= southEdge && if home == West then px pos <= westEdge else px pos >= eastEdge where northEdge = (fwidth field) / 2.0 - radiusPenaltyArea @@ -22,11 +22,6 @@ westEdge = penaltyAreaDepth eastEdge = (flength field) - penaltyAreaDepth -radiusPenaltySpot = 0.3 ∷ Metre -radiusPenaltyArea = 9.15 ∷ Metre -penaltyAreaDepth = 16.50 ∷ Metre -penaltySpotDepth = 11.00 ∷ Metre - data Home = West | East deriving (Eq,Show) instance Other Home where @@ -41,20 +36,25 @@ isEast East = True isEast _ = False -{-| goalPoles yields the py coordinates of the north pole and south pole of the goal (note that north < south). -} +-- | goalPoles yields the py coordinates of the north pole and south pole of the goal (note that north < south). goalPoles ∷ Field → (Metre,Metre) goalPoles field = (northPole,southPole) where northPole = ((fwidth field)-goalWidth)/2.0 southPole = northPole + goalWidth -{-| Official metrics of a ball field: -} +-- | Official metrics of a ball field: radiusCentreCircle = 9.15 ∷ Float --- | not official, taken for rendering -radiusCentreSpot = 0.3 :: Float goalWidth = 7.32 :: Float goalHeight = 2.44 :: Float goalAreaDepth = 5.50 :: Float radiusCornerKickArea = 0.90 :: Float --- | not official +-- | not official, taken for rendering goalPoleWidth = 0.3 :: Float +-- | not official, taken for rendering +radiusCentreSpot = 0.3 :: Float +radiusPenaltySpot = 0.2 ∷ Metre +radiusPenaltyArea = 9.15 ∷ Metre + +penaltyAreaDepth = 16.50 ∷ Metre +penaltySpotDepth = 11.00 ∷ Metre diff --git a/SoccerFun/MatchControl.hs b/SoccerFun/MatchControl.hs --- a/SoccerFun/MatchControl.hs +++ b/SoccerFun/MatchControl.hs @@ -43,7 +43,7 @@ , theReferee = referee , playingHalf = FirstHalf , playingTime = time - , unittime = 0.1 + , unittime = 0.05 , score = (0,0) , seed = rs } diff --git a/SoccerFun/UI/GL.hs b/SoccerFun/UI/GL.hs --- a/SoccerFun/UI/GL.hs +++ b/SoccerFun/UI/GL.hs @@ -20,13 +20,16 @@ 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) 5) newStdGen + match ← liftM (setMatchStart team1 team2 field (ivanovReferee field team1 team2) 1) newStdGen (prog,args) ← GL.getArgsAndInitialize -- GL.initialDisplayCapabilities $= [GL.With GL.DisplayDouble, GL.With GL.DisplaySamples] -- GL.multisample $= GL.Enabled @@ -57,9 +60,10 @@ writeIORef match match' GL.postRedisplay $ Just window let actions = mapMaybe logRefereeAction refereeActions - if null actions - then GL.addTimerCallback 50 gameLoop - else GL.addTimerCallback 1000 gameLoop + 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 @@ -98,19 +102,38 @@ GL.preservingMatrix $ do GL.translate $ vector2 (0, fwidth field + 2) GL.lineWidth $= 2 - drawStatus $ show (fst score) ++ ":" ++ show (snd score) ++ " " ++ show (fromIntegral (round (time * 100)) / 100) + drawStatus $ show (fst score) ++ ":" ++ show (snd score) ++ " " ++ show (round $ (1 - time) * 90) ++ ":00" - renderField Field {flength = l, fwidth = w} = do - colorRGB (1,1,1) -- white - GL.renderPrimitive GL.LineLoop $ do + 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 + GL.translate $ vector2 pos + GL.renderPrimitive GL.Polygon (circle goalPoleWidth 7) + renderBall (Free Ball {ballPos = p}) = do colorRGB (1,1,1) -- white - drawAt3D p $ GL.renderPrimitive GL.Polygon (circle 0.5 0.5 10) + drawAt3D p $ GL.renderPrimitive GL.Polygon (circle radiusBall 7) renderPlayer Player {pos = p, playerID = id} = drawAt p $ do square @@ -137,8 +160,6 @@ vertex2 (0.7,-0.7) vertex2 (0.7,0.7) vertex2 (-0.7,0.7) --- GL.translate $ vector2 (px pos, py pos) --- GL.renderObject GL.Solid $ GL.Cube 1 vector2 ∷ (Float,Float) → GL.Vector3 GL.GLfloat vector2 (x,y) = GL.Vector3 (convertFloat x) (convertFloat y) 0 @@ -146,7 +167,9 @@ vertex2 ∷ (Float,Float) → IO () vertex2 (x,y) = GL.vertex $ GL.Vertex2 (convertFloat x) (convertFloat y) -circle r1 r2 step = mapM_ vertex2 vs where +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 ] @@ -168,7 +191,7 @@ drawStatus label = GL.preservingMatrix $ do GL.translate $ GL.Vector3 (-0.3) (-0.3) (0 ∷ GL.GLfloat) - GL.scale 0.01 0.01 (0 ∷ GL.GLdouble) + GL.scale 0.03 0.03 (0 ∷ GL.GLdouble) GL.renderString GL.MonoRoman label convertDouble ∷ Double → GL.GLdouble