nek0/tracer
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

finish porting process

Browse source
This commit is contained in:
nek0 2020-05-05 10:26:16 +02:00
parent a33fec68d4
commit cdd5db2b73
11 changed files with 482 additions and 513 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
shell.nix
View file

@ -26,25 +26,25 @@ let
}) {}; }) {};
algebraic-graphs = with haskellPackages; callPackage( algebraic-graphs = with haskellPackages; callPackage(
{ mkDerivation, array, base, base-compat, base-orphans, containers { mkDerivation, array, base, containers, deepseq, extra
, deepseq, extra, inspection-testing, mtl, QuickCheck, stdenv , inspection-testing, mtl, QuickCheck, stdenv, transformers
}: }:
mkDerivation { mkDerivation {
pname = "algebraic-graphs"; pname = "algebraic-graphs";
version = "0.4"; version = "0.5";
sha256 = "c905d32a6178a11e3c8096dbbf3bd19e570e87362c51fdc8653b43a51e46d3b7"; sha256 = "89b9fecf8245476ec823355125fcb95decf41fd9784e807d7bd0d09f0a79c50b";
libraryHaskellDepends = [ libraryHaskellDepends = [
array base base-compat containers deepseq mtl array base containers deepseq mtl transformers
]; ];
testHaskellDepends = [ testHaskellDepends = [
array base base-compat base-orphans containers extra array base containers deepseq extra inspection-testing mtl
inspection-testing QuickCheck QuickCheck transformers
]; ];
homepage = "https://github.com/snowleopard/alga"; homepage = "https://github.com/snowleopard/alga";
description = "A library for algebraic graph construction and transformation"; description = "A library for algebraic graph construction and transformation";
license = stdenv.lib.licenses.mit; license = stdenv.lib.licenses.mit;
doCheck = false; }
}) {}; ) {};
nanovg = with haskellPackages; callPackage( nanovg = with haskellPackages; callPackage(
{ mkDerivation, base, bytestring, c2hs, containers, glew { mkDerivation, base, bytestring, c2hs, containers, glew

37
src/Init.hs
View file

@ -38,24 +38,25 @@ init = do
_ <- glewInit _ <- glewInit
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes]) nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
UserData UserData
<$> newMVar Load <$> newMVar Load -- state
<*> pure subs <*> pure subs -- subsystems
<*> newMVar M.empty <*> newMVar M.empty -- assetIcons
<*> newMVar M.empty <*> newMVar M.empty -- assetImages
<*> newMVar M.empty <*> newMVar M.empty -- assetFonts
<*> newMVar M.empty <*> newMVar M.empty -- assetAnimations
<*> newMVar NoController <*> newMVar NoController -- controls
<*> newMVar NoTranslation <*> newMVar NoTranslation -- translation
<*> pure nvg <*> pure nvg -- nano
<*> newMVar [] <*> newMVar [] -- uuid
<*> newEmptyMVar <*> newEmptyMVar -- worldState <-
<*> newMVar None <*> newMVar None -- stateData
<*> newEmptyMVar <*> newEmptyMVar -- stateMVar <-
<*> newMVar (0, "foobar!") <*> newEmptyMVar -- stateProgress <-
<*> newMVar Nothing <*> newMVar Nothing -- threadContext
<*> newMVar Nothing <*> newMVar Nothing -- window
<*> newMVar [] <*> newMVar [] -- joyCache
<*> newEmptyMVar <*> newEmptyMVar -- joyUUID <-
<*> newMVar True -- doNextStep
loadPlayerSprite loadPlayerSprite
:: FilePath -- Path to spritemap :: FilePath -- Path to spritemap

2
src/Interior.hs
View file

@ -1,7 +1,5 @@
module Interior where module Interior where
import qualified Affection as A
import Data.Matrix as M import Data.Matrix as M
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.List as L import Data.List as L

9
src/Load.hs
View file

@ -32,8 +32,7 @@ loadLoad ud = do
curWin <- liftIO $ readMVar (window ud) curWin <- liftIO $ readMVar (window ud)
tContext <- liftIO $ readMVar (threadContext ud) tContext <- liftIO $ readMVar (threadContext ud)
let progress = (0, "Starting up") let progress = (0, "Starting up")
void $ liftIO $ swapMVar (stateProgress ud) progress void $ liftIO $ putMVar (stateProgress ud) progress
void $ liftIO $ tryReadMVar (stateMVar ud)
_ <- liftIO $ createFont (nano ud) "bedstead" _ <- liftIO $ createFont (nano ud) "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf") (FileName "assets/font/Bedstead-Semicondensed.ttf")
_ <- liftIO $ forkIO $ _ <- liftIO $ forkIO $
@ -491,9 +490,13 @@ loadFork ws win glc nvg future progress = do
] ]
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Handing over" , "GL_Finish"
))) )))
finish finish
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Handing over"
)))
putMVar future putMVar future
( ws ( ws
, LoadData , LoadData

127
src/Main.hs
View file

@ -15,7 +15,8 @@ import Foreign.C.Types (CInt(..))
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Control.Monad (when) import Control.Monad
import Control.Concurrent.MVar
-- internal imports -- internal imports
@ -27,6 +28,15 @@ import Util
foreign import ccall unsafe "glewInit" foreign import ccall unsafe "glewInit"
glewInit :: IO CInt glewInit :: IO CInt
instance Affectionate UserData where
preLoop = (\ud -> pre ud >> smLoad Load ud)
handleEvents = handle
update = Main.update
draw = Main.draw
loadState = Init.init
cleanUp = clean
hasNextStep = liftIO . readMVar . doNextStep
main :: IO () main :: IO ()
main = do main = do
let config = AffectionConfig let config = AffectionConfig
@ -41,93 +51,84 @@ main = do
{ SDL.glProfile = SDL.Core SDL.Normal 3 3 { SDL.glProfile = SDL.Core SDL.Normal 3 3
} }
} }
, SDL.Windowed
) )
] ]
, canvasSize = Nothing } :: AffectionConfig UserData
, preLoop = pre >> smLoad Load
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, loadState = Init.init
, cleanUp = clean
, initScreenMode = SDL.Windowed
}
withAffection config withAffection config
pre :: Affection UserData () pre :: UserData -> Affection ()
pre = do pre ud = do
ad <- A.get ad <- A.get
ud <- getAffection threadCtx <- SDL.glCreateContext ((\(_, y, _) -> y) $ head $ drawWindows ad)
threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad) SDL.glMakeCurrent ((\(_, y, _) -> y) $ head $ drawWindows ad) (snd $ head $ glContext ad)
SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad) let Subsystems w _ k j _ = subsystems ud
let Subsystems w m k j t = subsystems ud
_ <- partSubscribe w (fitViewport (1280/720)) _ <- partSubscribe w (fitViewport (1280/720))
_ <- partSubscribe w exitOnWindowClose _ <- partSubscribe w (exitOnWindowClose ud)
_ <- partSubscribe k toggleFullScreen _ <- partSubscribe k toggleFullScreen
_ <- partSubscribe k quitGame _ <- partSubscribe k (quitGame ud)
u <- partSubscribe j cacheJoypad u <- partSubscribe j (cacheJoypad ud)
(ws, _) <- yieldSystemT (0, defStorage) (return ()) (ws, _) <- yieldSystemT (0, defStorage) (return ())
putAffection ud void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx)
{ threadContext = Just threadCtx void $ liftIO $ swapMVar (window ud) (Just $ (\(_, y, _) -> y) $ head $ drawWindows ad)
, window = Just (snd $ head $ drawWindows ad) void $ liftIO $ putMVar (worldState ud) ws
, worldState = ws void $ liftIO $ putMVar (joyUUID ud) u
, joyUUID = u
}
quitGame :: KeyboardMessage -> Affection UserData () quitGame :: UserData -> KeyboardMessage -> Affection ()
quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym) quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeEscape = quit | SDL.keysymKeycode sym == SDL.KeycodeEscape =
void $ liftIO $ swapMVar (doNextStep ud) False
| SDL.keysymKeycode sym == SDL.KeycodeF5 = do | SDL.keysymKeycode sym == SDL.KeycodeF5 = do
ad <- A.get ad <- A.get
ud <- getAffection curState <- liftIO $ readMVar (state ud)
when (state ud == Main WorldMap || state ud == Main MindMap) $ do when (curState == Main WorldMap || curState == Main MindMap) $ do
let Subsystems w m k j t = subsystems ud let Subsystems w m k j t = subsystems ud
mapM_ (partUnSubscribe w) (uuid ud) curUUID <- liftIO $ readMVar (uuid ud)
mapM_ (partUnSubscribe m) (uuid ud) mapM_ (partUnSubscribe w) curUUID
mapM_ (partUnSubscribe k) (uuid ud) mapM_ (partUnSubscribe m) curUUID
mapM_ (partUnSubscribe j) (uuid ud) mapM_ (partUnSubscribe k) curUUID
mapM_ (partUnSubscribe t) (uuid ud) mapM_ (partUnSubscribe j) curUUID
mapM_ (partUnSubscribe t) curUUID
SDL.glMakeCurrent SDL.glMakeCurrent
(snd $ head $ drawWindows ad) ((\(_, y, _) -> y) $ head $ drawWindows ad)
(snd $ head $ glContext ad) (snd $ head $ glContext ad)
(ws, _) <- yieldSystemT (0, defStorage) (return ()) (ws, _) <- yieldSystemT (0, defStorage) (return ())
putAffection ud void $ liftIO $ swapMVar (worldState ud) ws
{ worldState = ws void $ liftIO $ swapMVar (state ud) Load
, state = Load smLoad Load ud
} | otherwise = return ()
smLoad Load quitGame _ _ = return ()
| otherwise = return ()
quitGame _ = return ()
toggleFullScreen :: KeyboardMessage -> Affection UserData () toggleFullScreen :: KeyboardMessage -> Affection ()
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
| otherwise = return () | otherwise = return ()
toggleFullScreen _ = return () toggleFullScreen _ = return ()
update :: Double -> Affection UserData () update :: UserData -> Double -> Affection ()
update dt = do update ud dt = do
ud <- getAffection curState <- liftIO $ readMVar (state ud)
smUpdate (state ud) dt smUpdate curState ud dt
draw :: Affection UserData () draw :: UserData -> Affection ()
draw = do draw ud = do
ud <- getAffection curState <- liftIO $ readMVar (state ud)
liftIO $ beginFrame (nano ud) 1280 720 1 liftIO $ beginFrame (nano ud) 1280 720 1
smDraw (state ud) smDraw curState ud
liftIO $ endFrame (nano ud) liftIO $ endFrame (nano ud)
handle :: [SDL.EventPayload] -> Affection UserData () handle :: UserData -> [SDL.EventPayload] -> Affection ()
handle evs = do handle ud evs = do
s <- state <$> getAffection s <- liftIO $ readMVar (state ud)
smEvent s evs smEvent s ud evs
exitOnWindowClose :: WindowMessage -> Affection UserData () exitOnWindowClose :: UserData -> WindowMessage -> Affection ()
exitOnWindowClose (MsgWindowClose _ _) = do exitOnWindowClose ud (MsgWindowClose _ _) = do
liftIO $ logIO A.Debug "Window Closed" liftIO $ logIO A.Debug "Window Closed"
quit void $ liftIO $ swapMVar (doNextStep ud) False
exitOnWindowClose _ = return () exitOnWindowClose _ _ = return ()
clean :: UserData -> IO () clean :: UserData -> IO ()
clean ud = clean ud = do
SDL.glDeleteContext $ fromJust $ threadContext ud tContext <- readMVar (threadContext ud)
SDL.glDeleteContext $ fromJust tContext

