pijul nest
guest [sign in]

Fork channel

Create a new channel as a copy of main.

Rename channel

Rename main to:

Delete channel

Delete main? This cannot be undone.

Draw.hs
module Frontend.Draw where

import Prelude

import CSS.Color as CSS
import Color (Color, hsl, rgb, toHSLA, toHexString)
import Control.Safely (for_)
import Data.Array ((!!))
import Data.Function.Uncurried (Fn3, runFn3)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Frontend.Types (Box(..), Object(..), Tracklet, Vec2(..))
import Graphics.Canvas (CanvasElement, CanvasImageSource, getCanvasHeight, getCanvasWidth, getContext2D)
import Graphics.Canvas as Canvas
import Math (atan2, cos, pi, sin)

foreign import imgElementToImageSourceImpl :: forall r. Fn3 String (CanvasImageSource -> r) r (Effect r)

foreign import imageShape :: CanvasImageSource -> { width :: Int, height :: Int }


-- | Get a img element by ID, or `Nothing` if the element does not exist.
getImgElementById :: String -> Effect (Maybe CanvasImageSource)
getImgElementById elId = runFn3 imgElementToImageSourceImpl elId Just Nothing


metersToPixels :: Vec2 -> Box -> Vec2 -> Vec2
metersToPixels (V2 canvasW canvasH) (Box {x0, y0, x1, y1}) (V2 x y) = let
  w = x1 - x0
  h = y1 - y0
  px = (x - x0) / w * canvasW
  py = (1.0 - (y - y0) / h) * canvasH
  in V2 px py


canvasShape :: CanvasElement -> Effect Vec2
canvasShape elem = do
  w <- getCanvasWidth elem
  h <- getCanvasHeight elem
  pure $ V2 w h


drawTracklet :: CanvasElement -> Box -> Number -> Tracklet -> Effect Unit
drawTracklet elem box alpha tracklet = do
  shape <- canvasShape elem
  ctx <- getContext2D elem

  let
    color = rgb 100 100 200
  Canvas.setLineJoin ctx Canvas.BevelJoin
  Canvas.setLineWidth ctx 5.0
  Canvas.setGlobalAlpha ctx alpha
  Canvas.setStrokeStyle ctx (toHexString color)
  Canvas.beginPath ctx

  for_ tracklet \pt -> do
    let V2 px py = metersToPixels shape box pt.p
    Canvas.lineTo ctx px py
  Canvas.stroke ctx

  -- start circle
  case tracklet !! 0 of
    Nothing -> pure unit
    Just pt -> do
      let V2 px py = metersToPixels shape box pt.p
      Canvas.setGlobalAlpha ctx 0.2
      Canvas.setFillStyle ctx (toHexString $ rgb 200 100 100)
      Canvas.beginPath ctx
      Canvas.arc ctx
        { x: px
        , y: py
        , radius: 5.0, start: 0.0, end: 6.3
        }
      Canvas.fill ctx


hashedColor :: Int -> Color
hashedColor h = hsl (toNumber $ h * 15_485_867 `mod` 255) 1.0 0.3


colorToCss :: Color -> CSS.Color
colorToCss col = let
  {h, s, l, a} = toHSLA col
  in CSS.hsla h s l a


drawObject :: CanvasElement -> Box -> Object -> Effect Unit
drawObject elem box (Object obj) = do
  ctx <- getContext2D elem
  shape <- canvasShape elem

  let V2 hx hy' = obj.heading
      hy = -hy'
      angle = atan2 hy hx
      V2 px py = metersToPixels shape box $ obj.pos

  let color = toHexString (hashedColor obj.id)
      alpha = clamp 0.0 1.0 $ toNumber (10 - obj.gap) / 10.0
  Canvas.setLineWidth ctx 5.0
  Canvas.setGlobalAlpha ctx alpha
  Canvas.setStrokeStyle ctx color
  Canvas.setFillStyle ctx color

  Canvas.beginPath ctx
  Canvas.arc ctx
    { x: px
    , y: py
    , radius: 10.0, start: angle + 3.15 / 3.0, end: angle - 3.15 / 3.0
    }
  Canvas.moveTo ctx (px + cos (angle - pi / 3.0) * 10.0) (py + sin (angle - pi / 3.0) * 10.0)
  Canvas.lineTo ctx (px + hx * 20.0) (py + hy * 20.0)
  Canvas.lineTo ctx (px + cos (angle + pi / 3.0) * 10.0) (py + sin (angle + pi / 3.0) * 10.0)
  Canvas.stroke ctx
  Canvas.setGlobalAlpha ctx (alpha / 3.0)
  Canvas.fill ctx