reasonable delay forecasts

6 files changed, 100 insertions, 66 deletions

diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs
index 6313a8e..770d4ce 100644
--- a/lib/Extrapolation.hs
+++ b/lib/Extrapolation.hs
@@ -1,25 +1,32 @@
-{-# LANGUAGE AllowAmbiguousTypes     #-}
-{-# LANGUAGE ConstrainedClassMethods #-}
-{-# LANGUAGE ConstraintKinds         #-}
-{-# LANGUAGE DataKinds               #-}
-{-# LANGUAGE RecordWildCards         #-}
+{-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE ConstrainedClassMethods    #-}
+{-# LANGUAGE ConstraintKinds            #-}
+{-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE RecordWildCards            #-}
 
-module Extrapolation (Extrapolator(..), LinearExtrapolator, linearDelay) where
-import           Data.Foldable (maximumBy, minimumBy)
-import           Data.Function (on)
-import qualified Data.Map      as M
-import           Data.Time     (Day, UTCTime (UTCTime, utctDay), diffUTCTime,
-                                nominalDiffTimeToSeconds)
-import qualified Data.Vector   as V
-import           GHC.Float     (int2Double)
-import           GHC.IO        (unsafePerformIO)
-import Data.List.NonEmpty (NonEmpty)
+module Extrapolation (Extrapolator(..), LinearExtrapolator, linearDelay, secondsNow) where
+import           Data.Foldable      (maximumBy, minimumBy)
+import           Data.Function      (on)
+import           Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NE
+import qualified Data.Map           as M
+import           Data.Time          (Day, UTCTime (UTCTime, utctDay),
+                                     diffUTCTime, getCurrentTime,
+                                     nominalDiffTimeToSeconds)
+import qualified Data.Vector        as V
+import           GHC.Float          (int2Double)
+import           GHC.IO             (unsafePerformIO)
 
-import           Persist       (Running (..), TrainAnchor (..), TrainPing (..))
-import           GTFS          (Depth (Deep), GTFS (..), Shape (..), Stop (..),
-                                Time, Trip (..), stationGeopos, toSeconds, Seconds(..), seconds2Double)
+import           Conduit            (MonadIO (liftIO))
+import           Data.List          (sortBy)
+import           GTFS               (Depth (Deep), GTFS (..), Seconds (..),
+                                     Shape (..), Stop (..), Time, Trip (..),
+                                     seconds2Double, stationGeopos, toSeconds)
+import           Persist            (Running (..), TrainAnchor (..),
+                                     TrainPing (..))
 
 class Extrapolator a where
   -- | here's a position ping, guess things from that!
@@ -40,30 +47,35 @@ instance Extrapolator LinearExtrapolator where
     $ NE.nonEmpty $ NE.filter (\a -> trainAnchorWhen a < secondsNow) history
     where difference status = secondsNow - (trainAnchorWhen status)
 
-  extrapolateAtPosition = error "todo!"
+  -- note that this sorts (descending) for time first as a tie-breaker
+  -- (in case the train just stands still for a while, take the most recent update)
+  extrapolateAtPosition history positionNow =
+    fmap (minimumBy (compare `on` difference))
+    $ NE.nonEmpty $ sortBy (flippedCompare `on` trainAnchorWhen)
+    $ NE.filter (\a -> trainAnchorSequence a < positionNow) history
+    where difference status = positionNow - (trainAnchorSequence status)
+          flippedCompare a b = case compare a b of
+            LT -> GT
+            GT -> LT
+            a  -> a
 
   extrapolateAnchorFromPing gtfs@GTFS{..} Running{..} ping@TrainPing{..} = TrainAnchor
     { trainAnchorCreated = trainPingTimestamp
     , trainAnchorTrip = runningTrip
     , trainAnchorDay = runningDay
     , trainAnchorWhen = utcToSeconds trainPingTimestamp runningDay
-    -- either do this ^ as a "time when the train *should* be here" or
-    -- replace it with a trainAnchorWhere; this isn't very useful to get
-    -- delays at stations
-    , trainAnchorDelay = Just (linearDelay gtfs trip ping runningDay)
+    , trainAnchorSequence
+    , trainAnchorDelay
     , trainAnchorMsg = Nothing
     }
     where Just trip = M.lookup runningTrip trips
+          (trainAnchorDelay, trainAnchorSequence) = linearDelay gtfs trip ping runningDay
 
-linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> Seconds
+linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> (Seconds, Double)
 linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $ do
-  -- print (nextStop, lastStop)
-  -- print expectedTravelTime
-  -- -- print (((utcToSeconds trainPingTimestamp runningDay),  toSeconds (stopDeparture lastStop)))
-  -- print (observedProgress, expectedProgress)
-
-  -- these convoluted conversions necessary to get rounding in the right place
-  pure $ Seconds $ round $ (expectedProgress - observedProgress) * int2Double (unSeconds expectedTravelTime)
+  print (scheduledPosition, round $ (expectedProgress - observedProgress) * int2Double (unSeconds expectedTravelTime))
+  pure $ (Seconds $ round $ (expectedProgress - observedProgress) * int2Double (unSeconds expectedTravelTime)
+         , scheduledPosition)
   where closestPoint =
             minimumBy (compare `on` euclid (trainPingLat, trainPingLong)) line
         nextStop = snd $
@@ -78,17 +90,19 @@ linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $
         expectedTravelTime =
             toSeconds (stopArrival nextStop) tzseries runningDay
             - toSeconds (stopDeparture lastStop) tzseries runningDay
-        expectedProgress =
+        expectedProgress = crop $
             seconds2Double (utcToSeconds trainPingTimestamp runningDay
                          - toSeconds (stopDeparture lastStop) tzseries runningDay)
             / seconds2Double expectedTravelTime
-            -- where crop a
-            --         | a < 0 = 0
-            --         | a > 1 = 1
-            --         | otherwise = a
+            where crop a
+                    | a < 0 = 0
+                    | a > 1 = 1
+                    | otherwise = a
         observedProgress =
             distanceAlongLine line (stationGeopos $ stopStation lastStop) closestPoint
             / distanceAlongLine line (stationGeopos $ stopStation lastStop) (stationGeopos $ stopStation nextStop)
+        scheduledPosition =
+          (int2Double $ stopSequence lastStop) + observedProgress * (int2Double $ stopSequence nextStop - stopSequence lastStop)
 
 distanceAlongLine :: V.Vector (Double, Double) -> (Double, Double) -> (Double, Double) -> Double
 distanceAlongLine line p1 p2 = along2 - along1
@@ -106,6 +120,11 @@ utcToSeconds :: UTCTime -> Day -> Seconds
 utcToSeconds time day =
   Seconds $ round $ nominalDiffTimeToSeconds $ diffUTCTime time (UTCTime day 0)
 
+secondsNow :: MonadIO m => Day -> m Seconds
+secondsNow runningDay = do
+  now <- liftIO getCurrentTime
+  pure $ utcToSeconds now runningDay
+
 euclid :: Fractional f => (f,f) -> (f,f) -> f
 euclid (x1,y1) (x2,y2) = x*x + y*y
   where x = x1 - x2
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index f5c2018..4e2a7dc 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -1,19 +1,19 @@
-{-# LANGUAGE DataKinds                #-}
-{-# LANGUAGE DeriveAnyClass           #-}
-{-# LANGUAGE DeriveGeneric            #-}
-{-# LANGUAGE DerivingStrategies       #-}
-{-# LANGUAGE FlexibleContexts         #-}
-{-# LANGUAGE FlexibleInstances        #-}
-{-# LANGUAGE LambdaCase               #-}
-{-# LANGUAGE NamedFieldPuns           #-}
-{-# LANGUAGE RecordWildCards          #-}
-{-# LANGUAGE StandaloneDeriving       #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TupleSections            #-}
-{-# LANGUAGE TypeApplications         #-}
-{-# LANGUAGE TypeFamilies             #-}
-{-# LANGUAGE UndecidableInstances     #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE StandaloneKindSignatures   #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
 
 -- | All kinds of stuff that has to deal with GTFS directly
 -- (i.e. parsing, querying, Aeson instances, etc.)
@@ -37,8 +37,8 @@ import           Data.Kind                           (Type)
 import           Data.Maybe                          (fromJust, fromMaybe)
 import           Data.Text                           (Text)
 import           Data.Time                           (TimeZone (timeZoneMinutes),
-                                                      UTCTime (..),
-                                                      dayOfWeek, getCurrentTime)
+                                                      UTCTime (..), dayOfWeek,
+                                                      getCurrentTime)
 import           Data.Time.Calendar                  (Day, DayOfWeek (..))
 import           Data.Time.Calendar.MonthDay         (monthAndDayToDayOfYearValid)
 import qualified Data.Time.Calendar.OrdinalDate      as Day
@@ -71,7 +71,7 @@ import qualified Data.Text                           as T
 import           Data.Time.LocalTime.TimeZone.Olson  (getTimeZoneSeriesFromOlsonFile)
 import           Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries,
                                                       timeZoneFromSeries)
-import GHC.Float (int2Double)
+import           GHC.Float                           (int2Double)
 
 
 -- | for some reason this doesn't exist already in cassava
diff --git a/lib/Persist.hs b/lib/Persist.hs
index 371ddd0..aa040cf 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -45,9 +45,9 @@ import           Data.Time                   (NominalDiffTime, TimeOfDay,
 import           Data.Time.Calendar          (Day, DayOfWeek (..))
 import           Data.Vector                 (Vector)
 import           Database.Persist.Postgresql (SqlBackend)
+import           Fmt
 import           GHC.Generics                (Generic)
 import           Web.PathPieces              (PathPiece)
-import Fmt
 
 
 newtype Token = Token UUID
@@ -96,7 +96,8 @@ TrainAnchor json sql=tt_trip_anchor
   day Day
   created UTCTime
   when Seconds
-  delay Seconds Maybe
+  sequence Double
+  delay Seconds
   msg Text Maybe
   deriving Show Generic Eq ToSchema
 
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 721d7df..9b61828 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -17,18 +17,20 @@
 
 module Server.ControlRoom (ControlRoom(..)) where
 
-import           Control.Monad            (forM_)
+import           Control.Monad            (forM_, join)
 import           Control.Monad.Extra      (maybeM)
 import           Control.Monad.IO.Class   (MonadIO (liftIO))
 import qualified Data.ByteString.Char8    as C8
 import           Data.Functor             ((<&>))
 import           Data.List                (lookup)
+import           Data.List.NonEmpty       (nonEmpty)
 import           Data.Map                 (Map)
 import qualified Data.Map                 as M
 import           Data.Pool                (Pool)
 import           Data.Text                (Text)
 import qualified Data.Text                as T
-import           Data.Time                (UTCTime(..), getCurrentTime, utctDay)
+import           Data.Time                (UTCTime (..), getCurrentTime,
+                                           utctDay)
 import           Data.Time.Calendar       (Day)
 import           Data.Time.Format.ISO8601 (iso8601Show)
 import           Data.UUID                (UUID)
@@ -39,6 +41,7 @@ import           Database.Persist         (Entity (..), delete, entityVal, get,
 import           Database.Persist.Sql     (PersistFieldSql, SqlBackend,
                                            runSqlPool)
 import           Fmt                      ((+|), (|+))
+import           GHC.Float                (int2Double)
 import           GHC.Generics             (Generic)
 import           Server.Util              (Service)
 import           Text.Blaze.Html          (ToMarkup (..))
@@ -48,12 +51,12 @@ import           Text.Read                (readMaybe)
 import           Text.Shakespeare.Text
 import           Yesod
 import           Yesod.Form
-import Data.List.NonEmpty (nonEmpty)
 
+import           Extrapolation            (Extrapolator (..),
+                                           LinearExtrapolator, secondsNow)
 import           GTFS
+import           Numeric                  (showFFloat)
 import           Persist
-import Extrapolation (Extrapolator(..), LinearExtrapolator)
-import Control.Monad (join)
 
 
 data ControlRoom = ControlRoom
@@ -170,10 +173,11 @@ getTrainViewR trip day = do
     Nothing -> notFound
     Just res@Trip{..} -> do
       anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
-      tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] []
+      tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires]
       lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp]
       anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] []
         <&> nonEmpty . (fmap entityVal)
+      nowSeconds <- secondsNow day
       defaultLayout $ do
         mr <- getMessageRender
         setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))
@@ -187,14 +191,19 @@ getTrainViewR trip day = do
       (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>)
     $nothing
       <em>(_{MsgNoTrainPing})
-  <p><strong>Estimated Delay</strong>: Todo!
+  <p><strong>_{MsgEstimatedDelay}</strong>:
+    $maybe history <- anchors
+      $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds
+        \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
+    $nothing
+      <em> (_{MsgNone})
 <section>
   <h2>_{MsgStops}
   <ol>
     $forall Stop{..} <- tripStops
-      <li> #{stopArrival} #{stationName stopStation}
+      <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation}
         $maybe history <- anchors
-          $maybe delay <- guessDelay history (toSeconds stopArrival tzseries day)
+          $maybe delay <- guessDelay history (int2Double stopSequence)
             \ (#{delay})
 <section>
   <h2>_{MsgAnnouncements}
@@ -223,7 +232,8 @@ getTrainViewR trip day = do
         $else
           <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
 |]
-          where guessDelay history = join . fmap trainAnchorDelay . extrapolateAtSeconds @LinearExtrapolator history
+          where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition @LinearExtrapolator history
+                guessAtSeconds = extrapolateAtSeconds @LinearExtrapolator
 
 
 getTripsViewR :: Handler Html
diff --git a/messages/de.msg b/messages/de.msg
index 26f67ee..213337d 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -17,3 +17,5 @@ LastPing: Letzte Meldung
 TrainPing lat long time: #{lat},#{long}, um #{time}
 NoTrainPing: keine empfangen
 raw: roh
+EstimatedDelay: Geschätzte Verspätung
+OnStationSequence idx: an Stationsindex #{idx}
diff --git a/messages/en.msg b/messages/en.msg
index cc953ac..47bb66d 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -22,3 +22,5 @@ LastPing: Last Ping
 TrainPing lat@Double long@Double time@UTCTime: #{lat},#{long}, at #{time}
 NoTrainPing: none received
 raw: raw
+EstimatedDelay: Estimated Delay
+OnStationSequence idx@String: on station index #{idx}