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, translation)

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

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 k j t) = subsystems ud
  uu1 <- partSubscribe j joystickConnect
  uu2 <- partSubscribe j joystickDisconnect
  uu3 <- partSubscribe j emitJoyActionMessage
  uu4 <- partSubscribe k emitKbdActionMessage
  uu5 <- partSubscribe t handleActionMessages
  uu6 <- partSubscribe m handleClicks
  -- uu6 <- partSubscribe k emitKbdActionMessage
  partUnSubscribe j (joyUUID ud)
  putAffection ud
    { uuid      = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
    , state     = Menu Connect
    , stateData = MenuData (V2 0 0) S 0 0
    , joyCache  = []
    }
  mapM_ (partEmit j) (joyCache ud)

joystickConnect :: JoystickMessage -> Affection UserData ()
joystickConnect msg = do
  ud <- getAffection
  when (controls ud == NoController) $ do
    mjoy <- joystickAutoConnect msg
    maybe (return ()) (\joy -> do
      ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
      liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show ident)
      putAffection ud
        { controls = Joystick joy
        , translation = JoyTranslation defaultJoyTranslation
        }
      ) mjoy

joystickDisconnect :: JoystickMessage -> Affection UserData ()
joystickDisconnect msg = do
  ud <- getAffection
  case controls ud of
    Joystick joy -> do
      njoys <- joystickAutoDisconnect [joy] msg
      when (null njoys) $ do
        liftIO $ logIO A.Debug $ "Joystick disconnected"
        putAffection ud
          { controls = NoController
          , translation = NoTranslation
          }
    _ -> return ()

handleActionMessages :: ActionMessage -> Affection UserData ()
handleActionMessages (ActionMessage ActActivate _) = do
  ud <- getAffection
  putAffection ud
    { stateData = (stateData ud)
      { activate = 0.5
      }
    }
handleActionMessages (ActionMessage ActSwitchMap _) = do
  ud <- getAffection
  putAffection ud
    { stateData = (stateData ud)
      { switchMap = 0.5
      }
    }
handleActionMessages (ActionMessage (ActUp f) _) = do
  ud <- getAffection
  let V2 vx _ = velocity $ stateData ud
  putAffection ud
    { stateData = (stateData ud)
      { velocity = (V2 vx (-f))
      }
    }
handleActionMessages (ActionMessage (ActDown f) _) = do
  ud <- getAffection
  let V2 vx _ = velocity $ stateData ud
  putAffection ud
    { stateData = (stateData ud)
      { velocity = (V2 vx f)
      }
    }
handleActionMessages (ActionMessage (ActLeft f) _) = do
  ud <- getAffection
  let V2 _ vy = velocity $ stateData ud
  putAffection ud
    { stateData = (stateData ud)
      { velocity = (V2 (-f) vy)
      }
    }
handleActionMessages (ActionMessage (ActRight f) _) = do
  ud <- getAffection
  let V2 _ vy = velocity $ stateData ud
  putAffection ud
    { stateData = (stateData ud)
      { velocity = (V2 f vy)
      }
    }

handleClicks :: MouseMessage -> Affection UserData ()
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
  ud <- getAffection
  rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
  case controls ud of
    Joystick _ -> do
      when (arrowUp rels) adjustKbdUp
      when (arrowDown rels) adjustKbdDown
      when (arrowLeft rels) adjustKbdLeft
      when (arrowRight rels) adjustKbdRight
      when (buttonActivate rels) adjustKbdActivate
      when (buttonSwitchMap rels) adjustKbdSwitchMap
      when (buttonPlay rels) enterGame
    NoController -> do
      when (kbdIcon rels) $
        putAffection ud
          { controls = Keyboard
          , translation = KbdTranslation defaultKbdTranslation
          }
    Keyboard -> do
      when (kbdIcon rels) $
        putAffection ud
          { controls = NoController
          , translation = NoTranslation
          }
      when (buttonPlay rels) enterGame
  where
    adjustKbdUp = do
        fullClean
        loadAdjust (ActUp 1) Keyboard loadMenu
    adjustKbdDown = do
        fullClean
        loadAdjust (ActDown 1) Keyboard loadMenu
    adjustKbdLeft = do
        fullClean
        loadAdjust (ActLeft 1) Keyboard loadMenu
    adjustKbdRight = do
        fullClean
        loadAdjust (ActRight 1) Keyboard loadMenu
    adjustKbdActivate = do
      fullClean
      loadAdjust ActActivate Keyboard loadMenu
    adjustKbdSwitchMap = do
      fullClean
      loadAdjust ActSwitchMap Keyboard 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
    buttonSwitchMap (V2 rx ry) =
      rx > 650 / 1280 && rx < 800 / 1280 && ry > 220 / 720 && ry < 270 / 720
    buttonPlay (V2 rx ry) =
      rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
    kbdIcon (V2 rx ry) =
      rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 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))
          (max 0 ((switchMap $ stateData ud) - dt))
        }
    _ -> return ()

