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