reasonable delay forecasts

1 files changed, 20 insertions, 10 deletions

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