{-# LANGUAGE UnicodeSyntax #-} module SoccerFun.MatchGame where import Prelude.Unicode import SoccerFun.Types import SoccerFun.Player import SoccerFun.MatchControl import SoccerFun.RefereeAction import SoccerFun.Prelude showTime ∷ Minutes → String -- ^ display time in (mm:ss min) format showTime minutes = show (fromIntegral seconds/60) ++ ":" ++ (if (seconds `mod` 60 < 10) then "0" else "") ++ show (seconds `mod` 60) ++ " min" where seconds = round (((fromIntegral (round (minutes * 100.0) ∷ Int))/100.0) * 60.0) ∷ Int logRefereeAction :: RefereeAction -> Maybe String logRefereeAction (ReprimandPlayer tfp r) = Just $ "ReprimandPlayer " ++ show (playerNo tfp) ++ " " ++ show r logRefereeAction (Hands tfp) = Just $ "Hands " ++ show (playerNo tfp) logRefereeAction (TackleDetected tfp) = Just $ "TackleDetected " ++ show (playerNo tfp) logRefereeAction (SchwalbeDetected tfp) = Just $ "SchwalbeDetected " ++ show (playerNo tfp) logRefereeAction (TheaterDetected tfp) = Just $ "TheaterDetected " ++ show (playerNo tfp) logRefereeAction (DangerousPlay tfp) = Just $ "DangerousPlay " ++ show (playerNo tfp) logRefereeAction GameOver = Just $ "GameOver" logRefereeAction PauseGame = Just $ "PauseGame" logRefereeAction (AddTime t) = Just $ "AddTime " ++ (showTime t) logRefereeAction EndHalf = Just $ "EndHalf" logRefereeAction (Goal t) = Just $ "Goal " ++ show t logRefereeAction (Offside tfp) = Just $ "Offside " ++ show (playerNo tfp) logRefereeAction (DirectFreeKick t p) = Just $ "DirectFreeKick " ++ show t ++ " " ++ show p logRefereeAction (GoalKick t) = Just $ "GoalKick " ++ show t logRefereeAction (Corner t e) = Just $ "Corner " ++ show t ++ " " ++ show e logRefereeAction (ThrowIn t p) = Just $ "ThrowIn " ++ show t ++ " " ++ show p logRefereeAction (Penalty t) = Just $ "Penalty " ++ show t 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 ContinueGame = Nothing logRefereeAction (TellMessage txt) = Just $ "TellMessage " ++ show txt {- This module defines the match and tournament data structures. -} --import MatchLog, GuiInterface --data BallGame -- = BallGame { match ∷ Match -- the ball match to be played -- , actionPics ∷ ActionPics -- the action-images -- , history ∷ History -- recent history of game -- , frames ∷ Int -- nr of frames so far (reset to zero every second) -- , options ∷ Options -- options of ball game -- , logging ∷ WhatToLog -- logging options -- } -- --data Options -- = Options { closeReferee ∷ Bool -- automatically close referee dialog after one second (True - default) or by user (False) -- , showSplash ∷ Bool -- show splash screen at opening (False - default) or do (True) -- , displaySpeed ∷ DisplaySpeed -- slow, normal or fast-play (Normal - default) -- , showReferee ∷ Bool -- show referee-intermezzo (True - default) or not (False) -- , playingTime ∷ PlayingTime -- default playingtime (defaultPlayingTime) -- } --instance show Options --instance fromString Options --instance == Options -- --data History -- = History { time ∷ Seconds -- time in seconds of length history -- , past ∷ [Match] -- the recent history -- } -- --{- incFrames game increases the frames count of game. ---} --incFrames ∷ BallGame → BallGame --incFrames game@{frames} = game {frames=frames+1} -- --{- defaultPlayingTime returns recommended playing time ---} --defaultPlayingTime ∷ PlayingTime --defaultPlayingTime ∷ PlayingTime --defaultPlayingTime = 0.66--1.0 -- --{- defaultOptions returns default options. ---} --defaultOptions ∷ Options --defaultOptions -- = { closeReferee = True -- , showSplash = False -- , displaySpeed = Normal -- , showReferee = True -- , playingTime = defaultPlayingTime -- } -- -- --{- timeLeft is True if the game has not finished ---} --timeLeft ∷ BallGame → Bool --timeLeft game = game.match.Match.playingTime > zero -- --{- getOptions env reads the options file (if present) and returns its content. -- If no options file was found, it is created and filled with default values. -- setOptions options stores the options in the options file. ---} --getOptions ∷ *env → (Options,*env) | FileSystem env --getOptions env -- = case readFile optionsFile env of -- (Just options,env) = (fromString options,env) -- (nothing, env) = (defaultOptions, env) --setOptions ∷ Options *env → *env | FileSystem env -- --data Competition = Competition { results ∷ [[Maybe Score]] -- teams x teams matrix of match results (note: team x team → Nothing) --type Ranking = AssocList ClubName Rank --data Rank = Rank { matchpoints ∷ Int -- number of matchpoints (>= 0) -- , goalsScored ∷ Int -- number of scored goals (>= 0) -- , goalsAgainst ∷ Int -- number of goals against (>= 0) -- } --instance zero Rank --instance == Rank --instance < Rank --instance + Rank -- , west ∷ [ClubName] -- names of participating teams (west side) -- , east ∷ [ClubName] -- names of participating teams (east side) -- , usedRandomSeed∷ RandomSeed -- the seed that is used for computing the matches -- } -- --{- competition teams field referee time rs -- computes an entire competition between all teams in teams. -- Each match uses the same referee and same initial random seed value rs. ---} --competition ∷ [Home Field → Team] Field Referee PlayingTime RandomSeed → Competition -- --{- computeMatch match -- computes an entire match between the currently selected team1 and team2. ---} --computeMatch ∷ Match → Score -- --{- ranking competition -- computes the ranking of all teams that have participated in competition. ---} --ranking ∷ Competition → Ranking --ranking ∷ [ClubName] [Maybe Score] → Ranking -- --{- checkCompetitionFile westTeamNames rs env -- checks whether there is a competition backup file present for the current set -- of teams (assuming they start on the West home side) and initial random seed value rs -- for computing matches. -- If not, then such a file is created, and the same random seed value and empty list of scores is returned. -- If so, then the currently stored random seed value and list of scores is returned. ---} --checkCompetitionFile ∷ [ClubName] RandomSeed *env → ((RandomSeed,[Maybe Score]),*env) | FileSystem env -- --{- appendMatchToCompetitionFile west east env -- appends an empty entry of a match between west versus east in the competition backup file. -- It also returns the file pointer to allow a correct update in updateMatchToCompetitionFile. ---} --appendMatchToCompetitionFile∷ ClubName ClubName *env → (Int,*env) | FileSystem env -- -- --{- updateMatchToCompetitionFile west east score filepointer env -- updates the line that starts at filepointer in the competition backup file with the result -- of the match between west versus east. ---} --updateMatchToCompetitionFile∷ ClubName ClubName (Maybe Score) Int *env → *env | FileSystem env -- --import StdEnvExt, fileIO --import guiInterface, matchControl --pmort Parsers (parse, ∷ Parser, ∷ Result(..), ∷ SugPosition, ∷ Rose(..), ∷ RoseNode(..), ∷ SymbolTypes(..), ∷ SymbolType(..), yield, token, symbol, <&>, &>, , , , number, digit) -- -- -- -- -- --instance zero Rank where -- zero = { matchpoints = zero, goalsScored = zero, goalsAgainst = zero } --instance == Rank where -- (==) r1 r2 = (r1.matchpoints,r1.goalsScored,r1.goalsAgainst) == (r2.matchpoints,r2.goalsScored,r2.goalsAgainst) --instance < Rank where -- (<) r1 r2 = r1.matchpoints < r2.matchpoints || -- r1.matchpoints == r2.matchpoints && r1.goalsScored < r2.goalsScored || -- r1.matchpoints == r2.matchpoints && r1.goalsScored == r2.goalsScored && r1.goalsAgainst > r2.goalsAgainst --instance + Rank where -- (+) r1 r2 = { matchpoints = r1.matchpoints + r2.matchpoints -- , goalsScored = r1.goalsScored + r2.goalsScored -- , goalsAgainst = r1.goalsAgainst + r2.goalsAgainst -- } -- --competition ∷ [Home Field → Team] Field Referee PlayingTime RandomSeed → Competition --competition teams field referee playingtime rs -- = { results = [ [ if (nrWest == nrEast) -- Nothing -- (Just (computeMatch (setMatchStart (teamWest West field) (teamEast East field) field referee playingtime rs))) -- | (nrEast,teamEast) <- zip2 [1..] teams -- ] -- | (nrWest,teamWest) <- zip2 [1..] teams -- ] -- , west = map (\f → nameOf (f West field)) teams -- , east = map (\f → nameOf (f East field)) teams -- , usedRandomSeed = rs -- } -- computeMatch ∷ Match → Score computeMatch match | playingTime match > zero = computeMatch (snd (stepMatch match)) | otherwise = score match {- ranking ∷ [ClubName] [Maybe Score] → Ranking ranking names scores = foldl upd [(t,zero) | t <- names] (zip2 [(tw,te) | tw <- names, te <- names] scores) where upd ranking (_,Nothing) = ranking upd ranking ((west,east),Just (goalsWest,goalsEast)) = updkeyvalue west ((+) rankWest) (updkeyvalue east ((+) rankEast) ranking) where (mpsWest, mpsEast) = if (goalsWest > goalsEast) (3,0) (if (goalsWest < goalsEast) (0,3) (1,1)) (rankWest,rankEast) = ({matchpoints=mpsWest,goalsScored=goalsWest,goalsAgainst=goalsEast} ,{matchpoints=mpsEast,goalsScored=goalsEast,goalsAgainst=goalsWest} ) instance show Options where show {closeReferee,showSplash,displaySpeed,showReferee,playingTime} = "{closeReferee=" ++ show closeReferee ++ show ",showSplash=" ++ show showSplash ++ show ",displaySpeed=" ++ show displaySpeed ++ show ",showReferee=" ++ show showReferee ++ show ",playingTime=" ++ show playingTime ++ show "}" instance fromString Options where fromString str = case parse optionsP (fromString str) optionsFile "char" of Succ [opt:_] = opt _ = defaultOptions where optionsP ∷ Parser Char Options Options optionsP = token ['{closeReferee='] &> boolP <&> \closeReferee → token [',showSplash='] &> boolP <&> \showSplash → token [',displaySpeed='] &> displaySpeedP <&> \displaySpeed → token [',showReferee='] &> boolP <&> \showReferee → token [',playingTime='] &> realP <&> \playingTime → symbol '}' &> yield { closeReferee = closeReferee , showSplash = showSplash , displaySpeed = displaySpeed , showReferee = showReferee , playingTime = playingTime } boolP = (token ['True'] &> yield True) (token ['False'] &> yield False) realP = (symbol '-') <&> \minuss → digit <&> \digits1 → (symbol '.') <&> \dots → digit <&> \digits2 → yield (toReal (show (minuss ++ digits1 ++ dots ++ digits2))) displaySpeedP = (token ['Slow'] &> yield Slow) (token ['Target'] &> yield Target) (token ['Normal'] &> yield Normal) (token ['Faster'] &> yield Faster) (token ['Fastest'] &> yield Fastest) instance == Options where (==) o1 o2 = o1.closeReferee == o2.closeReferee && o1.showSplash == o2.showSplash && o1.displaySpeed == o2.displaySpeed && o1.showReferee == o2.showReferee && o1.Options.playingTime == o2.Options.playingTime setOptions ∷ Options *env → *env | FileSystem env setOptions options env = writeFile False optionsFile (show options) env optionsFile = "SoccerFunOptions.txt" checkCompetitionFile ∷ [ClubName] RandomSeed *env → ((RandomSeed,[Maybe Score]),*env) | FileSystem env checkCompetitionFile west rs env # (ok,cf,env) = fopen competitionFile FReadText env | not ok = ((rs,[]), createCompetitionFile west rs env) -- competition file does not exist: create it # (ok,frs,fwest,cf) = header cf | not ok || fwest <> teamsLine west = ((rs,[]), createCompetitionFile west rs (snd (fclose cf env))) -- competition file ill-formatted or different set of teams: create it # (scores,cf) = readScores cf -- competition file exists, and for this competition # (ok,env) = fclose cf env | not ok = abort ("Could not close competition file after reading scores.\n" +++ show (length scores) ) | otherwise = ((frs,scores),env) where readScores ∷ *File → ([Maybe Score],*File) readScores cf # (end,cf) = fend cf | end = ([],cf) # (line,cf) = freadline cf # score = if (line.[0] == 'x') Nothing (let (i1,l1) = span ((<>) ' ') [c | c<-:line] (i2,l2) = span ((<>) ' ') (tl l1) in Just (toInt (show i1),toInt (show i2)) ) # (scores,cf) = readScores cf = ([score:scores],cf) appendMatchToCompetitionFile∷ ClubName ClubName *env → (Int,*env) | FileSystem env appendMatchToCompetitionFile west east env # (ok,cf,env) = fopen competitionFile FAppendText env | not ok = abort "Could not open competition file for appending data.\n" # (pos,cf) = fposition cf # (ok,env) = fclose (cf <<< "x " <<< west <<< " vs " <<< east <<< '\n') env | not ok = abort "Could not close competition file after appending data.\n" | otherwise = (pos,env) updateMatchToCompetitionFile∷ ClubName ClubName (Maybe Score) Int *env → *env | FileSystem env updateMatchToCompetitionFile west east score pos env # (ok,cf,env) = fopen competitionFile FAppendText env | not ok = abort "Could not open competition file for appending data.\n" # (ok,cf) = fseek cf pos FSeekSet | not ok = abort "Could not seek in competition file for updating data.\n" # (ok,env) = fclose (cf <<< result <<< ' ' <<< west <<< " vs " <<< east <<< '\n') env | not ok = abort "Could not close competition file after appending data.\n" | otherwise = env where result = case score of Nothing = "x" Just (gw,ge) = gw +++> (" " ++ show ge) createCompetitionFile ∷ [ClubName] RandomSeed *env → *env | FileSystem env createCompetitionFile west rs env # (ok,cf,env) = fopen competitionFile FWriteText env | not ok = abort "Could not create competition file.\n" # (ok,env) = fclose (cf <<< seedLine rs <<< '\n' <<< teamsLine west <<< '\n') env | not ok = abort "Could not close competition file.\n" | otherwise = env header ∷ *File → (Bool,RandomSeed,String,*File) header file # (rsLine, file) = freadline file # (teamsLine,file) = freadline file = (size rsLine > 1 && size teamsLine > 1, fromString (rsLine%(0,size rsLine-2)), teamsLine%(0,size teamsLine-2),file) seedLine ∷ RandomSeed → String seedLine rs = show rs teamsLine ∷ [ClubName] → String teamsLine west = foldl (\t ts → t +++ "," +++ ts) "" west competitionFile = "competition.txt" ------------------------------------------------------------------------------ -}