aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2024-05-10 17:13:53 +0200
committerstuebinm2024-05-10 17:17:12 +0200
commit1e04f049b101d8250b8964dd0b465e703d03a4c2 (patch)
tree11abd8f8f6460b7af0d0b8648c2aaaf8a46a4eb6
parentffc0a842ae29db53dd92e276c089a6d5914c6456 (diff)
space time diagrams: real time & time zones
-rw-r--r--CHANGELOG.md1
-rw-r--r--lib/Server/Frontend.hs2
-rw-r--r--lib/Server/Frontend/SpaceTime.hs197
-rw-r--r--lib/Server/Frontend/Tickets.hs65
4 files changed, 179 insertions, 86 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 85a3dcb..68dc1d2 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -8,6 +8,7 @@
* Restructure: the backend server is no responsible for keeping track of which
trip on OBU is on, further minimising the required onboard-side logic
* Logs can now be sent as push notifications via ntfy-sh
+* added Space-Time diagrams. These will not work correctly if stops are in different time zones
## 0.0.1.0 -- ~ 2022-11-01
diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs
index 3beb9e0..cec4fa7 100644
--- a/lib/Server/Frontend.hs
+++ b/lib/Server/Frontend.hs
@@ -5,8 +5,8 @@ module Server.Frontend (Frontend(..), Handler) where
import Server.Frontend.Gtfs
import Server.Frontend.OnboardUnit
import Server.Frontend.Routes
-import Server.Frontend.Tickets
import Server.Frontend.SpaceTime
+import Server.Frontend.Tickets
import Yesod
import Yesod.Auth
diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs
index 307e795..878a627 100644
--- a/lib/Server/Frontend/SpaceTime.hs
+++ b/lib/Server/Frontend/SpaceTime.hs
@@ -1,104 +1,189 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
-module Server.Frontend.SpaceTime (getSpaceTimeDiagramR) where
+module Server.Frontend.SpaceTime (getSpaceTimeDiagramR, mkSpaceTimeDiagram, mkSpaceTimeDiagramHandler) where
-import Server.Frontend.Routes
+import Server.Frontend.Routes
+import Control.Monad (forM, when)
+import Data.Coerce (coerce)
+import Data.Function (on, (&))
import Data.Functor ((<&>))
+import Data.Graph (path)
+import Data.List
import qualified Data.Map as M
+import Data.Maybe (catMaybes, mapMaybe)
import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (Day, UTCTime (..), getCurrentTime)
import qualified Data.Vector as V
+import Debug.Trace (trace)
+import Fmt ((+|), (|+))
+import GHC.Float (double2Int, int2Double)
+import GTFS (Seconds (unSeconds))
import qualified GTFS
+import Persist
+import Server.Util (getTzseries)
import Text.Blaze.Html (Html)
-import qualified Data.Text as T
+import Text.Read (readMaybe)
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
+ 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
+ mkSpaceTimeDiagramHandler day >>= \case
+ Nothing -> notFound
+ Just widget -> defaultLayout [whamlet|
+ <h1>_{MsgSpaceTimeDiagram}
+ <section>
+ ^{widget}
+ |]
+mkSpaceTimeDiagramHandler :: Day -> Handler (Maybe Widget)
+mkSpaceTimeDiagramHandler day = do
+ tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do
+ stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do
+ arrival <- lift $ timeToPos day stopArrival
+ departure <- lift $ timeToPos day stopDeparture
+ pure (stop, arrival, departure))
+ anchors <- selectList [TrainAnchorTicket ==. entityKey ticket] [Desc TrainAnchorSequence]
+ pure (ticket, stops, anchors))
+
+ case tickets of
+ [] ->
+ pure Nothing
+ _ ->
+ mkSpaceTimeDiagram day tickets
+ <&> Just
+
+-- | Safety: tickets may not be empty
+mkSpaceTimeDiagram
+ :: Day
+ -> [(a, [(Stop, Double, Double)], [Entity TrainAnchor])]
+ -> Handler Widget
+mkSpaceTimeDiagram day tickets = do
-- 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))
+ stations <- runDB $ fmap (\(_,stops,_) -> stops) tickets
+ & maximumBy (compare `on` length)
+ & fmap (\(stop, _, _) -> stop)
+ & sortOn stopSequence
+ & zip [0..]
+ & mapM (\(idx, stop) -> do
+ s <- getJust (stopStation stop)
+ pure (stopStation stop, s, stop { stopSequence = idx }))
let maxSequence = stopSequence ((\(_,_,stop) -> stop) (last stations))
- let scaleSequence a = int2Double a * 100 / int2Double maxSequence
+ let scaleSequence a = a * 100 / int2Double maxSequence
- let (minY, maxY) = tickets
- <&> snd
+
+ (minY, maxY) <- tickets
+ <&> (\(_,stops,_) -> stops)
& concat
- <&> (timeToPos . stopDeparture . entityVal)
- & (\ys -> (minimum ys - 20, maximum ys + 20))
+ & mapM (timeToPos day . stopDeparture . (\(stop, _, _) -> stop))
+ <&> (\ys -> (minimum ys - 10, maximum ys + 30))
+
+ let timezone = head stations
+ & (\(_,_,stop) -> stop)
+ & stopArrival
+ & GTFS.tzname
- defaultLayout $ do
- [whamlet|
- <h1>_{MsgSpaceTimeDiagram}
+ timeLines <- ([0,3600..(24*3600)]
+ & mapM ((\a -> timeToPos day a <&> (,a)) . \seconds -> GTFS.Time seconds timezone))
+ <&> takeWhile ((< maxY - 20) . fst) . filter ((> minY) . fst)
- <section><svg viewBox="-2 #{minY} 106 #{maxY - minY}" width="100%">
+ pure [whamlet|
+ <svg viewBox="-6 #{minY} 108 #{maxY - minY}" width="100%">
+
+ -- horizontal lines per hour
+ $forall (y, time) <- timeLines
+ <path
+ style="fill:none;stroke:grey;stroke-width:0.2;stroke-dasharray:1"
+ d="M 0,#{y} 100,#{y}"
+ >
+ <text style="font-size:1pt;">
+ <tspan x="-5" y="#{y + 0.1}">#{time}
+
+ -- vertical lines per station
$forall (_, station, Stop{..}) <- stations
<path
style="fill:none;stroke:#79797a;stroke-width:0.3"
- d="M #{scaleSequence stopSequence},#{minY} #{scaleSequence stopSequence},#{maxY}"
+ d="M #{scaleSequence (int2Double stopSequence)},#{minY} #{scaleSequence (int2Double stopSequence)},#{maxY}"
>
- <text style="font-size:2pt;" transform="rotate(90)">
+ <text style="font-size:2pt;" transform="rotate(-90)">
<tspan
- x="#{minY + 3}"
- y="#{0 - (scaleSequence stopSequence + 0.5)}"
+ x="#{0 - maxY}"
+ y="#{scaleSequence (int2Double stopSequence) - 0.5}"
>#{stationName station}
- $forall (ticket, stops) <- tickets
+
+ -- static (scheduled) trip routes
+ $forall (ticket, stops, anchors) <- tickets
<path
- style="fill:none;stroke:blueviolet;stroke-width:0.3"
+ style="fill:none;stroke:blueviolet;stroke-width:0.3;stroke-dasharray:1.5"
d="M #{mkStopsline scaleSequence stations stops}"
>
+ <path
+ style="fill:none;stroke:red;stroke-width:0.3;"
+ d="M #{mkAnchorline scaleSequence stations anchors}"
+ >
+ |]
- |]
-
-mkStopsline :: (Int -> Double) -> [(StationId, Station, Stop)] -> [Entity Stop] -> Text
+mkStopsline :: (Double -> Double) -> [(StationId, Station, Stop)] -> [(Stop, Double, Double)] -> Text
mkStopsline scaleSequence stations stops = stops
- <&> (mkStop . entityVal)
+ <&> mkStop
& T.concat
- where mkStop stop = " "+|scaleSequence s|+","+|timeToPos (stopArrival stop)|+" "
- +|scaleSequence s|+","+|timeToPos (stopDeparture stop)|+""
+ where mkStop (stop, arrival, departure) =
+ " "+|scaleSequence s|+","+|arrival|+" "
+ +|scaleSequence s|+","+|departure|+""
where s = mapMaybe
(\(stationId, _, res) ->
if stationId == stopStation stop then Just res else Nothing) stations
& head
& stopSequence
+ & int2Double
+
+mkAnchorline :: (Double -> Double) -> [(StationId, Station, Stop)] -> [Entity TrainAnchor] -> Text
+mkAnchorline scaleSequence stations anchors = anchors
+ <&> (mkAnchor . entityVal)
+ & T.concat
+ where mkAnchor anchor =
+ " "+|scaleSequence (transSequence (trainAnchorSequence anchor))|+","
+ -- this use of secondsToPos is correct; when saves in the correct timezone already
+ +|secondsToPos (trainAnchorWhen anchor)|+""
+ where transSequence :: Double -> Double
+ transSequence a = int2Double (mapSequence lastStop) + percent
+ where percent = abs (a - int2Double (stopSequence lastStop))
+ / abs (int2Double (stopSequence lastStop - stopSequence nextStop))
+
+ mapSequence :: Stop -> Int
+ mapSequence stop = mapMaybe
+ (\(stationId, _, res) ->
+ if stationId == stopStation stop then Just res else Nothing) stations
+ & head
+ & stopSequence
+ lastStop = (\(_,_,stop) -> stop) (stations !! lastIndex)
+ nextStop = (\(_,_,stop) -> stop) (stations !! (lastIndex + 1))
+ lastIndex = if
+ | rounded < 0 -> 0
+ | rounded > length stations - 1 -> length stations - 2
+ | otherwise -> rounded
+ where rounded = floor (trainAnchorSequence anchor)
+
+
+-- TODO: these ignore time zones!
+secondsToPos :: Seconds -> Double
+secondsToPos = (/ 600) . int2Double . GTFS.unSeconds
+
--- TODO: ignores time zones!
-timeToPos = (\a -> a / 500) . int2Double . GTFS.timeSeconds
--- timeToPos time = unSeconds $ GTFS.toSeconds time _ _
+timeToPos :: Day -> GTFS.Time -> Handler Double
+timeToPos day time = do
+ settings <- getYesod <&> getSettings
+ tzseries <- liftIO $ getTzseries settings (GTFS.tzname time)
+ pure $ secondsToPos (GTFS.toSeconds time tzseries day)
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
index 43f24aa..ef80d42 100644
--- a/lib/Server/Frontend/Tickets.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -15,39 +15,41 @@ module Server.Frontend.Tickets
import Server.Frontend.Routes
-import Config (ServerConfig (..), UffdConfig (..))
-import Control.Monad (forM, forM_, join)
-import Control.Monad.Extra (maybeM)
-import Control.Monad.IO.Class (MonadIO (liftIO))
-import Data.Coerce (coerce)
-import Data.Function (on, (&))
-import Data.Functor ((<&>))
-import Data.List (lookup, nubBy)
-import Data.List.NonEmpty (nonEmpty)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Maybe (catMaybes, fromJust, isJust)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time (UTCTime (..), addDays,
- getCurrentTime, utctDay)
-import Data.Time.Calendar (Day)
-import Data.Time.Format.ISO8601 (iso8601Show)
-import Data.UUID (UUID)
-import qualified Data.UUID as UUID
-import qualified Data.Vector as V
-import Extrapolation (Extrapolator (..),
- LinearExtrapolator (..))
-import Fmt ((+|), (|+))
-import GHC.Float (int2Double)
+import Config (ServerConfig (..), UffdConfig (..))
+import Control.Monad (forM, forM_, join)
+import Control.Monad.Extra (maybeM)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Coerce (coerce)
+import Data.Function (on, (&))
+import Data.Functor ((<&>))
+import Data.List (lookup, nubBy)
+import Data.List.NonEmpty (nonEmpty)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, fromJust, isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (UTCTime (..), addDays,
+ getCurrentTime, utctDay)
+import Data.Time.Calendar (Day)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import qualified Data.Vector as V
+import Extrapolation (Extrapolator (..),
+ LinearExtrapolator (..))
+import Fmt ((+|), (|+))
+import GHC.Float (int2Double)
import qualified GTFS
-import Numeric (showFFloat)
+import Numeric (showFFloat)
import Persist
-import Server.Util (Service, secondsNow)
-import Text.Read (readMaybe)
+import Server.Frontend.SpaceTime (mkSpaceTimeDiagram,
+ mkSpaceTimeDiagramHandler)
+import Server.Util (Service, secondsNow)
+import Text.Read (readMaybe)
import Yesod
import Yesod.Auth
-import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
+import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
getTicketsR :: Handler Html
@@ -61,6 +63,8 @@ getTicketsR = do
Just day -> (day, day == today)
Nothing -> (today, True)
+ maybeSpaceTime <- mkSpaceTimeDiagramHandler day
+
let prevday = (T.pack . iso8601Show . addDays (-1)) day
let nextday = (T.pack . iso8601Show . addDays 1) day
gtfs <- getYesod <&> getGtfs
@@ -94,6 +98,9 @@ $maybe name <- mdisplayname
: _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign}
$if null tickets
<li style="text-align: center"><em>(_{MsgNone})</em>
+$maybe spaceTime <- maybeSpaceTime
+ <section>
+ ^{spaceTime}
<section>
<h2>_{MsgAccordingToGtfs}
<form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>