289
src/MainGame/MindMap.hs
View file

@ -15,6 +15,9 @@ import Data.String
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
import Control.Concurrent.MVar
import Control.Monad
-- internal imports -- internal imports
import Types import Types
@ -25,145 +28,146 @@ import Collision
import Util import Util
updateMind :: Double -> Affection UserData () updateMind :: UserData -> Double -> Affection ()
updateMind dt = do updateMind ud dt = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ do sData <- liftIO $ readMVar (stateData ud)
emap allEnts $ do (nws, _) <- yieldSystemT wState $ do
with player emap allEnts $ do
with xyvel with player
with mmvel with xyvel
V2 rx ry <- query xyvel with mmvel
-- let dr = (ry / sin (atan (1/2)) / 2) + rx V2 rx ry <- query xyvel
-- dc = rx - (ry / sin (atan (1/2)) / 2) -- let dr = (ry / sin (atan (1/2)) / 2) + rx
let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45) -- dc = rx - (ry / sin (atan (1/2)) / 2)
return $ unchanged let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
{ mmvel = Set $ 2 * V2 dr dc return $ unchanged
} { mmvel = Set $ 2 * V2 dr dc
emap allEnts $ do }
with anim emap allEnts $ do
with mmpos with anim
stat <- query anim with mmpos
let an = assetAnimations ud Map.! asId stat stat <- query anim
ntime = asElapsedTime stat + dt aAnims <- liftIO $ readMVar (assetAnimations ud)
nstate = if ntime > fromIntegral (asCurrentFrame stat) * let an = aAnims Map.! asId stat
(animDuration an / fromIntegral (length $ animSprites an)) ntime = asElapsedTime stat + dt
then nstate = if ntime > fromIntegral (asCurrentFrame stat) *
let nframe = asCurrentFrame stat + 1 (animDuration an / fromIntegral (length $ animSprites an))
in case animPlay an of then
APLoop -> let nframe = asCurrentFrame stat + 1
let (nnframe, nntime) = in case animPlay an of
if nframe >= length (animSprites an) APLoop ->
then (0, 0) let (nnframe, nntime) =
else (nframe, ntime) if nframe >= length (animSprites an)
in stat then (0, 0)
{ asCurrentFrame = nnframe else (nframe, ntime)
, asElapsedTime = nntime in stat
} { asCurrentFrame = nnframe
APOnce -> , asElapsedTime = nntime
let nnframe = if nframe >= length (animSprites an) }
then nframe - 1 APOnce ->
else nframe let nnframe = if nframe >= length (animSprites an)
in stat then nframe - 1
{ asCurrentFrame = nnframe else nframe
, asElapsedTime = ntime in stat
} { asCurrentFrame = nnframe
else , asElapsedTime = ntime
stat }
{ asElapsedTime = ntime else
} stat
return $ unchanged { asElapsedTime = ntime
{ anim = Set nstate }
} return $ unchanged
emap allEnts $ do { anim = Set nstate
with player }
with mmvel emap allEnts $ do
with mmpos with player
with rot with mmvel
with anim with mmpos
pos'@(V2 pr pc) <- query mmpos with rot
vel' <- query mmvel with anim
rot' <- query rot pos'@(V2 pr pc) <- query mmpos
stat <- query anim vel' <- query mmvel
let npos = pos' + fmap (* dt) vel' rot' <- query rot
dpos@(V2 dpr dpc) = npos - pos' stat <- query anim
aId = asId stat let npos = pos' + fmap (* dt) vel'
nstat = case aiName aId of dpos@(V2 dpr dpc) = npos - pos'
"walking" aId = asId stat
| sqrt (colldpos `dot` colldpos) > 0 -> nstat = case aiName aId of
stat "walking"
{ asId = aId | sqrt (colldpos `dot` colldpos) > 0 ->
{ aiDirection = fromMaybe rot' (direction vel') stat
} { asId = aId
} { aiDirection = fromMaybe rot' (direction vel')
| otherwise -> }
stat }
{ asId = aId | otherwise ->
{ aiDirection = fromMaybe rot' (direction vel') stat
, aiName = "standing" { asId = aId
} { aiDirection = fromMaybe rot' (direction vel')
, asCurrentFrame = 0 , aiName = "standing"
} }
"standing" , asCurrentFrame = 0
| sqrt (colldpos `dot` colldpos) > 0 -> }
stat "standing"
{ asId = aId | sqrt (colldpos `dot` colldpos) > 0 ->
{ aiDirection = fromMaybe rot' (direction vel') stat
, aiName = "walking" { asId = aId
} { aiDirection = fromMaybe rot' (direction vel')
, asCurrentFrame = 0 , aiName = "walking"
} }
| otherwise -> , asCurrentFrame = 0
stat }
{ asId = aId | otherwise ->
{ aiDirection = fromMaybe rot' (direction vel') stat
} { asId = aId
} { aiDirection = fromMaybe rot' (direction vel')
x -> error ("unknown animation name" ++ x) }
lll = (,) }
<$> ( x -> error ("unknown animation name" ++ x)
if dpr < 0 lll = (,)
then [(floor dpr :: Int) .. 0] <$> (
else [0 .. (ceiling dpr :: Int)]) if dpr < 0
<*> ( then [(floor dpr :: Int) .. 0]
if dpc < 0 else [0 .. (ceiling dpr :: Int)])
then [(floor dpc :: Int) .. 0] <*> (
else [0 .. (ceiling dpc :: Int)]) if dpc < 0
colldpos = dpos * Prelude.foldl then [(floor dpc :: Int) .. 0]
(\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a else [0 .. (ceiling dpc :: Int)])
in A.log A.Verbose (fromString $ show ret) ret) colldpos = dpos * Prelude.foldl
(V2 1 1) (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
( in A.log A.Verbose (fromString $ show ret) ret)
concatMap (V2 1 1)
(\(dr, dc) -> (
let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet concatMap
(fromIntegral $ floor pr + dr) (\(dr, dc) ->
(fromIntegral $ floor pc + dc) let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet
(mmImgMat (stateData ud)) (fromIntegral $ floor pr + dr)
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))-> (fromIntegral $ floor pc + dc)
Boundaries (mmImgMat sData)
(minr + fromIntegral dr, minc + fromIntegral dc) in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
(maxr + fromIntegral dr, maxc + fromIntegral dc) Boundaries
) bs (minr + fromIntegral dr, minc + fromIntegral dc)
) (maxr + fromIntegral dr, maxc + fromIntegral dc)
lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll) ) bs
) )
ent = unchanged lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
{ mmpos = Set $ pos' + colldpos )
, rot = Set (fromMaybe rot' $ direction vel') ent = unchanged
, anim = Set nstat { mmpos = Set $ pos' + colldpos
} , rot = Set (fromMaybe rot' $ direction vel')
return ent , anim = Set nstat
putAffection ud }
{ worldState = nws return ent
} void $ liftIO $ swapMVar (worldState ud) nws
drawMind :: Affection UserData () drawMind :: UserData -> Affection ()
drawMind = do drawMind ud = do
ud <- getAffection sData <- liftIO $ readMVar (stateData ud)
wState <- liftIO $ readMVar (worldState ud)
let ctx = nano ud let ctx = nano ud
dt <- getDelta dt <- getDelta
(_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do (_, (playerPos, posanims)) <- yieldSystemT wState $ do
pc <- fmap head $ efor allEnts $ do pc <- fmap head $ efor allEnts $ do
with player with player
with mmpos with mmpos
@ -177,7 +181,7 @@ drawMind = do
return (pos', stat, mbnds) return (pos', stat, mbnds)
return (pc, posanims) return (pc, posanims)
let V2 pr pc = playerPos let V2 pr pc = playerPos
mat = mmImgMat (stateData ud) mat = mmImgMat sData
cols = fromIntegral (ncols mat) cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat) rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double tileWidth = 64 :: Double
@ -185,8 +189,8 @@ drawMind = do
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2) x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2) y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
partposanims = M.fromList partposanims = M.fromList
(nrows $ mmImgMat $ stateData ud) (nrows $ mmImgMat $ sData)
(ncols $ mmImgMat $ stateData ud) (ncols $ mmImgMat $ sData)
((reverse . fst) ((reverse . fst)
(Prelude.foldl (Prelude.foldl
(\(done, proc) coord -> (\(done, proc) coord ->
@ -195,8 +199,8 @@ drawMind = do
) )
([], posanims) ([], posanims)
((,) ((,)
<$> [1 .. (nrows $ mmImgMat $ stateData ud)] <$> [1 .. (nrows $ mmImgMat $ sData)]
<*> [1 .. (ncols $ mmImgMat $ stateData ud)] <*> [1 .. (ncols $ mmImgMat $ sData)]
) )
) )
) )
@ -230,7 +234,8 @@ drawMind = do
(reverse $ zip [1..] ls)) (reverse $ zip [1..] ls))
(zip [1..] (toLists mat)) (zip [1..] (toLists mat))
fontSize ctx 20 fontSize ctx 20
fontFace ctx (assetFonts ud Map.! FontBedstead) aFonts <- readMVar (assetFonts ud)
fontFace ctx (aFonts Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter,AlignTop]) textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgb 255 128 0) fillColor ctx (rgb 255 128 0)
textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt))) textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt)))

