diff --git a/SoccerFun.cabal b/SoccerFun.cabal --- a/SoccerFun.cabal +++ b/SoccerFun.cabal @@ -1,5 +1,5 @@ Name: SoccerFun -Version: 0.5 +Version: 0.5.1 Copyright: (c) 2010, Jan Rochel License: BSD3 License-File: LICENSE diff --git a/SoccerFun/Field.hs b/SoccerFun/Field.hs --- a/SoccerFun/Field.hs +++ b/SoccerFun/Field.hs @@ -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 diff --git a/SoccerFun/MatchControl.hs b/SoccerFun/MatchControl.hs --- a/SoccerFun/MatchControl.hs +++ b/SoccerFun/MatchControl.hs @@ -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: diff --git a/SoccerFun/MatchGame.hs b/SoccerFun/MatchGame.hs --- a/SoccerFun/MatchGame.hs +++ b/SoccerFun/MatchGame.hs @@ -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 diff --git a/SoccerFun/Referee/Ivanov.hs b/SoccerFun/Referee/Ivanov.hs --- a/SoccerFun/Referee/Ivanov.hs +++ b/SoccerFun/Referee/Ivanov.hs @@ -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) diff --git a/SoccerFun/RefereeAction.hs b/SoccerFun/RefereeAction.hs --- a/SoccerFun/RefereeAction.hs +++ b/SoccerFun/RefereeAction.hs @@ -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 - diff --git a/SoccerFun/Tape/Record.hs b/SoccerFun/Tape/Record.hs --- a/SoccerFun/Tape/Record.hs +++ b/SoccerFun/Tape/Record.hs @@ -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 diff --git a/SoccerFun/Tape/Record/Template.hs b/SoccerFun/Tape/Record/Template.hs --- a/SoccerFun/Tape/Record/Template.hs +++ b/SoccerFun/Tape/Record/Template.hs @@ -1,6 +1,5 @@ {-# LANGUAGE UnicodeSyntax, CPP #-} {-# OPTIONS_GHC -pgmP cpp #-} --- | Usage: Hit /q/ to abort the match module Main where import Control.Monad diff --git a/tournament/mkIndex.sh b/tournament/mkIndex.sh --- a/tournament/mkIndex.sh +++ b/tournament/mkIndex.sh @@ -14,12 +14,14 @@ for j in teams/*; do game=`basename $i`-`basename $j` echo "" - if [ `stat -c%s "tapes/$game.log"` -lt 10 ]; then - [ -s tapes/$game.sft ] && echo "" - cat "tapes/$game.log" - [ -s tapes/$game.sft ] && echo "" - else - echo "error" + if [ -f "tapes/$game.log" ]; then + if [ `stat -c%s "tapes/$game.log"` -lt 10 ]; then + [ -s "tapes/$game.sft" ] && echo "" + cat "tapes/$game.log" + [ -s "tapes/$game.sft" ] && echo "" + else + echo "error" + fi fi echo "" done;