tracer/src/Menu/Connect.hs

module Menu.Connect where

import Affection as A

import qualified SDL hiding (V2)

import NanoVG hiding (V2)

import Linear hiding (rotate)

import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing, isJust)

import Control.Monad

-- internal imports

import Types
import Util

loadMenu :: Affection UserData ()
loadMenu = do
  ud <- getAffection
  ad <- get
  let (Subsystems _ m _ j t) = subsystems ud
  uu1 <- partSubscribe j joystickConnect
  uu2 <- partSubscribe j joystickDisconnect
  uu3 <- partSubscribe j emitActionMessage
  uu4 <- partSubscribe t handleActionMessages
  uu5 <- partSubscribe m handleClicks
  partUnSubscribe j (joyUUID ud)
  putAffection ud
    { uuid      = [ uu1, uu2, uu3, uu4 ]
    , state     = Menu Connect
    , stateData = MenuData (V2 0 0) S 0
    , joyCache  = []
    }
  mapM_ (partEmit j) (joyCache ud)

joystickConnect :: JoystickMessage -> Affection UserData ()
joystickConnect msg = do
  ud <- getAffection
  when (isNothing $ joystick ud) $ do
    mjoy <- joystickAutoConnect msg
    maybe (return ()) (\joy -> do
      ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
      liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
      putAffection ud
        { joystick = Just joy
        }
      ) mjoy

joystickDisconnect :: JoystickMessage -> Affection UserData ()
joystickDisconnect msg = do
  ud <- getAffection
  maybe (return ()) (\joy -> do
    njoys <- joystickAutoDisconnect [joy] msg
    when (null njoys) $ do
      liftIO $ logIO A.Debug $ "Joystick disconnected"
      putAffection ud
        { joystick = Nothing
        }
    ) (joystick ud)

handleActionMessages :: ActionMessage -> Affection UserData ()
handleActionMessages (ActionMessage Activate _) = do
  ud <- getAffection
  putAffection ud
    { stateData = (stateData ud)
      { activate = 0.5
      }
    }
handleActionMessages (ActionMessage (UpDown f) _) = do
  ud <- getAffection
  let V2 vx _ = velocity $ stateData ud
  putAffection ud
    { stateData = (stateData ud)
      { velocity = (V2 vx (fromIntegral f / 32768))
      }
    }
handleActionMessages (ActionMessage (LeftRight f) _) = do
  ud <- getAffection
  let V2 _ vy = velocity $ stateData ud
  putAffection ud
    { stateData = (stateData ud)
      { velocity = (V2 (fromIntegral f / 32768) vy)
      }
    }

handleClicks :: MouseMessage -> Affection UserData ()
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
  rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
  when (arrowUp rels) adjustUpDown
  where
  adjustUpDown = liftIO $ logIO A.Debug "TODO: adjustUpDown"
  arrowUp (V2 rx ry) =
    rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
handleClicks _ = return ()

updateMenu :: Double -> Affection UserData ()
updateMenu dt = do
  ud <- getAffection
  putAffection ud
    { stateData = MenuData
      (velocity $ stateData ud)
      (rotation $ stateData ud)
      (max 0 ((activate $ stateData ud) - dt))
    }

drawMenu :: Affection UserData ()
drawMenu = do
  ud <- getAffection
  liftIO $ do
    let ctx = nano ud
        controller = joystick ud
    save ctx
    beginPath ctx
    paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
      if isNothing controller
      then IconContrBlue
      else IconContrGreen
      ) 1
    rect ctx 600 620 80 80
    fillPaint ctx paint
    fill ctx
    when (isJust controller) $ do
      let V2 vx vy = velocity $ stateData ud
      beginPath ctx
      roundedRect ctx 140 110 1000 500 25
      strokeWidth ctx 5
      fillColor ctx (rgba 255 255 255 128)
      strokeColor ctx (rgba 255 255 255 255)
      stroke ctx
      fill ctx
      mapM_ (\deg -> do
        let V2 px py = fmap realToFrac $
              V2 360 360 - V2 50 50 + fmap realToFrac rot
            rot@(V2 rx ry) = fmap (fromIntegral . floor) $
              V2 0 120 `rotVec` deg :: V2 Int
        save ctx
        translate ctx (px + 50) (py + 50)
        rotate ctx (dtor deg)
        translate ctx (-50) (-50)
        case deg of
          0 -> when (vx < 0) $ do
            beginPath ctx
            fillColor ctx (rgb 255 128 0)
            roundedRect ctx 0 0 100 100 10
            closePath ctx
            fill ctx
            case state ud of
              Menu (Adjust (UpDown _)) -> do
                fillColor ctx (rgb 0 255 0)
                roundedRect ctx 0 0 100 100 10
                closePath ctx
                fill ctx
              _ ->
                return ()
          90 -> when (vy > 0) $ do
            beginPath ctx
            fillColor ctx (rgb 255 128 0)
            roundedRect ctx 0 0 100 100 10
            closePath ctx
            fill ctx
            case state ud of
              Menu (Adjust (LeftRight _)) -> do
                fillColor ctx (rgb 0 255 0)
                roundedRect ctx 0 0 100 100 10
                closePath ctx
                fill ctx
              _ ->
                return ()
          180 -> when (vx > 0) $ do
            beginPath ctx
            fillColor ctx (rgb 255 128 0)
            roundedRect ctx 0 0 100 100 10
            closePath ctx
            fill ctx
            case state ud of
              Menu (Adjust (UpDown _)) -> do
                fillColor ctx (rgb 0 255 0)
                roundedRect ctx 0 0 100 100 10
                closePath ctx
                fill ctx
              _ ->
                return ()
          270 -> when (vy < 0) $ do
            beginPath ctx
            fillColor ctx (rgb 255 128 0)
            roundedRect ctx 0 0 100 100 10
            closePath ctx
            fill ctx
            case state ud of
              Menu (Adjust (LeftRight _)) -> do
                fillColor ctx (rgb 0 255 0)
                roundedRect ctx 0 0 100 100 10
                closePath ctx
                fill ctx
              _ ->
                return ()
        beginPath ctx
        paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
        rect ctx 0 0 100 100
        fillPaint ctx paint
        closePath ctx
        fill ctx
        restore ctx
        ) [0, 90, 180, 270]
      beginPath ctx
      when (activate (stateData ud) > 0) $ do
        fillColor ctx (rgb 255 128 0)
        roundedRect ctx 650 160 150 50 10
        fill ctx
      roundedRect ctx 650 160 150 50 10
      strokeWidth ctx 2
      stroke ctx
      fontSize ctx 25
      fontFace ctx "bedstead"
      textAlign ctx (S.fromList [AlignCenter, AlignTop])
      fillColor ctx (rgba 255 255 255 255)
      textBox ctx 650 175 150 "Activate"
      closePath ctx
    restore ctx