{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE MultiWayIf      #-}
{-# LANGUAGE QuasiQuotes     #-}
{-# LANGUAGE RecordWildCards #-}

module Server.Frontend.SpaceTime (getSpaceTimeDiagramR, mkSpaceTimeDiagram, mkSpaceTimeDiagramHandler) where

import           Server.Frontend.Routes

import           Control.Monad          (forM, when)
import           Data.Coerce            (coerce)
import           Data.Function          (on, (&))
import           Data.Functor           ((<&>))
import           Data.Graph             (path)
import           Data.List
import qualified Data.Map               as M
import           Data.Maybe             (catMaybes, mapMaybe)
import           Data.Text              (Text)
import qualified Data.Text              as T
import           Data.Time              (Day, UTCTime (..), getCurrentTime)
import qualified Data.Vector            as V
import           Fmt                    ((+|), (|+))
import           GHC.Float              (double2Int, int2Double)
import           GTFS                   (Seconds (unSeconds))
import qualified GTFS
import           Persist
import           Server.Util            (getTzseries)
import           Text.Blaze.Html        (Html)
import           Text.Read              (readMaybe)
import           Yesod

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

  mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ] >>= \case
    Nothing -> notFound
    Just widget -> defaultLayout [whamlet|
     <h1>_{MsgSpaceTimeDiagram}
     <section>
       ^{widget}
    |]

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 scale day stopArrival
      departure <- lift $ timeToPos scale day stopDeparture
      pure (stop, arrival, departure))
    anchors <- selectList [TrainAnchorTicket ==. entityKey ticket] [Desc TrainAnchorSequence]
    pure (ticket, stops, anchors))

  case tickets of
    [] ->
      pure Nothing
    _ ->
      mkSpaceTimeDiagram scale day tickets
        <&> Just

-- | Safety: tickets may not be empty
mkSpaceTimeDiagram
  :: Double
  -> Day
  -> [(Entity Ticket, [(Stop, Double, Double)], [Entity TrainAnchor])]
  -> Handler Widget
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
    & maximumBy (compare `on` length)
    & fmap (\(stop, _, _) -> stop)
    & sortOn stopSequence
    & zip [0..]
    & mapM (\(idx, stop) -> do
          station <- getJust (stopStation stop)
          pure (station, stop { stopSequence = idx }))

  let reference = stations
       <&> \(_, stop) -> stop
  let maxSequence = stopSequence (last reference)
  let scaleSequence a = a * 100 / int2Double maxSequence


  (minY, maxY) <- tickets
       <&> (\(_,stops,_) -> stops)
       & concat
       & mapM (timeToPos scale day . stopDeparture . (\(stop, _, _) -> stop))
       <&> (\ys -> (minimum ys - 10, maximum ys + 30))

  let timezone = head reference
        & stopArrival
        & GTFS.tzname

  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|
       <svg viewBox="-6 #{minY} 108 #{maxY - minY}" width="100%">

         -- horizontal lines per hour
         $forall (y, time) <- timeLines
           <path
             style="fill:none;stroke:grey;stroke-width:0.2;stroke-dasharray:1"
             d="M 0,#{y} 100,#{y}"
             >
           <text style="font-size:1pt;">
             <tspan x="-5" y="#{y + 0.1}">#{time}

         -- vertical lines per station
         $forall (station, Stop{..}) <- stations
           <path
             style="fill:none;stroke:#79797a;stroke-width:0.3"
             d="M #{scaleSequence (int2Double stopSequence)},#{minY} #{scaleSequence (int2Double stopSequence)},#{maxY}"
             >
           <text style="font-size:2pt;" transform="rotate(-90)">
             <tspan
               x="#{0 - maxY}"
               y="#{scaleSequence (int2Double stopSequence) - 0.5}"
               >#{stationName station}

         -- trips
         $forall (ticket, stops, anchors) <- tickets
           <path
             style="fill:none;stroke:blueviolet;stroke-width:0.3;stroke-dasharray:1.5"
             d="M #{mkStopsline scaleSequence reference stops}"
             >
           <path
             style="fill:none;stroke:red;stroke-width:0.3;"
             d="M #{mkAnchorline scale scaleSequence reference stops anchors}"
             >
        |]

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 = mapSequenceWith reference stop & int2Double

mkAnchorline :: Double -> (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> [Entity TrainAnchor] -> Text
mkAnchorline scale scaleSequence reference stops anchors =
  anchors
  <&> (mkAnchor . entityVal)
  & T.concat
  where
    mkAnchor TrainAnchor{..} =
      " "+|scaleSequence transformed|+","
      -- this use of secondsToPos is correct; trainAnchorWhen saves in the correct timezone already
      +|secondsToPos scale 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 :: Double -> Seconds -> Double
secondsToPos scale = (* scale) . (/ 600) . int2Double . GTFS.unSeconds

timeToPos :: Double -> Day -> GTFS.Time -> Handler Double
timeToPos scale day time = do
  settings <- getYesod <&> getSettings
  tzseries <- liftIO $ getTzseries settings (GTFS.tzname time)
  pure $ secondsToPos scale (GTFS.toSeconds time tzseries day)