diff options
| -rw-r--r-- | lib/Server/Frontend.hs | 1 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 2 | ||||
| -rw-r--r-- | lib/Server/Frontend/SpaceTime.hs | 104 | ||||
| -rw-r--r-- | messages/de.msg | 1 | ||||
| -rw-r--r-- | messages/en.msg | 1 | ||||
| -rw-r--r-- | tracktrain.cabal | 1 |
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 |