247
src/MainGame/WorldMap.hs
View file

@ -11,7 +11,6 @@ import qualified SDL
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
import Control.Monad (when, void) import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State.Strict (evalStateT) import Control.Monad.State.Strict (evalStateT)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
@ -44,63 +43,49 @@ import NPC
import Animation import Animation
import Collision import Collision
loadMap :: Affection UserData () loadMap :: UserData -> Affection ()
loadMap = do loadMap ud = do
ud <- getAffection
ad <- get ad <- get
let (Subsystems _ _ k j t) = subsystems ud let (Subsystems _ _ k j t) = subsystems ud
uu0 <- partSubscribe k emitKbdActionMessage uu0 <- partSubscribe k (emitKbdActionMessage ud)
uu1 <- partSubscribe j emitJoyActionMessage uu1 <- partSubscribe j (emitJoyActionMessage ud)
uu2 <- partSubscribe t movePlayer2 uu2 <- partSubscribe t (movePlayer2 ud)
uu3 <- partSubscribe t playerInteract2 uu3 <- partSubscribe t (playerInteract2 ud)
uu4 <- partSubscribe t changeMaps2 uu4 <- partSubscribe t (changeMaps2 ud)
future <- liftIO newEmptyMVar void $ liftIO $ swapMVar (stateProgress ud) (0, "Ohai!")
progress <- liftIO $ newMVar (0, "Ohai!") _ <- liftIO $ forkIO $ loadMapFork ud ad (stateMVar ud) (stateProgress ud)
_ <- liftIO $ forkIO $ loadMapFork ud ad future progress void $ liftIO $ swapMVar (stateData ud) None
putAffection ud void $ liftIO $ swapMVar (uuid ud) [ uu0, uu1, uu2, uu3, uu4 ]
{ stateData = None void $ liftIO $ swapMVar (state ud) (Main WorldMap)
, uuid = [ uu0, uu1, uu2, uu3, uu4 ]
, stateMVar = future
, stateProgress = progress
, state = Main WorldMap
}
changeMaps :: KeyboardMessage -> Affection UserData () changeMaps :: UserData -> KeyboardMessage -> Affection ()
changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym) changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF1 = do | SDL.keysymKeycode sym == SDL.KeycodeF1 = do
ud <- getAffection curState <- liftIO $ readMVar (state ud)
case state ud of case curState of
Main MindMap -> Main MindMap ->
putAffection ud void $ liftIO $ swapMVar (state ud) (Main WorldMap)
{ state = Main WorldMap
}
Main WorldMap -> Main WorldMap ->
putAffection ud void $ liftIO $ swapMVar (state ud) (Main MindMap)
{ state = Main MindMap
}
_ -> return () _ -> return ()
| otherwise = return () | otherwise = return ()
changeMaps _ = return () changeMaps _ _ = return ()
changeMaps2 :: ActionMessage -> Affection UserData () changeMaps2 :: UserData -> ActionMessage -> Affection ()
changeMaps2 (ActionMessage ActSwitchMap _) = do changeMaps2 ud (ActionMessage ActSwitchMap _) = do
ud <- getAffection curState <- liftIO $ readMVar (state ud)
case state ud of case curState of
Main MindMap -> Main MindMap ->
putAffection ud void $ liftIO $ swapMVar (state ud) (Main WorldMap)
{ state = Main WorldMap
}
Main WorldMap -> Main WorldMap ->
putAffection ud void $ liftIO $ swapMVar (state ud) (Main MindMap)
{ state = Main MindMap
}
_ -> return () _ -> return ()
changeMaps2 _ = return () changeMaps2 _ _ = return ()
loadMapFork loadMapFork
:: UserData :: UserData
-> AffectionData UserData -> AffectionData
-> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData) -> MVar (SystemState Entity (AffectionState AffectionData IO), StateData)
-> MVar (Float, T.Text) -> MVar (Float, T.Text)
-> IO () -> IO ()
loadMapFork ud ad future progress = do loadMapFork ud ad future progress = do
@ -144,7 +129,8 @@ loadMapFork ud ad future progress = do
( p + increment ( p + increment
, "Creating WorldState" , "Creating WorldState"
))) )))
(nws, mmimgmat) <- evalStateT (runState (yieldSystemT (worldState ud) $ do wState <- liftIO $ readMVar (worldState ud)
(nws, mmimgmat) <- evalStateT (runState (yieldSystemT wState $ do
liftIO $ modifyMVar_ progress (return . (\(p, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Registering copiers into WorldState" , "Registering copiers into WorldState"
@ -352,7 +338,7 @@ loadMapFork ud ad future progress = do
then Nothing then Nothing
else a) else a)
(M.toList inter) (M.toList inter)
putMVar future (nws, MainData void $ putMVar future (nws, MainData
{ mapMat = mat { mapMat = mat
, imgMat = retMat , imgMat = retMat
, reachPoints = V.fromList rps , reachPoints = V.fromList rps
@ -360,11 +346,11 @@ loadMapFork ud ad future progress = do
, roomGraph = gr , roomGraph = gr
}) })
movePlayerKbd :: KeyboardMessage -> Affection UserData () movePlayerKbd :: UserData -> KeyboardMessage -> Affection ()
movePlayerKbd (MsgKeyboardEvent _ _ press False sym) movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
| SDL.keysymKeycode sym == SDL.KeycodeW = do | SDL.keysymKeycode sym == SDL.KeycodeW = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ (nws, _) <- yieldSystemT wState $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 vx _) <- query xyvel (V2 vx _) <- query xyvel
@ -374,12 +360,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 vx ry { xyvel = Set $ V2 vx ry
} }
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeS = do | SDL.keysymKeycode sym == SDL.KeycodeS = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ (nws, _) <- yieldSystemT wState $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 vx _) <- query xyvel (V2 vx _) <- query xyvel
@ -389,12 +373,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 vx ry { xyvel = Set $ V2 vx ry
} }
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeA = do | SDL.keysymKeycode sym == SDL.KeycodeA = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ (nws, _) <- yieldSystemT wState $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 _ vy) <- query xyvel (V2 _ vy) <- query xyvel
@ -404,12 +386,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 rx vy { xyvel = Set $ V2 rx vy
} }
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeD = do | SDL.keysymKeycode sym == SDL.KeycodeD = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ (nws, _) <- yieldSystemT wState $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 _ vy) <- query xyvel (V2 _ vy) <- query xyvel
@ -419,16 +399,14 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 rx vy { xyvel = Set $ V2 rx vy
} }
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws
}
| otherwise = return () | otherwise = return ()
movePlayerKbd _ = return () movePlayerKbd _ _ = return ()
movePlayer2 :: ActionMessage -> Affection UserData () movePlayer2 :: UserData -> ActionMessage -> Affection ()
movePlayer2 (ActionMessage mov _) = do movePlayer2 ud (ActionMessage mov _) = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ (nws, _) <- yieldSystemT wState $
emap allEnts $ do emap allEnts $ do
with player with player
V2 vx vy <- query xyvel V2 vx vy <- query xyvel
@ -440,14 +418,12 @@ movePlayer2 (ActionMessage mov _) = do
ActRight f -> V2 f vy ActRight f -> V2 f vy
_ -> V2 vx vy _ -> V2 vx vy
} }
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws
}
playerInteract2 :: ActionMessage -> Affection UserData () playerInteract2 :: UserData -> ActionMessage -> Affection ()
playerInteract2 (ActionMessage ActActivate _) = do playerInteract2 ud (ActionMessage ActActivate _) = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ do (nws, _) <- yieldSystemT wState $ do
pdata <- efor allEnts $ do pdata <- efor allEnts $ do
with player with player
with pos with pos
@ -478,22 +454,21 @@ playerInteract2 (ActionMessage ActActivate _) = do
mapM_ (\(t, s, e) -> mapM_ (\(t, s, e) ->
setEntity e =<< objectTransition t s True e (Just pent) setEntity e =<< objectTransition t s True e (Just pent)
) relEnts ) relEnts
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws playerInteract2 _ _ = return ()
}
playerInteract2 _ = return ()
drawMap :: Affection UserData () drawMap :: UserData -> Affection ()
drawMap = do drawMap ud = do
ud <- getAffection sData <- liftIO $ readMVar (stateData ud)
wState <- liftIO $ readMVar (worldState ud)
let ctx = nano ud let ctx = nano ud
case stateData ud of case sData of
None -> liftIO $ do None -> liftIO $ do
progress <- readMVar (stateProgress ud) progress <- readMVar (stateProgress ud)
drawLoadScreen ud progress drawLoadScreen ud progress
_ -> do _ -> do
dt <- getDelta dt <- getDelta
(_, dat) <- yieldSystemT (worldState ud) $ do (_, dat) <- yieldSystemT wState $ do
efor allEnts $ do efor allEnts $ do
with pos with pos
pos' <- query pos pos' <- query pos
@ -534,10 +509,10 @@ drawMap = do
([], [], []) ([], [], [])
dat dat
V2 pr pc = playerPos V2 pr pc = playerPos
MainData _ _ _ _ gr = stateData ud MainData _ _ _ _ gr = sData
seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr) seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr)
room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
mat = imgMat (stateData ud) mat = imgMat sData
cols = fromIntegral (ncols mat) cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat) rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double tileWidth = 64 :: Double
@ -545,8 +520,8 @@ drawMap = do
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2) x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2) y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
partposanims = M.fromList partposanims = M.fromList
(nrows $ mapMat $ stateData ud) (nrows $ mapMat sData)
(ncols $ mapMat $ stateData ud) (ncols $ mapMat sData)
((reverse . fst) ((reverse . fst)
(Prelude.foldl (Prelude.foldl
(\(done, proc) coord -> (\(done, proc) coord ->
@ -555,8 +530,8 @@ drawMap = do
) )
([], posanims) ([], posanims)
((,) ((,)
<$> [1 .. (nrows $ mapMat $ stateData ud)] <$> [1 .. (nrows $ mapMat sData)]
<*> [1 .. (ncols $ mapMat $ stateData ud)] <*> [1 .. (ncols $ mapMat sData)]
) )
) )
) )
@ -634,7 +609,8 @@ drawMap = do
closePath ctx closePath ctx
) posActions ) posActions
fontSize ctx 20 fontSize ctx 20
fontFace ctx (assetFonts ud Map.! FontBedstead) aFonts <- readMVar (assetFonts ud)
fontFace ctx (aFonts Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter,AlignTop]) textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgb 255 128 0) fillColor ctx (rgb 255 128 0)
textBox ctx 0 0 200 ( textBox ctx 0 0 200 (
@ -656,23 +632,23 @@ drawTile
-> Int -> Int
-> Maybe ImgId -> Maybe ImgId
-> IO () -> IO ()
drawTile ud ctx posanims pr pc row col img = drawTile ud ctx posanims pr pc row col img = do
do let (bef, beh) = L.partition delimiter sorted
let (bef, beh) = L.partition delimiter sorted aImages <- readMVar (assetImages ud)
save ctx save ctx
mapM_ (flip drawAnim fact) beh mapM_ (flip drawAnim fact) beh
maybe (return ()) (draw ud x (y - 42) 64 74 maybe (return ()) (Types.draw ud x (y - 42) 64 74
(if fromMaybe False (isWall <$> img) then fact else 1)) (if fromMaybe False (isWall <$> img) then fact else 1))
((assetImages ud Map.!) <$> case img of ((aImages Map.!) <$> case img of
Just ImgEmpty -> Nothing Just ImgEmpty -> Nothing
_ -> img _ -> img
) )
mapM_ (flip drawAnim fact) bef mapM_ (flip drawAnim fact) bef
restore ctx restore ctx
-- when (floor pr == row && floor pc == col) $ do -- when (floor pr == row && floor pc == col) $ do
-- A.logIO A.Debug ("sorted: " ++ show sorted) -- A.logIO A.Debug ("sorted: " ++ show sorted)
-- A.logIO A.Debug ("beh: " ++ show beh) -- A.logIO A.Debug ("beh: " ++ show beh)
-- A.logIO A.Debug ("bef: " ++ show bef) -- A.logIO A.Debug ("bef: " ++ show bef)
where where
delimiter (V2 nr nc, as, mbnds) = delimiter (V2 nr nc, as, mbnds) =
animFloats (asId as) || animFloats (asId as) ||
@ -726,29 +702,30 @@ drawTile ud ctx posanims pr pc row col img =
drawAnim (V2 nr nc, as, _) factor = do drawAnim (V2 nr nc, as, _) factor = do
let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32 let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32
ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58 ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58
draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as Types.draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as
updateMap :: Double -> Affection UserData () updateMap :: UserData -> Double -> Affection ()
updateMap dt = do updateMap ud dt = do
ud <- getAffection osData <- liftIO $ readMVar (stateData ud)
if stateData ud == None if osData == None
then do then do
mstart <- liftIO $ tryTakeMVar (stateMVar ud) mstart <- liftIO $ tryTakeMVar (stateMVar ud)
case mstart of case mstart of
Just (nws, mendat) -> do Just (nws, mendat) -> do
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws void $ liftIO $ swapMVar (stateData ud) mendat
, stateData = mendat void $ liftIO $ swapMVar (state ud) (Main WorldMap)
, state = Main WorldMap updateMap ud 0.1
} updateMap ud 0.1
updateMap 0.1 updateMap ud 0.1
updateMap 0.1 updateMap ud 19
updateMap 0.1
updateMap 19
liftIO $ logIO A.Debug "Loaded game data" liftIO $ logIO A.Debug "Loaded game data"
Nothing -> return () Nothing -> return ()
else do else do
(nws, _) <- yieldSystemT (worldState ud) $ do wState <- liftIO $ readMVar (worldState ud)
sData <- liftIO $ readMVar (stateData ud)
aAnim <- liftIO $ readMVar (assetAnimations ud)
(nws, _) <- yieldSystemT wState $ do
obstacleBounds <- efor allEnts $ do obstacleBounds <- efor allEnts $ do
with obstacle with obstacle
with pos with pos
@ -762,8 +739,8 @@ updateMap dt = do
fact' <- fromMaybe 1 <$> queryMaybe velFact fact' <- fromMaybe 1 <$> queryMaybe velFact
xyv2 <- queryMaybe xyvel xyv2 <- queryMaybe xyvel
stat <- query anim stat <- query anim
let an = assetAnimations ud Map.! asId stat let an = aAnim Map.! asId stat
mat = mapMat (stateData ud) mat = mapMat sData
ntime = asElapsedTime stat + dt ntime = asElapsedTime stat + dt
npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel') npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel')
dpos@(V2 dpr dpc) = npos - pos' dpos@(V2 dpr dpc) = npos - pos'
@ -789,7 +766,7 @@ updateMap dt = do
(fromMaybe [] $ collisionObstacle <$> M.unsafeGet (fromMaybe [] $ collisionObstacle <$> M.unsafeGet
(min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr) (min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr)
(min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc) (min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc)
(imgMat (stateData ud))) (imgMat sData))
(Prelude.map snd $ Prelude.filter (Prelude.map snd $ Prelude.filter
(\((V2 br bc), _) -> (\((V2 br bc), _) ->
floor pr + dr == floor br && floor pr + dr == floor br &&
@ -899,14 +876,12 @@ updateMap dt = do
objectAction dt t s e objectAction dt t s e
) tses ) tses
(nws2, _) <- yieldSystemT nws $ updateNPCs (nws2, _) <- yieldSystemT nws $ updateNPCs
(imgMat $ stateData ud) (imgMat sData)
(mapMat $ stateData ud) (mapMat sData)
nws nws
(V.filter (V.filter
(\p -> pointType p /= RoomExit) (\p -> pointType p /= RoomExit)
(reachPoints $ stateData ud) (reachPoints sData)
) )
dt dt
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws2
{ worldState = nws2
}

251
src/Menu/Connect.hs
View file

@ -10,9 +10,10 @@ import Linear hiding (rotate, translation)
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (isNothing, isJust)
import Data.String import Data.String
import Control.Concurrent.MVar
import Control.Monad import Control.Monad
-- internal imports -- internal imports
@ -22,108 +23,94 @@ import Util
import Menu.Adjust import Menu.Adjust
import MainGame.WorldMap import MainGame.WorldMap
loadMenu :: Affection UserData () loadMenu :: UserData -> Affection ()
loadMenu = do loadMenu ud = do
ud <- getAffection
ad <- get
let (Subsystems _ m k j t) = subsystems ud let (Subsystems _ m k j t) = subsystems ud
uu1 <- partSubscribe j joystickConnect uu1 <- partSubscribe j (joystickConnect ud)
uu2 <- partSubscribe j joystickDisconnect uu2 <- partSubscribe j (joystickDisconnect ud)
uu3 <- partSubscribe j emitJoyActionMessage uu3 <- partSubscribe j (emitJoyActionMessage ud)
uu4 <- partSubscribe k emitKbdActionMessage uu4 <- partSubscribe k (emitKbdActionMessage ud)
uu5 <- partSubscribe t handleActionMessages uu5 <- partSubscribe t (handleActionMessages ud)
uu6 <- partSubscribe m handleClicks uu6 <- partSubscribe m (handleClicks ud)
-- uu6 <- partSubscribe k emitKbdActionMessage -- uu6 <- partSubscribe k emitKbdActionMessage
partUnSubscribe j (joyUUID ud) juuid <- liftIO $ readMVar (joyUUID ud)
putAffection ud partUnSubscribe j juuid
{ uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ] cache <- liftIO $ readMVar (joyCache ud)
, state = Menu Connect void $ liftIO $ swapMVar (uuid ud) [ uu1, uu2, uu3, uu4, uu5, uu6 ]
, stateData = MenuData (V2 0 0) S 0 0 void $ liftIO $ swapMVar (state ud) (Menu Connect)
, joyCache = [] void $ liftIO $ swapMVar (stateData ud) (MenuData (V2 0 0) S 0 0)
} void $ liftIO $ swapMVar (joyCache ud) []
mapM_ (partEmit j) (joyCache ud) mapM_ (partEmit j) cache
joystickConnect :: JoystickMessage -> Affection UserData () joystickConnect :: UserData -> JoystickMessage -> Affection ()
joystickConnect msg = do joystickConnect ud msg = do
ud <- getAffection ctrls <- liftIO $ readMVar (controls ud)
when (controls ud == NoController) $ do when (ctrls == NoController) $ do
mjoy <- joystickAutoConnect msg mjoy <- joystickAutoConnect msg
maybe (return ()) (\joy -> do maybe (return ()) (\joy -> do
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show ident) liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show (ident :: Int))
putAffection ud void $ liftIO $ swapMVar (controls ud) (Joystick joy)
{ controls = Joystick joy void $ liftIO $ swapMVar (translation ud) (JoyTranslation defaultJoyTranslation)
, translation = JoyTranslation defaultJoyTranslation
}
) mjoy ) mjoy
joystickDisconnect :: JoystickMessage -> Affection UserData () joystickDisconnect :: UserData -> JoystickMessage -> Affection ()
joystickDisconnect msg = do joystickDisconnect ud msg = do
ud <- getAffection ctrls <- liftIO $ readMVar (controls ud)
case controls ud of case ctrls of
Joystick joy -> do Joystick joy -> do
njoys <- joystickAutoDisconnect [joy] msg njoys <- joystickAutoDisconnect [joy] msg
when (null njoys) $ do when (null njoys) $ do
liftIO $ logIO A.Debug $ "Joystick disconnected" liftIO $ logIO A.Debug $ "Joystick disconnected"
putAffection ud void $ liftIO $ swapMVar (controls ud) NoController
{ controls = NoController void $ liftIO $ swapMVar (translation ud) NoTranslation
, translation = NoTranslation
}
_ -> return () _ -> return ()
handleActionMessages :: ActionMessage -> Affection UserData () handleActionMessages :: UserData -> ActionMessage -> Affection ()
handleActionMessages (ActionMessage ActActivate _) = do handleActionMessages ud (ActionMessage ActActivate _) = do
ud <- getAffection liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
putAffection ud { activate = 0.5
{ stateData = (stateData ud)
{ activate = 0.5
}
} }
handleActionMessages (ActionMessage ActSwitchMap _) = do )
ud <- getAffection handleActionMessages ud (ActionMessage ActSwitchMap _) = do
putAffection ud liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
{ stateData = (stateData ud) { switchMap = 0.5
{ switchMap = 0.5
}
} }
handleActionMessages (ActionMessage (ActUp f) _) = do )
ud <- getAffection handleActionMessages ud (ActionMessage (ActUp f) _) = do
let V2 vx _ = velocity $ stateData ud liftIO $ modifyMVar_ (stateData ud) (\dat ->
putAffection ud let V2 vx _ = velocity dat
{ stateData = (stateData ud) in return dat
{ velocity = (V2 vx (-f)) { velocity = (V2 vx (-f))
} }
} )
handleActionMessages (ActionMessage (ActDown f) _) = do handleActionMessages ud (ActionMessage (ActDown f) _) = do
ud <- getAffection liftIO $ modifyMVar_ (stateData ud) (\dat ->
let V2 vx _ = velocity $ stateData ud let V2 vx _ = velocity dat
putAffection ud in return dat
{ stateData = (stateData ud)
{ velocity = (V2 vx f) { velocity = (V2 vx f)
} }
} )
handleActionMessages (ActionMessage (ActLeft f) _) = do handleActionMessages ud (ActionMessage (ActLeft f) _) = do
ud <- getAffection liftIO $ modifyMVar_ (stateData ud) (\dat ->
let V2 _ vy = velocity $ stateData ud let V2 _ vy = velocity dat
putAffection ud in return dat
{ stateData = (stateData ud)
{ velocity = (V2 (-f) vy) { velocity = (V2 (-f) vy)
} }
} )
handleActionMessages (ActionMessage (ActRight f) _) = do handleActionMessages ud (ActionMessage (ActRight f) _) = do
ud <- getAffection liftIO $ modifyMVar_ (stateData ud) (\dat ->
let V2 _ vy = velocity $ stateData ud let V2 _ vy = velocity dat
putAffection ud in return dat
{ stateData = (stateData ud)
{ velocity = (V2 f vy) { velocity = (V2 f vy)
} }
} )
handleClicks :: MouseMessage -> Affection UserData () handleClicks :: UserData -> MouseMessage -> Affection ()
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do
ud <- getAffection rels <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords cpos)
rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos) ctrls <- liftIO $ readMVar (controls ud)
case controls ud of case ctrls of
Joystick _ -> do Joystick _ -> do
when (arrowUp rels) adjustKbdUp when (arrowUp rels) adjustKbdUp
when (arrowDown rels) adjustKbdDown when (arrowDown rels) adjustKbdDown
@ -133,40 +120,36 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
when (buttonSwitchMap rels) adjustKbdSwitchMap when (buttonSwitchMap rels) adjustKbdSwitchMap
when (buttonPlay rels) enterGame when (buttonPlay rels) enterGame
NoController -> do NoController -> do
when (kbdIcon rels) $ when (kbdIcon rels) $ do
putAffection ud void $ liftIO $ swapMVar (controls ud) Keyboard
{ controls = Keyboard void $ liftIO $ swapMVar (translation ud) (KbdTranslation defaultKbdTranslation)
, translation = KbdTranslation defaultKbdTranslation
}
Keyboard -> do Keyboard -> do
when (kbdIcon rels) $ when (kbdIcon rels) $ do
putAffection ud void $ liftIO $ swapMVar (controls ud) NoController
{ controls = NoController void $ liftIO $ swapMVar (translation ud) NoTranslation
, translation = NoTranslation
}
when (buttonPlay rels) enterGame when (buttonPlay rels) enterGame
where where
adjustKbdUp = do adjustKbdUp = do
fullClean fullClean ud
loadAdjust (ActUp 1) Keyboard loadMenu loadAdjust ud (ActUp 1) Keyboard (loadMenu ud)
adjustKbdDown = do adjustKbdDown = do
fullClean fullClean ud
loadAdjust (ActDown 1) Keyboard loadMenu loadAdjust ud (ActDown 1) Keyboard (loadMenu ud)
adjustKbdLeft = do adjustKbdLeft = do
fullClean fullClean ud
loadAdjust (ActLeft 1) Keyboard loadMenu loadAdjust ud (ActLeft 1) Keyboard (loadMenu ud)
adjustKbdRight = do adjustKbdRight = do
fullClean fullClean ud
loadAdjust (ActRight 1) Keyboard loadMenu loadAdjust ud (ActRight 1) Keyboard (loadMenu ud)
adjustKbdActivate = do adjustKbdActivate = do
fullClean fullClean ud
loadAdjust ActActivate Keyboard loadMenu loadAdjust ud ActActivate Keyboard (loadMenu ud)
adjustKbdSwitchMap = do adjustKbdSwitchMap = do
fullClean fullClean ud
loadAdjust ActSwitchMap Keyboard loadMenu loadAdjust ud ActSwitchMap Keyboard (loadMenu ud)
enterGame = do enterGame = do
fullClean fullClean ud
loadMap loadMap ud
arrowUp (V2 rx ry) = arrowUp (V2 rx ry) =
rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720 rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
arrowDown (V2 rx ry) = arrowDown (V2 rx ry) =
@ -183,33 +166,35 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720 rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
kbdIcon (V2 rx ry) = kbdIcon (V2 rx ry) =
rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720 rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720
handleClicks _ = return () handleClicks _ _ = return ()
updateMenu :: Double -> Affection UserData () updateMenu :: UserData -> Double -> Affection ()
updateMenu dt = do updateMenu ud dt = do
ud <- getAffection sData <- liftIO $ readMVar (stateData ud)
case stateData ud of case sData of
MenuData _ _ _ _ -> MenuData _ _ _ _ ->
putAffection ud void $ liftIO $ swapMVar (stateData ud) (
{ stateData = MenuData MenuData
(velocity $ stateData ud) (velocity sData)
(rotation $ stateData ud) (rotation sData)
(max 0 ((activate $ stateData ud) - dt)) (max 0 ((activate sData) - dt))
(max 0 ((switchMap $ stateData ud) - dt)) (max 0 ((switchMap sData) - dt))
} )
_ -> return () _ -> return ()
drawMenu :: Affection UserData () drawMenu :: UserData -> Affection ()
drawMenu = do drawMenu ud = do
ud <- getAffection sData <- liftIO $ readMVar (stateData ud)
case stateData ud of curState <- liftIO $ readMVar (state ud)
aIcons <- liftIO $ readMVar (assetIcons ud)
case sData of
MenuData _ _ _ _ -> MenuData _ _ _ _ ->
liftIO $ do liftIO $ do
let ctx = nano ud let ctx = nano ud
controller = controls ud controller <- readMVar (controls ud)
save ctx save ctx
beginPath ctx beginPath ctx
cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.! cpaint <- imagePattern ctx 550 620 80 80 0 (aIcons M.!
case controller of case controller of
Joystick _ -> IconContrGreen Joystick _ -> IconContrGreen
_ -> IconContrBlue _ -> IconContrBlue
@ -219,17 +204,17 @@ drawMenu = do
closePath ctx closePath ctx
fill ctx fill ctx
beginPath ctx beginPath ctx
cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.! cpaint2 <- imagePattern ctx 650 620 80 80 0 (aIcons M.!
case controller of case controller of
Keyboard -> IconKbdGreen Keyboard -> IconKbdGreen
_ -> IconKbdBlue _ -> IconKbdBlue
) 1 ) 1
rect ctx 650 620 80 80 rect ctx 650 620 80 80
fillPaint ctx cpaint fillPaint ctx cpaint2
closePath ctx closePath ctx
fill ctx fill ctx
when (controller /= NoController) $ do when (controller /= NoController) $ do
let V2 vx vy = velocity $ stateData ud let V2 vx vy = velocity sData
beginPath ctx beginPath ctx
roundedRect ctx 140 110 1000 500 25 roundedRect ctx 140 110 1000 500 25
strokeWidth ctx 5 strokeWidth ctx 5
@ -240,7 +225,7 @@ drawMenu = do
mapM_ (\deg -> do mapM_ (\deg -> do
let V2 px py = fmap realToFrac $ let V2 px py = fmap realToFrac $
V2 360 360 - V2 50 50 + fmap realToFrac rot V2 360 360 - V2 50 50 + fmap realToFrac rot
rot@(V2 rx ry) = fmap (fromIntegral . floor) $ rot = fmap (fromIntegral . floor) $
V2 0 120 `rotVec` deg :: V2 Int V2 0 120 `rotVec` deg :: V2 Int
save ctx save ctx
translate ctx (px + 50) (py + 50) translate ctx (px + 50) (py + 50)
@ -254,7 +239,7 @@ drawMenu = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case state ud of case curState of
Menu (Adjust (ActUp _) _) -> do Menu (Adjust (ActUp _) _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
@ -276,7 +261,7 @@ drawMenu = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case state ud of case curState of
Menu (Adjust (ActLeft _) _) -> do Menu (Adjust (ActLeft _) _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
@ -298,7 +283,7 @@ drawMenu = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case state ud of case curState of
Menu (Adjust (ActUp _) _) -> do Menu (Adjust (ActUp _) _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
@ -320,7 +305,7 @@ drawMenu = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case state ud of case curState of
Menu (Adjust (ActLeft _) _) -> do Menu (Adjust (ActLeft _) _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
@ -336,20 +321,20 @@ drawMenu = do
_ -> _ ->
return () return ()
beginPath ctx beginPath ctx
apaint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1 apaint <- imagePattern ctx 0 0 100 100 0 (aIcons M.! IconArrow) 1
rect ctx 0 0 100 100 rect ctx 0 0 100 100
fillPaint ctx apaint fillPaint ctx apaint
closePath ctx closePath ctx
fill ctx fill ctx
restore ctx restore ctx
) [0, 90, 180, 270] ) [0, 90, 180, 270]
when (activate (stateData ud) > 0) $ do when (activate sData > 0) $ do
beginPath ctx beginPath ctx
fillColor ctx (rgb 255 128 0) fillColor ctx (rgb 255 128 0)
roundedRect ctx 650 160 150 50 10 roundedRect ctx 650 160 150 50 10
fill ctx fill ctx
closePath ctx closePath ctx
case state ud of case curState of
Menu (Adjust ActActivate _) -> do Menu (Adjust ActActivate _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
@ -368,13 +353,13 @@ drawMenu = do
fillColor ctx (rgb 255 255 255) fillColor ctx (rgb 255 255 255)
textBox ctx 650 175 150 "Activate" textBox ctx 650 175 150 "Activate"
closePath ctx closePath ctx
when (switchMap (stateData ud) > 0) $ do when (switchMap sData > 0) $ do
beginPath ctx beginPath ctx
fillColor ctx (rgb 255 128 0) fillColor ctx (rgb 255 128 0)
roundedRect ctx 650 220 150 50 10 roundedRect ctx 650 220 150 50 10
fill ctx fill ctx
closePath ctx closePath ctx
case state ud of case curState of
Menu (Adjust ActSwitchMap _) -> do Menu (Adjust ActSwitchMap _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)

2
src/Navigation.hs
View file

@ -3,7 +3,7 @@ module Navigation where
import Affection as A import Affection as A
import Data.Matrix as M import Data.Matrix as M
import Data.Maybe (isJust, catMaybes) import Data.Maybe (isJust)
-- internal imports -- internal imports

12
src/StateMachine.hs
View file

@ -13,26 +13,26 @@ import MainGame.WorldMap
import MainGame.MindMap import MainGame.MindMap
import Util import Util
instance StateMachine State UserData where instance StateMachine UserData State where
smLoad Load = loadLoad smLoad Load = loadLoad
smLoad (Menu Connect) = loadMenu smLoad (Menu Connect) = loadMenu
smLoad (Menu (Adjust a c)) = loadAdjust a c loadMenu smLoad (Menu (Adjust a c)) = (\ud -> loadAdjust ud a c (loadMenu ud))
smLoad (Main _) = loadMap smLoad (Main _) = loadMap
smUpdate Load = updateLoad smUpdate Load = updateLoad
smUpdate (Menu Connect) = updateMenu smUpdate (Menu Connect) = updateMenu
smUpdate (Menu (Adjust _ _)) = const (return ()) smUpdate (Menu (Adjust _ _)) = const $ const (return ())
smUpdate (Main WorldMap) = updateMap smUpdate (Main WorldMap) = updateMap
smUpdate (Main MindMap) = updateMind smUpdate (Main MindMap) = updateMind
smDraw Load = drawLoad smDraw Load = drawLoad
smDraw (Menu Connect) = drawMenu smDraw (Menu Connect) = drawMenu
smDraw (Menu (Adjust _ _)) = drawMenu >> drawAdjust smDraw (Menu (Adjust _ _)) = (\ud -> drawMenu ud >> drawAdjust (nano ud))
smDraw (Main WorldMap) = drawMap smDraw (Main WorldMap) = drawMap
smDraw (Main MindMap) = drawMind smDraw (Main MindMap) = drawMind
smEvent _ evs = do smEvent _ ud evs = do
Subsystems w m k j _ <- subsystems <$> getAffection let Subsystems w m k j _ = subsystems ud
_ <- consumeSDLEvents j =<< _ <- consumeSDLEvents j =<<
consumeSDLEvents k =<< consumeSDLEvents k =<<
consumeSDLEvents w =<< consumeSDLEvents w =<<

1
src/Types/UserData.hs
View file

@ -45,6 +45,7 @@ data UserData = UserData
, window :: MVar (Maybe SDL.Window) , window :: MVar (Maybe SDL.Window)
, joyCache :: MVar [JoystickMessage] , joyCache :: MVar [JoystickMessage]
, joyUUID :: MVar UUID , joyUUID :: MVar UUID
, doNextStep :: MVar Bool
} }
data Controller data Controller