SoccerFun 0.3.6 → 0.4
raw patch · 11 files changed
+279/−355 lines, 11 filesdep +binarydep +derivedep −GLUTdep −OpenGLPVP ok
version bump matches the API change (PVP)
Dependencies added: binary, derive
Dependencies removed: GLUT, OpenGL
API changes (from Hackage documentation)
- SoccerFun.UI.GL: colorRGB :: (GLfloat, GLfloat, GLfloat) -> IO ()
- SoccerFun.UI.GL: convertDouble :: Double -> GLdouble
- SoccerFun.UI.GL: convertFloat :: Float -> GLfloat
- SoccerFun.UI.GL: drawAt :: Position -> IO () -> IO ()
- SoccerFun.UI.GL: drawAt3D :: Position3D -> IO () -> IO ()
- SoccerFun.UI.GL: gameLength :: TimeUnit
- SoccerFun.UI.GL: registerCallbacks :: Window -> IORef GLdouble -> IORef Match -> IO ()
- SoccerFun.UI.GL: runMatch :: (Home -> Field -> Team) -> (Home -> Field -> Team) -> IO ()
- SoccerFun.UI.GL: square :: IO ()
- SoccerFun.UI.GL: vector2 :: (Float, Float) -> Vector3 GLfloat
- SoccerFun.UI.GL: vertex2 :: (Float, Float) -> IO ()
+ SoccerFun.MatchControl: Match :: Team -> Team -> BallState -> Field -> Referee -> Half -> PlayingTime -> Score -> StdGen -> TimeUnit -> Match
+ SoccerFun.MatchControl: alterHealth :: BallState -> Player -> Float -> Angle -> Angle -> Health
+ SoccerFun.MatchControl: alterStamina :: BallState -> Player -> Angle -> Angle -> Stamina
+ SoccerFun.MatchControl: data Match
+ SoccerFun.MatchControl: headingPenalty :: Player -> Velocity -> Velocity -> PenaltyFactor
+ SoccerFun.MatchControl: instance Show Match
+ SoccerFun.MatchControl: kickingPenalty :: Player -> Velocity -> PenaltyFactor
+ SoccerFun.MatchControl: lookupPlayer :: PlayerID -> Match -> Maybe Player
+ SoccerFun.MatchControl: maxFatigueLossAtFeint :: Player -> PenaltyFactor
+ SoccerFun.MatchControl: maxFatigueLossAtTackle :: Player -> PenaltyFactor
+ SoccerFun.MatchControl: maxVelocity :: Player -> Angle -> Angle -> Velocity
+ SoccerFun.MatchControl: maxVelocityLossAtFeint :: Player -> PenaltyFactor
+ SoccerFun.MatchControl: oppositeKickPenalty :: Player -> Angle -> PenaltyFactor
+ SoccerFun.MatchControl: playingHalf :: Match -> Half
+ SoccerFun.MatchControl: playingTime :: Match -> PlayingTime
+ SoccerFun.MatchControl: restoreStaminaVelocity :: BallState -> Player -> Angle -> Angle -> Velocity
+ SoccerFun.MatchControl: score :: Match -> Score
+ SoccerFun.MatchControl: seed :: Match -> StdGen
+ SoccerFun.MatchControl: setMatchStart :: Team -> Team -> Field -> Referee -> PlayingTime -> StdGen -> Match
+ SoccerFun.MatchControl: stepMatch :: Match -> Step
+ SoccerFun.MatchControl: team1 :: Match -> Team
+ SoccerFun.MatchControl: team2 :: Match -> Team
+ SoccerFun.MatchControl: theBall :: Match -> BallState
+ SoccerFun.MatchControl: theField :: Match -> Field
+ SoccerFun.MatchControl: theReferee :: Match -> Referee
+ SoccerFun.MatchControl: type NrOfGoals = Int
+ SoccerFun.MatchControl: type PenaltyFactor = Float
+ SoccerFun.MatchControl: type Score = (NrOfGoals, NrOfGoals)
+ SoccerFun.MatchControl: type Step = (([RefereeAction], [PlayerWithAction]), Match)
+ SoccerFun.MatchControl: unittime :: Match -> TimeUnit
+ SoccerFun.MatchGame: computeMatch :: Match -> Score
+ SoccerFun.MatchGame: logRefereeAction :: RefereeAction -> Maybe String
+ SoccerFun.MatchGame: showTime :: Minutes -> String
+ SoccerFun.Referee.Ivanov: FreeToKick :: FreeKickCountdownForOffside
+ SoccerFun.Referee.Ivanov: IvanovLongTermMemory :: [TackleAction] -> [PlayerID] -> Bool -> Bool -> AssocList PlayerID Health -> Maybe PlayerID -> Maybe ATeam -> FreeKickCountdownForOffside -> Maybe RefereeAction -> (Bool, Int) -> Maybe ATeam -> Maybe Float -> [PlayerID] -> (Team, Team) -> IvanovLongTermMemory
+ SoccerFun.Referee.Ivanov: IvanovShortTermMemory :: Bool -> [PunishedPlayer] -> [(ATeam, Reason)] -> [TackleAction] -> Mood -> Maybe PlayerID -> Bool -> IvanovShortTermMemory
+ SoccerFun.Referee.Ivanov: KickForcedByReferee :: FreeKickCountdownForOffside
+ SoccerFun.Referee.Ivanov: OffsidePossible :: FreeKickCountdownForOffside
+ SoccerFun.Referee.Ivanov: RdangerousPlay :: Reason
+ SoccerFun.Referee.Ivanov: Rhands :: Reason
+ SoccerFun.Referee.Ivanov: RillegalBallPossession :: Reason
+ SoccerFun.Referee.Ivanov: Roffside :: Reason
+ SoccerFun.Referee.Ivanov: Rschwalbe :: Reason
+ SoccerFun.Referee.Ivanov: Rtackle :: Reason
+ SoccerFun.Referee.Ivanov: Rtheater :: Reason
+ SoccerFun.Referee.Ivanov: addPunishScore :: Reason -> PunishedScore -> PunishedPlayer -> PunishedPlayer
+ SoccerFun.Referee.Ivanov: ballIsFor :: IvanovLongTermMemory -> Maybe ATeam
+ SoccerFun.Referee.Ivanov: ballKickedOrHeaded :: IvanovShortTermMemory -> Bool
+ SoccerFun.Referee.Ivanov: data FreeKickCountdownForOffside
+ SoccerFun.Referee.Ivanov: data IvanovLongTermMemory
+ SoccerFun.Referee.Ivanov: data IvanovShortTermMemory
+ SoccerFun.Referee.Ivanov: data Reason
+ SoccerFun.Referee.Ivanov: filterOutMeanActions :: [Player] -> [PlayerWithEffect] -> StdGen -> ([PlayerWithEffect], StdGen)
+ SoccerFun.Referee.Ivanov: firstKick :: IvanovLongTermMemory -> Maybe ATeam
+ SoccerFun.Referee.Ivanov: gameLength :: IvanovLongTermMemory -> Maybe Float
+ SoccerFun.Referee.Ivanov: gameStoppedForTackle :: IvanovShortTermMemory -> Bool
+ SoccerFun.Referee.Ivanov: getNaughtyPlayer :: [PunishedPlayer] -> PlayerID -> Maybe PunishedPlayer
+ SoccerFun.Referee.Ivanov: getOffsidePlayers :: Field -> Home -> XPos -> [Player] -> [PlayerID]
+ SoccerFun.Referee.Ivanov: inKeeperSpot :: Player -> ClubName -> Home -> Field -> Bool
+ SoccerFun.Referee.Ivanov: inOffsidePosition :: IvanovLongTermMemory -> [PlayerID]
+ SoccerFun.Referee.Ivanov: initialTeams :: IvanovLongTermMemory -> (Team, Team)
+ SoccerFun.Referee.Ivanov: instance Eq FreeKickCountdownForOffside
+ SoccerFun.Referee.Ivanov: instance Eq Reason
+ SoccerFun.Referee.Ivanov: isTackleOffender :: PlayerID -> [TackleAction] -> Bool
+ SoccerFun.Referee.Ivanov: isTackleVictim :: PlayerID -> [TackleAction] -> Bool
+ SoccerFun.Referee.Ivanov: ivanovReferee :: Field -> Team -> Team -> Referee
+ SoccerFun.Referee.Ivanov: keeper1HadBall :: IvanovLongTermMemory -> Bool
+ SoccerFun.Referee.Ivanov: keeper2HadBall :: IvanovLongTermMemory -> Bool
+ SoccerFun.Referee.Ivanov: lastKickedTheBall :: IvanovLongTermMemory -> Maybe PlayerID
+ SoccerFun.Referee.Ivanov: lastRoundTackles :: IvanovLongTermMemory -> [TackleAction]
+ SoccerFun.Referee.Ivanov: lowerOffsideCounter :: IvanovLongTermMemory -> IvanovLongTermMemory
+ SoccerFun.Referee.Ivanov: mkIvanovLongTermMemory :: Team -> Team -> IvanovLongTermMemory
+ SoccerFun.Referee.Ivanov: mkIvanovShortTermMemory :: Mood -> IvanovShortTermMemory
+ SoccerFun.Referee.Ivanov: myMood :: IvanovShortTermMemory -> Mood
+ SoccerFun.Referee.Ivanov: nearLastRoundTackle :: Position -> [TackleAction] -> Bool
+ SoccerFun.Referee.Ivanov: nextBallPos :: Position3D -> Speed3D -> (Position, XRadius, ZRadius) -> Bool
+ SoccerFun.Referee.Ivanov: offsideAndTouchedBall :: IvanovShortTermMemory -> Maybe PlayerID
+ SoccerFun.Referee.Ivanov: offsidePossible :: IvanovLongTermMemory -> FreeKickCountdownForOffside
+ SoccerFun.Referee.Ivanov: offsideline :: Field -> Home -> Ball -> [Player] -> Metre
+ SoccerFun.Referee.Ivanov: penalty :: IvanovShortTermMemory -> [(ATeam, Reason)]
+ SoccerFun.Referee.Ivanov: posForFreeKick :: Home -> Position -> [Player] -> Position
+ SoccerFun.Referee.Ivanov: prevHealthPlayers :: IvanovLongTermMemory -> AssocList PlayerID Health
+ SoccerFun.Referee.Ivanov: punishMore :: Reason -> Player -> PunishedScore -> IvanovShortTermMemory -> IvanovShortTermMemory
+ SoccerFun.Referee.Ivanov: punished :: IvanovShortTermMemory -> [PunishedPlayer]
+ SoccerFun.Referee.Ivanov: receivedYellow :: IvanovLongTermMemory -> [PlayerID]
+ SoccerFun.Referee.Ivanov: refBrainIvanov :: Field -> PlayingTime -> TimeUnit -> BallState -> Half -> Team -> Team -> (IvanovLongTermMemory, StdGen) -> ([RefereeAction], (IvanovLongTermMemory, StdGen))
+ SoccerFun.Referee.Ivanov: successfulActions :: Team -> [PlayerWithEffect]
+ SoccerFun.Referee.Ivanov: thisRoundTackles :: IvanovShortTermMemory -> [TackleAction]
+ SoccerFun.Referee.Ivanov: type Mood = Float
+ SoccerFun.Referee.Ivanov: type Offender = (PlayerID, Position, Health)
+ SoccerFun.Referee.Ivanov: type PunishedPlayer = (PlayerID, PunishedScore, [Reason])
+ SoccerFun.Referee.Ivanov: type PunishedScore = Int
+ SoccerFun.Referee.Ivanov: type TackleAction = (Victim, Offender, Velocity)
+ SoccerFun.Referee.Ivanov: type Victim = (PlayerID, Position, Health)
+ SoccerFun.Referee.Ivanov: typeOfKickoff :: IvanovLongTermMemory -> Maybe RefereeAction
+ SoccerFun.Referee.Ivanov: waitingForSideSkipping :: IvanovLongTermMemory -> (Bool, Int)
+ SoccerFun.Tape: Tape :: [Step] -> Tape
+ SoccerFun.Tape: data Tape
+ SoccerFun.Tape: instance Binary ATeam
+ SoccerFun.Tape: instance Binary Ball
+ SoccerFun.Tape: instance Binary BallState
+ SoccerFun.Tape: instance Binary Edge
+ SoccerFun.Tape: instance Binary FeintDirection
+ SoccerFun.Tape: instance Binary Field
+ SoccerFun.Tape: instance Binary Half
+ SoccerFun.Tape: instance Binary Match
+ SoccerFun.Tape: instance Binary Player
+ SoccerFun.Tape: instance Binary PlayerAction
+ SoccerFun.Tape: instance Binary PlayerEffect
+ SoccerFun.Tape: instance Binary PlayerID
+ SoccerFun.Tape: instance Binary Position
+ SoccerFun.Tape: instance Binary Position3D
+ SoccerFun.Tape: instance Binary RefereeAction
+ SoccerFun.Tape: instance Binary Reprimand
+ SoccerFun.Tape: instance Binary Skill
+ SoccerFun.Tape: instance Binary Speed
+ SoccerFun.Tape: instance Binary Speed3D
+ SoccerFun.Tape: instance Binary Success
+ SoccerFun.Tape: instance Binary Tape
+ SoccerFun.Tape: recordMatch :: Match -> Tape
Files
- SoccerFun.cabal +16/−10
- SoccerFun/MatchControl.hs +19/−18
- SoccerFun/MatchGame.hs +2/−0
- SoccerFun/Tape.hs +127/−0
- SoccerFun/UI/GL.hs +0/−212
- template/Child.hs +0/−81
- template/Children.hs +0/−31
- template/Children/Child.hs +81/−0
- template/Children/Team.hs +31/−0
- template/Main.hs +2/−2
- template/Makefile +1/−1
SoccerFun.cabal view
@@ -1,5 +1,5 @@ Name: SoccerFun-Version: 0.3.6+Version: 0.4 Copyright: (c) 2010, Jan Rochel License: BSD3 License-File: LICENSE@@ -13,19 +13,24 @@ 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-Data-Files: template/Makefile template/*.hs+Data-Files: template/Main.hs template/Makefile template/Children/Child.hs template/Children/Team.hs Library- Extensions: UnicodeSyntax, NamedFieldPuns, Rank2Types, ExistentialQuantification, FlexibleInstances+ Extensions:+ UnicodeSyntax+ NamedFieldPuns+ Rank2Types+ ExistentialQuantification+ FlexibleInstances+ TemplateHaskell Build-Depends: base >= 4 && < 4.3, base-unicode-symbols >= 0.2 && < 0.3,- GLUT >= 2.2 && < 2.3,- OpenGL >= 2.4 && < 2.5, random >= 1.0 && < 1.1,- mtl >= 1.1 && < 1.2+ mtl >= 1.1 && < 1.2,+ derive >= 2.3 && < 2.4,+ binary >= 0.5 && < 0.6 Exposed-Modules:- SoccerFun.UI.GL SoccerFun.Ball SoccerFun.Types SoccerFun.Team@@ -33,10 +38,11 @@ SoccerFun.Field SoccerFun.Player SoccerFun.RefereeAction- Other-Modules:- SoccerFun.MatchGame+ SoccerFun.Tape SoccerFun.MatchControl- SoccerFun.Referee+ SoccerFun.MatchGame SoccerFun.Referee.Ivanov+ Other-Modules:+ SoccerFun.Referee SoccerFun.Random SoccerFun.Prelude
SoccerFun/MatchControl.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE UnicodeSyntax, TemplateHaskell #-} module SoccerFun.MatchControl where import Prelude.Unicode@@ -12,23 +12,24 @@ import SoccerFun.Ball import SoccerFun.Player import Control.Monad.Identity-import Control.Monad.State+import Control.Monad.State (State, runState) import Data.Maybe import Data.List import SoccerFun.Field -data Match = Match { team1 ∷ Team -- ^ team1- , team2 ∷ Team -- ^ team2- , theBall ∷ BallState -- ^ the whereabouts of the ball- , theField ∷ Field -- ^ the ball field- , theReferee ∷ Referee -- ^ the referee- , playingHalf ∷ Half -- ^ first half or second half team1 plays West at first half and East at second half- , playingTime ∷ PlayingTime -- ^ todo: add a boolean gameOver, playingtime will not walk back to (zero) and its up to the referee at which time he is to end the game- , score ∷ Score -- ^ the score- , seed ∷ StdGen -- ^ random seed for generating pseudo random values- , unittime ∷ TimeUnit -- ^ the time unit of a single simulation step- }- deriving Show+data Match = Match+ {team1 ∷ Team, -- ^ team1+ team2 ∷ Team, -- ^ team2+ theBall ∷ BallState, -- ^ the whereabouts of the ball+ theField ∷ Field, -- ^ the ball field+ theReferee ∷ Referee, -- ^ the referee+ playingHalf ∷ Half, -- ^ first half or second half team1 plays West at first half and East at second half+ playingTime ∷ PlayingTime, -- ^ todo: add a boolean gameOver, playingtime will not walk back to (zero) and its up to the referee at which time he is to end the game+ score ∷ Score, -- ^ the score+ seed ∷ StdGen, -- ^ random seed for generating pseudo random values+ unittime ∷ TimeUnit -- ^ the time unit of a single simulation step+ } deriving Show+ type Score = (NrOfGoals,NrOfGoals) -- ^ (goals by Team1, goals by Team2) type NrOfGoals = Int -- ^ (zero) <= nr of goals @@ -49,7 +50,9 @@ , seed = rs } -stepMatch ∷ Match → (([RefereeAction],[PlayerWithAction]),Match)+type Step = (([RefereeAction],[PlayerWithAction]),Match)++stepMatch ∷ Match → Step stepMatch match = runIdentity $ do (refereeActions, match) ← return $ refereeTurn match match ← return $ performRefereeActions refereeActions match@@ -59,9 +62,7 @@ match ← return $ advanceTime match return $ ((refereeActions,succeededActions),match) where-{- playersTurn match- lets every player player conjure an initiative--}+ -- lets every player player conjure an initiative playersTurn ∷ [RefereeAction] → Match → ([PlayerWithAction],Match) playersTurn refereeActions match= (intendedActions,newMatch) where
SoccerFun/MatchGame.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE UnicodeSyntax #-} module SoccerFun.MatchGame where +import Prelude.Unicode import SoccerFun.Types+import SoccerFun.Player import SoccerFun.MatchControl import SoccerFun.RefereeAction import SoccerFun.Prelude
+ SoccerFun/Tape.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE UnicodeSyntax, TemplateHaskell #-}+-- | record a match to a tape which is serialisable+module SoccerFun.Tape where++import Prelude.Unicode+import Data.DeriveTH+import Data.Binary+import SoccerFun.MatchControl+import SoccerFun.Player+import SoccerFun.Types+import SoccerFun.Field+import SoccerFun.Geometry+import SoccerFun.Ball+import SoccerFun.RefereeAction+import Control.Monad++instance Binary Match where+ put m = do+ put $ team1 m+ put $ team2 m+ put $ theBall m+ put $ theField m+ put $ playingHalf m+ put $ playingTime m+ put $ score m+ put $ unittime m+ get = do+ team1 ← get+ team2 ← get+ theBall ← get+ theField ← get+ playingHalf ← get+ playingTime ← get+ score ← get+ unittime ← get+ return $ Match+ {team1 = team1,+ team2 = team2,+ theBall = theBall,+ theField = theField,+ theReferee = undefined,+ playingHalf = playingHalf,+ playingTime = playingTime,+ score = score,+ seed = undefined,+ unittime = unittime}++instance Binary Player where+ put p = do+ put $ playerID p+ put $ name p+ put $ height p+ put $ pos p+ put $ speed p+ put $ nose p+ put $ skills p+ put $ effect p+ put $ stamina p+ put $ health p+ get = do+ playerID ← get+ name ← get+ height ← get+ pos ← get+ speed ← get+ nose ← get+ skills ← get+ effect ← get+ stamina ← get+ health ← get+ return $ Player+ {playerID = playerID,+ name = name,+ height = height,+ pos = pos,+ speed = speed,+ nose = nose,+ skills = skills,+ effect = effect,+ stamina = stamina,+ health = health,+ brain = undefined}++$( derive makeBinary ''Half )+$( derive makeBinary ''Field )+$( derive makeBinary ''Position3D )+$( derive makeBinary ''Ball )+$( derive makeBinary ''BallState )+$( derive makeBinary ''PlayerID )+$( derive makeBinary ''Position )+$( derive makeBinary ''Speed )+$( derive makeBinary ''Skill )+$( derive makeBinary ''PlayerEffect )+$( derive makeBinary ''Success )+$( derive makeBinary ''Speed3D )+$( derive makeBinary ''FeintDirection )+$( derive makeBinary ''RefereeAction )+$( derive makeBinary ''PlayerAction )+$( derive makeBinary ''Edge )+$( derive makeBinary ''ATeam )+$( derive makeBinary ''Reprimand )+++data Tape = Tape [Step]++magic = "SoccerFun tape"+version = "0.3.7"++instance Binary Tape where+ put (Tape steps) = do+ put magic+ put version+ put steps+ get = do+ let checkMagic m = when (not $ m ≡ magic) (error "This file does not contain a SoccerFun tape!")+ checkMagic =<< get+ let checkVersion v = when (not $ v ≡ version) (error $ "Incompatible tape version: " ⧺ show v)+ checkVersion =<< get+ liftM Tape get++recordMatch ∷ Match → Tape+recordMatch m = Tape $ recordMatch' (([],[]), m) where++ recordMatch' ∷ (([RefereeAction],[PlayerWithAction]),Match) → [(([RefereeAction],[PlayerWithAction]),Match)]+ recordMatch' = takeWhile matchRunning ∘ iterate (stepMatch ∘ snd)++ matchRunning (actions,match) = playingTime match > 0
− SoccerFun/UI/GL.hs
@@ -1,212 +0,0 @@-{-# 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 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 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.initialDisplayCapabilities $= [GL.With GL.DisplayDouble, GL.With GL.DisplaySamples]--- GL.multisample $= GL.Enabled- 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 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- 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') ← 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) -- 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
− template/Child.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}--- | A very simple minded player, that always chases after the ball and kicks the ball towards the opponent's goal.-module Child where--import SoccerFun.Player-import SoccerFun.Types-import SoccerFun.Geometry-import Control.Monad.State-import SoccerFun.Field-import SoccerFun.Ball-import SoccerFun.RefereeAction----- Generate a child.-child ∷ ClubName → Home → Field → Position → PlayersNumber → Player-child club home field position no = Player- {playerID = PlayerID {clubName = club, playerNo = no},- name = "child." ++ show no,- height = minHeight,- pos = position,- nose = 0,- speed = 0,- skills = (Running, Kicking, Rotating),- effect = Nothing,- stamina = maxStamina,- health = maxHealth,- -- The only thing the child remembers is on which side it belongs to- brain = Brain {m = Memory {myHome = home}, ai = minibrain field}}---- The child remembers nothing but which side it is playing on.-data Memory = Memory {myHome ∷ Home}---- A stateful computation, with the memory serving as a state.-type Think = State Memory---- | Based on the perceived surroundings (BrainInput) and the memories, make a decision (BrainOutput) and update the memory.-minibrain ∷ Field → PlayerAI Memory--- = Field → BrainInput → Think PlayerAction-minibrain field BrainInput {referee=refereeActions, me=me, ball=ballState, others=others} = do- mem ← get- let home = myHome mem- when (any isEndHalf refereeActions) (put mem {myHome = other home})- if ballIsClose- then let goal = centerOfGoal (other home) field in kick goal- else trackBall $ maxKickReach me- where- ball = getBall ballState (me : others) ∷ Ball- ballXY = pxy $ ballPos ball ∷ Position- ballIsClose = dist (pos me) ballXY < maxKickReach me-- move ∷ Speed → Angle → Think PlayerAction- move speed angle = return $ Move speed angle-- centerOfGoal ∷ Home → Field → Position- centerOfGoal home field = Position- {py = let (n,s) = goalPoles field in (n+s)/2,- px = if home == West then 0 else flength field}-- kick ∷ Position → Think PlayerAction- kick point = let- angle = angleWithObject (pos me) point- v = 2.0*dist (pos me) point- in if (dist (pos me) (ballPos ball) <= maxKickReach me)- then return $ KickBall Speed3D {vxy = Speed {direction=angle,velocity=v},vz=1.0}- else halt-- trackBall ∷ Metre → Think PlayerAction- trackBall eps = fix ballXY eps-- halt ∷ Think PlayerAction- halt = move 0 0-- -- run towards a position- fix ∷ Position → Metre → Think PlayerAction- fix point eps = let- distance = dist (pos me) point- angle = angleWithObject (pos me) point- v = max 6.0 distance- in if (distance <= eps)- then halt- else move Speed {direction=angle,velocity=v} (angle - (nose me))
− template/Children.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}-module Children where--import Child-import SoccerFun.Types-import SoccerFun.Geometry-import SoccerFun.Team-import SoccerFun.Player-import SoccerFun.Field--children ∷ Home → Field → Team-children home field = if home == West then players else mirror field players where-- clubname = "Children" ++ show home- players = [child clubname home field (placeOnField pos) nr | (nr,pos) ← zip [1..] playerPositions]-- placeOnField (dx,dy) = Position {px = dx * middleX, py = dy * fwidth field} - middleX = flength field / 2.0-- playerPositions =- [(0.00,0.50),- (0.20,0.30),- (0.20,0.70),- (0.23,0.50),- (0.50,0.05),- (0.50,0.95),- (0.60,0.50),- (0.70,0.15),- (0.70,0.85),- (0.90,0.45),- (0.90,0.55)]
+ template/Children/Child.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE UnicodeSyntax #-}+-- | A very simple minded player, that always chases after the ball and kicks the ball towards the opponent's goal.+module Children.Child where++import SoccerFun.Player+import SoccerFun.Types+import SoccerFun.Geometry+import Control.Monad.State+import SoccerFun.Field+import SoccerFun.Ball+import SoccerFun.RefereeAction+++-- Generate a child.+child ∷ ClubName → Home → Field → Position → PlayersNumber → Player+child club home field position no = Player+ {playerID = PlayerID {clubName = club, playerNo = no},+ name = "child." ++ show no,+ height = minHeight,+ pos = position,+ nose = 0,+ speed = 0,+ skills = (Running, Kicking, Rotating),+ effect = Nothing,+ stamina = maxStamina,+ health = maxHealth,+ -- The only thing the child remembers is on which side it belongs to+ brain = Brain {m = Memory {myHome = home}, ai = minibrain field}}++-- The child remembers nothing but which side it is playing on.+data Memory = Memory {myHome ∷ Home}++-- A stateful computation, with the memory serving as a state.+type Think = State Memory++-- | Based on the perceived surroundings (BrainInput) and the memories, make a decision (BrainOutput) and update the memory.+minibrain ∷ Field → PlayerAI Memory+-- = Field → BrainInput → Think PlayerAction+minibrain field BrainInput {referee=refereeActions, me=me, ball=ballState, others=others} = do+ mem ← get+ let home = myHome mem+ when (any isEndHalf refereeActions) (put mem {myHome = other home})+ if ballIsClose+ then let goal = centerOfGoal (other home) field in kick goal+ else trackBall $ maxKickReach me+ where+ ball = getBall ballState (me : others) ∷ Ball+ ballXY = pxy $ ballPos ball ∷ Position+ ballIsClose = dist (pos me) ballXY < maxKickReach me++ move ∷ Speed → Angle → Think PlayerAction+ move speed angle = return $ Move speed angle++ centerOfGoal ∷ Home → Field → Position+ centerOfGoal home field = Position+ {py = let (n,s) = goalPoles field in (n+s)/2,+ px = if home == West then 0 else flength field}++ kick ∷ Position → Think PlayerAction+ kick point = let+ angle = angleWithObject (pos me) point+ v = 2.0*dist (pos me) point+ in if (dist (pos me) (ballPos ball) <= maxKickReach me)+ then return $ KickBall Speed3D {vxy = Speed {direction=angle,velocity=v},vz=1.0}+ else halt++ trackBall ∷ Metre → Think PlayerAction+ trackBall eps = fix ballXY eps++ halt ∷ Think PlayerAction+ halt = move 0 0++ -- run towards a position+ fix ∷ Position → Metre → Think PlayerAction+ fix point eps = let+ distance = dist (pos me) point+ angle = angleWithObject (pos me) point+ v = max 6.0 distance+ in if (distance <= eps)+ then halt+ else move Speed {direction=angle,velocity=v} (angle - (nose me))
+ template/Children/Team.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE UnicodeSyntax #-}+module Children.Team where++import Children.Child+import SoccerFun.Types+import SoccerFun.Geometry+import SoccerFun.Team+import SoccerFun.Player+import SoccerFun.Field++team ∷ Home → Field → Team+team home field = if home == West then players else mirror field players where++ clubname = "Children" ++ show home+ players = [child clubname home field (placeOnField pos) nr | (nr,pos) ← zip [1..] playerPositions]++ placeOnField (dx,dy) = Position {px = dx * middleX, py = dy * fwidth field} + middleX = flength field / 2.0++ playerPositions =+ [(0.00,0.50),+ (0.20,0.30),+ (0.20,0.70),+ (0.23,0.50),+ (0.50,0.05),+ (0.50,0.95),+ (0.60,0.50),+ (0.70,0.15),+ (0.70,0.85),+ (0.90,0.45),+ (0.90,0.55)]
template/Main.hs view
@@ -2,7 +2,7 @@ module Main where import SoccerFun.UI.GL-import Children+import Children.Team as Children main ∷ IO ()-main = runMatch children children+main = runMatch Children.team Children.team
template/Makefile view
@@ -7,4 +7,4 @@ ghc ${GHC_ARGS} --make Main.hs clean:- rm -f *.o *.hi Main+ rm -f *.o *.hi */*.o */*.hi Main