aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/Frontend/SpaceTime.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server/Frontend/SpaceTime.hs')
-rw-r--r--lib/Server/Frontend/SpaceTime.hs195
1 files changed, 195 insertions, 0 deletions
diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs
new file mode 100644
index 0000000..16e8205
--- /dev/null
+++ b/lib/Server/Frontend/SpaceTime.hs
@@ -0,0 +1,195 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.SpaceTime (getSpaceTimeDiagramR, mkSpaceTimeDiagram, mkSpaceTimeDiagramHandler) where
+
+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 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 Text.Read (readMaybe)
+import Yesod
+
+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
+
+ mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ] >>= \case
+ Nothing -> notFound
+ Just widget -> defaultLayout [whamlet|
+ <h1>_{MsgSpaceTimeDiagram}
+ <section>
+ ^{widget}
+ |]
+
+mkSpaceTimeDiagramHandler :: Double -> Day -> [Filter Ticket] -> Handler (Maybe Widget)
+mkSpaceTimeDiagramHandler scale day filter = do
+ tickets <- runDB $ selectList filter [ Asc TicketId ] >>= mapM (\ticket -> do
+ stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do
+ arrival <- lift $ timeToPos scale day stopArrival
+ departure <- lift $ timeToPos scale day stopDeparture
+ pure (stop, arrival, departure))
+ anchors <- selectList [TrainAnchorTicket ==. entityKey ticket] [Desc TrainAnchorSequence]
+ pure (ticket, stops, anchors))
+
+ case tickets of
+ [] ->
+ pure Nothing
+ _ ->
+ mkSpaceTimeDiagram scale day tickets
+ <&> Just
+
+-- | Safety: tickets may not be empty
+mkSpaceTimeDiagram
+ :: Double
+ -> Day
+ -> [(Entity Ticket, [(Stop, Double, Double)], [Entity TrainAnchor])]
+ -> Handler Widget
+mkSpaceTimeDiagram scale 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 (\(_,stops,_) -> stops) tickets
+ & maximumBy (compare `on` length)
+ & fmap (\(stop, _, _) -> stop)
+ & sortOn stopSequence
+ & zip [0..]
+ & mapM (\(idx, stop) -> do
+ station <- getJust (stopStation stop)
+ pure (station, stop { stopSequence = idx }))
+
+ let reference = stations
+ <&> \(_, stop) -> stop
+ let maxSequence = stopSequence (last reference)
+ let scaleSequence a = a * 100 / int2Double maxSequence
+
+
+ (minY, maxY) <- tickets
+ <&> (\(_,stops,_) -> stops)
+ & concat
+ & mapM (timeToPos scale day . stopDeparture . (\(stop, _, _) -> stop))
+ <&> (\ys -> (minimum ys - 10, maximum ys + 30))
+
+ let timezone = head reference
+ & stopArrival
+ & GTFS.tzname
+
+ timeLines <- ([0,(double2Int $ 3600 / scale)..(24*3600)]
+ & mapM ((\a -> timeToPos scale day a <&> (,a)) . \seconds -> GTFS.Time seconds timezone))
+ <&> takeWhile ((< maxY - 20) . fst) . filter ((> minY) . fst)
+
+ 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 (int2Double stopSequence)},#{minY} #{scaleSequence (int2Double stopSequence)},#{maxY}"
+ >
+ <text style="font-size:2pt;" transform="rotate(-90)">
+ <tspan
+ x="#{0 - maxY}"
+ y="#{scaleSequence (int2Double stopSequence) - 0.5}"
+ >#{stationName station}
+
+ -- trips
+ $forall (ticket, stops, anchors) <- tickets
+ <path
+ style="fill:none;stroke:blueviolet;stroke-width:0.3;stroke-dasharray:1.5"
+ d="M #{mkStopsline scaleSequence reference stops}"
+ >
+ <path
+ style="fill:none;stroke:red;stroke-width:0.3;"
+ d="M #{mkAnchorline scale scaleSequence reference stops anchors}"
+ >
+ |]
+
+mkStopsline :: (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> Text
+mkStopsline scaleSequence reference stops = stops
+ <&> mkStop
+ & T.concat
+ where mkStop (stop, arrival, departure) =
+ " "+|scaleSequence s|+","+|arrival|+" "
+ +|scaleSequence s|+","+|departure|+""
+ where s = mapSequenceWith reference stop & int2Double
+
+mkAnchorline :: Double -> (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> [Entity TrainAnchor] -> Text
+mkAnchorline scale scaleSequence reference stops anchors =
+ anchors
+ <&> (mkAnchor . entityVal)
+ & T.concat
+ where
+ mkAnchor TrainAnchor{..} =
+ " "+|scaleSequence transformed|+","
+ -- this use of secondsToPos is correct; trainAnchorWhen saves in the correct timezone already
+ +|secondsToPos scale trainAnchorWhen|+""
+ where
+ transformed = int2Double (mapSequence lastStop) + offset
+
+ offset =
+ abs (trainAnchorSequence - int2Double (stopSequence lastStop))
+ / int2Double (stopSequence lastStop - stopSequence nextStop)
+ -- the below is necessary to flip if necessary (it can be either -1 or +1)
+ * int2Double (mapSequence lastStop - mapSequence nextStop)
+
+ mapSequence = mapSequenceWith reference
+
+ lastStop = stops
+ & filter (\(Stop{..},_,_) ->
+ int2Double stopSequence <= trainAnchorSequence)
+ & last
+ & \(stop,_,_) -> stop
+ nextStop = stops
+ & filter (\(Stop{..},_,_) ->
+ int2Double stopSequence > trainAnchorSequence)
+ & head
+ & \(stop,_,_) -> stop
+
+-- | map a stop sequence number into the graph's space
+mapSequenceWith :: [Stop] -> Stop -> Int
+mapSequenceWith reference stop = filter
+ (\referenceStop -> stopStation referenceStop == stopStation stop) reference
+ & head
+ & stopSequence
+
+-- | SAFETY: ignores time zones
+secondsToPos :: Double -> Seconds -> Double
+secondsToPos scale = (* scale) . (/ 600) . int2Double . GTFS.unSeconds
+
+timeToPos :: Double -> Day -> GTFS.Time -> Handler Double
+timeToPos scale day time = do
+ settings <- getYesod <&> getSettings
+ tzseries <- liftIO $ getTzseries settings (GTFS.tzname time)
+ pure $ secondsToPos scale (GTFS.toSeconds time tzseries day)
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-06 16:35:48 +0000