diff --git a/shell.nix b/shell.nix index 103323a..95e13d8 100644 --- a/shell.nix +++ b/shell.nix @@ -134,7 +134,7 @@ let f = { mkDerivation, astar, base, containers, linear , matrix, OpenGL, random, stdenv, stm, text, unordered-containers - , vector, JuicyPixels, JuicyPixels-extra, bytestring + , vector, JuicyPixels, JuicyPixels-extra, bytestring, mtl }: mkDerivation { pname = "tracer-game"; @@ -146,7 +146,7 @@ let executableHaskellDepends = [ affectionNeko astar base containers ecstasyNeko linear matrix nanovgNeko OpenGL random sdl2Nek0 stm text unordered-containers vector JuicyPixels - JuicyPixels-extra bytestring agNek0 + JuicyPixels-extra bytestring agNek0 mtl ]; license = stdenv.lib.licenses.gpl3; }; diff --git a/src/Init.hs b/src/Init.hs index 75f772b..0c95659 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -33,7 +33,7 @@ init = do <*> (Mouse <$> newTVarIO []) <*> (Keyboard <$> newTVarIO []) _ <- glewInit - (ws, _) <- yieldSystemT (0, defStorage) (return ()) + -- (ws, _) <- yieldSystemT (0, defStorage) (return ()) nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes]) return UserData { state = Load @@ -43,7 +43,7 @@ init = do , assetFonts = M.empty , nano = nvg , uuid = [] - , worldState = ws + -- , worldState = ws , stateData = None , threadContext = Nothing } diff --git a/src/Load.hs b/src/Load.hs index 0158ab8..478a0d8 100644 --- a/src/Load.hs +++ b/src/Load.hs @@ -51,11 +51,14 @@ loadLoad = do } loadFork - :: (SystemState Entity IO) + :: SystemState Entity (AffectionState (AffectionData UserData) IO) -> SDL.Window -> SDL.GLContext -> Context - -> MVar (SystemState Entity IO, StateData) + -> MVar + ( SystemState Entity (AffectionState (AffectionData UserData) IO) + , StateData + ) -> MVar (Float, T.Text) -> IO () loadFork ws win glc nvg future progress = do diff --git a/src/Main.hs b/src/Main.hs index 6601610..12debe4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,6 +3,8 @@ module Main where import Affection as A +import Data.Ecstasy + import qualified SDL import NanoVG hiding (V2(..), V3(..)) @@ -55,9 +57,11 @@ pre = do let Subsystems w m k = subsystems ud _ <- partSubscribe w (fitViewport (1280/720)) _ <- partSubscribe w exitOnWindowClose + (ws, _) <- yieldSystemT (0, defStorage) (return ()) putAffection ud { threadContext = Just threadCtx - , window = Just (drawWindow ad) + , window = Just (drawWindow ad) + , worldState = ws } update :: Double -> Affection UserData () diff --git a/src/MainGame/MindMap.hs b/src/MainGame/MindMap.hs index 0618263..9f1cb30 100644 --- a/src/MainGame/MindMap.hs +++ b/src/MainGame/MindMap.hs @@ -25,7 +25,7 @@ import Util (direction) updateMind :: Double -> Affection UserData () updateMind dt = do ud <- getAffection - (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do + (nws, _) <- yieldSystemT (worldState ud) $ do emap allEnts $ do with anim with mmpos @@ -149,7 +149,7 @@ drawMind = do ud <- getAffection let ctx = nano ud dt <- getDelta - (_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do + (_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do pc <- fmap head $ efor allEnts $ do with player with mmpos diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index 4852072..2104f3b 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -12,6 +12,7 @@ import NanoVG hiding (V2(..)) import Control.Monad (when, void) import Control.Monad.IO.Class (liftIO) +import Control.Monad.State.Strict (evalStateT) import Control.Concurrent.MVar import Control.Concurrent (forkIO) @@ -43,13 +44,14 @@ import Animation loadMap :: Affection UserData () loadMap = do ud <- getAffection + ad <- get let (Subsystems _ m k) = subsystems ud uu1 <- partSubscribe m movePlayer uu2 <- partSubscribe k changeMaps uu3 <- partSubscribe m playerInteract future <- liftIO newEmptyMVar progress <- liftIO $ newMVar (0, "Ohai!") - _ <- liftIO $ forkIO $ loadMapFork ud future progress + _ <- liftIO $ forkIO $ loadMapFork ud ad future progress putAffection ud { stateData = None , uuid = [uu1, uu2, uu3] @@ -74,10 +76,11 @@ changeMaps _ = return () loadMapFork :: UserData - -> MVar (SystemState Entity IO, StateData) + -> AffectionData UserData + -> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData) -> MVar (Float, T.Text) -> IO () -loadMapFork ud future progress = do +loadMapFork ud ad future progress = do let loadSteps = 20 fc = FloorConfig (10, 10) @@ -107,7 +110,7 @@ loadMapFork ud future progress = do _ <- liftIO $ swapMVar progress (15 / loadSteps, "Unfolding and Converting MindMap to images") let !mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat _ <- liftIO $ swapMVar progress (16 / loadSteps, "Creating WorldState") - (nws, _) <- yieldSystemT (worldState ud) $ do + (nws, _) <- evalStateT (runState (yieldSystemT (worldState ud) $ do let pmmpos = (+ 0.5) . (fromIntegral :: Int -> Double) . floor <$> mmPos (fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph)) delta = (0, 0) : @@ -139,6 +142,7 @@ loadMapFork ud future progress = do , anim = Just $ AnimState (AnimId "copier" "open" N) 0 0 , objAccess = Just $ (V2 1 0, NW) , objType = Just ObjCopier + , objState = Just "idle" } ) (A.log A.Debug ("number of copiers: " ++ show (length copiers)) copiers) void $ liftIO $ swapMVar progress (18 / loadSteps, "Registering computers into WorldState") @@ -189,6 +193,7 @@ loadMapFork ud future progress = do } ) npcposs void $ liftIO $ swapMVar progress (20 / loadSteps, "Handing over") + )) ad putMVar future (nws, MainData { mapMat = mat , imgMat = M.fromList (nrows inter) (ncols inter) $ @@ -207,7 +212,7 @@ mouseToPlayer mv2 = do (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2 let dr = (ry / sin (atan (1/2)) / 2) + rx dc = rx - (ry / sin (atan (1/2)) / 2) - (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ + (nws, _) <- yieldSystemT (worldState ud) $ emap allEnts $ do with player pure $ unchanged @@ -223,7 +228,7 @@ movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) = mouseToPlayer m movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do ud <- getAffection - (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ + (nws, _) <- yieldSystemT (worldState ud) $ emap allEnts $ do with player pure $ unchanged @@ -237,10 +242,11 @@ movePlayer _ = return () playerInteract :: MouseMessage -> Affection UserData () playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do ud <- getAffection + ad <- get (V2 rx ry) <- liftIO $ (* V2 640 360) <$> relativizeMouseCoords m let dr = ((ry / 32) / sin (atan 0.5) / 2) + (rx / 64) dc = (rx / 64) - ((ry / 32) / sin (atan 0.5) / 2) - (nws, relEnts) <- liftIO $ yieldSystemT (worldState ud) $ do + (nws, relEnts) <- yieldSystemT (worldState ud) $ do emap allEnts $ do with player with rot @@ -259,23 +265,28 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do 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 == fmap floor pos' || fmap floor ppos == fmap floor pos' + rel) && fmap floor (ppos + V2 dr dc) == fmap floor pos' && pdir == dir - then return $ Just (otype, ent) + then return $ Just (otype, ostate, ent) else return Nothing - return (catMaybes mrelEnts) - liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts) - -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc)) + 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 e + ) relEnts putAffection ud { worldState = nws } - mapM_ (uncurry objectAction) relEnts playerInteract _ = return () drawMap :: Affection UserData () @@ -288,7 +299,7 @@ drawMap = do drawLoadScreen ud progress _ -> do dt <- getDelta - (_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do + (_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do pc <- fmap head $ efor allEnts $ do with player with pos @@ -454,7 +465,7 @@ updateMap dt = do , stateData = mendat } else do - (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do + (nws, _) <- yieldSystemT (worldState ud) $ do emap allEnts $ do with anim stat <- query anim @@ -641,6 +652,16 @@ updateMap dt = do (reachPoints $ stateData ud) ) dt + tses <- efor allEnts $ do + with objType + with objState + t <- query objType + s <- query objState + e <- queryEnt + return (t, s, e) + mapM_ (\(t, s, e) -> + objectAction dt t s e + ) tses putAffection ud { worldState = nws } diff --git a/src/Object.hs b/src/Object.hs index 339fe31..d98541d 100644 --- a/src/Object.hs +++ b/src/Object.hs @@ -1,28 +1,95 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module Object where import Affection +import Control.Monad (when) + import Data.Ecstasy import Types -instance ObjectAction UserData ObjType where - objectAction ObjCopier ent = do - ud <- getAffection - (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do - emap (anEnt ent) $ do - with anim - liftIO $ logIO Debug "copying!" +instance ObjectAction ObjType ObjState where + -- objectAction ObjCopier "idle" ent = do + -- ud <- getAffection + -- (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do + -- emap (anEnt ent) $ do + -- with anim + -- mtime <- queryMaybe objStateTime + -- case mtime of + -- Nothing -> do + -- liftIO $ logIO Debug "copying!" + -- let nstat = AnimState + -- (AnimId "copier" "copy" N) + -- 0 + -- 0 + -- return unchanged + -- { anim = Set nstat + -- , objStateTime = Set 5 + -- , objState = "copying" + -- } + -- Just ttl -> do + -- dt <- getDelta + -- return unchanged + -- { objStateTime = Set (ttl - dt) + -- } + -- putAffection ud + -- { worldState = nws + -- } + + objectAction dt t@ObjCopier s@"copying" ent = do + emap (anEnt ent) $ do + mtime <- queryMaybe objStateTime + case mtime of + Nothing -> do + liftIO $ logIO Debug ("Copier " ++ show ent ++ ": copying!") + return unchanged + { objStateTime = Set (actionTime t s) + , objState = Set "copying" + } + Just ttl -> do + return unchanged + { objStateTime = Set (ttl - dt) + } + [trans] <- efor (anEnt ent) $ do + mttl <- queryMaybe objStateTime + case mttl of + Nothing -> return False + Just ttl -> return (ttl < 0) + when trans (setEntity ent =<< objectTransition t s ent) + + objectAction _ _ _ _ = return () + + objectTransition ObjCopier "idle" ent = do + [e] <- efor (anEnt ent) $ do let nstat = AnimState (AnimId "copier" "copy" N) 0 0 return unchanged - { anim = Set nstat + { objState = Set "copying" + , anim = Set nstat } - putAffection ud - { worldState = nws - } + return e - objectAction _ _ = return () + objectTransition ObjCopier "copying" ent = do + [e] <- efor (anEnt ent) $ do + let nstat = AnimState + (AnimId "copier" "open" N) + 0 + 0 + return unchanged + { anim = Set nstat + , objState = Set "idle" + , objStateTime = Unset + } + return e + + objectTransition _ _ _ = return unchanged + +instance ActionTime ObjType ObjState where + actionTime ObjCopier "copying" = 5 + + actionTime o s = error (show o ++ ": " ++ s ++ ": has not time") diff --git a/src/Types.hs b/src/Types.hs index b884547..3bd28b6 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -15,3 +15,6 @@ import Types.MindMap as T import Types.Drawable as T import Types.Collidible as T import Types.ObjType as T +import Types.ObjClass as T +import Types.Entity as T +import Types.NPCState as T diff --git a/src/Types/Entity.hs b/src/Types/Entity.hs new file mode 100644 index 0000000..bccfaf8 --- /dev/null +++ b/src/Types/Entity.hs @@ -0,0 +1,30 @@ +module Types.Entity where + +import Data.Ecstasy + +import Linear (V2) + +import Types.Direction +import Types.Map +import Types.NPCState +import Types.Animation +import Types.ObjType + +data Entity f = Entity + { pos :: Component f 'Field (V2 Double) + , mmpos :: Component f 'Field (V2 Double) + , gridPos :: Component f 'Field (V2 Int) + , vel :: Component f 'Field (V2 Double) + , mmvel :: Component f 'Field (V2 Double) + , velFact :: Component f 'Field Double + , rot :: Component f 'Field Direction + , obstacle :: Component f 'Field (Boundaries Double) + , player :: Component f 'Unique () + , npcMoveState :: Component f 'Field NPCMoveState + , anim :: Component f 'Field AnimState + , objAccess :: Component f 'Field ((V2 Int), Direction) + , objType :: Component f 'Field ObjType + , objState :: Component f 'Field ObjState + , objStateTime :: Component f 'Field Double + } + deriving (Generic) diff --git a/src/Types/NPCState.hs b/src/Types/NPCState.hs new file mode 100644 index 0000000..a57d2a1 --- /dev/null +++ b/src/Types/NPCState.hs @@ -0,0 +1,13 @@ +module Types.NPCState where + +import Control.Concurrent.MVar (MVar) +import Linear (V2) + +data NPCMoveState + = NPCWalking + { npcWalkPath :: [V2 Int] + } + | NPCStanding + { npcStandTime :: Double + , npcFuturePath :: MVar [V2 Int] + } diff --git a/src/Types/ObjClass.hs b/src/Types/ObjClass.hs new file mode 100644 index 0000000..e9e1894 --- /dev/null +++ b/src/Types/ObjClass.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module Types.ObjClass where + +import Affection + +import Data.Ecstasy + +import Types.Entity +import Types.UserData + +class ObjectAction otype ostate where + objectAction + :: Double + -> otype + -> ostate + -> Ent + -> SystemT Entity (AffectionState (AffectionData UserData) IO) () + + objectTransition + :: otype + -> ostate + -> Ent + -> SystemT Entity (AffectionState (AffectionData UserData) IO) (Entity 'SetterOf) + +class ActionTime otype ostate where + actionTime :: otype -> ostate -> Double diff --git a/src/Types/ObjType.hs b/src/Types/ObjType.hs index 9ad9745..aae2e6e 100644 --- a/src/Types/ObjType.hs +++ b/src/Types/ObjType.hs @@ -11,7 +11,12 @@ data ObjType | ObjToilet deriving (Show, Eq, Ord, Enum) -class ObjectAction us t where - objectAction :: t -> Ent -> Affection us () +type ObjState = String - objectUpdate :: t -> Ent -> Affection us () +-- class ObjectAction us otype ostate where +-- objectAction :: otype -> ostate -> Ent -> Affection us () +-- +-- objectTransition :: otype -> ostate -> Ent -> Affection us Entity +-- +-- class ActionTime otype ostate where +-- actionTime :: otype -> ostate -> Double diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index 608d54c..7c977ad 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -24,6 +24,8 @@ import Types.FontId import Types.Direction import Types.Animation import Types.ObjType +import Types.Entity +import Types.NPCState data UserData = UserData { state :: State @@ -33,9 +35,12 @@ data UserData = UserData , assetAnimations :: M.Map AnimId Animation , nano :: Context , uuid :: [UUID] - , worldState :: SystemState Entity IO + , worldState :: SystemState Entity (AffectionState (AffectionData UserData) IO) , stateData :: StateData - , stateMVar :: MVar (SystemState Entity IO, StateData) + , stateMVar :: MVar + ( SystemState Entity (AffectionState (AffectionData UserData) IO) + , StateData + ) , stateProgress :: MVar (Float, T.Text) , threadContext :: Maybe SDL.GLContext , window :: Maybe SDL.Window @@ -49,31 +54,33 @@ data SubMain = WorldMap | MindMap -data Entity f = Entity - { pos :: Component f 'Field (V2 Double) - , mmpos :: Component f 'Field (V2 Double) - , gridPos :: Component f 'Field (V2 Int) - , vel :: Component f 'Field (V2 Double) - , mmvel :: Component f 'Field (V2 Double) - , velFact :: Component f 'Field Double - , rot :: Component f 'Field Direction - , obstacle :: Component f 'Field (Boundaries Double) - , player :: Component f 'Unique () - , npcMoveState :: Component f 'Field NPCMoveState - , anim :: Component f 'Field AnimState - , objAccess :: Component f 'Field ((V2 Int), Direction) - , objType :: Component f 'Field ObjType - } - deriving (Generic) - -data NPCMoveState - = NPCWalking - { npcWalkPath :: [V2 Int] - } - | NPCStanding - { npcStandTime :: Double - , npcFuturePath :: MVar [V2 Int] - } +-- data Entity f = Entity +-- { pos :: Component f 'Field (V2 Double) +-- , mmpos :: Component f 'Field (V2 Double) +-- , gridPos :: Component f 'Field (V2 Int) +-- , vel :: Component f 'Field (V2 Double) +-- , mmvel :: Component f 'Field (V2 Double) +-- , velFact :: Component f 'Field Double +-- , rot :: Component f 'Field Direction +-- , obstacle :: Component f 'Field (Boundaries Double) +-- , player :: Component f 'Unique () +-- , npcMoveState :: Component f 'Field NPCMoveState +-- , anim :: Component f 'Field AnimState +-- , objAccess :: Component f 'Field ((V2 Int), Direction) +-- , objType :: Component f 'Field ObjType +-- , objState :: Component f 'Field ObjState +-- , objStateTime :: Component f 'Field Double +-- } +-- deriving (Generic) +-- +-- data NPCMoveState +-- = NPCWalking +-- { npcWalkPath :: [V2 Int] +-- } +-- | NPCStanding +-- { npcStandTime :: Double +-- , npcFuturePath :: MVar [V2 Int] +-- } data Subsystems = Subsystems { subWindow :: Window diff --git a/tracer-game.cabal b/tracer-game.cabal index e443712..bec17cf 100644 --- a/tracer-game.cabal +++ b/tracer-game.cabal @@ -31,6 +31,9 @@ executable tracer-game , Types.Drawable , Types.Collidible , Types.ObjType + , Types.ObjClass + , Types.Entity + , Types.NPCState , Animation , StateMachine , Floorplan @@ -67,6 +70,7 @@ executable tracer-game , JuicyPixels-extra , bytestring , algebraic-graphs + , mtl hs-source-dirs: src ghc-options: -Wall -threaded default-language: Haskell2010