SoccerFun 0.5 → 0.5.1
raw patch · 9 files changed
+1580/−1638 lines, 9 files
Files
- SoccerFun.cabal +1/−1
- SoccerFun/Field.hs +17/−9
- SoccerFun/MatchControl.hs +668/−657
- SoccerFun/MatchGame.hs +3/−13
- SoccerFun/Referee/Ivanov.hs +851/−927
- SoccerFun/RefereeAction.hs +22/−24
- SoccerFun/Tape/Record.hs +10/−0
- SoccerFun/Tape/Record/Template.hs +0/−1
- tournament/mkIndex.sh +8/−6
SoccerFun.cabal view
@@ -1,5 +1,5 @@ Name: SoccerFun-Version: 0.5+Version: 0.5.1 Copyright: (c) 2010, Jan Rochel License: BSD3 License-File: LICENSE
SoccerFun/Field.hs view
@@ -18,10 +18,10 @@ 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- southEdge = (fwidth field) / 2.0 + radiusPenaltyArea- westEdge = penaltyAreaDepth- eastEdge = (flength field) - penaltyAreaDepth+ northEdge = fwidth field / 2 - radiusPenaltyArea+ southEdge = fwidth field / 2 + radiusPenaltyArea+ westEdge = penaltyAreaDepth+ eastEdge = flength field - penaltyAreaDepth data Home = West | East deriving (Eq,Show,Typeable) @@ -37,6 +37,9 @@ isEast East = True isEast _ = False +centre ∷ Field → Position+centre f = Position (flength f / 2) (fwidth f / 2)+ -- | 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@@ -49,13 +52,18 @@ goalHeight = 2.44 :: Float goalAreaDepth = 5.50 :: Float radiusCornerKickArea = 0.90 :: Float--- | not official, taken for rendering++-- | not official, taken for rendering. TODO: remove these things from the module goalPoleWidth = 0.4 :: Float--- | not official, taken for rendering radiusCentreSpot = 0.3 :: Float- radiusPenaltySpot = 0.2 ∷ Metre-radiusPenaltyArea = 9.15 ∷ Metre -penaltyAreaDepth = 16.50 ∷ Metre+-- | The vertical size of the penalty area divided by two+radiusPenaltyArea ∷ Metre+radiusPenaltyArea = 20.16++-- | The horizontal size of the penalty area+penaltyAreaDepth ∷ Metre+penaltyAreaDepth = 16.50+ penaltySpotDepth = 11.00 ∷ Metre
SoccerFun/MatchControl.hs view
@@ -1,661 +1,672 @@ {-# LANGUAGE UnicodeSyntax, TemplateHaskell #-}-module SoccerFun.MatchControl where--import Prelude.Unicode-import SoccerFun.Prelude-import SoccerFun.Geometry-import System.Random-import SoccerFun.Types-import SoccerFun.Referee-import SoccerFun.Random-import SoccerFun.Team-import SoccerFun.Ball-import SoccerFun.Player-import Control.Monad.Identity-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--type Score = (NrOfGoals,NrOfGoals) -- ^ (goals by Team1, goals by Team2)-type NrOfGoals = Int -- ^ (zero) <= nr of goals--lookupPlayer ∷ PlayerID → Match → Maybe Player-lookupPlayer pid Match {team1 = t1, team2 = t2} = find ((==) pid ∘ playerID) (t1 ⧺ t2)--setMatchStart ∷ Team → Team → Field → Referee → PlayingTime → StdGen → Match-setMatchStart fstTeam sndTeam field referee time rs- = Match { team1 = validateTeam fstTeam- , team2 = validateTeam sndTeam- , theBall = Free (ballAtCenter field)- , theField = field- , theReferee = referee- , playingHalf = FirstHalf- , playingTime = time- , unittime = 0.05- , score = (0,0)- , seed = rs- }--type Step = (([RefereeAction],[PlayerWithAction]),Match)--stepMatch ∷ Match → Step-stepMatch match = runIdentity $ do- (refereeActions, match) ← return $ refereeTurn match- match ← return $ performRefereeActions refereeActions match- (intendedActions, match) ← return $ playersTurn refereeActions match- (succeededActions,match) ← return $ selectActions intendedActions match- match ← return $ performPlayerActions intendedActions succeededActions match- match ← return $ advanceTime match- return $ ((refereeActions,succeededActions),match)- where- -- lets every player player conjure an initiative- playersTurn ∷ [RefereeAction] → Match → ([PlayerWithAction],Match)- playersTurn refereeActions match= (intendedActions,newMatch)- where- actionsOfTeam1 = map (think refereeActions (theBall match) (team2 match)) (singleOutElems (team1 match))- actionsOfTeam2 = map (think refereeActions (theBall match) (team1 match)) (singleOutElems (team2 match))- newMatch = match { team1 = map snd actionsOfTeam1,team2 = map snd actionsOfTeam2}- intendedActions = [(action,playerID) | (action,Player{playerID=playerID}) <- actionsOfTeam1 ++ actionsOfTeam2]-- think ∷ [RefereeAction] → BallState → [Player] → (Player,[Player]) → (PlayerAction,Player)- think refereeActions ballstate opponents (me@Player{ effect=effect,brain=brain@Brain{ai=ai,m=m}},ownTeam)- | isNothing effect = (action,newMe)- | otherwise = checkIfNotOnGround (fromJust effect) action newMe- where- (action,newM) = runState (ai $ BrainInput{referee=refereeActions,ball=ballstate,others=ownTeam ++ opponents,me=me}) m- newMe = clonePlayer (brain{ai=ai,m=newM}) me { effect=effect}-- checkIfNotOnGround ∷ PlayerEffect → PlayerAction → Player → (PlayerAction,Player)- checkIfNotOnGround (OnTheGround i) action fb- | i <= 0 = (action, fb { effect = Nothing})- | otherwise = (allowOnlyPlayTheater,fb { effect = Just (OnTheGround (i-1))- , stamina= alterStamina ballstate fb (zero) (zero)})- where- allowOnlyPlayTheater= case action of- PlayTheater → action- _ → Move (zero) { direction = (direction (speed fb))} (zero) -- Run (zero) { direction = (direction (speed fb))}- checkIfNotOnGround _ action fb- = (action,fb)--{- selectActions actions match- removes all failing actions, and returns the list of remaining succeeding actions.- It updates the random stream in match, and neutralizes actions of tackled players.--} selectActions ∷ [PlayerWithAction] → Match → ([PlayerWithAction],Match)- selectActions actions match@Match{seed=seed} = runIdentity $ do- (seed,succeededActions) ← return $ validActions match seed actions- ((successTackles,failedTackles),seed) ← return $ analyseTackleActions match succeededActions seed- succeededActions ← return $ filter (isNoTackleVictim successTackles) (removeMembers succeededActions failedTackles)- return $ (succeededActions,match { seed=seed})- where- {- actions that are always valid: {Move, Run, Rotate, Feint, Schwalbe, PlayTheater}- actions that may have success: {Tackle} (looked at later at performactions)- actions where at most (fromIntegral 1) can succeed: {GainBall, KickBall, HeadBall, Catch}- -} validActions ∷ Match → StdGen → [PlayerWithAction] → (StdGen,[PlayerWithAction])- validActions match seed [] = (seed,[])- validActions match seed actions- | isJust ballAction = (seed1,(fromJust ballAction:otherActions))- | otherwise = (seed1,otherActions)- where- allPlayers = (team1 match) ++ (team2 match)- (ballActions,otherActions) = spanfilter (isActionOnBall ∘ fst) actions- (seed1,ballAction) = selectBallAction (theBall match) allPlayers seed ballActions-- selectBallAction ∷ BallState → [Player] → StdGen → [PlayerWithAction] → (StdGen,Maybe PlayerWithAction)- selectBallAction ballstate allPlayers seed desiredActions = runIdentity $ do- (ps,seed) ← return $ iterateStn (length desiredActions) random seed- odds ← return $ [ (successOfAction ballstate allPlayers action (if (p==fromIntegral 1) then p else (makeRandomRealistic p)),action)- | (action,p) <- zip desiredActions ps- ]- okOdds ← return $ filter (\(p,a) → p > (zero)) odds- if null okOdds then return $ (seed,Nothing) else do- maxOddProb ← return $ maximum (map fst okOdds)- bestActions ← return $ [a | (p,a) <- okOdds, p >= maxOddProb]- (p,seed) ← return $ random seed- if p==fromIntegral 1 then return $ (seed,Just (head bestActions)) else do- let l = fromIntegral $ length bestActions ∷ Float- let m = p * l- let idx = floor m- return (seed,Just (bestActions !! idx))- where- successOfAction ∷ BallState → [Player] → PlayerWithAction → Float → Float- successOfAction ballstate allPlayers (action,who) p- = myFatigue * myHealth * p * successOfAction- where- successOfAction = if (isGainBall action && ballGainable && ballAtGainSpeed) then successGaining else- (if (isCatchBall action && ballCatchable && ballAtCatchSpeed) then successCatching else- (if (isKickBall action && ballKickable) then successKicking else- (if (isHeadBall action && ballHeadable) then successHeading else- (zero)- )))- Just me = find (identifyPlayer who) allPlayers- myFatigue = (stamina me)- myHealth = (health me)- mySkills = skillsAsList me- myLength = (height me)- iGainWell = elem Gaining mySkills- iKickWell = elem Kicking mySkills- iHeadWell = elem Heading mySkills- iCatchWell = elem Catching mySkills-- ballGainable = dPlayerBall <= maxGainReach me- ballKickable = dPlayerBall <= maxKickReach me- ballHeadable = dPlayerBall <= maxHeadReach me- ballCatchable = dPlayerBall <= maxCatchReach me- ballAtGainSpeed = dVelocity <= maxGainVelocityDifference me dPlayerBall- ballAtCatchSpeed = dVelocity <= maxCatchVelocityDifference me dPlayerBall- dSpeed = (zero) { dxy = scaleVector (velocity (speed me)) (toRVector (direction (speed me)))}- -- RVector3D { dxy = scaleVector (velocity (vxy (ballSpeed theBall))) (toRVector (direction (vxy (ballSpeed theBall))))- , dz = (vz (ballSpeed theBall))- }- dVelocity = sizeVector3D dSpeed-- theBall = getBall ballstate allPlayers- dPlayerBall = dist (toPosition3D (pos me)) (ballPos theBall)-- othersWithBall = [fb | fb <- allPlayers, ballIsGainedBy (playerID fb) ballstate && not (identifyPlayer who fb)]- otherHasBall = not (null othersWithBall)- otherDribblesWell = elem Dribbling (skillsAsList (head othersWithBall))-- successGaining = if (ballIsFree ballstate) then (lengthPenalty * if iGainWell then 0.95 else 0.8) else- (if otherHasBall then (lengthPenalty * if iGainWell then 0.75 else 0.3 * if otherDribblesWell then 0.6 else 1.0)- else 1.0)- successKicking = if (ballIsFree ballstate) then (lengthBonus * if iKickWell then 0.95 else 0.85) else- (if otherHasBall then (lengthBonus * if iKickWell then 0.80 else 0.70 * if otherDribblesWell then 0.7 else 1.0)- else 1.0)- successHeading = if iHeadWell then 0.95 else 0.9- successCatching = if iCatchWell then 1.0 else 0.95- lengthBonus = (myLength-1.2) ** 0.15- lengthPenalty = (2.6-myLength) ** 0.1-- analyseTackleActions ∷ Match → [PlayerWithAction] → StdGen → (([PlayerWithAction],[PlayerWithAction]),StdGen)- analyseTackleActions match performedActions seed- = spanfilterSt (isPossibleTackle match) [action | action <- performedActions, isPlayerTackle (fst action)] seed- where- isPossibleTackle ∷ Match → PlayerWithAction → StdGen → (Bool,StdGen)- isPossibleTackle match@Match{team1=team1,team2=team2} (Tackle victimID _,playerID) seed- | dMeVictim > maxTackleReach offender -- victim is out of reach- = (False,seed)- | otherwise = (((p + chanceOfSuccess) / 2) > 0.5,seed') -- victim is within reach, but tackle may fail- where- (p,seed') = random seed- allPlayers = team1 ++ team2- Just offender = find (identifyPlayer playerID) allPlayers- Just victim = find (identifyPlayer victimID) allPlayers- dMeVictim = dist (pos offender) (pos victim)- chanceOfSuccess = (1.0 - dMeVictim + if (elem Tackling (skillsAsList offender)) then 0.9 else 0.7) /2-- isNoTackleVictim ∷ [PlayerWithAction] → PlayerWithAction → Bool- isNoTackleVictim tackles (action,playerID)- = isSchwalbe action- ||- isPlayTheater action- ||- null [victim | (Tackle victim _,_) <- tackles, victim==playerID]--{- refereeTurn match- determines whether the rules of soccer are adhered to and yields a list of referee actions.--} refereeTurn ∷ Match → ([RefereeAction],Match)- refereeTurn match@Match{theReferee=referee@Referee{ rbrain=brain@Brain{ai=ai,m=m}},theBall=theBall,playingHalf=playingHalf,team1=team1,team2=team2,playingTime=playingTime,unittime=unittime,seed=seed}- = (refereeActions,match { theReferee=newReferee,seed=newSeed})- where- (refereeActions,(newM,newSeed)) = ai playingTime unittime theBall playingHalf team1 team2 (m,seed)- newReferee = cloneReferee (Brain{ai=ai,m=newM}) referee--{- performRefereeActions refereeActions match- performs for each ball player in match his succeededAction, informs them about the referee actions, and moves the ball.--} performRefereeActions ∷ [RefereeAction] → Match → Match- performRefereeActions refActions match = foldl doRefereeEvent match refActions- where- doRefereeEvent ∷ Match → RefereeAction → Match- doRefereeEvent theMatch@Match{playingHalf=playingHalf,theField=theField,team1=team1,team2=team2} refereeAction- | isAlterMatchBallAndTeams = theMatch { theBall=Free (mkBall pos (zero))}- | isGameProgressEvent = gameProgress theMatch- | isDisplaceTeamsEvent = theMatch { team1=map (displacePlayer ds) team1,team2=map (displacePlayer ds) team2}- | isReprimandEvent = let (team1',team2') = reprimandPlayer (nameOf team1) tef repr (team1,team2) in theMatch { team1=team1',team2=team2'}- | otherwise = theMatch- where- (isAlterMatchBallAndTeams,pos) = case refereeAction of- DirectFreeKick _ pos → (True,pos)- ThrowIn _ pos → (True,pos)- Corner _ _ → (True,fromJust (getKickPos theField playingHalf refereeAction))- GoalKick _ → (True,fromJust (getKickPos theField playingHalf refereeAction))- Penalty _ → (True,fromJust (getKickPos theField playingHalf refereeAction))- CenterKick _ → (True,fromJust (getKickPos theField playingHalf refereeAction))- otherwise → (False,error "UNDEF pos")- (isGameProgressEvent,gameProgress)- = case refereeAction of- GameOver → (True,\m → m { playingTime=(zero)})- AddTime t → (True,\m → m { playingTime=(playingTime m+)t})- EndHalf → (True,\m → m { playingHalf=SecondHalf})- Goal t → (True,\m@Match{score=(w,e)} → m { score=if (t==Team1) then (w+1,e) else (w,e+1)})- otherwise → (False,error "UNDEF gameProgress")- (isDisplaceTeamsEvent,ds) = case refereeAction of- DisplacePlayers ds → (True, ds)- otherwise → (False,error "UNDEF ds")- (isReprimandEvent,(tef,repr)) = case refereeAction of- ReprimandPlayer p r → (True, (p,r))- otherwise → (False,(error "UNDEF tef", error "UNDEF repr"))-- displacePlayer ∷ Displacements → Player → Player- displacePlayer displacements fb- = case lookup (playerID fb) displacements of- Just pos → fb { pos=pos}- nothing → fb-- reprimandPlayer ∷ ClubName → PlayerID → Reprimand → ([Player],[Player]) → ([Player],[Player])- reprimandPlayer club1 playerID RedCard (team1,team2)- = splitAt (nrPlayers1 - if ((clubName playerID) == club1) then 1 else 0) (uneq1++uneq2)- where- (uneq1,_,uneq2) = break1 (identifyPlayer playerID) (team1++team2)- nrPlayers1 = length team1- reprimandPlayer _ _ _ teams = teams--{- performPlayerActions actions succeededActions match- performs for each ball player in match his succeededAction and moves the ball.--} performPlayerActions ∷ [PlayerWithAction] → [PlayerWithAction] → Match → Match- performPlayerActions actions succeededActions match@Match{theField=theField,theBall=theBall,team1=team1,team2=team2,seed=seed,unittime=unittime} = runIdentity $ do- (seed,ball,newPlayers1,newPlayers2)- ← return $ foldl (flip (performAction succeededActions)) (seed,theBall,team1,team2) actions- (ball,seed) ← return $ moveBall theField (newPlayers1++newPlayers2) (ball,seed)- match ← return $ match { team1=newPlayers1, team2=newPlayers2, theBall=ball, seed=seed }- return $ match- where- performAction ∷ [PlayerWithAction] → PlayerWithAction → (StdGen,BallState,[Player],[Player])- → (StdGen,BallState,[Player],[Player])- performAction succeededActions initiative (seed,ball,allPlayers1,allPlayers2)- | elem initiative succeededActions -- plan has succeeded- = performAction' initiative (seed,ball,allPlayers1,allPlayers2)- | otherwise -- plan has failed- = (seed,ball,map (failThisPlayerAction initiative) allPlayers1,map (failThisPlayerAction initiative) allPlayers2)- where- failThisPlayerAction ∷ PlayerWithAction → Player → Player- failThisPlayerAction (idea,playerID) fb- | identifyPlayer playerID fb- = fb { effect=Just (failPlayerAction idea)}- | otherwise = fb-- performAction' ∷ PlayerWithAction → (StdGen,BallState,[Player],[Player])- → (StdGen,BallState,[Player],[Player])-- performAction' (Move sp angle,playerID) (seed,ball,team1,team2) = runIdentity $ do- (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return (seed1,ball,team1,team2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- curNose = (nose fb)- curSpeed = (speed fb)- skills = skillsAsList fb- playerHasBall = ballIsGainedBy playerID ball- (p,seed1) = random seed- feasibleAngle = ((signum angle)) * (abs angle `boundedBy` (0, maxRotateAngle fb))- newNose = curNose + feasibleAngle- angleDifficulty = angleHowFarFromPi ((direction sp)-newNose)- angleDifference = angleHowFarFromAngle (direction sp) newNose- newStamina = alterStamina ball fb angleDifficulty angleDifference- newHealth = alterHealth ball fb p angleDifficulty angleDifference- healthFat = getHealthStaminaFactor newHealth newStamina- newVel = healthFat * (velocity sp `boundedBy` (0, maxVelocity fb angleDifficulty angleDifference))- newSpeed = sp { velocity=newVel}- newPosition' = movePoint (scaleVector (unittime * newVel) (toRVector (direction newSpeed))) (pos fb)- newPosition = pointToRectangle ((zero),Position{px=(flength theField),py=(fwidth theField)}) newPosition'- newFb = fb { stamina = newStamina- , health = newHealth- , speed = newSpeed- , pos = newPosition- , nose = newNose- , effect = Just (Moved newSpeed feasibleAngle)- }-- {- Run has become deprecated.- Rules for running:- (1) you can't run through another player- (2) you can't run faster than maximum velocity for a player (depends on Running and Dribbling skill)- (3) you can't leave field- (4) running fast lowers your stamina- (5) running slow increases your stamina and health- (6) poor health or poor stamina lowers your maximum velocity- performAction' (Run speed,playerID) (seed,ball,team1,team2)- | null bumpedInto = runIdentity $ do -- no collision with other player- newFb ← fb { pos = newPosition- , speed = newSpeed- , stamina = newStamina- , effect = Just (Ran eventSpeed { direction = (direction eventSpeed) - (direction (speed fb))})- }- (team1,team2) ← splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return $ (seed2,ball,team1,team2)- | otherwise = runIdentity $ do -- collission with other player- playerSpeed ← (speed fb) { direction=(direction newSpeed), velocity=(velocity 0.3*newSpeed)}- newFb ← fb { speed = playerSpeed- , stamina = newStamina- , effect = Just (Ran (speed fb) { velocity=(velocity 0.3*newSpeed)})- }- (team1,team2) ← splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- (p3,seed3) ← random seed2- (seed4,team1,team2)- ← moveBumpedPlayers newSpeed { velocity=(velocity 0.3*newSpeed), direction = (direction 0.4*p3*newSpeed)}- bumpedInto (seed3,team1,team2)- return $ (seed4,ball,team1,team2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- (p1,seed1) = random seed- (p2,seed2) = random seed1- angleDifficulty = angleHowFarFromPi (direction speed)- angleDifference = if (isNothing (effect fb)) then (zero) else (case fromJust (effect fb) of- Ran s → angleHowFarFromAngle (direction speed) (direction s)- _ → (zero))- playerHasBall = ballIsGainedBy playerID ball- newStamina = alterStamina ball fb angleDifficulty angleDifference- newHealth = alterHealth ball fb p1 angleDifficulty angleDifference- healthFat = getHealthStaminaFactor newHealth newStamina- newVel = healthFat * (velocity speed `boundedBy` (0, maxVelocity fb angleDifficulty angleDifference))- newSpeed = (speed fb) { velocity=newVel}- newAngle = if (p2 == (fromIntegral 1)) then ((direction (speed fb)) + (direction speed)) else- (if (p2 > 0.5) then ((direction (speed fb)) + (0.85 + 0.15 * healthFat) * pi - pi + (direction speed)) else- ((direction (speed fb)) + (1.15 - 0.15 * healthFat) * pi - pi + (direction speed)))- eventSpeed = (speed fb) { velocity=newVel, direction=newAngle}- newPosition' = movePoint (scaleVector (unittime * newVel) (toRVector newAngle)) (pos fb)- newPosition = pointToRectangle ((zero),{px=(flength theField),py=(fwidth theField)}) newPosition'- bumpedInto = (playerID [fb) | fb <- uneq1++uneq2 | inRadiusOfPlayer newPosition fb]- -}- {- Rotate has become deprecated:- Rules for rotating:- (1) Rotating with slow velocity increases your stamina and health- (2) Rotating with high velocity lowers your stamina and health- (3) poor health or poor stamina lowers your maximum velocity- (4) poor health or poor stamina lowers your precision with turning- (5) you can't leave field- (6) you can't run faster than your maximum velocity- (7) you can't run through another player- performAction' (Rotate speed,playerID) (seed,ball,team1,team2)- | not (null bumpedInto) = runIdentity $ do- playerSpeed ← (speed fb) { direction=newAngle, velocity=(velocity 0.3*newSpeed)}- newFb ← fb { speed = playerSpeed- , stamina = newStamina- , effect = Just (Rotated {direction=newAngle,velocity=(velocity 0.3*newSpeed)})- }- (team1,team2) ← splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- (p2,seed2) ← random seed1- (seed3,team1,team2) ← moveBumpedPlayers newSpeed { velocity=(velocity 0.3*newSpeed), direction = (direction 0.4*p2*newSpeed)}- bumpedInto (seed2,team1,team2)- return $ (seed3,ball,team1,team2)- | otherwise = runIdentity $ do- newFb ← fb { pos = newPosition- , speed = newSpeed- , stamina = newStamina- , effect = Just (Rotated newSpeed)- }- (newTeam1,newTeam2) ← splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return $ (seed1,ball,newTeam1,newTeam2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- (p1,seed1) = random seed- newV' = healthFat * (setbetween (velocity speed) (zero) (maxVelocity fb (zero) (zero)))- newV = if (newAngle >= maxRotateAngle fb { speed=(speed fb) { velocity=newV'}}) then (max (newV' - 0.5) (zero)) else newV'- newAngle = let lengthFactor = if (elem Rotating skills) then ((height fb)-0.2) else (height fb)- healthFactor = (healthFat/((direction 0.75*lengthFactor))*speed)- in if ((direction speed) > (zero)) then (min ( maxRotateAngle fb) healthFactor) else- (max (~(maxRotateAngle fb)) healthFactor)- skills = skillsAsList fb- playerHasBall = ballIsGainedBy playerID ball- newStamina = alterStamina ball fb (zero) (zero)- newHealth = alterHealth ball fb p1 (zero) (zero)- healthFat = getHealthStaminaFactor newHealth newStamina- newDirection = (direction (speed fb)) + newAngle- newSpeed = (speed fb) { direction=newDirection, velocity=newV}- newPosition' = movePoint (scaleVector (unittime * newV) (toRVector newDirection)) (pos fb)- newPosition = pointToRectangle ((zero),{px=(flength theField),py=(fwidth theField)}) newPosition'- bumpedInto = (playerID [fb) | fb <- uneq1++uneq2 | inRadiusOfPlayer newPosition fb]- -}- {- Rules for gaining ball:- (1) ball obtains position and surface speed of obtaining player- -} performAction' (GainBall,playerID) (seed,ball,team1,team2) = runIdentity $ do- (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return $ (seed,GainedBy playerID,team1,team2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- newFb = fb { effect = Just (GainedBall Success)}-- {- Rules for kicking ball:- (1) kicking decreases stamina- (2) kicking is more effective towards your direction, and least effective in opposite direction- (3) being taller, you can kick harder- (4) a low stamina/health lower your max kickspeed- (5) todo: kicking a ball held/gained by a keeper, may damage the keeper- -} performAction' (KickBall (Speed3D{vxy=Speed{velocity=v,direction=d},vz=vz}),playerID) (seed,ball,team1,team2) = runIdentity $ do- (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return $ (seed2,Free newBall,team1,team2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- (p1,seed1) = random seed- (p2,seed2) = random seed1- newFb = fb { stamina=newStamina,effect=Just (KickedBall (Just newSpeed))}- theBall = getBall ball (team1 ++ team2)- skills = skillsAsList fb- fatHealth = getHealthStaminaFactor (health fb) (stamina fb)- maxV = maxVelocityBallKick fb- newV = speedFactor * (v `boundedBy` (0,maxV))- newVz = speedFactor * (vz `boundedBy` (0, maxV))- newSpeed = Speed3D{vxy=Speed{velocity=newV,direction=newDirection},vz=newVz}- newStamina = kickingPenalty fb newV * (stamina fb)- speedFactor = oppositeKickPenalty fb d- newBall = theBall { ballSpeed=newSpeed}- newDirection = runIdentity $ do- if p2 == (fromIntegral 1) then return d else do- failure ← return $ (fromIntegral 1) - if (elem Kicking skills) then (makeRandomRealisticSkilled p2) else (makeRandomRealistic p2)- if p1 `mod` (2::Int) ≡ 0 then do- newD ← return $ d - failure * maxKickingDeviation fb- return $ if (newD < (zero)) then (newD + 2.0*pi) else newD- else do- newD ← return $ d + failure * maxKickingDeviation fb- return $ if (newD > 2.0*pi) then (newD - 2.0*pi) else newD-- {- Rules for heading ball:- (1) heading decreases stamina, but less than kicking- (2) kicking is more effective towards your direction, and least effective in opposite direction- (3) a low stamina/health lower your max headspeed, but less than kicking- (4) heading is less harder than kicking, but is not effected by your length- (5) todo: heading a ball held/gained by a keeper, may damage the keeper (less than with kicking)- -} performAction' (HeadBall (Speed3D{vxy=Speed{velocity=v,direction=d},vz=vz}),playerID) (seed,ballstate,team1,team2) = runIdentity $ do- (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return $ (seed2,Free newBall,team1,team2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- (p1,seed1) = random seed- (p2,seed2) = random seed1- skills = skillsAsList fb- fatHealth = getHealthStaminaFactor (health fb) (stamina fb)- ball = getBall ballstate (team1 ++ team2)- ballSpeed' = (velocity (vxy (ballSpeed ball)))- maxV = maxVelocityBallHead fb ballSpeed'- newV = v `boundedBy` (zero, maxV)- newVz = 0.25 * (vz `boundedBy` (0, maxV))- newDirection = runIdentity $ do- if p2 == (fromIntegral 1) then return d else do- failure ← return $ (fromIntegral 1) - if (elem Heading skills) then makeRandomRealisticSkilled p2 else makeRandomRealistic p2- if p1 `mod` (2::Int) ≡ 0 then do- newD ← return $ d - failure * maxHeadingDeviation fb- return $ if (newD < (zero)) then (newD + 2.0*pi) else newD- else do- newD ← return $ d + failure * maxHeadingDeviation fb- return $ if (newD > 2.0*pi) then (newD - 2.0*pi) else newD- newSpeed = Speed3D{vxy=Speed{velocity=newV,direction=newDirection},vz=newVz}- newStamina = headingPenalty fb newV ballSpeed' * (stamina fb)- newFb = fb { stamina=newStamina,effect=Just (HeadedBall (Just newSpeed))}- newBall = ball { ballSpeed=newSpeed}-- {- Rules for feinting:- (1) you must have velocity in order to feint manouvre.- (2) a feint manouvre changes your position, and decreases your velocity (depends on Feinting skill)- -} performAction' (Feint d,playerID) (seed,ball,team1,team2) = runIdentity $ do- (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return $ (seed,ball,team1,team2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- playerHasBall = ballIsGainedBy playerID ball- newStamina = maxFatigueLossAtFeint fb * (stamina fb)- fatHealth = getHealthStaminaFactor (health fb) (stamina fb)- newVelocity = fatHealth * (velocity (speed fb)) * maxVelocityLossAtFeint fb- newSpeed = (speed fb) { velocity=newVelocity}- (leftv,rightv) = orthogonal (direction (speed fb))- sidestep = case d of FeintLeft → leftv; _ → rightv- newPosition' = movePoint ((scaleVector (maxFeintStep fb) (toRVector sidestep))- +- (scaleVector (unittime * newVelocity) (toRVector (direction (speed fb))))- ) (pos fb)- newPosition = pointToRectangle ((zero),Position{px=(flength theField),py=(fwidth theField)}) newPosition'- newFb = fb { pos=newPosition,speed=newSpeed,stamina=newStamina,effect=Just (Feinted d)}-- {- Rules for Tackling- (1) tackling may lower the health of the victim but increases his stamina (last is because he lies on the ground the next rounds)- (2) tackling costs stamina- -} performAction' (Tackle victimID ve,playerID) (seed,ball,team1,team2) = runIdentity $ do- return $ (seed1,newBall,team1T,team2T)- where- nrPlayersTeam1 = length team1- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- (team1N,team2N) = splitAt nrPlayersTeam1 (unbreak1 (uneq1,newFb,uneq2))- (uneq1T,fbT,uneq2T) = break1 (identifyPlayer victimID) (team1N ++ team2N)- (team1T,team2T) = splitAt nrPlayersTeam1 (unbreak1 (uneq1T,newTarget,uneq2T))- newStaminaSelf = maxFatigueLossAtTackle fb * (stamina fb)- fatHealthSelf = getHealthStaminaFactor (health fb) (stamina fb)- newFb = fb { stamina = newStaminaSelf, effect = Just (Tackled victimID ve Success)}- targetHasBall = ballIsGainedBy victimID ball- (p,seed1) = random seed- newV' = min maxTackleVelocity ve- maxTackleVelocity = 10.0- newV = newV'/10.0- healthDamageTarget = newV * fatHealthSelf * (0.5*p + 0.1) + ((height fbT)-minLength)/2.0- newHealthTarget = max 0.0 (health fbT) - healthDamageTarget- newTarget = fbT { health = newHealthTarget, effect = Just (OnTheGround 3) }- newBall = if targetHasBall then (Free (mkBall (pos fbT) (speed fbT))) else ball-- {- Rules for Schwalbe- (1) Schwalbe cures stamina- (2) Performing a Schwalbe when ball was gained causes to lose ball- -} performAction' (Schwalbe,playerID) (seed,ball,team1,team2) = runIdentity $ do- (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return $ (seed,ball,team1,team2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- newFb = fb { effect = Just (OnTheGround 1)}-- {- Rules for catching- (1) ball optains speed and distance of player- -} performAction' (CatchBall,playerID) (seed,ball,team1,team2) = runIdentity $ do- (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return $ (seed,GainedBy playerID,team1,team2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- newFb = fb { effect=Just (CaughtBall Success)}-- {- Rules for playing theater- (1) playingTheater costs stamina- (2) Performing a Schwalbe when ball was gained causes to lose ball- -} performAction' (PlayTheater,playerID) (seed,ball,team1,team2) = runIdentity $ do- (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return $ (seed,ball,team1,team2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- e = (effect fb)- wasOnTheGround = if (isNothing e) then False else (isOnTheGround (fromJust e))- newEvent = if (isOnTheGround (fromJust e)) then (fromJust e) else PlayedTheater- newFb = fb { effect = Just newEvent}-- moveBumpedPlayers ∷ Speed → [PlayerID] → (StdGen,[Player],[Player])- → (StdGen,[Player],[Player])- moveBumpedPlayers newSpeed bumpedInto (seed,team1,team2)- = foldl (moveBumpedPlayer newSpeed) (seed,team1,team2) bumpedInto- where- moveBumpedPlayer ∷ Speed → (StdGen,[Player],[Player]) → PlayerID- → (StdGen,[Player],[Player])- moveBumpedPlayer newSpeed (seed,team1,team2) playerID = runIdentity $ do- (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))- return $ (seed1,team1,team2)- where- (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)- (p,seed1) = random seed- newPos = let a = p*2.0*pi in movePoint RVector {dx=0.5*cos a,dy=0.5*sin a} (pos fb)- newFb = fb { speed=newSpeed, pos=newPos}--- {- moveBall moves the ball (fromIntegral 1) unit, taking into account the surface and air resistance.- -} moveBall ∷ Field → [Player] → (BallState,StdGen) → (BallState,StdGen)- moveBall _ _ gained@(GainedBy playerID,seed)- = gained- moveBall field allPlayers (Free ball@Ball{ballSpeed=Speed3D{vxy=Speed{velocity=v,direction=d},vz=vz},ballPos=ballPos},seed)- = (Free ball { ballSpeed=newSpeed,ballPos=newBallpos},seed1)- where- inTheAir = (pz ballPos) > (zero)- resistance = if inTheAir then airResistance else surfaceResistance- surfaceMovement = scaleVector (unittime * v) (toRVector d)- newSpeed2D = let newV = resistance*v in Speed{direction = d, velocity = if (newV <= 0.05) then (zero) else newV}--- newVz' = if inTheAir then (vz - unittime*accellerationSec) else (zero)- newVz' = vz - unittime*accellerationSec- newHeight' = (pz ballPos) + vz- (newHeight,newVz) = if (newHeight' < (zero)) then (0.5*(abs newHeight'),let newV = 0.33*(abs newVz') in if (newV <= 0.8) then (zero) else newV) else -- ball bounces, loss of velocity- (newHeight',newVz')- newSpeed' = Speed3D{vxy=newSpeed2D, vz=newVz}- newBallpos = Position3D{pxy=movePoint surfaceMovement (pxy ballPos),pz=newHeight}- fieldDimensions = ((zero),Position{px=(flength field),py=(fwidth field)})- (newSpeed,seed1) = ballBouncesAgainst field newBallpos newSpeed' allPlayers seed-- -- if the then ball else bounces against something, velocity will be reduced again and the direction will be changed.- ballBouncesAgainst ∷ Field → Position3D → Speed3D → [Player] → StdGen → (Speed3D,StdGen)- ballBouncesAgainst field newBallpos newSpeed@Speed3D{vxy=Speed{velocity=v,direction=d},vz=s3d} allPlayers seed- -- the ball may hit (fromIntegral 1) of the poles of (fromIntegral 1) of the goal or (fromIntegral 1) of the players and bounce away- -- ball hits (fromIntegral 1) of the goal poles- | againstGoalWestNorthPole || againstGoalWestSouthPole || againstGoalEastNorthPole || againstGoalEastSouthPole- -- 50% bounce left, 50% bounce right- = (newSpeed { vxy = (vxy newSpeed) { direction = if (p1<=0.5) then (d-p2*pi) else (d+p2*pi), velocity = resistance*v}},seed2)- -- ball hits the top of (fromIntegral 1) of the goals- | againstGoalWestPoleUpper || againstGoalEastPoleUpper = runIdentity $ do- forwardOrBack ← return $ if (p1<=0.5) then Forward else Back- upOrDown ← return $ if ((pz newBallpos) < goalHeight+(goalPoleWidth/2.0)) then Down else Up- return $ bounceBall upOrDown (bounceBall forwardOrBack (newSpeed,seed2))- -- ball hits (fromIntegral 1) of the players- | any (\fb → inRadiusOfPlayer (pxy newBallpos) fb && (height fb) >= (pz newBallpos)) allPlayers- -- bounces pure at random (player might get ported)- = (newSpeed { vxy = (vxy newSpeed) { direction = p2*2.0*pi, velocity = resistance*v}, vz=p1*s3d},seed2)- -- ball hits nothing- | otherwise- = (newSpeed,seed2)- where- (p1,seed1) = random seed- (p2,seed2) = random seed1- (northPole,southPole) = goalPoles field- againstGoalWestNorthPole = inCircleRadiusOfPosition newBallpos (goalPoleWidth/2.0) goalHeight Position {px=0.0, py=northPole - goalPoleWidth/2.0}- againstGoalWestSouthPole = inCircleRadiusOfPosition newBallpos (goalPoleWidth/2.0) goalHeight Position {px=0.0, py=southPole + goalPoleWidth/2.0}- againstGoalEastNorthPole = inCircleRadiusOfPosition newBallpos (goalPoleWidth/2.0) goalHeight Position {px=(flength field),py=northPole - goalPoleWidth/2.0}- againstGoalEastSouthPole = inCircleRadiusOfPosition newBallpos (goalPoleWidth/2.0) goalHeight Position {px=(flength field),py=southPole + goalPoleWidth/2.0}- againstGoalWestPoleUpper = (isbetween (py (pxy newBallpos)) (northPole-goalPoleWidth/2.0) (southPole+goalPoleWidth/2.0))- &&- (isbetween (pz newBallpos) goalHeight (goalHeight+goalPoleWidth))- &&- ((px (pxy newBallpos)) <= (zero))- againstGoalEastPoleUpper = (isbetween (py (pxy newBallpos)) (northPole-goalPoleWidth/2.0) (southPole+goalPoleWidth/2.0))- &&- (isbetween (pz newBallpos) goalHeight (goalHeight+goalPoleWidth))- &&- ((px (pxy newBallpos)) >= (flength field))-- advanceTime ∷ Match → Match- advanceTime match@Match{playingTime=playingTime, unittime=unittime}- = match { playingTime = max (zero) ((playingTime*160.0 - unittime)/160.0)}+module SoccerFun.MatchControl (Match (..), Score, NrOfGoals, setMatchStart, Step, stepMatch, lookupPlayer) where++import Prelude.Unicode+import SoccerFun.Prelude+import SoccerFun.Geometry+import System.Random+import SoccerFun.Types+import SoccerFun.Referee+import SoccerFun.Random+import SoccerFun.Team+import SoccerFun.Ball+import SoccerFun.Player+import Control.Monad.Identity+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++type Score = (NrOfGoals,NrOfGoals) -- ^ (goals by Team1, goals by Team2)+type NrOfGoals = Int -- ^ (zero) <= nr of goals++lookupPlayer ∷ PlayerID → Match → Maybe Player+lookupPlayer pid Match {team1 = t1, team2 = t2} = find ((==) pid ∘ playerID) (t1 ⧺ t2)++setMatchStart ∷ Team → Team → Field → Referee → PlayingTime → StdGen → Match+setMatchStart fstTeam sndTeam field referee time rs = Match+ {team1 = validateTeam fstTeam,+ team2 = validateTeam sndTeam,+ theBall = Free (ballAtCenter field),+ theField = field,+ theReferee = referee,+ playingHalf = FirstHalf,+ playingTime = time,+ unittime = 0.05,+ score = (0,0),+ seed = rs}++type Step = (([RefereeAction],[PlayerWithAction]),Match)++stepMatch ∷ Match → Step+stepMatch match = runIdentity $ do+ (refereeActions, match) ← return $ refereeTurn match+ match ← return $ performRefereeActions refereeActions match+ (intendedActions, match) ← return $ playersTurn refereeActions match+ (succeededActions,match) ← return $ selectActions intendedActions match+ match ← return $ performPlayerActions intendedActions succeededActions match+ match ← return $ advanceTime match+ return $ ((refereeActions,succeededActions),match)++-- | lets every player player conjure an initiative+playersTurn ∷ [RefereeAction] → Match → ([PlayerWithAction],Match)+playersTurn refereeActions match = (intendedActions, match {team1 = map snd actionsOfTeam1,team2 = map snd actionsOfTeam2}) where+ actionsOfTeam1 = map (think refereeActions (theBall match) (team2 match)) (singleOutElems (team1 match))+ actionsOfTeam2 = map (think refereeActions (theBall match) (team1 match)) (singleOutElems (team2 match))+ intendedActions = [(action,playerID) | (action,Player{playerID=playerID}) <- actionsOfTeam1 ++ actionsOfTeam2]++ think ∷ [RefereeAction] → BallState → [Player] → (Player,[Player]) → (PlayerAction,Player)+ think refereeActions ballstate opponents (me@Player{ effect=effect,brain=brain@Brain{ai=ai,m=m}},ownTeam)+ | isNothing effect = (action,newMe)+ | otherwise = checkIfNotOnGround (fromJust effect) action newMe+ where+ (action,newM) = runState (ai $ BrainInput{referee=refereeActions,ball=ballstate,others=ownTeam ++ opponents,me=me}) m+ newMe = clonePlayer (brain{ai=ai,m=newM}) me { effect=effect}++ checkIfNotOnGround ∷ PlayerEffect → PlayerAction → Player → (PlayerAction,Player)+ checkIfNotOnGround (OnTheGround i) action fb+ | i <= 0 = (action, fb { effect = Nothing})+ | otherwise = (allowOnlyPlayTheater,fb { effect = Just (OnTheGround (i-1))+ , stamina= alterStamina ballstate fb (zero) (zero)})+ where+ allowOnlyPlayTheater= case action of+ PlayTheater → action+ _ → Move (zero) { direction = (direction (speed fb))} (zero) -- Run (zero) { direction = (direction (speed fb))}+ checkIfNotOnGround _ action fb+ = (action,fb)++{- selectActions actions match+ removes all failing actions, and returns the list of remaining succeeding actions.+ It updates the random stream in match, and neutralizes actions of tackled players.+-}+selectActions ∷ [PlayerWithAction] → Match → ([PlayerWithAction],Match)+selectActions actions match@Match{seed=seed} = runIdentity $ do+ (seed,succeededActions) ← return $ validActions match seed actions+ ((successTackles,failedTackles),seed) ← return $ analyseTackleActions match succeededActions seed+ succeededActions ← return $ filter (isNoTackleVictim successTackles) (removeMembers succeededActions failedTackles)+ return $ (succeededActions,match { seed=seed})+ where+ {- actions that are always valid: {Move, Run, Rotate, Feint, Schwalbe, PlayTheater}+ actions that may have success: {Tackle} (looked at later at performactions)+ actions where at most (fromIntegral 1) can succeed: {GainBall, KickBall, HeadBall, Catch}+ -}+ validActions ∷ Match → StdGen → [PlayerWithAction] → (StdGen,[PlayerWithAction])+ validActions match seed [] = (seed,[])+ validActions match seed actions+ | isJust ballAction = (seed1,(fromJust ballAction:otherActions))+ | otherwise = (seed1,otherActions)+ where+ allPlayers = (team1 match) ++ (team2 match)+ (ballActions,otherActions) = spanfilter (isActionOnBall ∘ fst) actions+ (seed1,ballAction) = selectBallAction (theBall match) allPlayers seed ballActions++ selectBallAction ∷ BallState → [Player] → StdGen → [PlayerWithAction] → (StdGen,Maybe PlayerWithAction)+ selectBallAction ballstate allPlayers seed desiredActions = runIdentity $ do+ (ps,seed) ← return $ iterateStn (length desiredActions) random seed+ odds ← return $ [ (successOfAction ballstate allPlayers action (if (p==fromIntegral 1) then p else (makeRandomRealistic p)),action)+ | (action,p) <- zip desiredActions ps+ ]+ okOdds ← return $ filter (\(p,a) → p > (zero)) odds+ if null okOdds then return $ (seed,Nothing) else do+ maxOddProb ← return $ maximum (map fst okOdds)+ bestActions ← return $ [a | (p,a) <- okOdds, p >= maxOddProb]+ (p,seed) ← return $ random seed+ if p==fromIntegral 1 then return $ (seed,Just (head bestActions)) else do+ let l = fromIntegral $ length bestActions ∷ Float+ let m = p * l+ let idx = floor m+ return (seed,Just (bestActions !! idx))+ where+ successOfAction ∷ BallState → [Player] → PlayerWithAction → Float → Float+ successOfAction ballstate allPlayers (action,who) p+ = myFatigue * myHealth * p * successOfAction+ where+ successOfAction = if (isGainBall action && ballGainable && ballAtGainSpeed) then successGaining else+ (if (isCatchBall action && ballCatchable && ballAtCatchSpeed) then successCatching else+ (if (isKickBall action && ballKickable) then successKicking else+ (if (isHeadBall action && ballHeadable) then successHeading else+ (zero)+ )))+ Just me = find (identifyPlayer who) allPlayers+ myFatigue = (stamina me)+ myHealth = (health me)+ mySkills = skillsAsList me+ myLength = (height me)+ iGainWell = elem Gaining mySkills+ iKickWell = elem Kicking mySkills+ iHeadWell = elem Heading mySkills+ iCatchWell = elem Catching mySkills++ ballGainable = dPlayerBall <= maxGainReach me+ ballKickable = dPlayerBall <= maxKickReach me+ ballHeadable = dPlayerBall <= maxHeadReach me+ ballCatchable = dPlayerBall <= maxCatchReach me+ ballAtGainSpeed = dVelocity <= maxGainVelocityDifference me dPlayerBall+ ballAtCatchSpeed = dVelocity <= maxCatchVelocityDifference me dPlayerBall+ dSpeed = (zero) { dxy = scaleVector (velocity (speed me)) (toRVector (direction (speed me)))}+ -+ RVector3D { dxy = scaleVector (velocity (vxy (ballSpeed theBall))) (toRVector (direction (vxy (ballSpeed theBall))))+ , dz = (vz (ballSpeed theBall))+ }+ dVelocity = sizeVector3D dSpeed++ theBall = getBall ballstate allPlayers+ dPlayerBall = dist (toPosition3D (pos me)) (ballPos theBall)++ othersWithBall = [fb | fb <- allPlayers, ballIsGainedBy (playerID fb) ballstate && not (identifyPlayer who fb)]+ otherHasBall = not (null othersWithBall)+ otherDribblesWell = elem Dribbling (skillsAsList (head othersWithBall))++ successGaining = if (ballIsFree ballstate) then (lengthPenalty * if iGainWell then 0.95 else 0.8) else+ (if otherHasBall then (lengthPenalty * if iGainWell then 0.75 else 0.3 * if otherDribblesWell then 0.6 else 1.0)+ else 1.0)+ successKicking = if (ballIsFree ballstate) then (lengthBonus * if iKickWell then 0.95 else 0.85) else+ (if otherHasBall then (lengthBonus * if iKickWell then 0.80 else 0.70 * if otherDribblesWell then 0.7 else 1.0)+ else 1.0)+ successHeading = if iHeadWell then 0.95 else 0.9+ successCatching = if iCatchWell then 1.0 else 0.95+ lengthBonus = (myLength-1.2) ** 0.15+ lengthPenalty = (2.6-myLength) ** 0.1++analyseTackleActions ∷ Match → [PlayerWithAction] → StdGen → (([PlayerWithAction],[PlayerWithAction]),StdGen)+analyseTackleActions match performedActions seed+ = spanfilterSt (isPossibleTackle match) [action | action <- performedActions, isPlayerTackle (fst action)] seed+ where+ isPossibleTackle ∷ Match → PlayerWithAction → StdGen → (Bool,StdGen)+ isPossibleTackle match@Match{team1=team1,team2=team2} (Tackle victimID _,playerID) seed+ | dMeVictim > maxTackleReach offender -- victim is out of reach+ = (False,seed)+ | otherwise = (((p + chanceOfSuccess) / 2) > 0.5,seed') -- victim is within reach, but tackle may fail+ where+ (p,seed') = random seed+ allPlayers = team1 ++ team2+ Just offender = find (identifyPlayer playerID) allPlayers+ Just victim = find (identifyPlayer victimID) allPlayers+ dMeVictim = dist (pos offender) (pos victim)+ chanceOfSuccess = (1.0 - dMeVictim + if (elem Tackling (skillsAsList offender)) then 0.9 else 0.7) /2++isNoTackleVictim ∷ [PlayerWithAction] → PlayerWithAction → Bool+isNoTackleVictim tackles (action,playerID)+ = isSchwalbe action+ ∨ isPlayTheater action+ ∨ null [victim | (Tackle victim _,_) <- tackles, victim==playerID]++{- refereeTurn match+ determines whether the rules of soccer are adhered to and yields a list of referee actions.+-}+refereeTurn ∷ Match → ([RefereeAction],Match)+refereeTurn match@Match{theReferee=referee@Referee{ rbrain=brain@Brain{ai=ai,m=m}},theBall=theBall,playingHalf=playingHalf,team1=team1,team2=team2,playingTime=playingTime,unittime=unittime,seed=seed}+ = (refereeActions,match { theReferee=newReferee,seed=newSeed})+ where+ (refereeActions,(newM,newSeed)) = ai playingTime unittime theBall playingHalf team1 team2 (m,seed)+ newReferee = cloneReferee (Brain{ai=ai,m=newM}) referee++{- performRefereeActions refereeActions match+ performs for each ball player in match his succeededAction, informs them about the referee actions, and moves the ball.+-}+performRefereeActions ∷ [RefereeAction] → Match → Match+performRefereeActions refActions match = foldl doRefereeEvent match refActions+ where+ doRefereeEvent ∷ Match → RefereeAction → Match+ doRefereeEvent theMatch@Match{playingHalf=playingHalf,theField=theField,team1=team1,team2=team2} refereeAction+ | isAlterMatchBallAndTeams = theMatch { theBall=Free (mkBall pos (zero))}+ | isGameProgressEvent = gameProgress theMatch+ | isDisplaceTeamsEvent = theMatch { team1=map (displacePlayer ds) team1,team2=map (displacePlayer ds) team2}+ | isReprimandEvent = let (team1',team2') = reprimandPlayer (nameOf team1) tef repr (team1,team2) in theMatch { team1=team1',team2=team2'}+ | otherwise = theMatch+ where+ (isAlterMatchBallAndTeams,pos) = case refereeAction of+ DirectFreeKick _ pos → (True,pos)+ ThrowIn _ pos → (True,pos)+ Corner _ _ → (True,fromJust (getKickPos theField playingHalf refereeAction))+ GoalKick _ → (True,fromJust (getKickPos theField playingHalf refereeAction))+ Penalty _ → (True,fromJust (getKickPos theField playingHalf refereeAction))+ CenterKick _ → (True,fromJust (getKickPos theField playingHalf refereeAction))+ otherwise → (False,error "UNDEF pos")+ (isGameProgressEvent,gameProgress)+ = case refereeAction of+ GameOver → (True,\m → m { playingTime=(zero)})+ AddTime t → (True,\m → m { playingTime=(playingTime m+)t})+ EndHalf → (True,\m → m { playingHalf=SecondHalf})+ Goal t → (True,\m@Match{score=(w,e)} → m { score=if (t==Team1) then (w+1,e) else (w,e+1)})+ otherwise → (False,error "UNDEF gameProgress")+ (isDisplaceTeamsEvent,ds) = case refereeAction of+ DisplacePlayers ds → (True, ds)+ otherwise → (False,error "UNDEF ds")+ (isReprimandEvent,(tef,repr)) = case refereeAction of+ ReprimandPlayer p r → (True, (p,r))+ otherwise → (False,(error "UNDEF tef", error "UNDEF repr"))++displacePlayer ∷ Displacements → Player → Player+displacePlayer displacements fb+ = case lookup (playerID fb) displacements of+ Just pos → fb { pos=pos}+ nothing → fb++reprimandPlayer ∷ ClubName → PlayerID → Reprimand → ([Player],[Player]) → ([Player],[Player])+reprimandPlayer club1 playerID RedCard (team1,team2)+ = splitAt (nrPlayers1 - if ((clubName playerID) == club1) then 1 else 0) (uneq1++uneq2)+ where+ (uneq1,_,uneq2) = break1 (identifyPlayer playerID) (team1++team2)+ nrPlayers1 = length team1+reprimandPlayer _ _ _ teams = teams++{- performPlayerActions actions succeededActions match+ performs for each ball player in match his succeededAction and moves the ball.+-}+performPlayerActions ∷ [PlayerWithAction] → [PlayerWithAction] → Match → Match+performPlayerActions actions succeededActions match@Match{theField=theField,theBall=theBall,team1=team1,team2=team2,seed=seed,unittime=unittime} = runIdentity $ do+ (seed,ball,newPlayers1,newPlayers2)+ ← return $ foldl (flip (performAction succeededActions)) (seed,theBall,team1,team2) actions+ (ball,seed) ← return $ moveBall theField (newPlayers1++newPlayers2) (ball,seed)+ match ← return $ match { team1=newPlayers1, team2=newPlayers2, theBall=ball, seed=seed }+ return $ match+ where+ performAction ∷ [PlayerWithAction] → PlayerWithAction → (StdGen,BallState,[Player],[Player])+ → (StdGen,BallState,[Player],[Player])+ performAction succeededActions initiative (seed,ball,allPlayers1,allPlayers2)+ | elem initiative succeededActions -- plan has succeeded+ = performAction' initiative (seed,ball,allPlayers1,allPlayers2)+ | otherwise -- plan has failed+ = (seed,ball,map (failThisPlayerAction initiative) allPlayers1,map (failThisPlayerAction initiative) allPlayers2)+ where+ failThisPlayerAction ∷ PlayerWithAction → Player → Player+ failThisPlayerAction (idea,playerID) fb+ | identifyPlayer playerID fb+ = fb { effect=Just (failPlayerAction idea)}+ | otherwise = fb++ performAction' ∷ PlayerWithAction → (StdGen,BallState,[Player],[Player])+ → (StdGen,BallState,[Player],[Player])++ performAction' (Move sp angle,playerID) (seed,ball,team1,team2) = runIdentity $ do+ (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return (seed1,ball,team1,team2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ curNose = (nose fb)+ curSpeed = (speed fb)+ skills = skillsAsList fb+ playerHasBall = ballIsGainedBy playerID ball+ (p,seed1) = random seed+ feasibleAngle = ((signum angle)) * (abs angle `boundedBy` (0, maxRotateAngle fb))+ newNose = curNose + feasibleAngle+ angleDifficulty = angleHowFarFromPi ((direction sp)-newNose)+ angleDifference = angleHowFarFromAngle (direction sp) newNose+ newStamina = max (alterStamina ball fb angleDifficulty angleDifference) maxStamina+ newHealth = alterHealth ball fb p angleDifficulty angleDifference+ healthFat = getHealthStaminaFactor newHealth newStamina+ newVel = healthFat * (velocity sp `boundedBy` (0, maxVelocity fb angleDifficulty angleDifference))+ newSpeed = sp { velocity=newVel}+ newPosition' = movePoint (scaleVector (unittime * newVel) (toRVector (direction newSpeed))) (pos fb)+ newPosition = pointToRectangle ((zero),Position{px=(flength theField),py=(fwidth theField)}) newPosition'+ newFb = fb { stamina = newStamina+ , health = newHealth+ , speed = newSpeed+ , pos = newPosition+ , nose = newNose+ , effect = Just (Moved newSpeed feasibleAngle)+ }++ {- Run has become deprecated.+ Rules for running:+ (1) you can't run through another player+ (2) you can't run faster than maximum velocity for a player (depends on Running and Dribbling skill)+ (3) you can't leave field+ (4) running fast lowers your stamina+ (5) running slow increases your stamina and health+ (6) poor health or poor stamina lowers your maximum velocity+ -}{-+ performAction' (Run speed,playerID) (seed,ball,team1,team2)+ | null bumpedInto = runIdentity $ do -- no collision with other player+ newFb ← fb { pos = newPosition+ , speed = newSpeed+ , stamina = newStamina+ , effect = Just (Ran eventSpeed { direction = (direction eventSpeed) - (direction (speed fb))})+ }+ (team1,team2) ← splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return $ (seed2,ball,team1,team2)+ | otherwise = runIdentity $ do -- collission with other player+ playerSpeed ← (speed fb) { direction=(direction newSpeed), velocity=(velocity 0.3*newSpeed)}+ newFb ← fb { speed = playerSpeed+ , stamina = newStamina+ , effect = Just (Ran (speed fb) { velocity=(velocity 0.3*newSpeed)})+ }+ (team1,team2) ← splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ (p3,seed3) ← random seed2+ (seed4,team1,team2)+ ← moveBumpedPlayers newSpeed { velocity=(velocity 0.3*newSpeed), direction = (direction 0.4*p3*newSpeed)}+ bumpedInto (seed3,team1,team2)+ return $ (seed4,ball,team1,team2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ (p1,seed1) = random seed+ (p2,seed2) = random seed1+ angleDifficulty = angleHowFarFromPi (direction speed)+ angleDifference = if (isNothing (effect fb)) then (zero) else (case fromJust (effect fb) of+ Ran s → angleHowFarFromAngle (direction speed) (direction s)+ _ → (zero))+ playerHasBall = ballIsGainedBy playerID ball+ newStamina = alterStamina ball fb angleDifficulty angleDifference+ newHealth = alterHealth ball fb p1 angleDifficulty angleDifference+ healthFat = getHealthStaminaFactor newHealth newStamina+ newVel = healthFat * (velocity speed `boundedBy` (0, maxVelocity fb angleDifficulty angleDifference))+ newSpeed = (speed fb) { velocity=newVel}+ newAngle = if (p2 == (fromIntegral 1)) then ((direction (speed fb)) + (direction speed)) else+ (if (p2 > 0.5) then ((direction (speed fb)) + (0.85 + 0.15 * healthFat) * pi - pi + (direction speed)) else+ ((direction (speed fb)) + (1.15 - 0.15 * healthFat) * pi - pi + (direction speed)))+ eventSpeed = (speed fb) { velocity=newVel, direction=newAngle}+ newPosition' = movePoint (scaleVector (unittime * newVel) (toRVector newAngle)) (pos fb)+ newPosition = pointToRectangle ((zero),{px=(flength theField),py=(fwidth theField)}) newPosition'+ bumpedInto = (playerID [fb) | fb <- uneq1++uneq2 | inRadiusOfPlayer newPosition fb]+ -}+ {- Rotate has become deprecated:+ Rules for rotating:+ (1) Rotating with slow velocity increases your stamina and health+ (2) Rotating with high velocity lowers your stamina and health+ (3) poor health or poor stamina lowers your maximum velocity+ (4) poor health or poor stamina lowers your precision with turning+ (5) you can't leave field+ (6) you can't run faster than your maximum velocity+ (7) you can't run through another player+ -}{-+ performAction' (Rotate speed,playerID) (seed,ball,team1,team2)+ | not (null bumpedInto) = runIdentity $ do+ playerSpeed ← (speed fb) { direction=newAngle, velocity=(velocity 0.3*newSpeed)}+ newFb ← fb { speed = playerSpeed+ , stamina = newStamina+ , effect = Just (Rotated {direction=newAngle,velocity=(velocity 0.3*newSpeed)})+ }+ (team1,team2) ← splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ (p2,seed2) ← random seed1+ (seed3,team1,team2) ← moveBumpedPlayers newSpeed { velocity=(velocity 0.3*newSpeed), direction = (direction 0.4*p2*newSpeed)}+ bumpedInto (seed2,team1,team2)+ return $ (seed3,ball,team1,team2)+ | otherwise = runIdentity $ do+ newFb ← fb { pos = newPosition+ , speed = newSpeed+ , stamina = newStamina+ , effect = Just (Rotated newSpeed)+ }+ (newTeam1,newTeam2) ← splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return $ (seed1,ball,newTeam1,newTeam2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ (p1,seed1) = random seed+ newV' = healthFat * (setbetween (velocity speed) (zero) (maxVelocity fb (zero) (zero)))+ newV = if (newAngle >= maxRotateAngle fb { speed=(speed fb) { velocity=newV'}}) then (max (newV' - 0.5) (zero)) else newV'+ newAngle = let lengthFactor = if (elem Rotating skills) then ((height fb)-0.2) else (height fb)+ healthFactor = (healthFat/((direction 0.75*lengthFactor))*speed)+ in if ((direction speed) > (zero)) then (min ( maxRotateAngle fb) healthFactor) else+ (max (~(maxRotateAngle fb)) healthFactor)+ skills = skillsAsList fb+ playerHasBall = ballIsGainedBy playerID ball+ newStamina = alterStamina ball fb (zero) (zero)+ newHealth = alterHealth ball fb p1 (zero) (zero)+ healthFat = getHealthStaminaFactor newHealth newStamina+ newDirection = (direction (speed fb)) + newAngle+ newSpeed = (speed fb) { direction=newDirection, velocity=newV}+ newPosition' = movePoint (scaleVector (unittime * newV) (toRVector newDirection)) (pos fb)+ newPosition = pointToRectangle ((zero),{px=(flength theField),py=(fwidth theField)}) newPosition'+ bumpedInto = (playerID [fb) | fb <- uneq1++uneq2 | inRadiusOfPlayer newPosition fb]+ -}+ {- Rules for gaining ball:+ (1) ball obtains position and surface speed of obtaining player+ -}+ performAction' (GainBall,playerID) (seed,ball,team1,team2) = runIdentity $ do+ (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return $ (seed,GainedBy playerID,team1,team2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ newFb = fb { effect = Just (GainedBall Success)}++ {- Rules for kicking ball:+ (1) kicking decreases stamina+ (2) kicking is more effective towards your direction, and least effective in opposite direction+ (3) being taller, you can kick harder+ (4) a low stamina/health lower your max kickspeed+ (5) todo: kicking a ball held/gained by a keeper, may damage the keeper+ -}+ performAction' (KickBall (Speed3D{vxy=Speed{velocity=v,direction=d},vz=vz}),playerID) (seed,ball,team1,team2) = runIdentity $ do+ (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return $ (seed2,Free newBall,team1,team2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ (p1,seed1) = random seed+ (p2,seed2) = random seed1+ newFb = fb { stamina=newStamina,effect=Just (KickedBall (Just newSpeed))}+ theBall = getBall ball (team1 ++ team2)+ skills = skillsAsList fb+ fatHealth = getHealthStaminaFactor (health fb) (stamina fb)+ maxV = maxVelocityBallKick fb+ newV = speedFactor * (v `boundedBy` (0,maxV))+ newVz = speedFactor * (vz `boundedBy` (0, maxV))+ newSpeed = Speed3D{vxy=Speed{velocity=newV,direction=newDirection},vz=newVz}+ newStamina = kickingPenalty fb newV * (stamina fb)+ speedFactor = oppositeKickPenalty fb d+ newBall = theBall { ballSpeed=newSpeed}+ newDirection = runIdentity $ do+ if p2 == (fromIntegral 1) then return d else do+ failure ← return $ (fromIntegral 1) - if (elem Kicking skills) then (makeRandomRealisticSkilled p2) else (makeRandomRealistic p2)+ if p1 `mod` (2::Int) ≡ 0 then do+ newD ← return $ d - failure * maxKickingDeviation fb+ return $ if (newD < (zero)) then (newD + 2.0*pi) else newD+ else do+ newD ← return $ d + failure * maxKickingDeviation fb+ return $ if (newD > 2.0*pi) then (newD - 2.0*pi) else newD++ {- Rules for heading ball:+ (1) heading decreases stamina, but less than kicking+ (2) kicking is more effective towards your direction, and least effective in opposite direction+ (3) a low stamina/health lower your max headspeed, but less than kicking+ (4) heading is less harder than kicking, but is not effected by your length+ (5) todo: heading a ball held/gained by a keeper, may damage the keeper (less than with kicking)+ -}+ performAction' (HeadBall (Speed3D{vxy=Speed{velocity=v,direction=d},vz=vz}),playerID) (seed,ballstate,team1,team2) = runIdentity $ do+ (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return $ (seed2,Free newBall,team1,team2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ (p1,seed1) = random seed+ (p2,seed2) = random seed1+ skills = skillsAsList fb+ fatHealth = getHealthStaminaFactor (health fb) (stamina fb)+ ball = getBall ballstate (team1 ++ team2)+ ballSpeed' = (velocity (vxy (ballSpeed ball)))+ maxV = maxVelocityBallHead fb ballSpeed'+ newV = v `boundedBy` (zero, maxV)+ newVz = 0.25 * (vz `boundedBy` (0, maxV))+ newDirection = runIdentity $ do+ if p2 == (fromIntegral 1) then return d else do+ failure ← return $ (fromIntegral 1) - if (elem Heading skills) then makeRandomRealisticSkilled p2 else makeRandomRealistic p2+ if p1 `mod` (2::Int) ≡ 0 then do+ newD ← return $ d - failure * maxHeadingDeviation fb+ return $ if (newD < (zero)) then (newD + 2.0*pi) else newD+ else do+ newD ← return $ d + failure * maxHeadingDeviation fb+ return $ if (newD > 2.0*pi) then (newD - 2.0*pi) else newD+ newSpeed = Speed3D{vxy=Speed{velocity=newV,direction=newDirection},vz=newVz}+ newStamina = headingPenalty fb newV ballSpeed' * (stamina fb)+ newFb = fb { stamina=newStamina,effect=Just (HeadedBall (Just newSpeed))}+ newBall = ball { ballSpeed=newSpeed}++ {- Rules for feinting:+ (1) you must have velocity in order to feint manouvre.+ (2) a feint manouvre changes your position, and decreases your velocity (depends on Feinting skill)+ -}+ performAction' (Feint d,playerID) (seed,ball,team1,team2) = runIdentity $ do+ (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return $ (seed,ball,team1,team2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ playerHasBall = ballIsGainedBy playerID ball+ newStamina = maxFatigueLossAtFeint fb * (stamina fb)+ fatHealth = getHealthStaminaFactor (health fb) (stamina fb)+ newVelocity = fatHealth * (velocity (speed fb)) * maxVelocityLossAtFeint fb+ newSpeed = (speed fb) { velocity=newVelocity}+ (leftv,rightv) = orthogonal (direction (speed fb))+ sidestep = case d of FeintLeft → leftv; _ → rightv+ newPosition' = movePoint ((scaleVector (maxFeintStep fb) (toRVector sidestep))+ ++ (scaleVector (unittime * newVelocity) (toRVector (direction (speed fb))))+ ) (pos fb)+ newPosition = pointToRectangle ((zero),Position{px=(flength theField),py=(fwidth theField)}) newPosition'+ newFb = fb { pos=newPosition,speed=newSpeed,stamina=newStamina,effect=Just (Feinted d)}++ {- Rules for Tackling+ (1) tackling may lower the health of the victim but increases his stamina (last is because he lies on the ground the next rounds)+ (2) tackling costs stamina+ -}+ performAction' (Tackle victimID ve,playerID) (seed,ball,team1,team2) = runIdentity $ do+ return $ (seed1,newBall,team1T,team2T)+ where+ nrPlayersTeam1 = length team1+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ (team1N,team2N) = splitAt nrPlayersTeam1 (unbreak1 (uneq1,newFb,uneq2))+ (uneq1T,fbT,uneq2T) = break1 (identifyPlayer victimID) (team1N ++ team2N)+ (team1T,team2T) = splitAt nrPlayersTeam1 (unbreak1 (uneq1T,newTarget,uneq2T))+ newStaminaSelf = maxFatigueLossAtTackle fb * (stamina fb)+ fatHealthSelf = getHealthStaminaFactor (health fb) (stamina fb)+ newFb = fb { stamina = newStaminaSelf, effect = Just (Tackled victimID ve Success)}+ targetHasBall = ballIsGainedBy victimID ball+ (p,seed1) = random seed+ newV' = min maxTackleVelocity ve+ maxTackleVelocity = 10.0+ newV = newV'/10.0+ healthDamageTarget = newV * fatHealthSelf * (0.5*p + 0.1) + ((height fbT)-minLength)/2.0+ newHealthTarget = max 0.0 (health fbT) - healthDamageTarget+ newTarget = fbT { health = newHealthTarget, effect = Just (OnTheGround 3) }+ newBall = if targetHasBall then (Free (mkBall (pos fbT) (speed fbT))) else ball++ {- Rules for Schwalbe+ (1) Schwalbe cures stamina+ (2) Performing a Schwalbe when ball was gained causes to lose ball+ -}+ performAction' (Schwalbe,playerID) (seed,ball,team1,team2) = runIdentity $ do+ (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return $ (seed,ball,team1,team2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ newFb = fb { effect = Just (OnTheGround 1)}++ {- Rules for catching+ (1) ball optains speed and distance of player+ -}+ performAction' (CatchBall,playerID) (seed,ball,team1,team2) = runIdentity $ do+ (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return $ (seed,GainedBy playerID,team1,team2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ newFb = fb { effect=Just (CaughtBall Success)}++ {- Rules for playing theater+ (1) playingTheater costs stamina+ (2) Performing a Schwalbe when ball was gained causes to lose ball+ -}+ performAction' (PlayTheater,playerID) (seed,ball,team1,team2) = runIdentity $ do+ (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return $ (seed,ball,team1,team2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ e = (effect fb)+ wasOnTheGround = if (isNothing e) then False else (isOnTheGround (fromJust e))+ newEvent = if (isOnTheGround (fromJust e)) then (fromJust e) else PlayedTheater+ newFb = fb { effect = Just newEvent}++ moveBumpedPlayers ∷ Speed → [PlayerID] → (StdGen,[Player],[Player])+ → (StdGen,[Player],[Player])+ moveBumpedPlayers newSpeed bumpedInto (seed,team1,team2)+ = foldl (moveBumpedPlayer newSpeed) (seed,team1,team2) bumpedInto+ where+ moveBumpedPlayer ∷ Speed → (StdGen,[Player],[Player]) → PlayerID+ → (StdGen,[Player],[Player])+ moveBumpedPlayer newSpeed (seed,team1,team2) playerID = runIdentity $ do+ (team1,team2) ← return $ splitAt (length team1) (unbreak1 (uneq1,newFb,uneq2))+ return $ (seed1,team1,team2)+ where+ (uneq1,fb,uneq2) = break1 (identifyPlayer playerID) (team1 ++ team2)+ (p,seed1) = random seed+ newPos = let a = p*2.0*pi in movePoint RVector {dx=0.5*cos a,dy=0.5*sin a} (pos fb)+ newFb = fb { speed=newSpeed, pos=newPos}+++ {- moveBall moves the ball (fromIntegral 1) unit, taking into account the surface and air resistance.+ -}+ moveBall ∷ Field → [Player] → (BallState,StdGen) → (BallState,StdGen)+ moveBall _ _ gained@(GainedBy playerID,seed)+ = gained+ moveBall field allPlayers (Free ball@Ball{ballSpeed=Speed3D{vxy=Speed{velocity=v,direction=d},vz=vz},ballPos=ballPos},seed)+ = (Free ball { ballSpeed=newSpeed,ballPos=newBallpos},seed1)+ where+ inTheAir = (pz ballPos) > (zero)+ resistance = if inTheAir then airResistance else surfaceResistance+ surfaceMovement = scaleVector (unittime * v) (toRVector d)+ newSpeed2D = let newV = resistance*v in Speed{direction = d, velocity = if (newV <= 0.05) then (zero) else newV}+-- newVz' = if inTheAir then (vz - unittime*accellerationSec) else (zero)+ newVz' = vz - unittime*accellerationSec+ newHeight' = (pz ballPos) + vz+ (newHeight,newVz) = if (newHeight' < (zero)) then (0.5*(abs newHeight'),let newV = 0.33*(abs newVz') in if (newV <= 0.8) then (zero) else newV) else -- ball bounces, loss of velocity+ (newHeight',newVz')+ newSpeed' = Speed3D{vxy=newSpeed2D, vz=newVz}+ newBallpos = Position3D{pxy=movePoint surfaceMovement (pxy ballPos),pz=newHeight}+ fieldDimensions = ((zero),Position{px=(flength field),py=(fwidth field)})+ (newSpeed,seed1) = ballBouncesAgainst field newBallpos newSpeed' allPlayers seed++ -- if the then ball else bounces against something, velocity will be reduced again and the direction will be changed.+ ballBouncesAgainst ∷ Field → Position3D → Speed3D → [Player] → StdGen → (Speed3D,StdGen)+ ballBouncesAgainst field newBallpos newSpeed@Speed3D{vxy=Speed{velocity=v,direction=d},vz=s3d} allPlayers seed+ -- the ball may hit (fromIntegral 1) of the poles of (fromIntegral 1) of the goal or (fromIntegral 1) of the players and bounce away+ -- ball hits (fromIntegral 1) of the goal poles+ | againstGoalWestNorthPole || againstGoalWestSouthPole || againstGoalEastNorthPole || againstGoalEastSouthPole+ -- 50% bounce left, 50% bounce right+ = (newSpeed { vxy = (vxy newSpeed) { direction = if (p1<=0.5) then (d-p2*pi) else (d+p2*pi), velocity = resistance*v}},seed2)+ -- ball hits the top of (fromIntegral 1) of the goals+ | againstGoalWestPoleUpper || againstGoalEastPoleUpper = runIdentity $ do+ forwardOrBack ← return $ if (p1<=0.5) then Forward else Back+ upOrDown ← return $ if ((pz newBallpos) < goalHeight+(goalPoleWidth/2.0)) then Down else Up+ return $ bounceBall upOrDown (bounceBall forwardOrBack (newSpeed,seed2))+ -- ball hits (fromIntegral 1) of the players+ | any (\fb → inRadiusOfPlayer (pxy newBallpos) fb && (height fb) >= (pz newBallpos)) allPlayers+ -- bounces pure at random (player might get ported)+ = (newSpeed { vxy = (vxy newSpeed) { direction = p2*2.0*pi, velocity = resistance*v}, vz=p1*s3d},seed2)+ -- ball hits nothing+ | otherwise+ = (newSpeed,seed2)+ where+ (p1,seed1) = random seed+ (p2,seed2) = random seed1+ (northPole,southPole) = goalPoles field+ againstGoalWestNorthPole = inCircleRadiusOfPosition newBallpos (goalPoleWidth/2.0) goalHeight Position {px=0.0, py=northPole - goalPoleWidth/2.0}+ againstGoalWestSouthPole = inCircleRadiusOfPosition newBallpos (goalPoleWidth/2.0) goalHeight Position {px=0.0, py=southPole + goalPoleWidth/2.0}+ againstGoalEastNorthPole = inCircleRadiusOfPosition newBallpos (goalPoleWidth/2.0) goalHeight Position {px=(flength field),py=northPole - goalPoleWidth/2.0}+ againstGoalEastSouthPole = inCircleRadiusOfPosition newBallpos (goalPoleWidth/2.0) goalHeight Position {px=(flength field),py=southPole + goalPoleWidth/2.0}+ againstGoalWestPoleUpper = (isbetween (py (pxy newBallpos)) (northPole-goalPoleWidth/2.0) (southPole+goalPoleWidth/2.0))+ &&+ (isbetween (pz newBallpos) goalHeight (goalHeight+goalPoleWidth))+ &&+ ((px (pxy newBallpos)) <= (zero))+ againstGoalEastPoleUpper = (isbetween (py (pxy newBallpos)) (northPole-goalPoleWidth/2.0) (southPole+goalPoleWidth/2.0))+ &&+ (isbetween (pz newBallpos) goalHeight (goalHeight+goalPoleWidth))+ &&+ ((px (pxy newBallpos)) >= (flength field))++advanceTime ∷ Match → Match+advanceTime match@Match{playingTime=playingTime, unittime=unittime}+ = match { playingTime = max (zero) ((playingTime*160.0 - unittime)/160.0)} {-| Attribute altering functions depending on angles:
SoccerFun/MatchGame.hs view
@@ -14,9 +14,7 @@ import System.Random import System.Exit import System.Process-import System.Cmd import Data.List (findIndices)-import Paths_SoccerFun (getDataFileName) showTime ∷ Minutes → String -- ^ display time in (mm:ss min) format@@ -46,24 +44,16 @@ logRefereeAction (CenterKick t) = Just $ "CenterKick " ++ show t logRefereeAction (Advantage t) = Just $ "Advantage " ++ show t logRefereeAction (OwnBallIllegally tfp) = Just $ "OwnBallIllegally" ++ show (playerNo tfp)-logRefereeAction (DisplacePlayers ds) = Just $ "DisplacePlayers"+logRefereeAction (DisplacePlayers ds) = Nothing -- Just $ "DisplacePlayers" logRefereeAction ContinueGame = Nothing logRefereeAction (TellMessage txt) = Just $ "TellMessage " ++ show txt 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+ team1 = take 11 $ t1 West field+ team2 = take 11 $ t2 East field in liftM (setMatchStart team1 team2 field (ivanovReferee field team1 team2) 1) newStdGen--dynRecord ∷ FilePath → FilePath → IO ()-dynRecord p1 p2 = do- (loc1,name1) ← compileTeam p1- (loc2,name2) ← compileTeam p2- record ← getDataFileName "SoccerFun/Tape/Record/Template.hs"- exitCode ← system $ "runhaskell -i" ⧺ loc1 ⧺ " -i" ⧺ loc2 ⧺ " -DTEAM1=" ⧺ name1 ⧺ " -DTEAM2=" ⧺ name2 ⧺ " " ⧺ record- when (exitCode ≢ ExitSuccess) (fail "Could merge teams, probably due to a type error.") compileTeam ∷ FilePath → IO (FilePath,String) compileTeam p = do
SoccerFun/Referee/Ivanov.hs view
@@ -16,930 +16,854 @@ import SoccerFun.Field -chanceOfPenaltySuccess = 0.3-chanceOfSchwalbeSuccess = 0.7-chanceOfTheaterSuccess = 0.8-chanceOfCatchSuccess = 0.5-healthInaccurateFactor = 1.0 -- (is multiplied with 0.5)-nearEventRadius = 10.0-replaceDistance = 5.0----ivanovPics ∷ [Path]---ivanovPics = map inDir [ "IvanovWarning"--- , "ivanovYellow"--- , "ivanovRed"--- , "ivanovBadluck"--- , "ivanovWijstLinks"--- , "ivanovWijstRechts"--- , "ivanovBadluck"--- , "ivanovFluit"--- , "ivanovFluit"--- , "ivanovTheater"--- ]--- where--- inDir img = "afbeeldingen|"<+++img<+++".bmp"--ivanovReferee ∷ Field → Team → Team → Referee-ivanovReferee field t1 t2 = Referee { rname = "Ivanov"- , rbrain = Brain { m = mkIvanovLongTermMemory t1 t2- , ai = refBrainIvanov field- }--- , refActionPics = ivanovPics- }---- Memory that is passed around for the referee-data IvanovLongTermMemory = IvanovLongTermMemory { lastRoundTackles ∷ [TackleAction]- , inOffsidePosition ∷ [PlayerID]- , keeper1HadBall ∷ Bool -- True iff keeper of Team1 had ball in previous round- , keeper2HadBall ∷ Bool -- True iff keeper of Team2 had ball in previous round- , prevHealthPlayers ∷ AssocList PlayerID Health -- the health of the players in previous round- , lastKickedTheBall ∷ Maybe PlayerID- , ballIsFor ∷ Maybe ATeam- , offsidePossible ∷ FreeKickCountdownForOffside -- because of a certain type of free kick- , typeOfKickoff ∷ Maybe RefereeAction- , waitingForSideSkipping ∷ (Bool,Int)- , firstKick ∷ Maybe ATeam- , gameLength ∷ Maybe Float- , receivedYellow ∷ [PlayerID]- , initialTeams ∷ (Team,Team) -- to restore initial positions after kick-off.- }-type TackleAction = (Victim,Offender,Velocity)-type Victim = (PlayerID,Position,Health) -- Victim of a tackle-type Offender = (PlayerID,Position,Health) -- Offender of a tackle--{- KickForcedByReferee : The next kick should be a kick that is appointed by the referee and therefor can not be offside- FreeToKick : The first gain or kick after a free kick; can not be offside- OffsidePossible : It is possible that you are standing offside--}-data FreeKickCountdownForOffside- = OffsidePossible- | FreeToKick- | KickForcedByReferee-instance Eq FreeKickCountdownForOffside where- (==) OffsidePossible OffsidePossible = False -- disable offside since it is buggy- (==) FreeToKick FreeToKick = True- (==) KickForcedByReferee KickForcedByReferee = True- (==) _ _ = False--lowerOffsideCounter ∷ IvanovLongTermMemory → IvanovLongTermMemory-lowerOffsideCounter longMem- = (longMem) { typeOfKickoff = Nothing- , offsidePossible = if ((offsidePossible longMem) == KickForcedByReferee) then FreeToKick else OffsidePossible- }---- Memory used within one timeslice. Is discarded every round.-data IvanovShortTermMemory = IvanovShortTermMemory { gameStoppedForTackle ∷ Bool- , punished ∷ [PunishedPlayer]- , penalty ∷ [(ATeam,Reason)]- , thisRoundTackles ∷ [TackleAction]- , myMood ∷ Mood- , offsideAndTouchedBall ∷ Maybe PlayerID- , ballKickedOrHeaded ∷ Bool- }-type PunishedPlayer = (PlayerID,PunishedScore,[Reason])-type PunishedScore = Int -- < 0 points is probably nothing- -- 1-2 points is probably warning- -- 3-4 points is probably yellow- -- > 4 points is probably red---- Reason of punishments-data Reason = Rtackle- | Roffside- | Rtheater- | Rschwalbe- | Rhands- | RdangerousPlay- | RillegalBallPossession- deriving Eq--mkIvanovShortTermMemory ∷ Mood → IvanovShortTermMemory-mkIvanovShortTermMemory m = IvanovShortTermMemory { gameStoppedForTackle = False- , punished = []- , penalty = []- , thisRoundTackles = []- , myMood = m- , offsideAndTouchedBall = Nothing- , ballKickedOrHeaded = False- }--type Mood = Float -- Random factor used to randomly pick action when Ivanov is not sure about what happened---mkIvanovLongTermMemory ∷ Team → Team → IvanovLongTermMemory-mkIvanovLongTermMemory t1 t2 = IvanovLongTermMemory { lastRoundTackles = []- , inOffsidePosition = []- , keeper1HadBall = False- , keeper2HadBall = False- , prevHealthPlayers = []- , lastKickedTheBall = Nothing- , ballIsFor = Nothing- , offsidePossible = OffsidePossible- , typeOfKickoff = Nothing- , waitingForSideSkipping = (False, zero)- , firstKick = Nothing- , gameLength = Nothing- , receivedYellow = []- , initialTeams = (t1,t2)- }---- Has #param2 done something naughty? In other words, is #param2 known in the list provided as #param1?-getNaughtyPlayer ∷ [PunishedPlayer] → PlayerID → Maybe PunishedPlayer-getNaughtyPlayer punished fbID'- = case [pun | pun@(fbID,_,_) ← punished, fbID == fbID'] of- (pun:_) → Just pun- _ → Nothing---- Punish baller, if he then was else already punished before, punish him more, otherwise just punish him. Do not make duplicates.-punishMore ∷ Reason → Player → PunishedScore → IvanovShortTermMemory → IvanovShortTermMemory-punishMore reason fb score shortMem- = (shortMem) { punished = newPunished}- where- newPunished = case break' (\(fbID,_,_) → identifyPlayer fbID fb) (punished shortMem) of- (before,[p],after) → unbreak (before,[addPunishScore reason score p],after)- (before,[],[]) → before ++ [((playerID fb),score,[reason])]- otherwise → error "punishMore: short term memory (punished) contains duplicate entries.\n"---- Give the baller a higher punishscore and add the reason if he then was else not punished before for the same reason-addPunishScore ∷ Reason → PunishedScore → PunishedPlayer → PunishedPlayer-addPunishScore reason newScore (fbID,score,reasons)- = (fbID,score+newScore,nub (reasons ++ [reason]))--successfulActions ∷ Team → [PlayerWithEffect]-successfulActions players = map (\Player {effect,playerID} → (effect,playerID)) players---- How this referee thinks about the match and come to his conclusions.-refBrainIvanov ∷ Field → PlayingTime → TimeUnit → BallState → Half → Team → Team → (IvanovLongTermMemory,StdGen)- → ([RefereeAction], (IvanovLongTermMemory,StdGen))-refBrainIvanov field time dt ballState half team1 team2 (longTermMemory,seed) = runIdentity $ do- longTermMemory ← return $ if (isJust (gameLength longTermMemory)) then longTermMemory else (longTermMemory) { gameLength = Just time}- -- filter actions (what mean actions do I notice and what not)- (team1Actions,seed) ← return $ filterOutMeanActions allPlayers (successfulActions team1) seed- -- filter actions team2- (team2Actions,seed) ← return $ filterOutMeanActions allPlayers (successfulActions team2) seed- -- look into the consequences of last round tackles- (p,seed) ← return $ random (seed ∷ StdGen)- (shortTermMemory, seed) ← return $ analyseTackles (mkIvanovShortTermMemory p) team1Actions team2Actions (lastRoundTackles longTermMemory) seed- -- analyse the taken actions- (shortTermMemory,longTermMemory) ← return $ analyseActions Team1 team1Actions shortTermMemory longTermMemory- (shortTermMemory,longTermMemory) ← return $ analyseActions Team2 team2Actions shortTermMemory longTermMemory-- -- check for other people who are on the ground (for some mysterious reason)- shortTermMemory ← return $ analysePeopleOnTheGround (receivedYellow longTermMemory) shortTermMemory team1 team2-- -- give end-verdict of this round- (conclusions,longTermMemory) ← return $ drawConclusions shortTermMemory longTermMemory- return (conclusions,(longTermMemory,seed))- where- allPlayers = team1 ++ team2- theBall = getBall ballState allPlayers-- -- though teams are returned, only positions AND directions will be altered by a Displace-action- replacePlayers ∷ Team → Team → RefereeAction → Field → Ball → IvanovLongTermMemory → Displacements- replacePlayers team1 team2 kickAction field theBall longTermMemory- | isForKeeper kickAction Team1 = replaceFielders team1 posi ++ replaceTeam team2 posi- | isForKeeper kickAction Team2 = replaceTeam team1 posi ++ replaceFielders team2 posi- | isCenterKick kickAction = let- kickOffTeam1 = [(playerID,pos) | Player {playerID,pos} ← fst (initialTeams longTermMemory)]- kickOffTeam2 = [(playerID,pos) | Player {playerID,pos} ← snd (initialTeams longTermMemory)]- in let ng- | half == FirstHalf = kickOffTeam1 ++ kickOffTeam2- | otherwise = map (\(fbID,pos) → (fbID,mirror field pos)) (kickOffTeam1 ++ kickOffTeam2)- in ng- | isForTeam kickAction Team1 = replaceExceptPlayerCloseToPos team1 posi ++ replaceTeam team2 posi- | otherwise = replaceTeam team1 posi ++ replaceExceptPlayerCloseToPos team2 posi- where- posi = case getKickPos field half kickAction of- Just p → p- nothing → (pxy (ballPos theBall))-- replaceTeam ∷ Team → Position → Displacements- replaceTeam team posi = replacePlayers' posi replaceDistance team-- replaceFielders ∷ Team → Position → Displacements- replaceFielders team posi = replacePlayers' posi replaceDistance (filter isFielder team)-- replaceExceptPlayerCloseToPos ∷ Team → Position → Displacements- replaceExceptPlayerCloseToPos team posi = replacePlayers' posi replaceDistance (filter (not . (identifyPlayer (playerID closestPlayer))) team)- where- closestPlayer = getClosestPlayer team posi (nameOf team)-- isForKeeper ∷ RefereeAction → ATeam → Bool- isForKeeper (GoalKick team) theTeam = team==theTeam- isForKeeper _ _ = False-- isForTeam ∷ RefereeAction → ATeam → Bool- isForTeam (DirectFreeKick team1 _) team2 = team1==team2- isForTeam (GoalKick team1) team2 = team1==team2- isForTeam (Corner team1 _) team2 = team1==team2- isForTeam (ThrowIn team1 _) team2 = team1==team2- isForTeam (Penalty team1) team2 = team1==team2- isForTeam (CenterKick team1) team2 = team1==team2- isForTeam _ _ = True-- getClosestPlayer ∷ [Player] → Position → String → Player- getClosestPlayer [] posi err = error ("getClosestPlayer: no player to pick from " ++ err)- getClosestPlayer fbs posi error = foldr1 (isCloser posi) fbs- where- isCloser ∷ Position → Player → Player → Player- isCloser posi fb1@Player {pos=pos1} fb2@Player {pos=pos2}- | dist posi pos1 <= dist posi pos2 = fb1- | otherwise = fb2-- replacePlayers' ∷ Position → Float → [Player] → Displacements- replacePlayers' posi radius players = [displace (dist (pos fb) posi) fb | fb ← players, dist (pos fb) posi < radius]- where- displace dist fb = ((playerID fb),newPos)- where- newPos = if (dist <= 0.1*radius)- then (alterPos (movePoint (scaleVector radius RVector {dx=cos (dist*2.0*pi),dy=sin (dist*2.0*pi)}) posi))- else (alterPos (movePoint (scaleVector radius RVector {dx=cos angle, dy=sin angle}) posi))- angle = atan (((py (pos fb)) - (py posi)) / ((px (pos fb)) - (px posi)))-- -- corrects when players are placed beyond the borders of the field- alterPos ∷ Position → Position- alterPos mypos- | (px mypos) >= (flength field) = alterPos' (Just ((flength field) - one)) Nothing mypos posi- | (px mypos) <= zero = alterPos' (Just one) Nothing mypos posi- | (py mypos) >= (fwidth field) = alterPos' Nothing (Just ((fwidth field) - one)) mypos posi- | (py mypos) <= zero = alterPos' Nothing (Just one) mypos posi- | otherwise = mypos- where- alterPos' ∷ (Maybe XPos) → (Maybe YPos) → Position → Position → Position- alterPos' xpos ypos myPos middlePos- | isJust xpos && isJust ypos = Position { px = fromJust xpos, py = fromJust ypos }- | isJust xpos = let amount = abs (fromJust xpos - (px myPos)) in Position { px = fromJust xpos- , py = if ((py myPos) > (py middlePos))- then (if ((py myPos) < (fwidth field) - amount)- then ((py myPos) + amount)- else ((py myPos) - amount - 2.0*distY)- )- else (if ((py myPos) > amount)- then ((py myPos) - amount)- else ((py myPos) + amount + 2.0*distY)- )- }- | isJust ypos = let amount = abs (fromJust ypos - (py myPos)) in Position { py = fromJust ypos- , px = if ((px myPos) > (px middlePos))- then (if ((px myPos) + amount < (flength field))- then ((px myPos) + amount)- else ((px myPos) - amount - 2.0*distX)- )- else (if ((px myPos) > amount)- then ((px myPos) - amount)- else ((px myPos) + amount + 2.0*distX)- )- }- | otherwise = myPos- where- distY = abs ((py myPos) - (py middlePos))- distX = abs ((px myPos) - (px middlePos))-- analyseTackles ∷ IvanovShortTermMemory → [PlayerWithEffect] → [PlayerWithEffect] → [TackleAction] → StdGen → (IvanovShortTermMemory,StdGen)- -- were there any tackles in the last round?? NO- analyseTackles shortTermMemory _ _ [] seed- = (shortTermMemory,seed)- -- YES: there were tackles last round, whistle for that and ignore all other irrelative events- analyseTackles shortTermMemory team1Actions team2Actions (((victim@PlayerID {playerNo=vNmbr},victimPos,victimHealth), (offender@PlayerID {clubName=oCn,playerNo=oNmbr},offenderPos,offenderHealth), velo) : _) seed = runIdentity $ do -- PA: hmmm, tl of tackles are ignored here.- offendersTeam ← return $ if (nameOf team1 == oCn) then Team1 else Team2- Just victimNow ← return $ find (identifyPlayer victim) allPlayers- Just offenderNow ← return $ find (identifyPlayer offender) allPlayers- shortTermMemory ← return $ (shortTermMemory) { gameStoppedForTackle = True}- -- was the ball near the tackle event(s)- punishScore ← return $ if (dist (pxy (ballPos theBall)) offenderPos <= 6.0) then 2 else 1 -- ball was near tackle event(s)- +- if (vNmbr==1) then 5 else (if (velo >= 6.0) then 3 else 2) -- penalty for keeper victim is highest- -- victim is playing theater?- actionOfVictim ← return $ case concat [maybeToList fa | (fa,fbId) ← if (offendersTeam==Team1) then team2Actions else team1Actions, identifyPlayer fbId victimNow] of- (fa:_) → Just fa- _ → Nothing- -- what is the damage to the victim?- healthDrop ← return $ victimHealth - (health victimNow) + (p-0.5)* healthInaccurateFactor- -- is the victim making theater?- victimPunishScore ← return $ if (isJust actionOfVictim) then (if (isPlayedTheater (fromJust actionOfVictim)) then 3 else 0) else 0- -- victim is not playing theater?- punishScore ← return $ if (victimPunishScore == 0)- then (definePunishmentOnHealthDrop healthDrop punishScore)- else punishScore- -- was the ball on 20% part of the field to the offender's own goal?- ballWasNearGoal ← return $ half == FirstHalf && oCn == nameOf team1 && ((px (pxy (ballPos theBall))) >= 0.8 * (flength field) || (px (pxy (ballPos theBall))) <= 0.2 * (flength field))- || half == SecondHalf && oCn == nameOf team2 && ((px (pxy (ballPos theBall))) >= 0.8 * (flength field) || (px (pxy (ballPos theBall))) <= 0.2 * (flength field))- ballWasInPenaltyArea ← return $ oCn == nameOf team1 && inPenaltyArea field (opponentHome Team2 half) (pxy (ballPos theBall))- || oCn == nameOf team2 && inPenaltyArea field (opponentHome Team1 half) (pxy (ballPos theBall))- punishScore ← return $ punishScore + if ballWasNearGoal then 1 else 0- shortTermMemory ← return $ if ballWasInPenaltyArea- then (shortTermMemory) { penalty = (penalty shortTermMemory) ++ [(offendersTeam,Rtackle)]}- else shortTermMemory- offenderFromSMemory ← return $ getNaughtyPlayer (punished shortTermMemory) offender- victimFromSMemory ← return $ getNaughtyPlayer (punished shortTermMemory) victim- offenderVerdict ← return $ if (isJust offenderFromSMemory)- then (addPunishScore Rtackle punishScore (fromJust offenderFromSMemory))- else (offender,punishScore,[Rtackle])- victimVerdict ← return $ if (isJust victimFromSMemory)- then (addPunishScore Rtheater victimPunishScore (fromJust victimFromSMemory))- else (victim,victimPunishScore,[Rtheater])- return $ if (snd3 offenderVerdict == 0)- then if (snd3 victimVerdict == 0)- then (shortTermMemory,seed1)- else ((shortTermMemory) { punished = (punished shortTermMemory) ++ [victimVerdict]},seed1)- else if (snd3 victimVerdict == 0)- then ((shortTermMemory) { punished = (punished shortTermMemory) ++ [offenderVerdict]},seed1)- else ((shortTermMemory) { punished = (punished shortTermMemory) ++ [offenderVerdict,victimVerdict]},seed1)- where- (p,seed1) = random seed-- definePunishmentOnHealthDrop ∷ Float → Int → Int- definePunishmentOnHealthDrop healthDrop punishScore- | healthDrop < 0.5 = punishScore- | 0.5 <= healthDrop && healthDrop <= 1.5- = punishScore + 1- | 1.5 < healthDrop && healthDrop <= 3.5- = punishScore + 2- | otherwise = punishScore + 3-- analyseActions ∷ ATeam → [PlayerWithEffect] → IvanovShortTermMemory → IvanovLongTermMemory- → (IvanovShortTermMemory,IvanovLongTermMemory)- analyseActions team [] shortTermMemory longTermMemory- = (shortTermMemory,(longTermMemory) { lastRoundTackles = []})- analyseActions team (action@(fa,PlayerID {clubName=cn,playerNo=nmbr}):actions) shortTermMemory longTermMemory- -- Am I in the pause between the first and the second half (long enough to allow switching of sides)- | fst (waitingForSideSkipping longTermMemory) = runIdentity $ do- let ng- | snd (waitingForSideSkipping longTermMemory) <= zero- = (shortTermMemory,(longTermMemory) { waitingForSideSkipping = (False,zero)})- | otherwise- = (shortTermMemory,(longTermMemory) { waitingForSideSkipping = (True,snd (waitingForSideSkipping longTermMemory)-one)})- return ng- -- did I stop the game because of tackle-actions?- | (gameStoppedForTackle shortTermMemory) = runIdentity $ do- let ng- -- No more analysing game, but still look at mean actions with a connection to the tackle(s)- | perhaps isSchwalbed fa- = let ng- | isTackleVictim (playerID taf) (lastRoundTackles longTermMemory) -- was he victim- || isTackleOffender (playerID tef) (lastRoundTackles longTermMemory) -- or offender- || nearLastRoundTackle (pos fb) (lastRoundTackles longTermMemory) -- or near a tackle?- = let ng- | inPenaltyArea field (opponentHome team half) (pos fb) -- was it in penaltyarea?- = analyseActions team actions (shortTermMemory) { penalty = (penalty shortTermMemory) ++ [(team,Rschwalbe)]} longTermMemory- | otherwise -- punish him or punish him more- = analyseActions team actions (punishMore Rschwalbe tef 1 shortTermMemory) longTermMemory- in ng- | otherwise -- otherwise ignore- = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction- in ng- | perhaps isPlayedTheater fa- = let ng- | isTackleOffender (playerID tef) (lastRoundTackles longTermMemory) -- was he offender- || nearLastRoundTackle (pos fb) (lastRoundTackles longTermMemory) -- or near a tackle- && not (isTackleVictim (playerID taf) (lastRoundTackles longTermMemory))-- and is not a victim- = let ng- | inPenaltyArea field (opponentHome team half) (pos fb) -- was it in penaltyarea?- = analyseActions team actions (shortTermMemory) { penalty = (penalty shortTermMemory) ++ [(team,Rtheater)]} longTermMemory- | otherwise- = analyseActions team actions (punishMore Rtheater tef 1 shortTermMemory) longTermMemory- in ng- -- victims are already scanned during tackle analyses to see if it then was else worth to check the health of the victim- | otherwise -- otherwise ignore- = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction- in ng- | perhaps isTackled fa- = let ng- | isTackleVictim (playerID taf) ((lastRoundTackles longTermMemory)) -- was he victim- || isTackleOffender (playerID tef) ((lastRoundTackles longTermMemory)) -- or offender- || nearLastRoundTackle (pos fb) (lastRoundTackles longTermMemory) -- or near a tackle?- = let ng- | inPenaltyArea field (opponentHome team half) (pos fb) -- was it in penaltyarea?- = analyseActions team actions (shortTermMemory) { penalty = (penalty shortTermMemory) ++ [(team,Rschwalbe)]} longTermMemory- | otherwise -- punish him or punish him more- = analyseActions team actions (punishMore Rtackle tef 2 shortTermMemory) longTermMemory- in ng- --otherwise ignore- -- Usually ignore, but: a tackle is something serious... when I'm in a bad mood, I will not ignore this one- | (myMood shortTermMemory) > 0.8- = let ng- | inPenaltyArea field (opponentHome team half) (pos fb) -- was it in penaltyarea?- = analyseActions team actions (shortTermMemory) { penalty = (penalty shortTermMemory) ++ [(team,Rschwalbe)]} longTermMemory- | otherwise- = analyseActions team actions (punishMore Rtackle tef 3 shortTermMemory) longTermMemory- in ng- | otherwise -- player was lucky...- = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction- in ng- | perhaps isCaughtBall fa- = let ng- | isKeeper tef && inKeeperSpot tef team1Name currHome field -- is he a keeper?- = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction- | isTackleVictim (playerID taf) (lastRoundTackles longTermMemory) -- was he victim- || isTackleOffender (playerID tef) (lastRoundTackles longTermMemory) -- or offender- || nearLastRoundTackle (pos fb) (lastRoundTackles longTermMemory) -- or near a tackle?- = let ng- | inPenaltyArea field (opponentHome team half) (pos fb) -- was it in penaltyarea?- = analyseActions team actions (shortTermMemory) { penalty = (penalty shortTermMemory) ++ [(team,Rschwalbe)]} longTermMemory- | otherwise -- punish him or punish him more- = analyseActions team actions (punishMore Rhands tef 2 shortTermMemory) longTermMemory- in ng- | otherwise -- otheriwse ignore- = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction- in ng- -- All other kind of actions are ignored- | otherwise- = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction- return ng- -- There were no tackle-actions last round → Ivanov needs to keep thinking- -- Everyone is free to move over the field- | perhaps isMoved fa || perhaps isFeinted fa- = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction- -- Gainball is illegal when in offside position- -- A legal gainBall causes no one to be in offside position (until a kick- or headball event)- | perhaps isGainedBall fa = runIdentity $ do- longTermMemory ← return $ if (isNothing (firstKick longTermMemory)) then (longTermMemory) { firstKick = Just team} else longTermMemory- -- He was not allowed to get the ball (because of referee-action in the previous round)- if not (wasAllowedToGetBall (ballIsFor longTermMemory) (nameOf team1) (nameOf team2) cn)- then return $ analyseActions team actions (punishMore RillegalBallPossession tef 1 shortTermMemory) longTermMemory- else do- longTermMemory ← return $ (longTermMemory) { ballIsFor = Nothing}- -- He was in offside position- return $ if elem (playerID tef) (inOffsidePosition longTermMemory) && (offsidePossible longTermMemory) == OffsidePossible- -- Detect offside for wistle- then analyseActions team actions (punishMore Roffside tef 0 shortTermMemory) { offsideAndTouchedBall=Just (playerID tef)} longTermMemory- else analyseActions team actions shortTermMemory (longTermMemory) { inOffsidePosition = []}- -- {Kick/Head}Ball is illegal when in offside position (ball was not gained)- | perhaps isKickedBall fa || perhaps isHeadedBall fa = runIdentity $ do- longTermMemory ← return $ if (isNothing (firstKick longTermMemory)) then (longTermMemory) { firstKick = Just team} else longTermMemory- shortTermMemory ← return $ (shortTermMemory) { ballKickedOrHeaded = True}- -- He was not allowed to get the ball- return $ if not (wasAllowedToGetBall (ballIsFor longTermMemory) (nameOf team1) (nameOf team2) cn)- then analyseActions team actions (punishMore RillegalBallPossession tef 1 shortTermMemory) longTermMemory- else runIdentity $ do- longTermMemory ← return $ (longTermMemory) { ballIsFor = Nothing}- return $ if elem (playerID tef) (inOffsidePosition longTermMemory) && (offsidePossible longTermMemory) == OffsidePossible -- detect offside for wistle- then analyseActions team actions (punishMore Roffside tef 0 shortTermMemory) { offsideAndTouchedBall=Just (playerID tef)} longTermMemory- else runIdentity $ do- -- A legal {Kick/Head}Ball may be illegal/dangerous play when ball was gained by keeper- (team1Name,currHome) ← return $ if (half == FirstHalf) then (nameOf team1,West) else (nameOf team1,East)- keeper1HadBall ← return $- let keepers = filter isKeeper team1- keeper = head keepers- in not (null keepers) && ballIsGainedBy (playerID keeper) ballState && inKeeperSpot keeper team1Name currHome field && (keeper1HadBall longTermMemory)- keeper2HadBall ← return $- let keepers = filter isKeeper team2- keeper = head keepers- in not (null keepers) && ballIsGainedBy (playerID keeper) ballState && inKeeperSpot keeper team1Name currHome field && (keeper2HadBall longTermMemory)- if keeper1HadBall && nmbr/=1 || keeper2HadBall && nmbr/=1- then return $ analyseActions team actions (punishMore RdangerousPlay tef 5 shortTermMemory) longTermMemory- else do- -- A legal {Kick/Head}Ball may put people in a potential offside position- longTermMemory ← return $ (longTermMemory) { lastKickedTheBall = Just (playerID tef)}- (homeOfTeam1,homeOfTeam2) ← return $ if (half == FirstHalf) then (West,East) else (East,West)- if team == Team1- then do- closestDefenderTeam2Xpos ← return $ offsideline field homeOfTeam2 theBall team2- inOffsidePos ← return $ getOffsidePlayers field homeOfTeam1 closestDefenderTeam2Xpos (removeMember tef team1)- return $ analyseActions team actions shortTermMemory (longTermMemory) { inOffsidePosition = inOffsidePos}- else do- closestDefenderTeam1Xpos ← return $ offsideline field homeOfTeam1 theBall team1- inOffsidePos ← return $ getOffsidePlayers field homeOfTeam2 closestDefenderTeam1Xpos (removeMember tef team2)- return $ analyseActions team actions shortTermMemory (longTermMemory) { inOffsidePosition = inOffsidePos}- | perhaps isTackled fa = runIdentity $ do- -- Store him, so we can look next round at the damage of the victim- (victimID,ve) ← return $ case fromJust fa of (Tackled victimID ve _) → (victimID,ve)- moreTackles ← return $ case filter (identifyPlayer victimID) (team1++team2) of- (fb:_) → [(((playerID fb),(pos fb),(health fb)),((playerID tef),(pos tef),(health tef)),ve)]- none → []- shortTermMemory ← return $ (shortTermMemory) { thisRoundTackles = (thisRoundTackles shortTermMemory) ++ moreTackles}- return $ analyseActions team actions shortTermMemory longTermMemory- | perhaps isSchwalbed fa = runIdentity $ do- opponents ← return $ if (team == Team1) then team2 else team1- opponentNear ← return $ not (null [posi | Player {pos=posi} ← opponents, dist (pos fb) posi <= 5.0])- ballNear ← return $ dist (zero) { pxy=(pos fb)} (ballPos theBall) <= 10.0- shortTermMemory ← return $ if (inPenaltyArea field (opponentHome team half) (pos fb)) -- In penaltyarea?- then (shortTermMemory) { penalty = (penalty shortTermMemory) ++ [(team,Rschwalbe)]}- else (if (opponentNear && ballNear) -- Was an opponent near and was the ball near? Then punish else 4- then (punishMore Rschwalbe tef 4 shortTermMemory)- else (if ballNear -- Was the ball near? Then punish else 2- then (punishMore Rschwalbe tef 2 shortTermMemory)- else (if opponentNear -- Was an opponent near? Then punish else 3- then (punishMore Rschwalbe tef 3 shortTermMemory)- else (punishMore Rschwalbe tef 1 shortTermMemory)- )))- return $ analyseActions team actions shortTermMemory longTermMemory- | perhaps isCaughtBall fa = runIdentity $ do- longTermMemory ← return $ if (isNothing (firstKick longTermMemory)) then (longTermMemory) { firstKick = Just team} else longTermMemory- return $ if isKeeper tef && inKeeperSpot tef team1Name currHome field -- is he a keeper (todo: and located in his penaltyarea (for everything, gaining ball, etc.)- then analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction- else runIdentity $ do- shortTermMemory ← return $ if (inPenaltyArea field (opponentHome team half) (pxy (ballPos theBall)))- then (punishMore Rhands tef 2 shortTermMemory) { penalty = (penalty shortTermMemory) ++ [(team,Rhands)]}- else (punishMore Rhands tef 4 shortTermMemory)- return $ analyseActions team actions shortTermMemory longTermMemory- -- theater, but no tackle or schwalbe was seen, so theater will be punished lightly- | perhaps isPlayedTheater fa- = analyseActions team actions (punishMore Rtheater tef 1 shortTermMemory) longTermMemory- -- unknown action- | otherwise- = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction- where- (team1Name,currHome) = if (half==FirstHalf) then (nameOf team1,West) else (nameOf team1,East)- Just tef = find (identifyPlayer PlayerID {clubName=cn,playerNo=nmbr}) allPlayers- taf = tef- fb = taf-- ignoreThisAction = analyseActions team actions shortTermMemory longTermMemory-- wasAllowedToGetBall ∷ (Maybe ATeam) → ClubName → ClubName → ClubName → Bool- wasAllowedToGetBall Nothing _ _ _ = True- wasAllowedToGetBall (Just team) team1 team2 myTeam- | team == Team1 = team1 == myTeam- | otherwise = team2 == myTeam-- analysePeopleOnTheGround ∷ [PlayerID] → IvanovShortTermMemory → Team → Team → IvanovShortTermMemory- analysePeopleOnTheGround receivedYellow shortMem team1 team2- | (gameStoppedForTackle shortMem) -- have I stopped the game already for a tackle- = shortMem- | otherwise- = analysePeopleOnTheGround' receivedYellow shortMem [fb | fb ← team1 ++ team2, lastEventIsOnTheGround (effect fb)]- where- lastEventIsOnTheGround ∷ (Maybe PlayerEffect) → Bool- lastEventIsOnTheGround es = isJust es && isOnTheGround (fromJust es)-- analysePeopleOnTheGround' ∷ [PlayerID] → IvanovShortTermMemory → [Player] → IvanovShortTermMemory- analysePeopleOnTheGround' _ shortMem []- = shortMem- analysePeopleOnTheGround' receivedYellow shortMem (fb@Player {playerID=PlayerID {clubName=cn}}:tefls) = runIdentity $ do- -- how many opponents could have tackled him- suspects ← return $ [s | s ← team1 ++ team2, dist (pos fb) (pos s) <= maxTackleReach s]- healthDrop ← return $ case lookup (playerID fb) (prevHealthPlayers longTermMemory) of- Just prevHealth → (health fb) - prevHealth- none → zero- motive4Schwalbe ← return $ ballDirectionIsTowardsGoal && ballNear- goodMotive4Schwalbe ← return $ motive4Schwalbe && ballWasInPenaltyAreaOpponent- schwalbeThreshold ← return $ if motive4Schwalbe- then if goodMotive4Schwalbe- then if victimReprimandedBefore then (0.5,0.4 ) else (0.3,0.25)- else if victimReprimandedBefore then (0.2,0.17) else (0.1,0.08)- else if victimReprimandedBefore then (0.1,0.08) else (-999.0,-999.0)- schwalbeThreshold ← return $ if (length suspects > 1)- then (fst schwalbeThreshold * 0.5, snd schwalbeThreshold * 0.5)- else schwalbeThreshold- if not (null suspects) -- tackle or schwalbe??- then do- primarySuspect ← return $ suspects !! ((length suspects * (round ((myMood shortMem) * 10.0))) `mod` (length suspects) )- isNoOtherDefenderLeft ← return $ if (cn == nameOf team1 && half==FirstHalf || cn == nameOf team2 && half==SecondHalf)- then (null [fb | fb ← filter isFielder team2, (px (pos fb)) > (px (pos primarySuspect))])- else if (cn == nameOf team1 && half==SecondHalf || cn == nameOf team2 && half==FirstHalf)- then (null [fb | fb ← filter isFielder team2, (px (pos fb)) < (px (pos primarySuspect))])- else (error "primary suspect of possible tackle does not play in one of the teams")- opponentReprimandedBefore ← return $ elem (playerID primarySuspect) receivedYellow -- not (null (reprimands (events primarySuspect))) || (gotYellow (events primarySuspect))- motive4Tackle ← return $ ballDirectionIsTowardsGoal && ballNear || ballGoingTowardsVictim- goodMotive4Tackle ← return $ motive4Tackle && (isNoOtherDefenderLeft || goalVeryNear)- tackleThreshold ← return $ if motive4Tackle- then if goodMotive4Tackle- then if opponentReprimandedBefore then (0.5,0.6 ) else (0.7,0.75)- else if opponentReprimandedBefore then (0.8,0.83) else (0.9,0.92)- else if opponentReprimandedBefore then (0.9,0.92) else (999.0,999.0)- shortMem ← return $ if ((myMood shortMem) >= fst tackleThreshold && (myMood shortMem) < snd tackleThreshold && healthDrop > 0.1) -- Give yellow for tackle- then (punishMore Rtackle primarySuspect 3 shortMem)- else (if ((myMood shortMem) >= fst tackleThreshold) -- Warn for tackle- then (punishMore Rtheater primarySuspect 1 shortMem)- else (if ((myMood shortMem) <= fst schwalbeThreshold && (myMood shortMem) > snd schwalbeThreshold && healthDrop > 0.1)-- then Give else yellow for schwalbe- then (punishMore Rschwalbe fb 3 shortMem)- else (if ((myMood shortMem) <= fst schwalbeThreshold) -- Warn for schwalbe- then (punishMore Rschwalbe fb 1 shortMem)- else shortMem- )))- return $ analysePeopleOnTheGround' receivedYellow shortMem tefls- else do- shortMem ← return $ if ((myMood shortMem) <= fst schwalbeThreshold && (myMood shortMem) > snd schwalbeThreshold && healthDrop > 0.1) -- Warn good for schwalbe- then (punishMore Rschwalbe fb 2 shortMem)- else (if ((myMood shortMem) <= fst schwalbeThreshold) -- Warn for schwalbe- then (punishMore Rschwalbe fb 1 shortMem)- else shortMem- )- return $ analysePeopleOnTheGround' receivedYellow shortMem tefls- where- goalVeryNear = if (cn == nameOf team1 && half == FirstHalf || cn == nameOf team2 && half == SecondHalf)- then (dist (pos fb) Position {px=(flength field),py=(fwidth field)/2.0} <= 20.0) -- east goal- else (if (cn == nameOf team1 && half == SecondHalf || cn == nameOf team2 && half == FirstHalf)- then (dist (pos fb) Position {px=zero,py=(fwidth field)/2.0} <= 20.0) -- west goal- else (error "fallen player is not from one of the teams"))- ballNear = dist (zero) { pxy=(pos fb)} (ballPos theBall) <= 8.0- victimReprimandedBefore = elem (playerID fb) receivedYellow- ballWasInPenaltyAreaOpponent = cn == nameOf team1 && inPenaltyArea field (opponentHome Team1 half) (pxy (ballPos theBall))- ||- cn == nameOf team2 && inPenaltyArea field (opponentHome Team2 half) (pxy (ballPos theBall))- ballWasInPenaltyAreaSelf = cn == nameOf team1 && inPenaltyArea field (opponentHome Team2 half) (pxy (ballPos theBall))- ||- cn == nameOf team2 && inPenaltyArea field (opponentHome Team1 half) (pxy (ballPos theBall))- ballDirectionIsTowardsGoal = if (cn == nameOf team1 && half == FirstHalf || cn == nameOf team2 && half == SecondHalf)- then ((direction (vxy (ballSpeed theBall))) > 0.5*pi && (direction (vxy (ballSpeed theBall))) < 1.5*pi) -- to east ..- else (if (cn == nameOf team1 && half == SecondHalf || cn == nameOf team2 && half == FirstHalf)- then ((direction (vxy (ballSpeed theBall))) < 0.5*pi || (direction (vxy (ballSpeed theBall))) > 1.5*pi) -- to west .. PA: odd, why use ..||.. here and ..&&.. immediately above?- else (error "fallen player is not from one of the teams"))- ballGoingTowardsVictim = nextBallPos (ballPos theBall) (ballSpeed theBall) ((pos fb),5.0,(height fb))-- drawConclusions ∷ IvanovShortTermMemory → IvanovLongTermMemory → ([RefereeAction],IvanovLongTermMemory)- drawConclusions shortMem longMem = runIdentity $ do- longMem ← return $ (longMem) { keeper1HadBall = ballIsGainedBy PlayerID {playerNo=1,clubName=nameOf team1} ballState--all hasBall (filter isKeeper team1)- , keeper2HadBall = ballIsGainedBy PlayerID {playerNo=1,clubName=nameOf team2} ballState--all hasBall (filter isKeeper team2)- , prevHealthPlayers = map (\fb → ((playerID fb), (health fb))) (team1 ++ team2)- }- teamPenalty ← return $ firstPenalty (penalty shortMem)- offencePenalty ← return $ getMostImportantKickAction basicActions- (kickAction,longMem) ← return $ if (isJust teamPenalty) then (let t = fromJust teamPenalty in (Just (Penalty t),(longMem) { ballIsFor = Just t- , typeOfKickoff = Just (Penalty t)}))- else (if (isJust offencePenalty) then (let p = fromJust offencePenalty in (offencePenalty, (longMem) { ballIsFor = Just (actionForWhichTeam p)- , typeOfKickoff = offencePenalty}))- else ((Nothing,longMem)- ))- noticedActions ← return $ map fst basicActions- longMem ← return $ if (isJust kickAction) then (longMem) { offsidePossible = KickForcedByReferee}- else (if ((ballKickedOrHeaded shortMem)) then (lowerOffsideCounter longMem)- else longMem- )- if not (gameStoppedForTackle shortMem) -- We haven't analysed tackles this round, it was a normal round- then do- refActions ← return $ case kickAction of- Just kick → noticedActions ++ [DisplacePlayers (replacePlayers team1 team2 kick field theBall longMem)]- _ → noticedActions- let ng- | time <= (fromJust (gameLength longMem))/2.0 && half == FirstHalf = runIdentity $ do-- is it time to change half?- longMem ← return $ (longMem) { waitingForSideSkipping = (True,150)}- teamThatMayStartAtSecondHalf- ← return $ if (isJust (firstKick longMem))- then (if ((fromJust (firstKick longMem)) == Team1) then Team2 else Team1)- else Team2- centerKick ← return $ CenterKick teamThatMayStartAtSecondHalf- ds ← return $ mirrorTeams (replacePlayers team1 team2 centerKick field theBall longMem)- return (refActions ++ [ContinueGame] ++ [EndHalf,centerKick,DisplacePlayers ds],(longMem) { ballIsFor = Just teamThatMayStartAtSecondHalf})-- | time <= zero -- is it time to stop the game?- = (refActions ++ [GameOver],longMem)- -- Is the ball out of the lines and do we have: a goal, a corner, a goal kick, or a throw in- | otherwise = runIdentity $ do- (behindLineActions,longMem) ← return $ getBehindLinesActions half theBall field longMem- -- No matter what happened, ball behind the line is ball behind the line- if length behindLineActions > zero- then do- displacements ← return $ replacePlayers team1 team2 (last behindLineActions) field theBall longMem- refActions ← return $ refActions ++ [DisplacePlayers displacements]- return (refActions ++ [ContinueGame] ++ behindLineActions,(longMem) { offsidePossible = KickForcedByReferee})- else do- longMem ← return $ (longMem) { lastRoundTackles = (thisRoundTackles shortMem)}- -- We have no new tackles for the next round- let ng- | null (thisRoundTackles shortMem) = runIdentity $ do- let ng- | isJust kickAction = runIdentity $ do- kick ← return $ fromJust kickAction- goalArea ← return $ kickActionIsFreeKickInPenaltyArea kick- if isJust goalArea- then do- displacements ← return $ replacePlayers team1 team2 (fromJust goalArea) field theBall longMem- return (refActions ++ [ContinueGame,DisplacePlayers displacements,fromJust goalArea],longMem)- else return (refActions ++ [ContinueGame,kick],longMem)- | otherwise- = (refActions ++ [ContinueGame],longMem)- return ng- -- We have new tackles for the next round- | otherwise- = (refActions ++ [PauseGame,AddTime (1.0/30.0)],longMem)- return ng- return ng- -- We have analysed tackles this round- else- -- We have a position to restart the game from- if isJust kickAction- then do- kick ← return $ fromJust kickAction- goalArea ← return $ kickActionIsFreeKickInPenaltyArea kick- if isJust goalArea- then do- displacements ← return $ replacePlayers team1 team2 (fromJust goalArea) field theBall longMem- return ([ContinueGame] ++ noticedActions ++ [DisplacePlayers displacements,fromJust goalArea],longMem)- else do- displacements ← return $ replacePlayers team1 team2 kick field theBall longMem- return ([ContinueGame] ++ noticedActions ++ [DisplacePlayers displacements,kick],longMem)- -- I still have to think about a new place to restart the game from- else error "should have a position to restart the game from"- where- basicActions = getAllBasicActions (receivedYellow longMem) shortMem-- mirrorTeams ∷ Displacements → Displacements- mirrorTeams ds = map (\(fbID,pos) → (fbID,mirror field pos)) ds-- kickActionIsFreeKickInPenaltyArea ∷ RefereeAction → Maybe RefereeAction- kickActionIsFreeKickInPenaltyArea (DirectFreeKick team pos)- | inPenaltyArea field (opponentHome team half) pos- = Just (Penalty team)- | inPenaltyArea field (teamHome team half) pos- = Just (GoalKick team)- | otherwise- = Nothing- kickActionIsFreeKickInPenaltyArea _- = Nothing-- getBehindLinesActions ∷ Half → Ball → Field → IvanovLongTermMemory → ([RefereeAction],IvanovLongTermMemory)- getBehindLinesActions half theBall field longMem@IvanovLongTermMemory {lastKickedTheBall}- | (pxy (ballPos theBall)) == p -- ball is not behind (see definition of pointToRectangle)- = ([],longMem)- | isNothing lastKickedTheBall -- the ball got behind by unknown forces- = ([CenterKick Team1],longMem)- | (px (pxy (ballPos theBall))) < zero = runIdentity $ do -- behind line West?- (team,homeTeamWest) ← return $ if (half == FirstHalf) then (Team1,nameOf team1) else (Team2,nameOf team2) -- first half?- let ng- | isbetween (py (pxy (ballPos theBall))) ((fwidth field)/2.0 - goalWidth/2.0) ((fwidth field)/2.0 + goalWidth/2.0) -- goal?- &&- (pz (ballPos theBall)) < goalHeight- = if (team==Team1) then ([Goal Team2,CenterKick Team1],(longMem) { ballIsFor=Just Team1})- else ([Goal Team1,CenterKick Team2],(longMem) { ballIsFor=Just Team2})- | clubName (fromJust lastKickedTheBall) == homeTeamWest = runIdentity $ do -- lastPlayerKicked Team1?- corner ← return $ if ((py (pxy (ballPos theBall))) > (fwidth field)/2.0) then South else North- return ([Corner (other team) corner],(longMem) { ballIsFor = Just (other team)})- | otherwise -- opponent team → goalkick- = ([GoalKick team],(longMem) { ballIsFor = Just team})- return ng- | (px (pxy (ballPos theBall))) > (flength field)= runIdentity $ do -- behind line East?- (team,homeTeamEast) ← return $ if (half == FirstHalf) then (Team2,nameOf team2) else (Team1,nameOf team1)- let ng- | isbetween (py (pxy (ballPos theBall))) ((fwidth field)/2.0 - goalWidth/2.0) ((fwidth field)/2.0 + goalWidth/2.0) -- goal?- &&- (pz (ballPos theBall)) < goalHeight- = if (team==Team1) then ([Goal Team2,CenterKick Team1],(longMem) { ballIsFor=Just Team1})- else ([Goal Team1,CenterKick Team2],(longMem) { ballIsFor=Just Team2})- | clubName (fromJust lastKickedTheBall) == homeTeamEast = runIdentity $ do -- lastPlayerKicked Team1?- corner ← return $ if ((py (pxy (ballPos theBall))) > (fwidth field)/2.0) then South else North- return ([Corner (other team) corner],(longMem) { ballIsFor = Just (other team)})- | otherwise- = ([GoalKick team],(longMem) { ballIsFor = Just team})- return ng- | otherwise = runIdentity $ do- throwin ← return $ if (clubName (fromJust lastKickedTheBall) == nameOf team1) then Team2 else Team1- return ([ThrowIn throwin p],(longMem) { ballIsFor = Just throwin})- where- p = pointToRectangle (zero,Position {px=(flength field),py=(fwidth field)}) (pxy (ballPos theBall))-- {- Most important (in given order): Tackle, OwnBallIllegally, Offside, DangerousPlay, Hands- Even: the rest- -} getMostImportantKickAction ∷ [(RefereeAction,RefereeAction)] → Maybe RefereeAction- getMostImportantKickAction actions- | null actions = Nothing- | otherwise = Just resumeAction- where- (_,resumeAction) = minimumBy (\(a1,r1) (a2,r2) → priority a1 `compare` priority a2) actions- priority action = if (isTackleDetected action) then 5- else (if (isOwnBallIllegally action) then 4- else (if (isOffside action) then 3- else (if (isDangerousPlay action) then 2- else (if (isHands action) then 1- else 0- ))))-- actionForWhichTeam ∷ RefereeAction → ATeam- actionForWhichTeam (DirectFreeKick t _) = t- actionForWhichTeam (GoalKick t) = t- actionForWhichTeam (Corner t _) = t- actionForWhichTeam (ThrowIn t _) = t- actionForWhichTeam (Penalty t) = t- actionForWhichTeam (CenterKick t) = t- actionForWhichTeam _ = error "actionForWhichTeam: kick action expected"-- getAllBasicActions ∷ [PlayerID] → IvanovShortTermMemory → [(RefereeAction,RefereeAction)]- getAllBasicActions receivedYellow shortMem = getAllBasicPunishActions receivedYellow (punished shortMem)- where- -- PA: this should really be programmed as a map→- getAllBasicPunishActions ∷ [PlayerID] → [PunishedPlayer] → [(RefereeAction,RefereeAction)]- getAllBasicPunishActions _ [] = []- getAllBasicPunishActions receivedYellow ((fbID@PlayerID{clubName=cn},punish,[]):pals)- | punish > 4- = ((ReprimandPlayer fbID RedCard,DirectFreeKick otherTeam kickPos) : rest)- | punish >= 3 = runIdentity $ do- yellow ← return $ (ReprimandPlayer fbID YellowCard,DirectFreeKick otherTeam kickPos)- red ← return $ (ReprimandPlayer fbID RedCard, DirectFreeKick otherTeam kickPos)- let ng- | elem fbID receivedYellow- = (yellow : red : rest)- | otherwise = (yellow : rest)- return ng- | punish >= 1 = ((ReprimandPlayer fbID Warning,DirectFreeKick otherTeam kickPos) : rest)- | otherwise = rest- where- kickPosHome = if (cn == nameOf team1 && half == FirstHalf || cn == nameOf team2 && half == SecondHalf) then East else West- kickPosTeam = if (cn == nameOf team1) then team2 else team1- kickPos = posForFreeKick kickPosHome (pxy (ballPos theBall)) kickPosTeam- otherTeam = if (cn == nameOf team1) then Team2 else Team1- rest = getAllBasicPunishActions receivedYellow pals- getAllBasicPunishActions receivedYellow ((fbID@PlayerID{clubName=cn},punish,(r:rls)):pals)- | r == Rtackle = ((TackleDetected fbID,DirectFreeKick otherTeam kickPos) : rest)- | r == Roffside && isJust (offsideAndTouchedBall shortMem) =- let ng- | fromJust (offsideAndTouchedBall shortMem) == fbID- = ((Offside fbID,DirectFreeKick otherTeam kickPos) : rest)- | otherwise = rest- in ng- | r == Rtheater = ((TheaterDetected fbID,DirectFreeKick otherTeam kickPos) : rest)- | r == Rschwalbe = ((SchwalbeDetected fbID,DirectFreeKick otherTeam kickPos) : rest)- | r == Rhands = ((Hands fbID,DirectFreeKick otherTeam kickPos) : rest)- | r == RdangerousPlay = ((DangerousPlay fbID,DirectFreeKick otherTeam kickPos) : rest)- | r == RillegalBallPossession = ((OwnBallIllegally fbID,DirectFreeKick otherTeam kickPos) : rest)- | otherwise = error "getAllBasicPunishActions: unknown reason of RefereeAction."- where- kickPosHome = if (cn == nameOf team1 && half == FirstHalf || cn == nameOf team2 && half == SecondHalf) then East else West- kickPosTeam = if (cn == nameOf team1) then team2 else team1- kickPos = posForFreeKick kickPosHome (pxy (ballPos theBall)) kickPosTeam- otherTeam = if (cn == nameOf team1) then Team2 else Team1- rest = getAllBasicPunishActions receivedYellow ((fbID,punish,rls):pals)-- firstPenalty ∷ [(ATeam,Reason)] → Maybe ATeam- firstPenalty [] = Nothing- firstPenalty ((t,_):_) = Just (other t)--isTackleVictim ∷ PlayerID → [TackleAction] → Bool-isTackleVictim fbID tackleEvents = any (\((fbID',_,_),_,_) → fbID == fbID') tackleEvents--isTackleOffender ∷ PlayerID → [TackleAction] → Bool-isTackleOffender fbID tackleEvents = any (\(_,(fbID',_,_),_) → fbID == fbID') tackleEvents--nearLastRoundTackle ∷ Position → [TackleAction] → Bool-nearLastRoundTackle pos tackleEvents = all near tackleEvents- where- near ((_,vpos,_),(_,opos,_),_) = dist pos vpos > nearEventRadius && dist pos opos > nearEventRadius---- Used for offside, so we only look at the xposition-offsideline ∷ Field → Home → Ball → [Player] → Metre-offsideline field home ball fbs = case sortBy cmp ((px (pxy (ballPos ball))) : [(px (pos fb)) | fb ← fbs]) of- [] → edge- [x] → x- [_,x] → x- (_:_:x:_) → x- where- (cmp,edge) = if (home == West)- then (compare,zero)- else (\x y → compare y x,(flength field))--getOffsidePlayers ∷ Field → Home → XPos → [Player] → [PlayerID]-getOffsidePlayers field home line fbs = map playerIdentity (filter (\fb@Player{pos=Position{px=posx}} -> atOtherHalf posx && (cmp (px (pos fb)) line)) fbs)- where- (cmp,atOtherHalf) = if (home == West) then ((>),(<) fieldhalf) else ((<),(>) fieldhalf)- fieldhalf = (flength field) / 2.0---- A referee can not see everything correct.-filterOutMeanActions ∷ [Player] → [PlayerWithEffect] → StdGen → ([PlayerWithEffect],StdGen)-filterOutMeanActions allPlayers allActions seed- = ([action | (p,action) ← zip ps allActions, noticeAction action p],seed1)- where- (ps,seed1) = iterateStn (length allActions) random seed-- noticeAction ∷ PlayerWithEffect → Float → Bool- noticeAction (fa,playerID) p- | foul = avg [p,1.0 - pa + if (elem skill (skillsAsList fb)) then 0.1 else 0.0] <= 0.5- | otherwise = True- where- Just fb = find (identifyPlayer playerID) allPlayers- (foul,pa,skill) = if (perhaps isTackled fa) then (True,chanceOfPenaltySuccess, Tackling)- else (if (perhaps isSchwalbed fa) then (True,chanceOfSchwalbeSuccess,Schwalbing)- else (if (perhaps isPlayedTheater fa) then (True,chanceOfTheaterSuccess, PlayingTheater)- else (if (perhaps isCaughtBall fa) then (True,chanceOfCatchSuccess, Catching)- else (False,error "ASNTD",error "ISAONE")- )))--nextBallPos ∷ Position3D → Speed3D → (Position,XRadius,ZRadius) → Bool-nextBallPos item dir (target,radius,height)- = isGettingToPos (iterate (nextPos dir) item)- where- targetAtGround = (zero) { pxy=target}- targetInAir = Position3D {pxy=target, pz=height}-- nextPos ∷ Speed3D → Position3D → Position3D- nextPos speed currentPosition- = movePoint3D RVector3D {dxy=RVector{dx=(cos (direction (vxy speed)))*newV,dy=(sin (direction (vxy speed)))*newV},dz=newV3} currentPosition- where- resistance = if ((pz currentPosition) > zero) then airResistance else surfaceResistance- newV = resistance * (velocity (vxy speed))- newV3 = (vz speed) - 0.1*accellerationSec-- isGettingToPos ∷ [Position3D] → Bool- isGettingToPos [] = False- isGettingToPos [x] = False- isGettingToPos (x:y:xs)- | dist x targetAtGround < radius || dist x targetInAir < radius- = True- | avg [dist x targetAtGround,dist x targetInAir] < avg [dist y targetAtGround,dist y targetInAir] -- object is moving away- = False- | otherwise = isGettingToPos (y:xs) -- object is coming closer----- Freekicks are granted from the pos of the player that is the most closest to the ball but not a position more forward to the goal-posForFreeKick ∷ Home → Position {-→ Position-} → [Player] → Position-posForFreeKick home ballPos {-victimPos-} [] = ballPos--victimPos-posForFreeKick home ballPos {-victimPos-} team- = case [fb | fb ← team, (dist (pos fb) ballPos) <= 15.0 ] of- [] → ballPos- close → pos (foldr1 closer2ball close)- where- closer2ball ∷ Player → Player → Player- closer2ball fb1 fb2- | dist (pos fb1) ballPos < dist (pos fb2) ballPos = fb1- | otherwise = fb2--inKeeperSpot ∷ Player → ClubName → Home → Field → Bool-inKeeperSpot fb clubName home field = inPenaltyArea field (if (getClubName fb == clubName) then home else (other home)) (pos fb)+chanceOfPenaltySuccess = 0.3+chanceOfSchwalbeSuccess = 0.7+chanceOfTheaterSuccess = 0.8+chanceOfCatchSuccess = 0.5+healthInaccurateFactor = 1.0 -- (is multiplied with 0.5)+nearEventRadius = 10.0+replaceDistance = 5.0++ivanovReferee ∷ Field → Team → Team → Referee+ivanovReferee field t1 t2 = Referee+ {rname = "Ivanov", rbrain = Brain {m = mkIvanovLongTermMemory t1 t2, ai = refBrainIvanov field}}++-- Memory that is passed around for the referee+data IvanovLongTermMemory = IvanovLongTermMemory+ {lastRoundTackles ∷ [TackleAction],+ inOffsidePosition ∷ [PlayerID],+ keeper1HadBall ∷ Bool, -- True iff keeper of Team1 had ball in previous round+ keeper2HadBall ∷ Bool, -- True iff keeper of Team2 had ball in previous round+ prevHealthPlayers ∷ AssocList PlayerID Health, -- the health of the players in previous round+ lastKickedTheBall ∷ Maybe PlayerID,+ ballIsFor ∷ Maybe ATeam,+ offsidePossible ∷ FreeKickCountdownForOffside, -- because of a certain type of free kick+ typeOfKickoff ∷ Maybe RefereeAction,+ waitingForSideSkipping ∷ (Bool,Int),+ gameLength ∷ Maybe Float,+ receivedYellow ∷ [PlayerID],+ initialTeams ∷ (Team,Team)} -- to restore initial positions after kick-off.++type TackleAction = (Victim,Offender,Velocity)+type Victim = (PlayerID,Position,Health) -- Victim of a tackle+type Offender = (PlayerID,Position,Health) -- Offender of a tackle++{- KickForcedByReferee : The next kick should be a kick that is appointed by the referee and therefor can not be offside+ FreeToKick : The first gain or kick after a free kick; can not be offside+ OffsidePossible : It is possible that you are standing offside+-}+data FreeKickCountdownForOffside+ = OffsidePossible+ | FreeToKick+ | KickForcedByReferee+instance Eq FreeKickCountdownForOffside where+ (==) OffsidePossible OffsidePossible = False -- disable offside since it is buggy+ (==) FreeToKick FreeToKick = True+ (==) KickForcedByReferee KickForcedByReferee = True+ (==) _ _ = False++lowerOffsideCounter ∷ IvanovLongTermMemory → IvanovLongTermMemory+lowerOffsideCounter longMem = longMem+ {typeOfKickoff = Nothing,+ offsidePossible = if (offsidePossible longMem) == KickForcedByReferee then FreeToKick else OffsidePossible}++-- Memory used within one timeslice. Is discarded every round.+data IvanovShortTermMemory = IvanovShortTermMemory+ {gameStoppedForTackle ∷ Bool,+ punished ∷ [PunishedPlayer],+ penalty ∷ [(ATeam,Reason)],+ thisRoundTackles ∷ [TackleAction],+ myMood ∷ Mood,+ offsideAndTouchedBall ∷ Maybe PlayerID,+ ballKickedOrHeaded ∷ Bool}++type PunishedPlayer = (PlayerID,PunishedScore,[Reason])+type PunishedScore = Int -- < 0 points is probably nothing+ -- 1-2 points is probably warning+ -- 3-4 points is probably yellow+ -- > 4 points is probably red++-- Reason of punishments+data Reason = Rtackle | Roffside | Rtheater | Rschwalbe | Rhands | RdangerousPlay | RillegalBallPossession deriving Eq++mkIvanovShortTermMemory ∷ Mood → IvanovShortTermMemory+mkIvanovShortTermMemory m = IvanovShortTermMemory+ {gameStoppedForTackle = False,+ punished = [],+ penalty = [],+ thisRoundTackles = [],+ myMood = m,+ offsideAndTouchedBall = Nothing,+ ballKickedOrHeaded = False}++type Mood = Float -- Random factor used to randomly pick action when Ivanov is not sure about what happened++mkIvanovLongTermMemory ∷ Team → Team → IvanovLongTermMemory+mkIvanovLongTermMemory t1 t2 = IvanovLongTermMemory+ {lastRoundTackles = [],+ inOffsidePosition = [],+ keeper1HadBall = False,+ keeper2HadBall = False,+ prevHealthPlayers = [],+ lastKickedTheBall = Nothing,+ ballIsFor = Just Team1,+ offsidePossible = OffsidePossible,+ typeOfKickoff = Just $ CenterKick Team1,+ waitingForSideSkipping = (False, zero),+ gameLength = Nothing,+ receivedYellow = [],+ initialTeams = (t1,t2)}++-- Has #param2 done something naughty? In other words, is #param2 known in the list provided as #param1?+getNaughtyPlayer ∷ [PunishedPlayer] → PlayerID → Maybe PunishedPlayer+getNaughtyPlayer punished fbID' = case [pun | pun@(fbID,_,_) ← punished, fbID == fbID'] of+ (pun:_) → Just pun+ _ → Nothing++-- Punish baller, if he then was else already punished before, punish him more, otherwise just punish him. Do not make duplicates.+punishMore ∷ Reason → Player → PunishedScore → IvanovShortTermMemory → IvanovShortTermMemory+punishMore reason fb score shortMem = shortMem { punished = newPunished} where+ newPunished = case break' (\(fbID,_,_) → identifyPlayer fbID fb) (punished shortMem) of+ (before,[p],after) → unbreak (before,[addPunishScore reason score p],after)+ (before,[],[]) → before ++ [((playerID fb),score,[reason])]+ otherwise → error "punishMore: short term memory (punished) contains duplicate entries.\n"++-- Give the baller a higher punishscore and add the reason if he then was else not punished before for the same reason+addPunishScore ∷ Reason → PunishedScore → PunishedPlayer → PunishedPlayer+addPunishScore reason newScore (fbID,score,reasons) = (fbID,score+newScore,nub (reasons ++ [reason]))++successfulActions ∷ Team → [PlayerWithEffect]+successfulActions players = map (\Player {effect,playerID} → (effect,playerID)) players++-- How this referee thinks about the match and come to his conclusions.+refBrainIvanov ∷ Field → PlayingTime → TimeUnit → BallState → Half → Team → Team → (IvanovLongTermMemory,StdGen) → ([RefereeAction], (IvanovLongTermMemory,StdGen))+refBrainIvanov field time dt ballState half team1 team2 (longTermMemory,seed) = runIdentity $ do+ longTermMemory ← return $ if isJust (gameLength longTermMemory) then longTermMemory else longTermMemory { gameLength = Just time}+ -- filter actions (what mean actions do I notice and what not)+ (team1Actions,seed) ← return $ filterOutMeanActions allPlayers (successfulActions team1) seed+ -- filter actions team2+ (team2Actions,seed) ← return $ filterOutMeanActions allPlayers (successfulActions team2) seed+ -- look into the consequences of last round tackles+ (p,seed) ← return $ random (seed ∷ StdGen)+ (shortTermMemory, seed) ← return $ analyseTackles (mkIvanovShortTermMemory p) team1Actions team2Actions (lastRoundTackles longTermMemory) seed+ -- analyse the taken actions+ (shortTermMemory,longTermMemory) ← return $ analyseActions Team1 team1Actions shortTermMemory longTermMemory+ (shortTermMemory,longTermMemory) ← return $ analyseActions Team2 team2Actions shortTermMemory longTermMemory++ -- check for other people who are on the ground (for some mysterious reason)+ shortTermMemory ← return $ analysePeopleOnTheGround (receivedYellow longTermMemory) shortTermMemory team1 team2++ -- give end-verdict of this round+ (conclusions,longTermMemory) ← return $ drawConclusions shortTermMemory longTermMemory+ return (conclusions,(longTermMemory,seed))+ where+ allPlayers = team1 ++ team2+ theBall = getBall ballState allPlayers++ kickoffDisplacements ∷ IvanovLongTermMemory → Displacements+ kickoffDisplacements longTermMemory = if half == FirstHalf+ then kickOffTeam1 ++ kickOffTeam2+ else map (\(fbID,pos) → (fbID,mirror field pos)) (kickOffTeam1 ++ kickOffTeam2)+ where+ kickOffTeam1 = [(playerID,pos) | Player {playerID,pos} ← fst (initialTeams longTermMemory)]+ kickOffTeam2 = [(playerID,pos) | Player {playerID,pos} ← snd (initialTeams longTermMemory)]++ -- though teams are returned, only positions AND directions will be altered by a Displace-action+ replacePlayers ∷ Team → Team → RefereeAction → Field → Ball → IvanovLongTermMemory → Displacements+ replacePlayers team1 team2 kickAction field theBall longTermMemory+ | isForKeeper kickAction Team1 = replaceFielders team1 posi ++ replaceTeam team2 posi+ | isForKeeper kickAction Team2 = replaceTeam team1 posi ++ replaceFielders team2 posi+ | isCenterKick kickAction = if ballIsFor longTermMemory == Just Team1+ then replacePlayers' (centre field) radiusCentreCircle team2+ else replacePlayers' (centre field) radiusCentreCircle team1+-- replacePlayers' ∷ Position → Float → [Player] → Displacements+-- kickOffTeam1 = [(playerID,pos) | Player {playerID,pos} ← fst (initialTeams longTermMemory)]+-- kickOffTeam2 = [(playerID,pos) | Player {playerID,pos} ← snd (initialTeams longTermMemory)]+-- in let ng+-- | half == FirstHalf = kickOffTeam1 ++ kickOffTeam2+-- | otherwise = map (\(fbID,pos) → (fbID,mirror field pos)) (kickOffTeam1 ++ kickOffTeam2)+-- in ng+ | isForTeam kickAction Team1 = replaceExceptPlayerCloseToPos team1 posi ++ replaceTeam team2 posi+ | otherwise = replaceTeam team1 posi ++ replaceExceptPlayerCloseToPos team2 posi+ where+ posi = case getKickPos field half kickAction of+ Just p → p+ nothing → (pxy (ballPos theBall))++ replaceTeam ∷ Team → Position → Displacements+ replaceTeam team posi = replacePlayers' posi replaceDistance team++ replaceFielders ∷ Team → Position → Displacements+ replaceFielders team posi = replacePlayers' posi replaceDistance (filter isFielder team)++ replaceExceptPlayerCloseToPos ∷ Team → Position → Displacements+ replaceExceptPlayerCloseToPos team posi = replacePlayers' posi replaceDistance (filter (not . (identifyPlayer (playerID closestPlayer))) team) where closestPlayer = getClosestPlayer team posi (nameOf team)++ isForKeeper ∷ RefereeAction → ATeam → Bool+ isForKeeper (GoalKick team) theTeam = team==theTeam+ isForKeeper _ _ = False++ isForTeam ∷ RefereeAction → ATeam → Bool+ isForTeam (DirectFreeKick team1 _) team2 = team1==team2+ isForTeam (GoalKick team1) team2 = team1==team2+ isForTeam (Corner team1 _) team2 = team1==team2+ isForTeam (ThrowIn team1 _) team2 = team1==team2+ isForTeam (Penalty team1) team2 = team1==team2+ isForTeam (CenterKick team1) team2 = team1==team2+ isForTeam _ _ = True++ getClosestPlayer ∷ [Player] → Position → String → Player+ getClosestPlayer [] posi err = error ("getClosestPlayer: no player to pick from " ++ err)+ getClosestPlayer fbs posi error = foldr1 (isCloser posi) fbs where+ isCloser ∷ Position → Player → Player → Player+ isCloser posi fb1@Player {pos=pos1} fb2@Player {pos=pos2}+ | dist posi pos1 <= dist posi pos2 = fb1+ | otherwise = fb2++ replacePlayers' ∷ Position → Float → [Player] → Displacements+ replacePlayers' posi radius players = [displace (dist (pos fb) posi) fb | fb ← players, dist (pos fb) posi < radius] where+ displace dist fb = ((playerID fb),newPos) where+ newPos = if (dist <= 0.1*radius)+ then (alterPos (movePoint (scaleVector radius RVector {dx=cos (dist*2.0*pi),dy=sin (dist*2.0*pi)}) posi))+ else (alterPos (movePoint (scaleVector radius RVector {dx=cos angle, dy=sin angle}) posi))+ angle = atan (((py (pos fb)) - py posi) / ((px (pos fb)) - px posi))++ -- corrects when players are placed beyond the borders of the field+ alterPos ∷ Position → Position+ alterPos mypos+ | px mypos >= flength field = alterPos' (Just (flength field - one)) Nothing mypos posi+ | (px mypos) <= zero = alterPos' (Just one) Nothing mypos posi+ | (py mypos) >= fwidth field = alterPos' Nothing (Just (fwidth field - one)) mypos posi+ | (py mypos) <= zero = alterPos' Nothing (Just one) mypos posi+ | otherwise = mypos+ where+ alterPos' ∷ (Maybe XPos) → (Maybe YPos) → Position → Position → Position+ alterPos' xpos ypos myPos middlePos+ | isJust xpos && isJust ypos = Position { px = fromJust xpos, py = fromJust ypos }+ | isJust xpos = let amount = abs (fromJust xpos - px myPos) in Position { px = fromJust xpos+ , py = if py myPos > py middlePos+ then (if ((py myPos) < fwidth field - amount)+ then ((py myPos) + amount)+ else ((py myPos) - amount - 2.0*distY)+ )+ else (if ((py myPos) > amount)+ then ((py myPos) - amount)+ else ((py myPos) + amount + 2.0*distY)+ )+ }+ | isJust ypos = let amount = abs (fromJust ypos - py myPos) in Position { py = fromJust ypos+ , px = if ((px myPos) > (px middlePos))+ then (if ((px myPos) + amount < flength field)+ then ((px myPos) + amount)+ else ((px myPos) - amount - 2.0*distX)+ )+ else (if ((px myPos) > amount)+ then ((px myPos) - amount)+ else ((px myPos) + amount + 2.0*distX)+ )+ }+ | otherwise = myPos+ where+ distY = abs ((py myPos) - py middlePos)+ distX = abs ((px myPos) - px middlePos)++ analyseTackles ∷ IvanovShortTermMemory → [PlayerWithEffect] → [PlayerWithEffect] → [TackleAction] → StdGen → (IvanovShortTermMemory,StdGen)+ -- were there any tackles in the last round?? NO+ analyseTackles shortTermMemory _ _ [] seed = (shortTermMemory,seed)+ -- YES: there were tackles last round, whistle for that and ignore all other irrelative events+ analyseTackles shortTermMemory team1Actions team2Actions (((victim@PlayerID {playerNo=vNmbr},victimPos,victimHealth), (offender@PlayerID {clubName=oCn,playerNo=oNmbr},offenderPos,offenderHealth), velo) : _) seed = runIdentity $ do -- PA: hmmm, tl of tackles are ignored here.+ offendersTeam ← return $ if nameOf team1 == oCn then Team1 else Team2+ Just victimNow ← return $ find (identifyPlayer victim) allPlayers+ Just offenderNow ← return $ find (identifyPlayer offender) allPlayers+ shortTermMemory ← return $ shortTermMemory { gameStoppedForTackle = True}+ -- was the ball near the tackle event(s)+ punishScore ← return $ if dist (pxy (ballPos theBall)) offenderPos <= 6.0 then 2 else 1 -- ball was near tackle event(s)+ ++ if vNmbr==1 then 5 else (if velo >= 6.0 then 3 else 2) -- penalty for keeper victim is highest+ -- victim is playing theater?+ actionOfVictim ← return $ case concat [maybeToList fa | (fa,fbId) ← if offendersTeam==Team1 then team2Actions else team1Actions, identifyPlayer fbId victimNow] of+ (fa:_) → Just fa+ _ → Nothing+ -- what is the damage to the victim?+ healthDrop ← return $ victimHealth - health victimNow + (p-0.5)* healthInaccurateFactor+ -- is the victim making theater?+ victimPunishScore ← return $ if isJust actionOfVictim then if isPlayedTheater (fromJust actionOfVictim) then 3 else 0 else 0+ -- victim is not playing theater?+ punishScore ← return $ if (victimPunishScore == 0)+ then (definePunishmentOnHealthDrop healthDrop punishScore)+ else punishScore+ -- was the ball on 20% part of the field to the offender's own goal?+ ballWasNearGoal ← return $ half == FirstHalf && oCn == nameOf team1 && ((px (pxy (ballPos theBall))) >= 0.8 * flength field || (px (pxy (ballPos theBall))) <= 0.2 * flength field)+ || half == SecondHalf && oCn == nameOf team2 && ((px (pxy (ballPos theBall))) >= 0.8 * flength field || (px (pxy (ballPos theBall))) <= 0.2 * flength field)+ ballWasInPenaltyArea ← return $ oCn == nameOf team1 && inPenaltyArea field (opponentHome Team2 half) (pxy (ballPos theBall))+ || oCn == nameOf team2 && inPenaltyArea field (opponentHome Team1 half) (pxy (ballPos theBall))+ punishScore ← return $ punishScore + if ballWasNearGoal then 1 else 0+ shortTermMemory ← return $ if ballWasInPenaltyArea+ then shortTermMemory {penalty = penalty shortTermMemory ++ [(offendersTeam,Rtackle)]}+ else shortTermMemory+ offenderFromSMemory ← return $ getNaughtyPlayer (punished shortTermMemory) offender+ victimFromSMemory ← return $ getNaughtyPlayer (punished shortTermMemory) victim+ offenderVerdict ← return $ if (isJust offenderFromSMemory)+ then (addPunishScore Rtackle punishScore (fromJust offenderFromSMemory))+ else (offender,punishScore,[Rtackle])+ victimVerdict ← return $ if (isJust victimFromSMemory)+ then (addPunishScore Rtheater victimPunishScore (fromJust victimFromSMemory))+ else (victim,victimPunishScore,[Rtheater])+ return $ if (snd3 offenderVerdict == 0)+ then if (snd3 victimVerdict == 0)+ then (shortTermMemory,seed1)+ else (shortTermMemory { punished = punished shortTermMemory ++ [victimVerdict]},seed1)+ else if (snd3 victimVerdict == 0)+ then (shortTermMemory { punished = punished shortTermMemory ++ [offenderVerdict]},seed1)+ else (shortTermMemory { punished = punished shortTermMemory ++ [offenderVerdict,victimVerdict]},seed1)+ where+ (p,seed1) = random seed++ definePunishmentOnHealthDrop ∷ Float → Int → Int+ definePunishmentOnHealthDrop healthDrop punishScore+ | healthDrop < 0.5 = punishScore+ | 0.5 <= healthDrop && healthDrop <= 1.5 = punishScore + 1+ | 1.5 < healthDrop && healthDrop <= 3.5 = punishScore + 2+ | otherwise = punishScore + 3++ analyseActions ∷ ATeam → [PlayerWithEffect] → IvanovShortTermMemory → IvanovLongTermMemory+ → (IvanovShortTermMemory,IvanovLongTermMemory)+ analyseActions team [] shortTermMemory longTermMemory = (shortTermMemory,longTermMemory { lastRoundTackles = []})+ analyseActions team (action@(fa,PlayerID {clubName=cn,playerNo=nmbr}):actions) shortTermMemory longTermMemory+ -- Am I in the pause between the first and the second half (long enough to allow switching of sides)+ | fst (waitingForSideSkipping longTermMemory) = runIdentity $ do+ let ng+ | snd (waitingForSideSkipping longTermMemory) <= zero = (shortTermMemory,longTermMemory { waitingForSideSkipping = (False,zero)})+ | otherwise = (shortTermMemory,longTermMemory { waitingForSideSkipping = (True,snd (waitingForSideSkipping longTermMemory)-one)})+ return ng+ -- did I stop the game because of tackle-actions?+ | (gameStoppedForTackle shortTermMemory) = runIdentity $ do+ let ng+ -- No more analysing game, but still look at mean actions with a connection to the tackle(s)+ | perhaps isSchwalbed fa+ = let ng+ | isTackleVictim (playerID taf) (lastRoundTackles longTermMemory) -- was he victim+ || isTackleOffender (playerID tef) (lastRoundTackles longTermMemory) -- or offender+ || nearLastRoundTackle (pos fb) (lastRoundTackles longTermMemory) -- or near a tackle?+ = let ng+ | inPenaltyArea field (opponentHome team half) (pos fb) -- was it in penaltyarea?+ = analyseActions team actions shortTermMemory { penalty = penalty shortTermMemory ++ [(team,Rschwalbe)]} longTermMemory+ | otherwise -- punish him or punish him more+ = analyseActions team actions (punishMore Rschwalbe tef 1 shortTermMemory) longTermMemory+ in ng+ | otherwise -- otherwise ignore+ = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction+ in ng+ | perhaps isPlayedTheater fa+ = let ng+ | isTackleOffender (playerID tef) (lastRoundTackles longTermMemory) -- was he offender+ || nearLastRoundTackle (pos fb) (lastRoundTackles longTermMemory) -- or near a tackle+ && not (isTackleVictim (playerID taf) (lastRoundTackles longTermMemory))-- and is not a victim+ = let ng+ | inPenaltyArea field (opponentHome team half) (pos fb) -- was it in penaltyarea?+ = analyseActions team actions shortTermMemory { penalty = penalty shortTermMemory ++ [(team,Rtheater)]} longTermMemory+ | otherwise+ = analyseActions team actions (punishMore Rtheater tef 1 shortTermMemory) longTermMemory+ in ng+ -- victims are already scanned during tackle analyses to see if it then was else worth to check the health of the victim+ | otherwise -- otherwise ignore+ = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction+ in ng+ | perhaps isTackled fa+ = let ng+ | isTackleVictim (playerID taf) ((lastRoundTackles longTermMemory)) -- was he victim+ || isTackleOffender (playerID tef) ((lastRoundTackles longTermMemory)) -- or offender+ || nearLastRoundTackle (pos fb) (lastRoundTackles longTermMemory) -- or near a tackle?+ = let ng+ | inPenaltyArea field (opponentHome team half) (pos fb) -- was it in penaltyarea?+ = analyseActions team actions shortTermMemory { penalty = penalty shortTermMemory ++ [(team,Rschwalbe)]} longTermMemory+ | otherwise -- punish him or punish him more+ = analyseActions team actions (punishMore Rtackle tef 2 shortTermMemory) longTermMemory+ in ng+ --otherwise ignore+ -- Usually ignore, but: a tackle is something serious... when I'm in a bad mood, I will not ignore this one+ | (myMood shortTermMemory) > 0.8+ = let ng+ | inPenaltyArea field (opponentHome team half) (pos fb) -- was it in penaltyarea?+ = analyseActions team actions shortTermMemory { penalty = penalty shortTermMemory ++ [(team,Rschwalbe)]} longTermMemory+ | otherwise+ = analyseActions team actions (punishMore Rtackle tef 3 shortTermMemory) longTermMemory+ in ng+ | otherwise -- player was lucky...+ = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction+ in ng+ | perhaps isCaughtBall fa+ = let ng+ | isKeeper tef && inKeeperSpot tef team1Name currHome field -- is he a keeper?+ = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction+ | isTackleVictim (playerID taf) (lastRoundTackles longTermMemory) -- was he victim+ || isTackleOffender (playerID tef) (lastRoundTackles longTermMemory) -- or offender+ || nearLastRoundTackle (pos fb) (lastRoundTackles longTermMemory) -- or near a tackle?+ = let ng+ | inPenaltyArea field (opponentHome team half) (pos fb) -- was it in penaltyarea?+ = analyseActions team actions shortTermMemory { penalty = penalty shortTermMemory ++ [(team,Rschwalbe)]} longTermMemory+ | otherwise -- punish him or punish him more+ = analyseActions team actions (punishMore Rhands tef 2 shortTermMemory) longTermMemory+ in ng+ | otherwise -- otheriwse ignore+ = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction+ in ng+ -- All other kind of actions are ignored+ | otherwise = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction+ return ng+ -- There were no tackle-actions last round → Ivanov needs to keep thinking+ -- Everyone is free to move over the field+ | perhaps isMoved fa || perhaps isFeinted fa = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction+ -- Gainball is illegal when in offside position+ -- A legal gainBall causes no one to be in offside position (until a kick- or headball event)+ | perhaps isGainedBall fa = runIdentity $ do+ -- He was not allowed to get the ball (because of referee-action in the previous round)+ if not (wasAllowedToGetBall (ballIsFor longTermMemory) (nameOf team1) (nameOf team2) cn)+ then return $ analyseActions team actions (punishMore RillegalBallPossession tef 1 shortTermMemory) longTermMemory+ else do+ longTermMemory ← return $ longTermMemory { ballIsFor = Nothing}+ -- He was in offside position+ return $ if elem (playerID tef) (inOffsidePosition longTermMemory) && (offsidePossible longTermMemory) == OffsidePossible+ -- Detect offside for wistle+ then analyseActions team actions (punishMore Roffside tef 0 shortTermMemory) { offsideAndTouchedBall=Just (playerID tef)} longTermMemory+ else analyseActions team actions shortTermMemory longTermMemory { inOffsidePosition = []}+ -- {Kick/Head}Ball is illegal when in offside position (ball was not gained)+ | perhaps isKickedBall fa || perhaps isHeadedBall fa = runIdentity $ do+ shortTermMemory ← return $ shortTermMemory { ballKickedOrHeaded = True}+ -- He was not allowed to get the ball+ return $ if not (wasAllowedToGetBall (ballIsFor longTermMemory) (nameOf team1) (nameOf team2) cn)+ then analyseActions team actions (punishMore RillegalBallPossession tef 1 shortTermMemory) longTermMemory+ else runIdentity $ do+ longTermMemory ← return $ longTermMemory { ballIsFor = Nothing}+ return $ if elem (playerID tef) (inOffsidePosition longTermMemory) && (offsidePossible longTermMemory) == OffsidePossible -- detect offside for wistle+ then analyseActions team actions (punishMore Roffside tef 0 shortTermMemory) { offsideAndTouchedBall=Just (playerID tef)} longTermMemory+ else runIdentity $ do+ -- A legal {Kick/Head}Ball may be illegal/dangerous play when ball was gained by keeper+ (team1Name,currHome) ← return $ if half == FirstHalf then (nameOf team1, West) else (nameOf team1,East)+ keeper1HadBall ← return $+ let keepers = filter isKeeper team1+ keeper = head keepers+ in not (null keepers) && ballIsGainedBy (playerID keeper) ballState && inKeeperSpot keeper team1Name currHome field && (keeper1HadBall longTermMemory)+ keeper2HadBall ← return $+ let keepers = filter isKeeper team2+ keeper = head keepers+ in not (null keepers) && ballIsGainedBy (playerID keeper) ballState && inKeeperSpot keeper team1Name currHome field && (keeper2HadBall longTermMemory)+ if keeper1HadBall && nmbr/=1 || keeper2HadBall && nmbr/=1+ then return $ analyseActions team actions (punishMore RdangerousPlay tef 5 shortTermMemory) longTermMemory+ else do+ -- A legal {Kick/Head}Ball may put people in a potential offside position+ longTermMemory ← return $ longTermMemory { lastKickedTheBall = Just (playerID tef)}+ (homeOfTeam1,homeOfTeam2) ← return $ if half == FirstHalf then (West,East) else (East,West)+ if team == Team1+ then do+ closestDefenderTeam2Xpos ← return $ offsideline field homeOfTeam2 theBall team2+ inOffsidePos ← return $ getOffsidePlayers field homeOfTeam1 closestDefenderTeam2Xpos (removeMember tef team1)+ return $ analyseActions team actions shortTermMemory longTermMemory { inOffsidePosition = inOffsidePos}+ else do+ closestDefenderTeam1Xpos ← return $ offsideline field homeOfTeam1 theBall team1+ inOffsidePos ← return $ getOffsidePlayers field homeOfTeam2 closestDefenderTeam1Xpos (removeMember tef team2)+ return $ analyseActions team actions shortTermMemory longTermMemory { inOffsidePosition = inOffsidePos}+ | perhaps isTackled fa = runIdentity $ do+ -- Store him, so we can look next round at the damage of the victim+ (victimID,ve) ← return $ case fromJust fa of (Tackled victimID ve _) → (victimID,ve)+ moreTackles ← return $ case filter (identifyPlayer victimID) (team1++team2) of+ (fb:_) → [(((playerID fb),(pos fb),(health fb)),((playerID tef),(pos tef),(health tef)),ve)]+ none → []+ shortTermMemory ← return $ shortTermMemory { thisRoundTackles = thisRoundTackles shortTermMemory ++ moreTackles}+ return $ analyseActions team actions shortTermMemory longTermMemory+ | perhaps isSchwalbed fa = runIdentity $ do+ opponents ← return $ if team == Team1 then team2 else team1+ opponentNear ← return $ not (null [posi | Player {pos=posi} ← opponents, dist (pos fb) posi <= 5.0])+ ballNear ← return $ dist zero { pxy=pos fb} (ballPos theBall) <= 10.0+ shortTermMemory ← return $ if (inPenaltyArea field (opponentHome team half) (pos fb)) -- In penaltyarea?+ then shortTermMemory { penalty = penalty shortTermMemory ++ [(team,Rschwalbe)]}+ else (if (opponentNear && ballNear) -- Was an opponent near and was the ball near? Then punish else 4+ then (punishMore Rschwalbe tef 4 shortTermMemory)+ else (if ballNear -- Was the ball near? Then punish else 2+ then (punishMore Rschwalbe tef 2 shortTermMemory)+ else (if opponentNear -- Was an opponent near? Then punish else 3+ then (punishMore Rschwalbe tef 3 shortTermMemory)+ else (punishMore Rschwalbe tef 1 shortTermMemory)+ )))+ return $ analyseActions team actions shortTermMemory longTermMemory+ | perhaps isCaughtBall fa = runIdentity $ do+ return $ if isKeeper tef && inKeeperSpot tef team1Name currHome field -- is he a keeper (todo: and located in his penaltyarea (for everything, gaining ball, etc.)+ then analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction+ else runIdentity $ do+ shortTermMemory ← return $ if (inPenaltyArea field (opponentHome team half) (pxy (ballPos theBall)))+ then (punishMore Rhands tef 2 shortTermMemory) { penalty = penalty shortTermMemory ++ [(team,Rhands)]}+ else (punishMore Rhands tef 4 shortTermMemory)+ return $ analyseActions team actions shortTermMemory longTermMemory+ -- theater, but no tackle or schwalbe was seen, so theater will be punished lightly+ | perhaps isPlayedTheater fa = analyseActions team actions (punishMore Rtheater tef 1 shortTermMemory) longTermMemory+ -- unknown action+ | otherwise = analyseActions team actions shortTermMemory longTermMemory--ignoreThisAction+ where+ (team1Name,currHome) = if half==FirstHalf then (nameOf team1,West) else (nameOf team1,East)+ Just tef = find (identifyPlayer PlayerID {clubName=cn,playerNo=nmbr}) allPlayers+ taf = tef+ fb = taf++ ignoreThisAction = analyseActions team actions shortTermMemory longTermMemory++ wasAllowedToGetBall ∷ (Maybe ATeam) → ClubName → ClubName → ClubName → Bool+ wasAllowedToGetBall Nothing _ _ _ = True+ wasAllowedToGetBall (Just team) team1 team2 myTeam+ | team == Team1 = team1 == myTeam+ | otherwise = team2 == myTeam++ analysePeopleOnTheGround ∷ [PlayerID] → IvanovShortTermMemory → Team → Team → IvanovShortTermMemory+ analysePeopleOnTheGround receivedYellow shortMem team1 team2+ | (gameStoppedForTackle shortMem) = shortMem -- have I stopped the game already for a tackle+ | otherwise = analysePeopleOnTheGround' receivedYellow shortMem [fb | fb ← team1 ++ team2, lastEventIsOnTheGround (effect fb)]+ where+ lastEventIsOnTheGround ∷ (Maybe PlayerEffect) → Bool+ lastEventIsOnTheGround es = isJust es && isOnTheGround (fromJust es)++ analysePeopleOnTheGround' ∷ [PlayerID] → IvanovShortTermMemory → [Player] → IvanovShortTermMemory+ analysePeopleOnTheGround' _ shortMem [] = shortMem+ analysePeopleOnTheGround' receivedYellow shortMem (fb@Player {playerID=PlayerID {clubName=cn}}:tefls) = runIdentity $ do+ -- how many opponents could have tackled him+ suspects ← return $ [s | s ← team1 ++ team2, dist (pos fb) (pos s) <= maxTackleReach s]+ healthDrop ← return $ case lookup (playerID fb) (prevHealthPlayers longTermMemory) of+ Just prevHealth → (health fb) - prevHealth+ none → zero+ motive4Schwalbe ← return $ ballDirectionIsTowardsGoal && ballNear+ goodMotive4Schwalbe ← return $ motive4Schwalbe && ballWasInPenaltyAreaOpponent+ schwalbeThreshold ← return $ if motive4Schwalbe+ then if goodMotive4Schwalbe+ then if victimReprimandedBefore then (0.5,0.4) else (0.3,0.25)+ else if victimReprimandedBefore then (0.2,0.17) else (0.1,0.08)+ else if victimReprimandedBefore then (0.1,0.08) else (-999.0,-999.0)+ schwalbeThreshold ← return $ if length suspects > 1+ then (fst schwalbeThreshold * 0.5, snd schwalbeThreshold * 0.5)+ else schwalbeThreshold+ if not (null suspects) -- tackle or schwalbe??+ then do+ primarySuspect ← return $ suspects !! ((length suspects * round ((myMood shortMem) * 10.0)) `mod` (length suspects) )+ isNoOtherDefenderLeft ← return $ if (cn == nameOf team1 && half==FirstHalf || cn == nameOf team2 && half==SecondHalf)+ then (null [fb | fb ← filter isFielder team2, (px (pos fb)) > (px (pos primarySuspect))])+ else if (cn == nameOf team1 && half==SecondHalf || cn == nameOf team2 && half==FirstHalf)+ then (null [fb | fb ← filter isFielder team2, (px (pos fb)) < px (pos primarySuspect)])+ else (error "primary suspect of possible tackle does not play in one of the teams")+ opponentReprimandedBefore ← return $ elem (playerID primarySuspect) receivedYellow -- not (null (reprimands (events primarySuspect))) || (gotYellow (events primarySuspect))+ motive4Tackle ← return $ ballDirectionIsTowardsGoal && ballNear || ballGoingTowardsVictim+ goodMotive4Tackle ← return $ motive4Tackle && (isNoOtherDefenderLeft || goalVeryNear)+ tackleThreshold ← return $ if motive4Tackle+ then if goodMotive4Tackle+ then if opponentReprimandedBefore then (0.5,0.6) else (0.7,0.75)+ else if opponentReprimandedBefore then (0.8,0.83) else (0.9,0.92)+ else if opponentReprimandedBefore then (0.9,0.92) else (999.0,999.0)+ shortMem ← return $ if ((myMood shortMem) >= fst tackleThreshold && (myMood shortMem) < snd tackleThreshold && healthDrop > 0.1) -- Give yellow for tackle+ then (punishMore Rtackle primarySuspect 3 shortMem)+ else (if ((myMood shortMem) >= fst tackleThreshold) -- Warn for tackle+ then (punishMore Rtheater primarySuspect 1 shortMem)+ else (if ((myMood shortMem) <= fst schwalbeThreshold && (myMood shortMem) > snd schwalbeThreshold && healthDrop > 0.1)-- then Give else yellow for schwalbe+ then (punishMore Rschwalbe fb 3 shortMem)+ else (if ((myMood shortMem) <= fst schwalbeThreshold) -- Warn for schwalbe+ then (punishMore Rschwalbe fb 1 shortMem)+ else shortMem+ )))+ return $ analysePeopleOnTheGround' receivedYellow shortMem tefls+ else do+ shortMem ← return $ if ((myMood shortMem) <= fst schwalbeThreshold && (myMood shortMem) > snd schwalbeThreshold && healthDrop > 0.1) -- Warn good for schwalbe+ then (punishMore Rschwalbe fb 2 shortMem)+ else (if ((myMood shortMem) <= fst schwalbeThreshold) -- Warn for schwalbe+ then (punishMore Rschwalbe fb 1 shortMem)+ else shortMem+ )+ return $ analysePeopleOnTheGround' receivedYellow shortMem tefls+ where+ goalVeryNear = if (cn == nameOf team1 && half == FirstHalf || cn == nameOf team2 && half == SecondHalf)+ then (dist (pos fb) Position {px=flength field,py=fwidth field/2.0} <= 20.0) -- east goal+ else (if (cn == nameOf team1 && half == SecondHalf || cn == nameOf team2 && half == FirstHalf)+ then (dist (pos fb) Position {px=zero,py=fwidth field/2.0} <= 20.0) -- west goal+ else (error "fallen player is not from one of the teams"))+ ballNear = dist zero { pxy=pos fb} (ballPos theBall) <= 8.0+ victimReprimandedBefore = elem (playerID fb) receivedYellow+ ballWasInPenaltyAreaOpponent = cn == nameOf team1 && inPenaltyArea field (opponentHome Team1 half) (pxy (ballPos theBall))+ ||+ cn == nameOf team2 && inPenaltyArea field (opponentHome Team2 half) (pxy (ballPos theBall))+ ballWasInPenaltyAreaSelf = cn == nameOf team1 && inPenaltyArea field (opponentHome Team2 half) (pxy (ballPos theBall))+ ||+ cn == nameOf team2 && inPenaltyArea field (opponentHome Team1 half) (pxy (ballPos theBall))+ ballDirectionIsTowardsGoal = if (cn == nameOf team1 && half == FirstHalf || cn == nameOf team2 && half == SecondHalf)+ then ((direction (vxy (ballSpeed theBall))) > 0.5*pi && (direction (vxy (ballSpeed theBall))) < 1.5*pi) -- to east ..+ else (if (cn == nameOf team1 && half == SecondHalf || cn == nameOf team2 && half == FirstHalf)+ then ((direction (vxy (ballSpeed theBall))) < 0.5*pi || (direction (vxy (ballSpeed theBall))) > 1.5*pi) -- to west .. PA: odd, why use ..||.. here and ..&&.. immediately above?+ else (error "fallen player is not from one of the teams"))+ ballGoingTowardsVictim = nextBallPos (ballPos theBall) (ballSpeed theBall) ((pos fb),5.0,(height fb))++ drawConclusions ∷ IvanovShortTermMemory → IvanovLongTermMemory → ([RefereeAction],IvanovLongTermMemory)+ drawConclusions shortMem longMem = runIdentity $ do+ longMem ← return $ longMem { keeper1HadBall = ballIsGainedBy PlayerID {playerNo=1,clubName=nameOf team1} ballState--all hasBall (filter isKeeper team1)+ , keeper2HadBall = ballIsGainedBy PlayerID {playerNo=1,clubName=nameOf team2} ballState--all hasBall (filter isKeeper team2)+ , prevHealthPlayers = map (\fb → ((playerID fb), (health fb))) (team1 ++ team2)+ }+ teamPenalty ← return $ firstPenalty (penalty shortMem)+ offencePenalty ← return $ getMostImportantKickAction basicActions+ (kickAction,longMem) ← return $ if isJust teamPenalty+ then let t = fromJust teamPenalty in (Just (Penalty t), longMem { ballIsFor = Just t, typeOfKickoff = Just (Penalty t)})+ else if isJust offencePenalty+ then let p = fromJust offencePenalty in (offencePenalty, longMem { ballIsFor = Just (actionForWhichTeam p), typeOfKickoff = offencePenalty})+ else (Nothing,longMem)+ noticedActions ← return $ map fst basicActions+ longMem ← return $ if isJust kickAction then longMem { offsidePossible = KickForcedByReferee}+ else (if ballKickedOrHeaded shortMem then (lowerOffsideCounter longMem)+ else longMem+ )+ if not (gameStoppedForTackle shortMem) -- We haven't analysed tackles this round, it was a normal round+ then do+ let refActions = if isJust (ballIsFor longMem)+ then case typeOfKickoff longMem of+ Just kick → noticedActions ++ [DisplacePlayers (replacePlayers team1 team2 kick field theBall longMem)]+ Nothing → noticedActions+ else noticedActions+ let ng+ | time <= fromJust (gameLength longMem)/2.0 && half == FirstHalf = runIdentity $ do-- is it time to change half?+ longMem ← return $ longMem { waitingForSideSkipping = (True,150)}+ centerKick ← return $ CenterKick Team2+ let ds = kickoffDisplacements longMem+ return (refActions ++ [ContinueGame] ++ [EndHalf,centerKick,DisplacePlayers ds],longMem { ballIsFor = Just Team2, typeOfKickoff = Just centerKick})++ | time <= zero = (refActions ++ [GameOver],longMem) -- is it time to stop the game?+ -- Is the ball out of the lines and do we have: a goal, a corner, a goal kick, or a throw in+ | otherwise = runIdentity $ do+ (behindLineActions,longMem) ← return $ getBehindLinesActions half theBall field longMem+ -- No matter what happened, ball behind the line is ball behind the line+ if length behindLineActions > zero+ then do+ displacements ← return $ replacePlayers team1 team2 (last behindLineActions) field theBall longMem+ refActions ← return $ refActions ++ [DisplacePlayers displacements]+ return (refActions ++ [ContinueGame] ++ behindLineActions,longMem { offsidePossible = KickForcedByReferee})+ else do+ longMem ← return $ longMem { lastRoundTackles = thisRoundTackles shortMem}+ -- We have no new tackles for the next round+ let ng+ | null (thisRoundTackles shortMem) = runIdentity $ do+ let ng+ | isJust kickAction = runIdentity $ do+ kick ← return $ fromJust kickAction+ goalArea ← return $ kickActionIsFreeKickInPenaltyArea kick+ if isJust goalArea+ then do+ displacements ← return $ replacePlayers team1 team2 (fromJust goalArea) field theBall longMem+ return (refActions ++ [ContinueGame,DisplacePlayers displacements,fromJust goalArea],longMem)+ else return (refActions ++ [ContinueGame,kick],longMem)+ | otherwise = (refActions ++ [ContinueGame],longMem)+ return ng+ -- We have new tackles for the next round+ | otherwise = (refActions ++ [PauseGame,AddTime (1.0/30.0)],longMem)+ return ng+ return ng+ -- We have analysed tackles this round+ else+ -- We have a position to restart the game from+ if isJust kickAction+ then do+ kick ← return $ fromJust kickAction+ goalArea ← return $ kickActionIsFreeKickInPenaltyArea kick+ if isJust goalArea+ then do+ displacements ← return $ replacePlayers team1 team2 (fromJust goalArea) field theBall longMem+ return ([ContinueGame] ++ noticedActions ++ [DisplacePlayers displacements,fromJust goalArea],longMem)+ else do+ displacements ← return $ replacePlayers team1 team2 kick field theBall longMem+ return ([ContinueGame] ++ noticedActions ++ [DisplacePlayers displacements,kick],longMem)+ -- I still have to think about a new place to restart the game from+ else error "should have a position to restart the game from"+ where+ basicActions = getAllBasicActions (receivedYellow longMem) shortMem++ mirrorTeams ∷ Displacements → Displacements+ mirrorTeams ds = map (\(fbID,pos) → (fbID,mirror field pos)) ds++ kickActionIsFreeKickInPenaltyArea ∷ RefereeAction → Maybe RefereeAction+ kickActionIsFreeKickInPenaltyArea (DirectFreeKick team pos)+ | inPenaltyArea field (opponentHome team half) pos = Just (Penalty team)+ | inPenaltyArea field (teamHome team half) pos = Just (GoalKick team)+ | otherwise = Nothing+ kickActionIsFreeKickInPenaltyArea _ = Nothing++ getBehindLinesActions ∷ Half → Ball → Field → IvanovLongTermMemory → ([RefereeAction],IvanovLongTermMemory)+ getBehindLinesActions half theBall field longMem@IvanovLongTermMemory {lastKickedTheBall}+ | (pxy (ballPos theBall)) == p = ([],longMem) -- ball is not behind (see definition of pointToRectangle)+ | isNothing lastKickedTheBall = ([CenterKick Team1, DisplacePlayers $ kickoffDisplacements longMem],longMem) -- the ball got behind by unknown forces+ | (px (pxy (ballPos theBall))) < zero = runIdentity $ do -- behind line West?+ (team,homeTeamWest) ← return $ if half == FirstHalf then (Team1, nameOf team1) else (Team2,nameOf team2) -- first half?+ let ng+ | isbetween (py (pxy (ballPos theBall))) ((fwidth field)/2.0 - goalWidth/2.0) ((fwidth field)/2.0 + goalWidth/2.0) -- goal?+ &&+ (pz (ballPos theBall)) < goalHeight = if (team==Team1)+ then ([Goal Team2,CenterKick Team1, DisplacePlayers $ kickoffDisplacements longMem],longMem { ballIsFor=Just Team1})+ else ([Goal Team1,CenterKick Team2, DisplacePlayers $ kickoffDisplacements longMem],longMem { ballIsFor=Just Team2})+ | clubName (fromJust lastKickedTheBall) == homeTeamWest = runIdentity $ do -- lastPlayerKicked Team1?+ corner ← return $ if (py (pxy (ballPos theBall))) > (fwidth field)/2.0 then South else North+ return ([Corner (other team) corner],longMem { ballIsFor = Just (other team), typeOfKickoff = Just $ Corner (other team) corner})+ | otherwise = ([GoalKick team],longMem { ballIsFor = Just team, typeOfKickoff = Just (GoalKick team)}) -- opponent team → goalkick+ return ng+ | (px (pxy (ballPos theBall))) > (flength field)= runIdentity $ do -- behind line East?+ (team,homeTeamEast) ← return $ if half == FirstHalf then (Team2, nameOf team2) else (Team1,nameOf team1)+ let ng+ | isbetween (py (pxy (ballPos theBall))) ((fwidth field)/2.0 - goalWidth/2.0) ((fwidth field)/2.0 + goalWidth/2.0) -- goal?+ &&+ (pz (ballPos theBall)) < goalHeight = if (team==Team1)+ then ([Goal Team2,CenterKick Team1, DisplacePlayers $ kickoffDisplacements longMem],longMem { ballIsFor=Just Team1, typeOfKickoff = Just $ CenterKick Team1})+ else ([Goal Team1,CenterKick Team2, DisplacePlayers $ kickoffDisplacements longMem],longMem { ballIsFor=Just Team2, typeOfKickoff = Just $ CenterKick Team2})+ | clubName (fromJust lastKickedTheBall) == homeTeamEast = runIdentity $ do -- lastPlayerKicked Team1?+ corner ← return $ if (py (pxy (ballPos theBall))) > (fwidth field)/2.0 then South else North+ return ([Corner (other team) corner],longMem { ballIsFor = Just (other team), typeOfKickoff = Just $ Corner (other team) corner})+ | otherwise = ([GoalKick team],longMem { ballIsFor = Just team, typeOfKickoff = Just $ GoalKick team})+ return ng+ | otherwise = runIdentity $ do+ throwin ← return $ if clubName (fromJust lastKickedTheBall) == nameOf team1 then Team2 else Team1+ return ([ThrowIn throwin p],longMem { ballIsFor = Just throwin, typeOfKickoff = Just $ ThrowIn throwin p})+ where p = pointToRectangle (zero,Position {px=flength field,py=fwidth field}) (pxy (ballPos theBall))++ {- Most important (in given order): Tackle, OwnBallIllegally, Offside, DangerousPlay, Hands. Even: the rest -}+ getMostImportantKickAction ∷ [(RefereeAction,RefereeAction)] → Maybe RefereeAction+ getMostImportantKickAction actions = if null actions then Nothing else Just resumeAction where+ (_,resumeAction) = minimumBy (\(a1,r1) (a2,r2) → priority a1 `compare` priority a2) actions+ priority action+ | isTackleDetected action = 5+ | isOwnBallIllegally action = 4+ | isOffside action = 3+ | isDangerousPlay action = 2+ | isHands action = 1+ | otherwise = 0++ actionForWhichTeam ∷ RefereeAction → ATeam+ actionForWhichTeam (DirectFreeKick t _) = t+ actionForWhichTeam (GoalKick t) = t+ actionForWhichTeam (Corner t _) = t+ actionForWhichTeam (ThrowIn t _) = t+ actionForWhichTeam (Penalty t) = t+ actionForWhichTeam (CenterKick t) = t+ actionForWhichTeam _ = error "actionForWhichTeam: kick action expected"++ getAllBasicActions ∷ [PlayerID] → IvanovShortTermMemory → [(RefereeAction,RefereeAction)]+ getAllBasicActions receivedYellow shortMem = getAllBasicPunishActions receivedYellow (punished shortMem) where+ -- PA: this should really be programmed as a map→+ getAllBasicPunishActions ∷ [PlayerID] → [PunishedPlayer] → [(RefereeAction,RefereeAction)]+ getAllBasicPunishActions _ [] = []+ getAllBasicPunishActions receivedYellow ((fbID@PlayerID{clubName=cn},punish,[]):pals)+ | punish > 4 = ((ReprimandPlayer fbID RedCard,DirectFreeKick otherTeam kickPos) : rest)+ | punish >= 3 = runIdentity $ do+ yellow ← return $ (ReprimandPlayer fbID YellowCard,DirectFreeKick otherTeam kickPos)+ red ← return $ (ReprimandPlayer fbID RedCard, DirectFreeKick otherTeam kickPos)+ let ng+ | elem fbID receivedYellow = yellow : red : rest+ | otherwise = yellow : rest+ return ng+ | punish >= 1 = (ReprimandPlayer fbID Warning,DirectFreeKick otherTeam kickPos) : rest+ | otherwise = rest+ where+ kickPosHome = if cn == nameOf team1 && half == FirstHalf || cn == nameOf team2 && half == SecondHalf then East else West+ kickPosTeam = if cn == nameOf team1 then team2 else team1+ kickPos = posForFreeKick kickPosHome (pxy (ballPos theBall)) kickPosTeam+ otherTeam = if cn == nameOf team1 then Team2 else Team1+ rest = getAllBasicPunishActions receivedYellow pals+ getAllBasicPunishActions receivedYellow ((fbID@PlayerID{clubName=cn},punish,(r:rls)):pals)+ | r == Rtackle = (TackleDetected fbID,DirectFreeKick otherTeam kickPos) : rest+ | r == Roffside && isJust (offsideAndTouchedBall shortMem) =+ let ng+ | fromJust (offsideAndTouchedBall shortMem) == fbID = (Offside fbID,DirectFreeKick otherTeam kickPos) : rest+ | otherwise = rest+ in ng+ | r == Rtheater = (TheaterDetected fbID,DirectFreeKick otherTeam kickPos) : rest+ | r == Rschwalbe = (SchwalbeDetected fbID,DirectFreeKick otherTeam kickPos) : rest+ | r == Rhands = (Hands fbID,DirectFreeKick otherTeam kickPos) : rest+ | r == RdangerousPlay = (DangerousPlay fbID,DirectFreeKick otherTeam kickPos) : rest+ | r == RillegalBallPossession = (OwnBallIllegally fbID,DirectFreeKick otherTeam kickPos) : rest+ | otherwise = error "getAllBasicPunishActions: unknown reason of RefereeAction."+ where+ kickPosHome = if cn == nameOf team1 && half == FirstHalf || cn == nameOf team2 && half == SecondHalf then East else West+ kickPosTeam = if cn == nameOf team1 then team2 else team1+ kickPos = posForFreeKick kickPosHome (pxy (ballPos theBall)) kickPosTeam+ otherTeam = if cn == nameOf team1 then Team2 else Team1+ rest = getAllBasicPunishActions receivedYellow ((fbID,punish,rls):pals)++ firstPenalty ∷ [(ATeam,Reason)] → Maybe ATeam+ firstPenalty [] = Nothing+ firstPenalty ((t,_):_) = Just (other t)++isTackleVictim ∷ PlayerID → [TackleAction] → Bool+isTackleVictim fbID tackleEvents = any (\((fbID',_,_),_,_) → fbID == fbID') tackleEvents++isTackleOffender ∷ PlayerID → [TackleAction] → Bool+isTackleOffender fbID tackleEvents = any (\(_,(fbID',_,_),_) → fbID == fbID') tackleEvents++nearLastRoundTackle ∷ Position → [TackleAction] → Bool+nearLastRoundTackle pos tackleEvents = all near tackleEvents where+ near ((_,vpos,_),(_,opos,_),_) = dist pos vpos > nearEventRadius && dist pos opos > nearEventRadius++-- Used for offside, so we only look at the xposition+offsideline ∷ Field → Home → Ball → [Player] → Metre+offsideline field home ball fbs = case sortBy cmp ((px (pxy (ballPos ball))) : [(px (pos fb)) | fb ← fbs]) of+ [] → edge+ [x] → x+ [_,x] → x+ (_:_:x:_) → x+ where+ (cmp,edge) = if (home == West)+ then (compare,zero)+ else (\x y → compare y x,(flength field))++getOffsidePlayers ∷ Field → Home → XPos → [Player] → [PlayerID]+getOffsidePlayers field home line fbs = map playerIdentity (filter (\fb@Player{pos=Position{px=posx}} -> atOtherHalf posx && (cmp (px (pos fb)) line)) fbs) where+ (cmp,atOtherHalf) = if home == West then ((>),(<) fieldhalf) else ((<),(>) fieldhalf)+ fieldhalf = flength field / 2.0++-- A referee can not see everything correct.+filterOutMeanActions ∷ [Player] → [PlayerWithEffect] → StdGen → ([PlayerWithEffect],StdGen)+filterOutMeanActions allPlayers allActions seed = ([action | (p,action) ← zip ps allActions, noticeAction action p],seed1) where+ (ps,seed1) = iterateStn (length allActions) random seed++ noticeAction ∷ PlayerWithEffect → Float → Bool+ noticeAction (fa,playerID) p+ | foul = avg [p,1.0 - pa + if elem skill (skillsAsList fb) then 0.1 else 0.0] <= 0.5+ | otherwise = True+ where+ Just fb = find (identifyPlayer playerID) allPlayers+ (foul,pa,skill) = if perhaps isTackled fa then (True,chanceOfPenaltySuccess, Tackling)+ else (if perhaps isSchwalbed fa then (True,chanceOfSchwalbeSuccess,Schwalbing)+ else (if perhaps isPlayedTheater fa then (True,chanceOfTheaterSuccess, PlayingTheater)+ else (if perhaps isCaughtBall fa then (True,chanceOfCatchSuccess, Catching)+ else (False,error "ASNTD",error "ISAONE")+ )))++nextBallPos ∷ Position3D → Speed3D → (Position,XRadius,ZRadius) → Bool+nextBallPos item dir (target,radius,height) = isGettingToPos (iterate (nextPos dir) item) where+ targetAtGround = zero { pxy=target}+ targetInAir = Position3D {pxy=target, pz=height}++ nextPos ∷ Speed3D → Position3D → Position3D+ nextPos speed currentPosition = movePoint3D RVector3D {dxy=RVector{dx=cos (direction (vxy speed))*newV,dy=sin (direction (vxy speed))*newV},dz=newV3} currentPosition+ where+ resistance = if (pz currentPosition) > zero then airResistance else surfaceResistance+ newV = resistance * velocity (vxy speed)+ newV3 = vz speed - 0.1*accellerationSec++ isGettingToPos ∷ [Position3D] → Bool+ isGettingToPos [] = False+ isGettingToPos [x] = False+ isGettingToPos (x:y:xs)+ | dist x targetAtGround < radius || dist x targetInAir < radius = True+ | avg [dist x targetAtGround,dist x targetInAir] < avg [dist y targetAtGround,dist y targetInAir] = False -- object is moving away+ | otherwise = isGettingToPos (y:xs) -- object is coming closer+++-- Freekicks are granted from the pos of the player that is the most closest to the ball but not a position more forward to the goal+posForFreeKick ∷ Home → Position {-→ Position-} → [Player] → Position+posForFreeKick home ballPos {-victimPos-} [] = ballPos--victimPos+posForFreeKick home ballPos {-victimPos-} team = case [fb | fb ← team, (dist (pos fb) ballPos) <= 15.0 ] of+ [] → ballPos+ close → pos (foldr1 closer2ball close)+ where+ closer2ball ∷ Player → Player → Player+ closer2ball fb1 fb2+ | dist (pos fb1) ballPos < dist (pos fb2) ballPos = fb1+ | otherwise = fb2++inKeeperSpot ∷ Player → ClubName → Home → Field → Bool+inKeeperSpot fb clubName home field = inPenaltyArea field (if getClubName fb == clubName then home else (other home)) (pos fb)
SoccerFun/RefereeAction.hs view
@@ -7,31 +7,30 @@ data RefereeAction = ReprimandPlayer PlayerID Reprimand -- ^ player with given name receives reprimand- | Hands PlayerID -- ^ person is seen for doing hands- | TackleDetected PlayerID -- ^ person is seen for doing tackle- | SchwalbeDetected PlayerID -- ^ person is seen for doing schwalbe+ | Hands PlayerID -- ^ person is seen for doing hands+ | TackleDetected PlayerID -- ^ person is seen for doing tackle+ | SchwalbeDetected PlayerID -- ^ person is seen for doing schwalbe | TheaterDetected PlayerID- | DangerousPlay PlayerID -- ^ person is seen for doing dangerous actions- | GameOver -- ^ end of game- | PauseGame -- ^ game is paused- | AddTime ExtraTime -- ^ extra time is added to the game- | EndHalf -- ^ first half is over, teams go for a second half- | Goal ATeam -- ^ team playing at home has scored- | Offside PlayerID -- ^ player is offside at Home- | DirectFreeKick ATeam Position -- ^ a direct free kick is granted for team home at given position- | GoalKick ATeam -- ^ a goal kick is granted for team home- | Corner ATeam Edge -- ^ a corner kick is granted for team home- | ThrowIn ATeam Position -- ^ a throw in ball is granted for team home at given position- | Penalty ATeam -- ^ penalty at homeside- | CenterKick ATeam -- ^ team playing at home may start from the center- | Advantage ATeam -- ^ referee gives advantages to home-team- | OwnBallIllegally PlayerID -- ^ ball was for the other team- | DisplacePlayers Displacements -- ^ displaces all players at the provided position (used with free kicks)+ | DangerousPlay PlayerID -- ^ person is seen for doing dangerous actions+ | GameOver -- ^ end of game+ | PauseGame -- ^ game is paused+ | AddTime ExtraTime -- ^ extra time is added to the game+ | EndHalf -- ^ first half is over, teams go for a second half+ | Goal ATeam -- ^ team playing at home has scored+ | Offside PlayerID -- ^ player is offside at Home+ | DirectFreeKick ATeam Position -- ^ a direct free kick is granted for team home at given position+ | GoalKick ATeam -- ^ a goal kick is granted for team home+ | Corner ATeam Edge -- ^ a corner kick is granted for team home+ | ThrowIn ATeam Position -- ^ a throw in ball is granted for team home at given position+ | Penalty ATeam -- ^ penalty at homeside+ | CenterKick ATeam -- ^ team playing at home may start from the center+ | Advantage ATeam -- ^ referee gives advantages to home-team+ | OwnBallIllegally PlayerID -- ^ ball was for the other team+ | DisplacePlayers Displacements -- ^ displaces all players at the provided position (used with free kicks) | ContinueGame- | TellMessage String -- ^ no effect on match, message is displayed by referee+ | TellMessage String -- ^ no effect on match, message is displayed by referee deriving (Show, Eq) - isReprimandPlayer ∷ RefereeAction → Bool isReprimandPlayer (ReprimandPlayer _ _) = True isReprimandPlayer _ = False@@ -133,8 +132,8 @@ getKickPos ∷ Field → Half → RefereeAction → Maybe Position getKickPos field half (GoalKick team) = Just $ Position { py = (fwidth field)/2.0 , px = if (team == Team1 && half == FirstHalf || team == Team2 && half == SecondHalf)- then penaltyAreaDepth- else (flength field) - penaltyAreaDepth }+ then 5+ else (flength field) - 5 } getKickPos field half (Corner team edge) = Just $ Position { px = if (team == Team1 && half == SecondHalf || team == Team2 && half == FirstHalf) then halfRadiusCornerKickArea else ((flength field) - halfRadiusCornerKickArea)@@ -155,4 +154,3 @@ getKickPos _ _ (DirectFreeKick _ pos) = Just pos getKickPos _ _ (ThrowIn _ pos) = Just pos getKickPos _ _ _ = Nothing-
SoccerFun/Tape/Record.hs view
@@ -10,6 +10,16 @@ import SoccerFun.MatchControl import SoccerFun.MatchGame import System.Environment+import Paths_SoccerFun (getDataFileName)+import System.Cmd++dynRecord ∷ FilePath → FilePath → IO ()+dynRecord p1 p2 = do+ (loc1,name1) ← compileTeam p1+ (loc2,name2) ← compileTeam p2+ record ← getDataFileName "SoccerFun/Tape/Record/Template.hs"+ exitCode ← system $ "runhaskell -i" ⧺ loc1 ⧺ " -i" ⧺ loc2 ⧺ " -DTEAM1=" ⧺ name1 ⧺ " -DTEAM2=" ⧺ name2 ⧺ " " ⧺ record+ when (exitCode ≢ ExitSuccess) (fail "Could merge teams, probably due to a type error.") main ∷ IO () main = do
SoccerFun/Tape/Record/Template.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE UnicodeSyntax, CPP #-} {-# OPTIONS_GHC -pgmP cpp #-}--- | Usage: Hit /q/ to abort the match module Main where import Control.Monad
tournament/mkIndex.sh view
@@ -14,12 +14,14 @@ for j in teams/*; do game=`basename $i`-`basename $j` echo "<td>"- if [ `stat -c%s "tapes/$game.log"` -lt 10 ]; then- [ -s tapes/$game.sft ] && echo "<a href=\"$game.sft\">"- cat "tapes/$game.log"- [ -s tapes/$game.sft ] && echo "</a>"- else- echo "<a href=\"$game.log\">error</a>"+ if [ -f "tapes/$game.log" ]; then+ if [ `stat -c%s "tapes/$game.log"` -lt 10 ]; then+ [ -s "tapes/$game.sft" ] && echo "<a href=\"$game.sft\">"+ cat "tapes/$game.log"+ [ -s "tapes/$game.sft" ] && echo "</a>"+ else+ echo "<a href=\"$game.log\">error</a>"+ fi fi echo "</td>" done;