aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2024-05-09 01:25:16 +0200
committerstuebinm2024-05-09 01:31:29 +0200
commitffc0a842ae29db53dd92e276c089a6d5914c6456 (patch)
tree56a882aec39be4babf2467f41c2e0d8e61e3919d
parentdc519ae889ab40fe1723cd601c3e79b73bdd2f51 (diff)
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.
Diffstat (limited to '')
-rw-r--r--lib/Server/Frontend.hs1
-rw-r--r--lib/Server/Frontend/Routes.hs2
-rw-r--r--lib/Server/Frontend/SpaceTime.hs104
-rw-r--r--messages/de.msg1
-rw-r--r--messages/en.msg1
-rw-r--r--tracktrain.cabal1
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