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
import Menu.Adjust
import MainGame.WorldMap

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, uu5 ]
    , 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 || arrowDown rels) (adjustUpDown rels)
  when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels)
  when (buttonActivate rels) (adjustActivate)
  when (buttonPlay rels) (enterGame)
  where
    adjustUpDown rels = do
      if arrowUp rels
      then do
        fullClean
        loadAdjust (UpDown 1) loadMenu
      else do
        fullClean
        loadAdjust (UpDown (-1)) loadMenu
    adjustLeftRight rels = do
      if arrowLeft rels
      then do
        fullClean
        loadAdjust (LeftRight 1) loadMenu
      else do
        fullClean
        loadAdjust (LeftRight (-1)) loadMenu
    adjustActivate = do
      fullClean
      loadAdjust Activate loadMenu
    enterGame = do
      fullClean
      loadMap
    arrowUp (V2 rx ry) =
      rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
    arrowDown (V2 rx ry) =
      rx > 310 / 1280 && rx < 410 / 1280 && ry > 430 / 720 && ry < 530 / 720
    arrowLeft (V2 rx ry) =
      rx > 190 / 1280 && rx < 290 / 1280 && ry > 310 / 720 && ry < 410 / 720
    arrowRight (V2 rx ry) =
      rx > 430 / 1280 && rx < 530 / 1280 && ry > 310 / 720 && ry < 410 / 720
    buttonActivate (V2 rx ry) =
      rx > 650 / 1280 && rx < 800 / 1280 && ry > 160 / 720 && ry < 210 / 720
    buttonPlay (V2 rx ry) =
      rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
handleClicks _ = return ()

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

drawMenu :: Affection UserData ()
drawMenu = do
  ud <- getAffection
  case stateData ud of
    MenuData _ _ _ ->
      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 64)
          strokeColor ctx (rgb 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 -> do
                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 (UpDown _)) -> do
                    beginPath ctx
                    fillColor ctx (rgb 0 255 0)
                    roundedRect ctx 0 0 100 100 10
                    closePath ctx
                    fill ctx
                  _ ->
                    return ()
              90 -> do
                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 (LeftRight _)) -> do
                    beginPath ctx
                    fillColor ctx (rgb 0 255 0)
                    roundedRect ctx 0 0 100 100 10
                    closePath ctx
                    fill ctx
                  _ ->
                    return ()
              180 -> do
                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 (UpDown _)) -> do
                    beginPath ctx
                    fillColor ctx (rgb 0 255 0)
                    roundedRect ctx 0 0 100 100 10
                    closePath ctx
                    fill ctx
                  _ ->
                    return ()
              270 -> do
                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 (LeftRight _)) -> do
                    beginPath ctx
                    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
          case state ud of
            Menu (Adjust Activate) -> do
              beginPath ctx
              fillColor ctx (rgb 0 255 0)
              roundedRect ctx 650 160 150 50 10
              closePath ctx
              fill ctx
            _ ->
              return ()
          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
          roundedRect ctx 650 560 150 50 10
          strokeWidth ctx 5
          stroke ctx
          fontSize ctx 25
          fontFace ctx "bedstead"
          textAlign ctx (S.fromList [AlignCenter, AlignTop])
          fillColor ctx (rgba 255 255 255 255)
          textBox ctx 650 575 150 "Play"
        restore ctx
    _ -> return ()