drawMenu :: Affection UserData ()
drawMenu = do
  ud <- getAffection
  case stateData ud of
    MenuData _ _ _ _ ->
      liftIO $ do
        let ctx = nano ud
            controller = controls ud
        save ctx
        beginPath ctx
        cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.!
          case controller of
          Joystick _ -> IconContrGreen
          _          -> IconContrBlue
          ) 1
        rect ctx 550 620 80 80
        fillPaint ctx cpaint
        closePath ctx
        fill ctx
        beginPath ctx
        cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.!
          case controller of
          Keyboard -> IconKbdGreen
          _        -> IconKbdBlue
          ) 1
        rect ctx 650 620 80 80
        fillPaint ctx cpaint
        closePath ctx
        fill ctx
        when (controller /= NoController) $ 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 (ActUp _) _) -> do
                    beginPath ctx
                    fillColor ctx (rgb 0 255 0)
                    roundedRect ctx 0 0 100 100 10
                    closePath ctx
                    fill ctx
                  Menu (Adjust (ActDown _) _) -> 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 (ActLeft _) _) -> do
                    beginPath ctx
                    fillColor ctx (rgb 0 255 0)
                    roundedRect ctx 0 0 100 100 10
                    closePath ctx
                    fill ctx
                  Menu (Adjust (ActRight _) _) -> 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 (ActUp _) _) -> do
                    beginPath ctx
                    fillColor ctx (rgb 0 255 0)
                    roundedRect ctx 0 0 100 100 10
                    closePath ctx
                    fill ctx
                  Menu (Adjust (ActDown _) _) -> 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 (ActLeft _) _) -> do
                    beginPath ctx
                    fillColor ctx (rgb 0 255 0)
                    roundedRect ctx 0 0 100 100 10
                    closePath ctx
                    fill ctx
                  Menu (Adjust (ActRight _) _) -> do
                    beginPath ctx
                    fillColor ctx (rgb 0 255 0)
                    roundedRect ctx 0 0 100 100 10
                    closePath ctx
                    fill ctx
                  _ ->
                    return ()
            beginPath ctx
            apaint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
            rect ctx 0 0 100 100
            fillPaint ctx apaint
            closePath ctx
            fill ctx
            restore ctx
            ) [0, 90, 180, 270]
          when (activate (stateData ud) > 0) $ do
            beginPath ctx
            fillColor ctx (rgb 255 128 0)
            roundedRect ctx 650 160 150 50 10
            fill ctx
            closePath ctx
          case state ud of
            Menu (Adjust ActActivate _) -> do
              beginPath ctx
              fillColor ctx (rgb 0 255 0)
              roundedRect ctx 650 160 150 50 10
              closePath ctx
              fill ctx
            _ ->
              return ()
          beginPath 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 (rgb 255 255 255)
          textBox ctx 650 175 150 "Activate"
          closePath ctx
          when (switchMap (stateData ud) > 0) $ do
            beginPath ctx
            fillColor ctx (rgb 255 128 0)
            roundedRect ctx 650 220 150 50 10
            fill ctx
            closePath ctx
          case state ud of
            Menu (Adjust ActSwitchMap _) -> do
              beginPath ctx
              fillColor ctx (rgb 0 255 0)
              roundedRect ctx 650 220 150 50 10
              closePath ctx
              fill ctx
            _ ->
              return ()
          beginPath ctx
          roundedRect ctx 650 220 150 50 10
          strokeWidth ctx 2
          stroke ctx
          fontSize ctx 25
          fontFace ctx "bedstead"
          fillColor ctx (rgb 255 255 255)
          textAlign ctx (S.fromList [AlignCenter, AlignTop])
          textBox ctx 650 235 150 "Switch Map"
          closePath ctx
          beginPath ctx
          roundedRect ctx 650 560 150 50 10
          strokeWidth ctx 5
          stroke ctx
          closePath ctx
          fontSize ctx 25
          fontFace ctx "bedstead"
          textAlign ctx (S.fromList [AlignCenter, AlignTop])
          textBox ctx 650 575 150 "Play"
        restore ctx
    _ -> return ()