From ffc0a842ae29db53dd92e276c089a6d5914c6456 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 9 May 2024 01:25:16 +0200
Subject: 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.
---
 lib/Server/Frontend/Routes.hs    |   2 +
 lib/Server/Frontend/SpaceTime.hs | 104 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 106 insertions(+)
 create mode 100644 lib/Server/Frontend/SpaceTime.hs

(limited to 'lib/Server/Frontend')

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 _ _
-- 
cgit v1.2.3