Frontend.SpaceTime: make diagram's y axis scalable

in preparation for using these elsewhere, where they are less cramped

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