diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index 8484751..b53a934 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -45,18 +45,22 @@ loadMap :: Affection UserData () loadMap = do ud <- getAffection ad <- get - let (Subsystems _ m k _ _) = subsystems ud + let (Subsystems _ m k j t) = subsystems ud uu1 <- partSubscribe m movePlayer uu2 <- partSubscribe k changeMaps uu3 <- partSubscribe m playerInteract + uu4 <- partSubscribe j emitActionMessage + uu5 <- partSubscribe t movePlayer2 + uu6 <- partSubscribe t playerInteract2 future <- liftIO newEmptyMVar progress <- liftIO $ newMVar (0, "Ohai!") _ <- liftIO $ forkIO $ loadMapFork ud ad future progress putAffection ud { stateData = None - , uuid = [uu1, uu2, uu3] + , uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ] , stateMVar = future , stateProgress = progress + , state = Main WorldMap } changeMaps :: KeyboardMessage -> Affection UserData () @@ -190,6 +194,7 @@ loadMapFork ud ad future progress = do { pos = Just (V2 10.5 10.5) , mmpos = mmmpos , vel = Just (V2 0 0) + , xyvel = Just (V2 0 0) , mmvel = Just (V2 0 0) , player = Just () , rot = Just SE @@ -266,7 +271,7 @@ movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do (nws, _) <- yieldSystemT (worldState ud) $ emap allEnts $ do with player - pure $ unchanged + return $ unchanged { vel = Set $ V2 0 0 } putAffection ud @@ -274,6 +279,35 @@ movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do } movePlayer _ = return () +movePlayer2 :: ActionMessage -> Affection UserData () +movePlayer2 (ActionMessage (UpDown f) _) = do + ud <- getAffection + (nws, _) <- yieldSystemT (worldState ud) $ + emap allEnts $ do + with player + V2 vx _ <- query xyvel + let ry = fromIntegral f / 32768 :: Double + return $ unchanged + { xyvel = Set $ V2 vx ry + } + putAffection ud + { worldState = nws + } +movePlayer2 (ActionMessage (LeftRight f) _) = do + ud <- getAffection + (nws, _) <- yieldSystemT (worldState ud) $ + emap allEnts $ do + with player + V2 _ vy <- query xyvel + let rx = fromIntegral f / 32768 :: Double + return $ unchanged + { xyvel = Set $ V2 rx vy + } + putAffection ud + { worldState = nws + } +movePlayer2 _ = return () + playerInteract :: MouseMessage -> Affection UserData () playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do ud <- getAffection @@ -324,6 +358,44 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do } playerInteract _ = return () +playerInteract2 :: ActionMessage -> Affection UserData () +playerInteract2 (ActionMessage Activate _) = do + ud <- getAffection + (nws, _) <- yieldSystemT (worldState ud) $ do + [(ppos, pdir, pent)] <- efor allEnts $ do + with player + with pos + with rot + pos' <- query pos + rot' <- query rot + ent <- queryEnt + return (pos', rot', ent) + mrelEnts <- efor allEnts $ do + with pos + with objAccess + with objType + with objState + (rel, dir) <- query objAccess + pos' <- query pos + otype <- query objType + ostate <- query objState + ent <- queryEnt + if ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) || + (fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) && + pdir == dir + then return $ Just (otype, ostate, ent) + else return Nothing + let relEnts = catMaybes mrelEnts + liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts) + -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc)) + mapM_ (\(t, s, e) -> + setEntity e =<< objectTransition t s True e (Just pent) + ) relEnts + putAffection ud + { worldState = nws + } +playerInteract2 _ = return () + drawMap :: Affection UserData () drawMap = do ud <- getAffection @@ -529,6 +601,7 @@ updateMap dt = do putAffection ud { worldState = nws , stateData = mendat + , state = Main WorldMap } updateMap 0.1 updateMap 0.1 @@ -538,6 +611,16 @@ updateMap dt = do Nothing -> return () else do (nws, _) <- yieldSystemT (worldState ud) $ do + emap allEnts $ do + with player + with xyvel + with vel + V2 rx ry <- query xyvel + let dr = (ry / sin (atan (1/2)) / 2) + rx + dc = rx - (ry / sin (atan (1/2)) / 2) + return $ unchanged + { vel = Set $ 2 * V2 dr dc + } emap allEnts $ do with anim stat <- query anim diff --git a/src/Menu/Connect.hs b/src/Menu/Connect.hs index 9d28b5b..6a74ba7 100644 --- a/src/Menu/Connect.hs +++ b/src/Menu/Connect.hs @@ -19,6 +19,7 @@ import Control.Monad import Types import Util import Menu.Adjust +import MainGame.WorldMap loadMenu :: Affection UserData () loadMenu = do @@ -95,6 +96,7 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) 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 @@ -115,6 +117,9 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) 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) = @@ -125,146 +130,162 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) 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 - putAffection ud - { stateData = MenuData - (velocity $ stateData ud) - (rotation $ stateData ud) - (max 0 ((activate $ stateData ud) - dt)) - } + 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 - 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 + case stateData ud of + MenuData _ _ _ -> + liftIO $ do + let ctx = nano ud + controller = joystick ud 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 + 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 - 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 + when (isJust controller) $ do + let V2 vx vy = velocity $ stateData ud beginPath ctx - fillColor ctx (rgb 0 255 0) - roundedRect ctx 650 160 150 50 10 - closePath 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 - _ -> - 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 - restore 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 () diff --git a/src/Types/Entity.hs b/src/Types/Entity.hs index d1d56a9..b6317ac 100644 --- a/src/Types/Entity.hs +++ b/src/Types/Entity.hs @@ -16,6 +16,7 @@ data Entity f = Entity , mmpos :: Component f 'Field (V2 Double) , gridPos :: Component f 'Field (V2 Int) , vel :: Component f 'Field (V2 Double) + , xyvel :: Component f 'Field (V2 Double) , mmvel :: Component f 'Field (V2 Double) , velFact :: Component f 'Field Double , rot :: Component f 'Field Direction