module Frontend.Component.Filtering where
import Prelude
import Data.Array (length)
import Data.Array as A
import Data.Array.NonEmpty (NonEmptyArray, fromNonEmpty, head, toArray)
import Data.DateTime (DateTime, adjust, diff)
import Data.Either (Either(..), hush)
import Data.Foldable (for_)
import Data.HeytingAlgebra (tt, ff)
import Data.Int (round, toNumber)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.NonEmpty ((:|))
import Data.Number (fromString)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (class Duration, Hours(..), convertDuration, negateDuration)
import Effect (Effect)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class.Console (log)
import Frontend.Api (fetchInstantInterval, fetchTracklets)
import Frontend.Component.Plot as Plot
import Frontend.Dom (card)
import Frontend.Draw (drawTracklet, imageShape)
import Frontend.Tracklet.Filter (HLine, TrackletFilter)
import Frontend.Tracklet.Filter as F
import Frontend.Types (Box, Config(..), Info(..), MaybeInstant, Tracklet, Tracklets(..), Zone, dateTimeToSeconds)
import Frontend.UPlot (Opts, defaultOpts, defaultSeries)
import Frontend.Util (classes, datetimeToSeconds, secondsToDateTime)
import Graphics.Canvas (CanvasImageSource, drawImage, getCanvasElementById, getContext2D, setGlobalAlpha)
import Halogen (liftEffect)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
type State =
{ info :: Info
, config :: Config
, mapImage :: CanvasImageSource
, instants :: Maybe (Array MaybeInstant)
, tracklets :: Maybe (Array Tracklet)
, filtered :: Maybe (Array Tracklet)
, filter :: FilterRecord
, seekPos :: DateTime
, seekLen :: Hours
, fetching :: Boolean
, trackletAlpha :: Number
}
type Slots =
( plot :: H.Slot Plot.Query Void Unit
)
data Action
= Initialize
| SetInput Input
| Seek DateTime
| SetSeekLen Hours
| FetchData
| SetTrackletAlpha Number
| SetFilter FilterRecord
type Input = { info :: Info, config :: Config, mapImage :: CanvasImageSource }
type FilterRecord = { name :: String, filter :: TrackletFilter }
line = {x0: 12.0, x1: 14.0, y: 11.0} :: HLine
preparedFilters :: Array Zone -> NonEmptyArray FilterRecord
preparedFilters zones = let
originateAtZone {name, box} =
{ name: "Tracklets which originate at " <> name
, filter: F.first (F.insideBox box)
}
passThroughZone {name, box} =
{ name: "Tracklets which pass through " <> name
, filter: F.runParser $ F.any (F.insideBox box)
}
in fromNonEmpty $ {name: "Everything", filter: tt} :|
[ {name: "Nothing", filter: ff
}
]
<> (originateAtZone <$> zones)
<> (passThroughZone <$> zones)
seekLenChoices :: NonEmptyArray Hours
seekLenChoices = Hours <$> fromNonEmpty (1.0 :| [6.0, 12.0, 24.0])
_plot = (SProxy :: SProxy "plot")
component :: forall query output m. MonadAff m => H.Component HH.HTML query Input output m
component = H.mkComponent
{ initialState: \{info, config, mapImage} ->
{ info
, config
, mapImage
, instants: Nothing
, tracklets: Nothing
, filtered: Nothing
, filter: head $ preparedFilters (unwrap config).zones
, seekPos: (unwrap info).first_dt
, seekLen: head seekLenChoices
, fetching: false
, trackletAlpha: 0.8
}
, render
, eval: H.mkEval H.defaultEval
{ handleAction = handleAction
, initialize = Just Initialize
, receive = Just <<< SetInput
}
}
filteringOptions :: forall m. MonadAff m => State -> H.ComponentHTML Action Slots m
filteringOptions {info: Info info, config: Config config, seekPos, seekLen, fetching, trackletAlpha, tracklets, filtered, filter} = let
maxSeek = fromMaybe info.last_dt $ adjust (negateDuration seekLen) info.last_dt
in HH.div_
[ HH.text $ "Total tracklets: " <> fromMaybe "N/A" (show <<< length <$> tracklets)
, HH.br_
, HH.text $ "Filtered tracklets: " <> fromMaybe "N/A" (show <<< length <$> filtered)
, HH.hr_
, HH.div [ classes ["by-2"] ]
[ HH.text "Tracklet Alpha:"
, HH.input
[ HP.type_ HP.InputRange
, classes ["slider", "custom-range"]
, HP.min 0.0
, HP.max 255.0
, HE.onValueInput (map (SetTrackletAlpha <<< (_ / 255.0)) <<< fromString)
, HP.value $ show $ trackletAlpha * 255.0
]
]
, HH.div [ classes ["by-2"] ] $
[ HH.text "Show:"
, HH.br_
, HH.div [ classes ["container"] ]
[ HH.div [ classes ["row"] ]
(toArray (preparedFilters config.zones) <#> \f -> HH.div [ classes ["col-6"] ]
[ HH.input
[ HP.type_ HP.InputRadio
, HP.value "Hello!"
, HP.checked (f.name == filter.name)
, HE.onClick $ const $ Just $ SetFilter f
, classes ["mx-2"] ]
, HH.text f.name
])
]
]
]
seekingOptions :: forall m. MonadAff m => State -> H.ComponentHTML Action Slots m
seekingOptions {info: Info info, seekPos, seekLen, fetching, trackletAlpha, tracklets, filtered, filter} = let
maxSeek = fromMaybe info.last_dt $ adjust (negateDuration seekLen) info.last_dt
in HH.div_
[ HH.div [ classes ["my-2"] ] [ HH.text "Seek:" ]
, HH.div [ classes ["my-2"] ]
[ HH.input
[ HP.type_ HP.InputRange
, classes ["slider", "custom-range"]
, HP.min $ datetimeToSeconds info.first_dt
, HP.max $ datetimeToSeconds maxSeek
, HE.onValueInput (map Seek <<< secondsToDateTime <=< fromString)
, HP.value $ show $ dateTimeToSeconds $ seekPos `min` maxSeek
]
]
, HH.div [ classes ["my-2"] ] $ toArray seekLenChoices <#> \d ->
HH.button
[ HE.onClick $ const $ Just (SetSeekLen d)
, classes ["btn", if seekLen == d then "btn-primary" else "btn-primary-outline"]
] [HH.text $ show (round $ unwrap d) <> " h"]
, HH.div [ classes ["my-2"] ]
[ HH.button
[ HE.onClick $ const $ Just FetchData
, classes ["btn", "btn-primary", "btn-outline"]
] [HH.text "Fetch Data"]
, HH.i [classes $ ["m-2"] <> if fetching then ["fas", "fa-fw", "fa-hourglass"] else []] []
]
, HH.slot _plot unit Plot.component seekPlotOpts (const Nothing)
]
seekPlotOpts :: Opts
seekPlotOpts = defaultOpts
{ series = [defaultSeries, {stroke: "white", fill: "rgba(0, 0, 0, 0.1)"}, defaultSeries ]
}
render :: forall m. MonadAff m => State -> H.ComponentHTML Action Slots m
render state = let
{width, height} = imageShape state.mapImage
in
HH.div [ classes ["row"] ]
[ HH.div [ classes ["col-lg-7"] ]
[ card []
[ HH.text "Filtering" ]
[ filteringOptions state
]
, card []
[ HH.text "Seeking" ]
[ seekingOptions state
]
]
, card ["col-lg-5"]
[ HH.text "Tracklets" ]
[ HH.canvas [ HP.id_ "heatmap-canvas", HP.width width, HP.height height ]
]
]
drawTracklets :: CanvasImageSource -> Box -> Array Tracklet -> Number -> Effect Unit
drawTracklets mapImage box tracklets alpha = do
mCanvas <- liftEffect $ getCanvasElementById "heatmap-canvas"
liftEffect case mCanvas of
Nothing -> log "Can't locate canvas."
Just canvas -> do
ctx <- getContext2D canvas
setGlobalAlpha ctx 1.0
drawImage ctx mapImage 0.0 0.0
log $ "Drawing " <> show (length tracklets) <> " tracklets..."
for_ tracklets (drawTracklet canvas box alpha)
drawInstants :: forall s a output m d. Duration d =>
Array MaybeInstant -> DateTime -> d -> H.HalogenM s a Slots output m Unit
drawInstants instants seek window = do
let
inWindow t = let d = t `diff` seek in
Hours 0.0 <= d && d < convertDuration window
x = instants <#> (unwrap >>> _.timestamp >>> datetimeToSeconds >>> Just)
y = instants <#> (unwrap >>> _.objects >>> map (A.length >>> toNumber))
w = instants <#> \i ->
if inWindow (unwrap i).timestamp then Just 20.0 else Nothing
void $ H.query _plot unit $ H.tell (\a -> Plot.SetData [x, w, y] a)
handleAction :: forall output m. MonadAff m => Action -> H.HalogenM State Action Slots output m Unit
handleAction = case _ of
Initialize -> do
{info: Info info, config: Config config, seekPos, seekLen} <- H.get
instantRange <- liftAff $ fetchInstantInterval info.first_dt info.last_dt (Hours 0.2)
for_ instantRange \instants -> do H.modify_ $ _ { instants = Just instants }
drawInstants instants seekPos seekLen
handleAction FetchData
pure unit
SetInput { info, config } -> H.modify_ _ { info = info, config = config }
Seek time -> do
{instants, seekPos, seekLen} <- H.get
H.modify_ _ { seekPos = time }
for_ instants \i -> do
drawInstants i time seekLen
pure unit
SetSeekLen hours -> do
{info: Info info, instants, seekPos} <- H.get
let maxPos = fromMaybe info.last_dt $ adjust (negateDuration hours) info.last_dt
newPos = seekPos `min` maxPos
H.modify_ _ { seekLen = hours, seekPos = newPos }
for_ instants \i -> do
drawInstants i newPos hours
FetchData -> do
{info: Info info, config: Config config, mapImage, seekPos, seekLen, trackletAlpha, filter} <- H.get
H.modify_ _ { fetching = true }
let
t1 = seekPos
t2 = fromMaybe seekPos $ adjust seekLen seekPos
tracklets' <- liftAff $ fetchTracklets t1 t2 10
case tracklets' of
Left err -> log $ "Tracklets weren't fetched:" <> show err
Right (Tracklets tracklets) -> do
let filtered = A.filter filter.filter tracklets
liftEffect $ drawTracklets mapImage config.bbox filtered trackletAlpha
H.modify_ _ { filtered = Just filtered }
H.modify_ _ { fetching = false, tracklets = unwrap <$> hush tracklets' }
SetTrackletAlpha a -> do
{ config: Config config, mapImage, filtered } <- H.get
H.modify_ _ { trackletAlpha = a }
liftEffect $ drawTracklets mapImage config.bbox (fromMaybe [] filtered) a
SetFilter f -> do
{ config: Config config, mapImage, tracklets, trackletAlpha } <- H.get
let filtered = A.filter f.filter $ fromMaybe [] tracklets
log $ "Setting filter to " <> f.name
H.modify_ _ { filter = f, filtered = Just filtered }
liftEffect $ drawTracklets mapImage config.bbox filtered trackletAlpha