reworking interactions

This commit is contained in:
nek0 2018-08-10 08:58:26 +02:00
parent a0f198a18d
commit bcdd04e7d5
14 changed files with 248 additions and 65 deletions

View file

@ -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;
};

View file

@ -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
}

View file

@ -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

View file

@ -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)
, worldState = ws
}
update :: Double -> Affection UserData ()

View file

@ -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

View file

@ -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)
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
}

View file

@ -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
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
with anim
liftIO $ logIO Debug "copying!"
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
}
putAffection ud
{ worldState = nws
{ objState = Set "copying"
, anim = Set nstat
}
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")

View file

@ -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

30
src/Types/Entity.hs Normal file
View file

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

13
src/Types/NPCState.hs Normal file
View file

@ -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]
}

26
src/Types/ObjClass.hs Normal file
View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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