aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/Frontend
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server/Frontend')
-rw-r--r--lib/Server/Frontend/SpaceTime.hs103
1 files changed, 54 insertions, 49 deletions
diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs
index 878a627..87b9ace 100644
--- a/lib/Server/Frontend/SpaceTime.hs
+++ b/lib/Server/Frontend/SpaceTime.hs
@@ -20,7 +20,6 @@ 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))
@@ -48,7 +47,7 @@ getSpaceTimeDiagramR = do
mkSpaceTimeDiagramHandler :: Day -> Handler (Maybe Widget)
mkSpaceTimeDiagramHandler day = do
- tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do
+ tickets <- runDB $ selectList [ TicketDay ==. day ] [ Asc TicketId ] >>= mapM (\ticket -> do
stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do
arrival <- lift $ timeToPos day stopArrival
departure <- lift $ timeToPos day stopDeparture
@@ -66,7 +65,7 @@ mkSpaceTimeDiagramHandler day = do
-- | Safety: tickets may not be empty
mkSpaceTimeDiagram
:: Day
- -> [(a, [(Stop, Double, Double)], [Entity TrainAnchor])]
+ -> [(Entity Ticket, [(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
@@ -77,10 +76,12 @@ mkSpaceTimeDiagram day tickets = do
& sortOn stopSequence
& zip [0..]
& mapM (\(idx, stop) -> do
- s <- getJust (stopStation stop)
- pure (stopStation stop, s, stop { stopSequence = idx }))
+ station <- getJust (stopStation stop)
+ pure (station, stop { stopSequence = idx }))
- let maxSequence = stopSequence ((\(_,_,stop) -> stop) (last stations))
+ let reference = stations
+ <&> \(_, stop) -> stop
+ let maxSequence = stopSequence (last reference)
let scaleSequence a = a * 100 / int2Double maxSequence
@@ -90,8 +91,7 @@ mkSpaceTimeDiagram day tickets = do
& mapM (timeToPos day . stopDeparture . (\(stop, _, _) -> stop))
<&> (\ys -> (minimum ys - 10, maximum ys + 30))
- let timezone = head stations
- & (\(_,_,stop) -> stop)
+ let timezone = head reference
& stopArrival
& GTFS.tzname
@@ -112,7 +112,7 @@ mkSpaceTimeDiagram day tickets = do
<tspan x="-5" y="#{y + 0.1}">#{time}
-- vertical lines per station
- $forall (_, station, Stop{..}) <- stations
+ $forall (station, Stop{..}) <- stations
<path
style="fill:none;stroke:#79797a;stroke-width:0.3"
d="M #{scaleSequence (int2Double stopSequence)},#{minY} #{scaleSequence (int2Double stopSequence)},#{maxY}"
@@ -123,65 +123,70 @@ mkSpaceTimeDiagram day tickets = do
y="#{scaleSequence (int2Double stopSequence) - 0.5}"
>#{stationName station}
- -- static (scheduled) trip routes
+ -- trips
$forall (ticket, stops, anchors) <- tickets
<path
style="fill:none;stroke:blueviolet;stroke-width:0.3;stroke-dasharray:1.5"
- d="M #{mkStopsline scaleSequence stations stops}"
+ d="M #{mkStopsline scaleSequence reference stops}"
>
<path
style="fill:none;stroke:red;stroke-width:0.3;"
- d="M #{mkAnchorline scaleSequence stations anchors}"
+ d="M #{mkAnchorline scaleSequence reference stops anchors}"
>
|]
-mkStopsline :: (Double -> Double) -> [(StationId, Station, Stop)] -> [(Stop, Double, Double)] -> Text
-mkStopsline scaleSequence stations stops = stops
+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 = 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
+ where s = mapSequenceWith reference stop & int2Double
+
+mkAnchorline :: (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> [Entity TrainAnchor] -> Text
+mkAnchorline scaleSequence reference stops 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!
+ where
+ mkAnchor TrainAnchor{..} =
+ " "+|scaleSequence transformed|+","
+ -- this use of secondsToPos is correct; trainAnchorWhen saves in the correct timezone already
+ +|secondsToPos 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 :: Seconds -> Double
secondsToPos = (/ 600) . int2Double . GTFS.unSeconds
-
timeToPos :: Day -> GTFS.Time -> Handler Double
timeToPos day time = do
settings <- getYesod <&> getSettings
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 19:34:58 +0000