Sync by event timestamps (closes #53)

src/F24.hs

@@ -7,7 +7,9 @@ import qualified Data.ByteString as BS
 import Text.XML.Light.Types (Element)
 import Text.Printf (printf)
 import Control.Monad (liftM)
-import Data.DateTime
+import Data.Time
+import Data.Time.LocalTime
+import Data.Time.Clock (nominalDiffTimeToSeconds)
 import Data.Maybe
 import XmlUtils (attrLookupStrict, attrLookup, hasAttributeWithValue)
 import qualified XmlUtils as Xml
@@ -18,12 +20,12 @@ data Game coordinates = Game {
  away_team_name :: String,
  competition_id :: Int,
  competition_name :: String,
- game_date :: DateTime,
+ game_date :: LocalTime,
  home_team_id :: Int,
  home_team_name :: String,
  matchday :: Int,
- period_1_start :: DateTime,
- period_2_start :: DateTime,
+ period_1_start :: LocalTime,
+ period_2_start :: LocalTime,
  season_id :: Int,
  season_name :: String,
  events :: [Event coordinates]
@@ -49,8 +51,8 @@ data Event coordinates = Event {
  team_id :: Int,
  outcome :: Maybe Int,
  coordinates :: Maybe coordinates,
- timestamp :: DateTime,
- last_modified :: DateTime,
+ timestamp :: LocalTime,
+ last_modified :: LocalTime,
  qs :: [Q]
 }
 
@@ -74,6 +76,20 @@ qval i e = let qq = filter (hasQid i) (qs e)
 hasQid :: Int -> Q -> Bool
 hasQid i q = qualifier_id q == i
 
+-- The amount of seconds played until the event, treating all completed
+-- game periods as having lasted exactly 45 minutes.
+-- The first argument controls whether event timestamp should be used.
+eventClock :: Bool -> Game cs -> Event cs -> Double
+eventClock False _ ee = fromIntegral (60 * min ee + sec ee)
+eventClock True gg ee = nominalOffset + actualSincePeriodStart where
+ half = period_id ee
+ nominalOffset = fromIntegral (60 * 45 * (half - 1))
+ eventTimestamp = timestamp ee
+ periodStart = if half == 1 then period_1_start gg else period_2_start gg
+ actualSincePeriodStart = convert (diffLocalTime eventTimestamp periodStart)
+ convert = read . show . nominalDiffTimeToSeconds
+
+
 data Q = Q {
  qid :: Int,
  qualifier_id :: Int,
@@ -97,6 +113,14 @@ data F24Coordinates = F24Coordinates {
  yPercentage :: Float
 }
 
+-- Parse date-times such as 2018-09-15T14:56:30.
+parseDatetime :: String -> Maybe LocalTime
+parseDatetime = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S"
+
+-- Parse timestamps such 2018-09-15T14:19:24.588.
+parseTimestamp :: String -> Maybe LocalTime
+parseTimestamp = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q"
+
 loadGameFromFile :: String -> IO (Game F24Coordinates)
 loadGameFromFile filepath = do
  root <- Xml.loadXmlFromFile filepath
@@ -122,8 +146,8 @@ makeEvent el =
  team_id = attrLookupStrict el read "team_id",
  outcome = attrLookup el read "outcome",
  coordinates = coordinates,
- timestamp = attrLookupStrict el read "timestamp",
- last_modified = attrLookupStrict el read "last_modified",
+ timestamp = attrLookupStrict el (fromJust . parseTimestamp) "timestamp",
+ last_modified = attrLookupStrict el (fromJust . parseDatetime) "last_modified",
  qs = map makeQ $ Xml.getChildrenWithQName "Q" el
  }
  where
@@ -138,12 +162,12 @@ makeGame el = Game { gid = attrLookupStrict el read "id",
  away_team_name = attrLookupStrict el id "away_team_name",
  competition_id = attrLookupStrict el read "competition_id",
  competition_name = attrLookupStrict el id "competition_name",
- game_date = attrLookupStrict el read "game_date",
+ game_date = attrLookupStrict el (fromJust . parseDatetime) "game_date",
  home_team_id = attrLookupStrict el read "home_team_id",
  home_team_name = attrLookupStrict el id "home_team_name",
  matchday = attrLookupStrict el read "matchday",
- period_1_start = attrLookupStrict el read "period_1_start",
- period_2_start = attrLookupStrict el read "period_2_start",
+ period_1_start = attrLookupStrict el (fromJust . parseDatetime) "period_1_start",
+ period_2_start = attrLookupStrict el (fromJust . parseDatetime) "period_2_start",
  season_id = attrLookupStrict el read "season_id",
  season_name = attrLookupStrict el id "season_name",
  events = map makeEvent $ Xml.getChildrenWithQName "Event" el

src/Scoring.hs

@@ -33,9 +33,9 @@ euclideanDistance object target =
 -- The first argument controls how stringent the function is and should be positive.
 type ScoringFunction = Double -> F24.Event Tcb.Coordinates -> Tcb.Frame Tcb.Positions -> Double
 
-clockScore :: ScoringFunction
-clockScore scale e f =
- let seconds = fromIntegral $ 60 * F24.min e + F24.sec e
+clockScore :: Bool -> F24.Game Tcb.Coordinates -> ScoringFunction
+clockScore useTimestamp game scale e f =
+ let seconds = F24.eventClock useTimestamp game e
  dist = abs $ seconds - fromMaybe seconds (Tcb.clock f)
  in logDensity Gaussian.standard (dist / scale)
 

src/SyncMain.hs

@@ -16,6 +16,7 @@ data Options = Options {
  f24File :: String,
  outputFile :: String,
  timeOnly :: Bool,
+ timestamp :: Bool,
  showsync :: Bool,
  cScale :: Double,
  lScale :: Double,
@@ -33,6 +34,7 @@ options = Options
  <*> argument str (metavar "F24")
  <*> argument str (metavar "OUTPUT")
  <*> switch (long "time-only" <> short 't' <> help "Sync only by time")
+ <*> switch (long "timestamp" <> short 'u' <> help "Use F24 event timestamp instead of min:sec")
  <*> switch (long "show-sync" <> short 's' <> help "Print human-readable sync on screen")
  <*> option auto (long "scale-clock" <> short 'c' <> value 1 <> metavar "X" <> help "Clock difference resulting in unit penalty [s, default 1]")
  <*> option auto (long "scale-location" <> short 'l' <> value 5 <> metavar "X" <> help "Location difference resulting in unit penalty [m, default 5]")
@@ -77,7 +79,7 @@ main = do
  -- Build the scoring function as requested by the user.
  -- FIXME: Combine functions without mentioning arguments.
  let to = timeOnly opts
- let scoreClock = Scoring.clockScore (cScale opts)
+ let scoreClock = Scoring.clockScore (timestamp opts) f24Data (cScale opts)
  let scoreLocation e f = if to then 0 else Scoring.locationScore (100 * lScale opts) e f
  let scorePlayer e f = if to then 0 else Scoring.playerScore (F24.shirtNumbers f24Meta) (100 * pScale opts) e f
  let scoreBall e f = if to then 0 else Scoring.ballStatusScore (bScale opts) e f

src/XmlUtils.hs

@@ -14,7 +14,6 @@ import Text.XML.Light.Types
  )
 import Control.Exception
 import Control.Monad (liftM)
-import Data.DateTime
 import Data.Maybe (fromMaybe)
 import Data.Typeable
 

stack.yaml

@@ -18,7 +18,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-12.16
+resolver: lts-16.4
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -38,7 +38,6 @@ packages:
 # Dependency packages to be pulled from upstream that are not in the resolver
 # using the same syntax as the packages field.
 # (e.g., acme-missiles-0.3)
-extra-deps: ["datetime-0.3.1"]
 
 # Override default flag values for local packages and extra-deps
 # flags: {}

sync-soccer.cabal

@@ -24,11 +24,12 @@ executable sync-soccer
 -- ld-options: -static
  build-depends:
  base >= 4.7 && < 5
- , datetime
  , containers
  , split
  , xml
  , bytestring
  , array
  , statistics
- , optparse-applicative
+ , optparse-applicative
+ , time >= 1.9.3
+