From baa7430e3bb19d25f2264571c990f850e67bd969 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 31 Aug 2022 23:15:34 +0200
Subject: guess at future delays (horrible, incorrect, and unfinished)

---
 lib/Server/ControlRoom.hs | 16 +++++++++++++++-
 1 file changed, 15 insertions(+), 1 deletion(-)

(limited to 'lib/Server')

diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 164d8ff..721d7df 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -28,7 +28,7 @@ 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)
@@ -48,9 +48,12 @@ import           Text.Read                (readMaybe)
 import           Text.Shakespeare.Text
 import           Yesod
 import           Yesod.Form
+import Data.List.NonEmpty (nonEmpty)
 
 import           GTFS
 import           Persist
+import Extrapolation (Extrapolator(..), LinearExtrapolator)
+import Control.Monad (join)
 
 
 data ControlRoom = ControlRoom
@@ -169,6 +172,8 @@ getTrainViewR trip day = do
       anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
       tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] []
       lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp]
+      anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] []
+        <&> nonEmpty . (fmap entityVal)
       defaultLayout $ do
         mr <- getMessageRender
         setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))
@@ -188,6 +193,9 @@ getTrainViewR trip day = do
   <ol>
     $forall Stop{..} <- tripStops
       <li> #{stopArrival} #{stationName stopStation}
+        $maybe history <- anchors
+          $maybe delay <- guessDelay history (toSeconds stopArrival tzseries day)
+            \ (#{delay})
 <section>
   <h2>_{MsgAnnouncements}
   <ul>
@@ -215,6 +223,7 @@ getTrainViewR trip day = do
         $else
           <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
 |]
+          where guessDelay history = join . fmap trainAnchorDelay . extrapolateAtSeconds @LinearExtrapolator history
 
 
 getTripsViewR :: Handler Html
@@ -323,3 +332,8 @@ instance ToMarkup Token where
 
 instance ToMessage Double where
   toMessage = T.pack . show
+
+instance ToMarkup Seconds where
+  toMarkup (Seconds s) =
+    if s > 0 then toMarkup ("+"+|s `div` 60|+"" :: Text)
+    else toMarkup (s `div` 60)
-- 
cgit v1.2.3