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 ()