aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Server/Frontend/SpaceTime.hs43
-rw-r--r--lib/Server/Frontend/Tickets.hs2
2 files changed, 23 insertions, 22 deletions
diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs
index 87b9ace..16e8205 100644
--- a/lib/Server/Frontend/SpaceTime.hs
+++ b/lib/Server/Frontend/SpaceTime.hs
@@ -37,7 +37,7 @@ getSpaceTimeDiagramR = do
Just day -> pure day
Nothing -> liftIO $ getCurrentTime <&> utctDay
- mkSpaceTimeDiagramHandler day >>= \case
+ mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ] >>= \case
Nothing -> notFound
Just widget -> defaultLayout [whamlet|
<h1>_{MsgSpaceTimeDiagram}
@@ -45,12 +45,12 @@ getSpaceTimeDiagramR = do
^{widget}
|]
-mkSpaceTimeDiagramHandler :: Day -> Handler (Maybe Widget)
-mkSpaceTimeDiagramHandler day = do
- tickets <- runDB $ selectList [ TicketDay ==. day ] [ Asc TicketId ] >>= mapM (\ticket -> do
+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 day stopArrival
- departure <- lift $ timeToPos day stopDeparture
+ 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))
@@ -59,15 +59,16 @@ mkSpaceTimeDiagramHandler day = do
[] ->
pure Nothing
_ ->
- mkSpaceTimeDiagram day tickets
+ mkSpaceTimeDiagram scale day tickets
<&> Just
-- | Safety: tickets may not be empty
mkSpaceTimeDiagram
- :: Day
+ :: Double
+ -> Day
-> [(Entity Ticket, [(Stop, Double, Double)], [Entity TrainAnchor])]
-> Handler Widget
-mkSpaceTimeDiagram day tickets = do
+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
@@ -88,15 +89,15 @@ mkSpaceTimeDiagram day tickets = do
(minY, maxY) <- tickets
<&> (\(_,stops,_) -> stops)
& concat
- & mapM (timeToPos day . stopDeparture . (\(stop, _, _) -> stop))
+ & mapM (timeToPos scale day . stopDeparture . (\(stop, _, _) -> stop))
<&> (\ys -> (minimum ys - 10, maximum ys + 30))
let timezone = head reference
& stopArrival
& GTFS.tzname
- timeLines <- ([0,3600..(24*3600)]
- & mapM ((\a -> timeToPos day a <&> (,a)) . \seconds -> GTFS.Time seconds timezone))
+ 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|
@@ -131,7 +132,7 @@ mkSpaceTimeDiagram day tickets = do
>
<path
style="fill:none;stroke:red;stroke-width:0.3;"
- d="M #{mkAnchorline scaleSequence reference stops anchors}"
+ d="M #{mkAnchorline scale scaleSequence reference stops anchors}"
>
|]
@@ -144,8 +145,8 @@ mkStopsline scaleSequence reference stops = stops
+|scaleSequence s|+","+|departure|+""
where s = mapSequenceWith reference stop & int2Double
-mkAnchorline :: (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> [Entity TrainAnchor] -> Text
-mkAnchorline scaleSequence reference stops anchors =
+mkAnchorline :: Double -> (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> [Entity TrainAnchor] -> Text
+mkAnchorline scale scaleSequence reference stops anchors =
anchors
<&> (mkAnchor . entityVal)
& T.concat
@@ -153,7 +154,7 @@ mkAnchorline scaleSequence reference stops anchors =
mkAnchor TrainAnchor{..} =
" "+|scaleSequence transformed|+","
-- this use of secondsToPos is correct; trainAnchorWhen saves in the correct timezone already
- +|secondsToPos trainAnchorWhen|+""
+ +|secondsToPos scale trainAnchorWhen|+""
where
transformed = int2Double (mapSequence lastStop) + offset
@@ -184,11 +185,11 @@ mapSequenceWith reference stop = filter
& stopSequence
-- | SAFETY: ignores time zones
-secondsToPos :: Seconds -> Double
-secondsToPos = (/ 600) . int2Double . GTFS.unSeconds
+secondsToPos :: Double -> Seconds -> Double
+secondsToPos scale = (* scale) . (/ 600) . int2Double . GTFS.unSeconds
-timeToPos :: Day -> GTFS.Time -> Handler Double
-timeToPos day time = do
+timeToPos :: Double -> Day -> GTFS.Time -> Handler Double
+timeToPos scale day time = do
settings <- getYesod <&> getSettings
tzseries <- liftIO $ getTzseries settings (GTFS.tzname time)
- pure $ secondsToPos (GTFS.toSeconds time tzseries day)
+ pure $ secondsToPos scale (GTFS.toSeconds time tzseries day)
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
index 839aeba..c3de1a1 100644
--- a/lib/Server/Frontend/Tickets.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -63,7 +63,7 @@ getTicketsR = do
Just day -> (day, day == today)
Nothing -> (today, True)
- maybeSpaceTime <- mkSpaceTimeDiagramHandler day
+ maybeSpaceTime <- mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ]
let prevday = (T.pack . iso8601Show . addDays (-1)) day
let nextday = (T.pack . iso8601Show . addDays 1) day