diff options
| -rw-r--r-- | lib/Server/Frontend/SpaceTime.hs | 43 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tickets.hs | 2 |
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 |