{-# 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           Debug.Trace            (trace)
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 day >>= \case
    Nothing -> notFound
    Just widget -> defaultLayout [whamlet|
     <h1>_{MsgSpaceTimeDiagram}
     <section>
       ^{widget}
    |]

mkSpaceTimeDiagramHandler :: Day -> Handler (Maybe Widget)
mkSpaceTimeDiagramHandler day = do
  tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do
    stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do
      arrival <- lift $ timeToPos day stopArrival
      departure <- lift $ timeToPos day stopDeparture
      pure (stop, arrival, departure))
    anchors <- selectList [TrainAnchorTicket ==. entityKey ticket] [Desc TrainAnchorSequence]
    pure (ticket, stops, anchors))

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

-- | Safety: tickets may not be empty
mkSpaceTimeDiagram
  :: Day
  -> [(a, [(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
  -- 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
          s <- getJust (stopStation stop)
          pure (stopStation stop, s, stop { stopSequence = idx }))

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


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

  let timezone = head stations
        & (\(_,_,stop) -> stop)
        & stopArrival
        & GTFS.tzname

  timeLines <- ([0,3600..(24*3600)]
    & mapM ((\a -> timeToPos 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}

         -- static (scheduled) trip routes
         $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}"
             >
           <path
             style="fill:none;stroke:red;stroke-width:0.3;"
             d="M #{mkAnchorline scaleSequence stations anchors}"
             >
        |]

mkStopsline :: (Double -> Double) -> [(StationId, Station, Stop)] -> [(Stop, Double, Double)] -> Text
mkStopsline scaleSequence stations 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
  <&> (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!
secondsToPos :: Seconds -> Double
secondsToPos = (/ 600) . int2Double . GTFS.unSeconds


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