rough initial work on space-time diagrams

this does svg templating with hamlet. It might be better to use a
javascript library instead (templating svgs is a little confusing tbh),
but for now i'll see how far i get with this.

6 files changed, 110 insertions, 0 deletions

diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs
index 8d744db..3beb9e0 100644
--- a/lib/Server/Frontend.hs
+++ b/lib/Server/Frontend.hs
@@ -6,6 +6,7 @@ import           Server.Frontend.Gtfs
 import           Server.Frontend.OnboardUnit
 import           Server.Frontend.Routes
 import           Server.Frontend.Tickets
+import           Server.Frontend.SpaceTime
 
 import           Yesod
 import           Yesod.Auth
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
index 2d74338..8dceda5 100644
--- a/lib/Server/Frontend/Routes.hs
+++ b/lib/Server/Frontend/Routes.hs
@@ -45,6 +45,8 @@ mkYesodData "Frontend" [parseRoutes|
 /ticket/announce/#UUID AnnounceR POST
 /ticket/del-announce/#UUID DelAnnounceR GET
 
+/spacetime SpaceTimeDiagramR GET
+
 /token/block/#Token TokenBlock GET
 
 /gtfs/trips GtfsTripsViewR GET
diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs
new file mode 100644
index 0000000..307e795
--- /dev/null
+++ b/lib/Server/Frontend/SpaceTime.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.SpaceTime (getSpaceTimeDiagramR) where
+
+import Server.Frontend.Routes
+
+import           Data.Functor           ((<&>))
+import qualified Data.Map               as M
+import           Data.Text              (Text)
+import qualified Data.Vector            as V
+import qualified GTFS
+import           Text.Blaze.Html        (Html)
+import qualified Data.Text as T
+import           Yesod
+import Text.Read (readMaybe)
+import Data.Time (getCurrentTime, UTCTime (..))
+import Persist
+import Data.Function ((&), on)
+import Data.List
+import Data.Coerce (coerce)
+import Control.Monad (when, forM)
+import GHC.Float (int2Double)
+import Fmt ((|+), (+|))
+import Data.Maybe (catMaybes, mapMaybe)
+import GTFS (Seconds(unSeconds))
+
+getSpaceTimeDiagramR :: Handler Html
+getSpaceTimeDiagramR = do
+
+  req <- getRequest
+
+  day <- case lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) of
+    Just day -> pure  day
+    Nothing  -> liftIO $ getCurrentTime <&> utctDay
+
+  tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do
+    stops <- selectList [StopTicket ==. entityKey ticket] []
+    pure (ticket, stops))
+
+
+  -- TODO: this should be a nicer error message
+  when (null tickets)
+    notFound
+
+  -- we take the longest trip of the day. This will lead to unreasonable results
+  -- if there's more than one shape (this whole route should probably take a shape id tbh)
+  stations <- runDB $ fmap snd tickets
+        & maximumBy (compare `on` length)
+        & fmap entityVal
+        & sortOn stopSequence
+        & mapM (\stop -> do
+              s <- getJust (stopStation stop)
+              pure (stopStation stop, s, stop))
+
+  let maxSequence = stopSequence ((\(_,_,stop) -> stop) (last stations))
+  let scaleSequence a = int2Double a * 100 / int2Double maxSequence
+
+  let (minY, maxY) = tickets
+       <&> snd
+       & concat
+       <&> (timeToPos . stopDeparture . entityVal)
+       & (\ys -> (minimum ys - 20, maximum ys + 20))
+
+  defaultLayout $ do
+    [whamlet|
+       <h1>_{MsgSpaceTimeDiagram}
+
+       <section><svg viewBox="-2 #{minY} 106 #{maxY - minY}" width="100%">
+         $forall (_, station, Stop{..}) <- stations
+           <path
+             style="fill:none;stroke:#79797a;stroke-width:0.3"
+             d="M #{scaleSequence stopSequence},#{minY} #{scaleSequence stopSequence},#{maxY}"
+             >
+           <text style="font-size:2pt;" transform="rotate(90)">
+             <tspan
+               x="#{minY + 3}"
+               y="#{0 - (scaleSequence stopSequence + 0.5)}"
+               >#{stationName station}
+         $forall (ticket, stops) <- tickets
+           <path
+             style="fill:none;stroke:blueviolet;stroke-width:0.3"
+             d="M #{mkStopsline scaleSequence stations stops}"
+             >
+
+    |]
+
+mkStopsline :: (Int -> Double) -> [(StationId, Station, Stop)] -> [Entity Stop] -> Text
+mkStopsline scaleSequence stations stops = stops
+  <&> (mkStop . entityVal)
+  & T.concat
+  where mkStop stop = " "+|scaleSequence s|+","+|timeToPos (stopArrival stop)|+" "
+                             +|scaleSequence s|+","+|timeToPos (stopDeparture stop)|+""
+          where s = mapMaybe
+                  (\(stationId, _, res) ->
+                      if stationId == stopStation stop then Just res else Nothing) stations
+                  & head
+                  & stopSequence
+
+-- TODO: ignores time zones!
+timeToPos = (\a -> a / 500) . int2Double . GTFS.timeSeconds
+-- timeToPos time = unSeconds $ GTFS.toSeconds time _ _
diff --git a/messages/de.msg b/messages/de.msg
index 53e5ede..9fa87e7 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -40,6 +40,7 @@ ImportTrips: Fahrten importieren
 Tickets: Tickets
 delete: löschen
 AccordingToGtfs: Weitere Fahrten im GTFS
+SpaceTimeDiagram: Weg-Zeit
 
 OBU: Onboard-Unit
 ChooseTrain: Fahrt auswählen
diff --git a/messages/en.msg b/messages/en.msg
index a2ef189..61e8879 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -41,6 +41,7 @@ ImportTrips: import selected trips
 delete: delete
 AccordingToGtfs: Additional Trips contained in the Gtfs
 StartTracking: Start Tracking
+SpaceTimeDiagram: Space-Time Diagram
 
 OBU: Onboard-Unit
 ChooseTrain: Choose a Train
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 542f986..074863e 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -119,6 +119,7 @@ library
                  , Server.Frontend.Tickets
                  , Server.Frontend.OnboardUnit
                  , Server.Frontend.Gtfs
+                 , Server.Frontend.SpaceTime
     default-language: GHC2021
     default-extensions: OverloadedStrings
                       , ScopedTypeVariables