finish porting process
This commit is contained in:
parent
a33fec68d4
commit
cdd5db2b73
11 changed files with 482 additions and 513 deletions
18
shell.nix
18
shell.nix
|
|
@ -26,25 +26,25 @@ let
|
|||
}) {};
|
||||
|
||||
algebraic-graphs = with haskellPackages; callPackage(
|
||||
{ mkDerivation, array, base, base-compat, base-orphans, containers
|
||||
, deepseq, extra, inspection-testing, mtl, QuickCheck, stdenv
|
||||
{ mkDerivation, array, base, containers, deepseq, extra
|
||||
, inspection-testing, mtl, QuickCheck, stdenv, transformers
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "algebraic-graphs";
|
||||
version = "0.4";
|
||||
sha256 = "c905d32a6178a11e3c8096dbbf3bd19e570e87362c51fdc8653b43a51e46d3b7";
|
||||
version = "0.5";
|
||||
sha256 = "89b9fecf8245476ec823355125fcb95decf41fd9784e807d7bd0d09f0a79c50b";
|
||||
libraryHaskellDepends = [
|
||||
array base base-compat containers deepseq mtl
|
||||
array base containers deepseq mtl transformers
|
||||
];
|
||||
testHaskellDepends = [
|
||||
array base base-compat base-orphans containers extra
|
||||
inspection-testing QuickCheck
|
||||
array base containers deepseq extra inspection-testing mtl
|
||||
QuickCheck transformers
|
||||
];
|
||||
homepage = "https://github.com/snowleopard/alga";
|
||||
description = "A library for algebraic graph construction and transformation";
|
||||
license = stdenv.lib.licenses.mit;
|
||||
doCheck = false;
|
||||
}) {};
|
||||
}
|
||||
) {};
|
||||
|
||||
nanovg = with haskellPackages; callPackage(
|
||||
{ mkDerivation, base, bytestring, c2hs, containers, glew
|
||||
|
|
|
|||
37
src/Init.hs
37
src/Init.hs
|
|
@ -38,24 +38,25 @@ init = do
|
|||
_ <- glewInit
|
||||
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
|
||||
UserData
|
||||
<$> newMVar Load
|
||||
<*> pure subs
|
||||
<*> newMVar M.empty
|
||||
<*> newMVar M.empty
|
||||
<*> newMVar M.empty
|
||||
<*> newMVar M.empty
|
||||
<*> newMVar NoController
|
||||
<*> newMVar NoTranslation
|
||||
<*> pure nvg
|
||||
<*> newMVar []
|
||||
<*> newEmptyMVar
|
||||
<*> newMVar None
|
||||
<*> newEmptyMVar
|
||||
<*> newMVar (0, "foobar!")
|
||||
<*> newMVar Nothing
|
||||
<*> newMVar Nothing
|
||||
<*> newMVar []
|
||||
<*> newEmptyMVar
|
||||
<$> newMVar Load -- state
|
||||
<*> pure subs -- subsystems
|
||||
<*> newMVar M.empty -- assetIcons
|
||||
<*> newMVar M.empty -- assetImages
|
||||
<*> newMVar M.empty -- assetFonts
|
||||
<*> newMVar M.empty -- assetAnimations
|
||||
<*> newMVar NoController -- controls
|
||||
<*> newMVar NoTranslation -- translation
|
||||
<*> pure nvg -- nano
|
||||
<*> newMVar [] -- uuid
|
||||
<*> newEmptyMVar -- worldState <-
|
||||
<*> newMVar None -- stateData
|
||||
<*> newEmptyMVar -- stateMVar <-
|
||||
<*> newEmptyMVar -- stateProgress <-
|
||||
<*> newMVar Nothing -- threadContext
|
||||
<*> newMVar Nothing -- window
|
||||
<*> newMVar [] -- joyCache
|
||||
<*> newEmptyMVar -- joyUUID <-
|
||||
<*> newMVar True -- doNextStep
|
||||
|
||||
loadPlayerSprite
|
||||
:: FilePath -- Path to spritemap
|
||||
|
|
|
|||
|
|
@ -1,7 +1,5 @@
|
|||
module Interior where
|
||||
|
||||
import qualified Affection as A
|
||||
|
||||
import Data.Matrix as M
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.List as L
|
||||
|
|
|
|||
|
|
@ -32,8 +32,7 @@ loadLoad ud = do
|
|||
curWin <- liftIO $ readMVar (window ud)
|
||||
tContext <- liftIO $ readMVar (threadContext ud)
|
||||
let progress = (0, "Starting up")
|
||||
void $ liftIO $ swapMVar (stateProgress ud) progress
|
||||
void $ liftIO $ tryReadMVar (stateMVar ud)
|
||||
void $ liftIO $ putMVar (stateProgress ud) progress
|
||||
_ <- liftIO $ createFont (nano ud) "bedstead"
|
||||
(FileName "assets/font/Bedstead-Semicondensed.ttf")
|
||||
_ <- liftIO $ forkIO $
|
||||
|
|
@ -491,9 +490,13 @@ loadFork ws win glc nvg future progress = do
|
|||
]
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Handing over"
|
||||
, "GL_Finish"
|
||||
)))
|
||||
finish
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Handing over"
|
||||
)))
|
||||
putMVar future
|
||||
( ws
|
||||
, LoadData
|
||||
|
|
|
|||
125
src/Main.hs
125
src/Main.hs
|
|
@ -15,7 +15,8 @@ import Foreign.C.Types (CInt(..))
|
|||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
-- internal imports
|
||||
|
||||
|
|
@ -27,6 +28,15 @@ import Util
|
|||
foreign import ccall unsafe "glewInit"
|
||||
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 = do
|
||||
let config = AffectionConfig
|
||||
|
|
@ -41,93 +51,84 @@ main = do
|
|||
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
|
||||
}
|
||||
}
|
||||
, SDL.Windowed
|
||||
)
|
||||
]
|
||||
, canvasSize = Nothing
|
||||
, preLoop = pre >> smLoad Load
|
||||
, eventLoop = handle
|
||||
, updateLoop = update
|
||||
, drawLoop = draw
|
||||
, loadState = Init.init
|
||||
, cleanUp = clean
|
||||
, initScreenMode = SDL.Windowed
|
||||
}
|
||||
} :: AffectionConfig UserData
|
||||
withAffection config
|
||||
|
||||
pre :: Affection UserData ()
|
||||
pre = do
|
||||
pre :: UserData -> Affection ()
|
||||
pre ud = do
|
||||
ad <- A.get
|
||||
ud <- getAffection
|
||||
threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad)
|
||||
SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad)
|
||||
let Subsystems w m k j t = subsystems ud
|
||||
threadCtx <- SDL.glCreateContext ((\(_, y, _) -> y) $ head $ drawWindows ad)
|
||||
SDL.glMakeCurrent ((\(_, y, _) -> y) $ head $ drawWindows ad) (snd $ head $ glContext ad)
|
||||
let Subsystems w _ k j _ = subsystems ud
|
||||
_ <- partSubscribe w (fitViewport (1280/720))
|
||||
_ <- partSubscribe w exitOnWindowClose
|
||||
_ <- partSubscribe w (exitOnWindowClose ud)
|
||||
_ <- partSubscribe k toggleFullScreen
|
||||
_ <- partSubscribe k quitGame
|
||||
u <- partSubscribe j cacheJoypad
|
||||
_ <- partSubscribe k (quitGame ud)
|
||||
u <- partSubscribe j (cacheJoypad ud)
|
||||
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
||||
putAffection ud
|
||||
{ threadContext = Just threadCtx
|
||||
, window = Just (snd $ head $ drawWindows ad)
|
||||
, worldState = ws
|
||||
, joyUUID = u
|
||||
}
|
||||
void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx)
|
||||
void $ liftIO $ swapMVar (window ud) (Just $ (\(_, y, _) -> y) $ head $ drawWindows ad)
|
||||
void $ liftIO $ putMVar (worldState ud) ws
|
||||
void $ liftIO $ putMVar (joyUUID ud) u
|
||||
|
||||
quitGame :: KeyboardMessage -> Affection UserData ()
|
||||
quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeEscape = quit
|
||||
quitGame :: UserData -> KeyboardMessage -> Affection ()
|
||||
quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeEscape =
|
||||
void $ liftIO $ swapMVar (doNextStep ud) False
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeF5 = do
|
||||
ad <- A.get
|
||||
ud <- getAffection
|
||||
when (state ud == Main WorldMap || state ud == Main MindMap) $ do
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
when (curState == Main WorldMap || curState == Main MindMap) $ do
|
||||
let Subsystems w m k j t = subsystems ud
|
||||
mapM_ (partUnSubscribe w) (uuid ud)
|
||||
mapM_ (partUnSubscribe m) (uuid ud)
|
||||
mapM_ (partUnSubscribe k) (uuid ud)
|
||||
mapM_ (partUnSubscribe j) (uuid ud)
|
||||
mapM_ (partUnSubscribe t) (uuid ud)
|
||||
curUUID <- liftIO $ readMVar (uuid ud)
|
||||
mapM_ (partUnSubscribe w) curUUID
|
||||
mapM_ (partUnSubscribe m) curUUID
|
||||
mapM_ (partUnSubscribe k) curUUID
|
||||
mapM_ (partUnSubscribe j) curUUID
|
||||
mapM_ (partUnSubscribe t) curUUID
|
||||
SDL.glMakeCurrent
|
||||
(snd $ head $ drawWindows ad)
|
||||
((\(_, y, _) -> y) $ head $ drawWindows ad)
|
||||
(snd $ head $ glContext ad)
|
||||
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
||||
putAffection ud
|
||||
{ worldState = ws
|
||||
, state = Load
|
||||
}
|
||||
smLoad Load
|
||||
void $ liftIO $ swapMVar (worldState ud) ws
|
||||
void $ liftIO $ swapMVar (state ud) Load
|
||||
smLoad Load ud
|
||||
| otherwise = return ()
|
||||
quitGame _ = return ()
|
||||
quitGame _ _ = return ()
|
||||
|
||||
toggleFullScreen :: KeyboardMessage -> Affection UserData ()
|
||||
toggleFullScreen :: KeyboardMessage -> Affection ()
|
||||
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
|
||||
| otherwise = return ()
|
||||
toggleFullScreen _ = return ()
|
||||
|
||||
update :: Double -> Affection UserData ()
|
||||
update dt = do
|
||||
ud <- getAffection
|
||||
smUpdate (state ud) dt
|
||||
update :: UserData -> Double -> Affection ()
|
||||
update ud dt = do
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
smUpdate curState ud dt
|
||||
|
||||
draw :: Affection UserData ()
|
||||
draw = do
|
||||
ud <- getAffection
|
||||
draw :: UserData -> Affection ()
|
||||
draw ud = do
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
liftIO $ beginFrame (nano ud) 1280 720 1
|
||||
smDraw (state ud)
|
||||
smDraw curState ud
|
||||
liftIO $ endFrame (nano ud)
|
||||
|
||||
handle :: [SDL.EventPayload] -> Affection UserData ()
|
||||
handle evs = do
|
||||
s <- state <$> getAffection
|
||||
smEvent s evs
|
||||
handle :: UserData -> [SDL.EventPayload] -> Affection ()
|
||||
handle ud evs = do
|
||||
s <- liftIO $ readMVar (state ud)
|
||||
smEvent s ud evs
|
||||
|
||||
exitOnWindowClose :: WindowMessage -> Affection UserData ()
|
||||
exitOnWindowClose (MsgWindowClose _ _) = do
|
||||
exitOnWindowClose :: UserData -> WindowMessage -> Affection ()
|
||||
exitOnWindowClose ud (MsgWindowClose _ _) = do
|
||||
liftIO $ logIO A.Debug "Window Closed"
|
||||
quit
|
||||
exitOnWindowClose _ = return ()
|
||||
void $ liftIO $ swapMVar (doNextStep ud) False
|
||||
exitOnWindowClose _ _ = return ()
|
||||
|
||||
clean :: UserData -> IO ()
|
||||
clean ud =
|
||||
SDL.glDeleteContext $ fromJust $ threadContext ud
|
||||
clean ud = do
|
||||
tContext <- readMVar (threadContext ud)
|
||||
SDL.glDeleteContext $ fromJust tContext
|
||||
|
|
|
|||
|
|
@ -15,6 +15,9 @@ import Data.String
|
|||
|
||||
import NanoVG hiding (V2(..))
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Types
|
||||
|
|
@ -25,10 +28,11 @@ import Collision
|
|||
|
||||
import Util
|
||||
|
||||
updateMind :: Double -> Affection UserData ()
|
||||
updateMind dt = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $ do
|
||||
updateMind :: UserData -> Double -> Affection ()
|
||||
updateMind ud dt = do
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
(nws, _) <- yieldSystemT wState $ do
|
||||
emap allEnts $ do
|
||||
with player
|
||||
with xyvel
|
||||
|
|
@ -44,7 +48,8 @@ updateMind dt = do
|
|||
with anim
|
||||
with mmpos
|
||||
stat <- query anim
|
||||
let an = assetAnimations ud Map.! asId stat
|
||||
aAnims <- liftIO $ readMVar (assetAnimations ud)
|
||||
let an = aAnims Map.! asId stat
|
||||
ntime = asElapsedTime stat + dt
|
||||
nstate = if ntime > fromIntegral (asCurrentFrame stat) *
|
||||
(animDuration an / fromIntegral (length $ animSprites an))
|
||||
|
|
@ -139,7 +144,7 @@ updateMind dt = do
|
|||
let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet
|
||||
(fromIntegral $ floor pr + dr)
|
||||
(fromIntegral $ floor pc + dc)
|
||||
(mmImgMat (stateData ud))
|
||||
(mmImgMat sData)
|
||||
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
|
||||
Boundaries
|
||||
(minr + fromIntegral dr, minc + fromIntegral dc)
|
||||
|
|
@ -154,16 +159,15 @@ updateMind dt = do
|
|||
, anim = Set nstat
|
||||
}
|
||||
return ent
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
|
||||
drawMind :: Affection UserData ()
|
||||
drawMind = do
|
||||
ud <- getAffection
|
||||
drawMind :: UserData -> Affection ()
|
||||
drawMind ud = do
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
let ctx = nano ud
|
||||
dt <- getDelta
|
||||
(_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do
|
||||
(_, (playerPos, posanims)) <- yieldSystemT wState $ do
|
||||
pc <- fmap head $ efor allEnts $ do
|
||||
with player
|
||||
with mmpos
|
||||
|
|
@ -177,7 +181,7 @@ drawMind = do
|
|||
return (pos', stat, mbnds)
|
||||
return (pc, posanims)
|
||||
let V2 pr pc = playerPos
|
||||
mat = mmImgMat (stateData ud)
|
||||
mat = mmImgMat sData
|
||||
cols = fromIntegral (ncols mat)
|
||||
rows = fromIntegral (nrows mat)
|
||||
tileWidth = 64 :: Double
|
||||
|
|
@ -185,8 +189,8 @@ drawMind = do
|
|||
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
|
||||
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
|
||||
partposanims = M.fromList
|
||||
(nrows $ mmImgMat $ stateData ud)
|
||||
(ncols $ mmImgMat $ stateData ud)
|
||||
(nrows $ mmImgMat $ sData)
|
||||
(ncols $ mmImgMat $ sData)
|
||||
((reverse . fst)
|
||||
(Prelude.foldl
|
||||
(\(done, proc) coord ->
|
||||
|
|
@ -195,8 +199,8 @@ drawMind = do
|
|||
)
|
||||
([], posanims)
|
||||
((,)
|
||||
<$> [1 .. (nrows $ mmImgMat $ stateData ud)]
|
||||
<*> [1 .. (ncols $ mmImgMat $ stateData ud)]
|
||||
<$> [1 .. (nrows $ mmImgMat $ sData)]
|
||||
<*> [1 .. (ncols $ mmImgMat $ sData)]
|
||||
)
|
||||
)
|
||||
)
|
||||
|
|
@ -230,7 +234,8 @@ drawMind = do
|
|||
(reverse $ zip [1..] ls))
|
||||
(zip [1..] (toLists mat))
|
||||
fontSize ctx 20
|
||||
fontFace ctx (assetFonts ud Map.! FontBedstead)
|
||||
aFonts <- readMVar (assetFonts ud)
|
||||
fontFace ctx (aFonts Map.! FontBedstead)
|
||||
textAlign ctx (S.fromList [AlignCenter,AlignTop])
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt)))
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@ import qualified SDL
|
|||
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)
|
||||
|
|
@ -44,63 +43,49 @@ import NPC
|
|||
import Animation
|
||||
import Collision
|
||||
|
||||
loadMap :: Affection UserData ()
|
||||
loadMap = do
|
||||
ud <- getAffection
|
||||
loadMap :: UserData -> Affection ()
|
||||
loadMap ud = do
|
||||
ad <- get
|
||||
let (Subsystems _ _ k j t) = subsystems ud
|
||||
uu0 <- partSubscribe k emitKbdActionMessage
|
||||
uu1 <- partSubscribe j emitJoyActionMessage
|
||||
uu2 <- partSubscribe t movePlayer2
|
||||
uu3 <- partSubscribe t playerInteract2
|
||||
uu4 <- partSubscribe t changeMaps2
|
||||
future <- liftIO newEmptyMVar
|
||||
progress <- liftIO $ newMVar (0, "Ohai!")
|
||||
_ <- liftIO $ forkIO $ loadMapFork ud ad future progress
|
||||
putAffection ud
|
||||
{ stateData = None
|
||||
, uuid = [ uu0, uu1, uu2, uu3, uu4 ]
|
||||
, stateMVar = future
|
||||
, stateProgress = progress
|
||||
, state = Main WorldMap
|
||||
}
|
||||
uu0 <- partSubscribe k (emitKbdActionMessage ud)
|
||||
uu1 <- partSubscribe j (emitJoyActionMessage ud)
|
||||
uu2 <- partSubscribe t (movePlayer2 ud)
|
||||
uu3 <- partSubscribe t (playerInteract2 ud)
|
||||
uu4 <- partSubscribe t (changeMaps2 ud)
|
||||
void $ liftIO $ swapMVar (stateProgress ud) (0, "Ohai!")
|
||||
_ <- liftIO $ forkIO $ loadMapFork ud ad (stateMVar ud) (stateProgress ud)
|
||||
void $ liftIO $ swapMVar (stateData ud) None
|
||||
void $ liftIO $ swapMVar (uuid ud) [ uu0, uu1, uu2, uu3, uu4 ]
|
||||
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
||||
|
||||
changeMaps :: KeyboardMessage -> Affection UserData ()
|
||||
changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
changeMaps :: UserData -> KeyboardMessage -> Affection ()
|
||||
changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeF1 = do
|
||||
ud <- getAffection
|
||||
case state ud of
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
case curState of
|
||||
Main MindMap ->
|
||||
putAffection ud
|
||||
{ state = Main WorldMap
|
||||
}
|
||||
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
||||
Main WorldMap ->
|
||||
putAffection ud
|
||||
{ state = Main MindMap
|
||||
}
|
||||
void $ liftIO $ swapMVar (state ud) (Main MindMap)
|
||||
_ -> return ()
|
||||
| otherwise = return ()
|
||||
changeMaps _ = return ()
|
||||
changeMaps _ _ = return ()
|
||||
|
||||
changeMaps2 :: ActionMessage -> Affection UserData ()
|
||||
changeMaps2 (ActionMessage ActSwitchMap _) = do
|
||||
ud <- getAffection
|
||||
case state ud of
|
||||
changeMaps2 :: UserData -> ActionMessage -> Affection ()
|
||||
changeMaps2 ud (ActionMessage ActSwitchMap _) = do
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
case curState of
|
||||
Main MindMap ->
|
||||
putAffection ud
|
||||
{ state = Main WorldMap
|
||||
}
|
||||
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
||||
Main WorldMap ->
|
||||
putAffection ud
|
||||
{ state = Main MindMap
|
||||
}
|
||||
void $ liftIO $ swapMVar (state ud) (Main MindMap)
|
||||
_ -> return ()
|
||||
changeMaps2 _ = return ()
|
||||
changeMaps2 _ _ = return ()
|
||||
|
||||
loadMapFork
|
||||
:: UserData
|
||||
-> AffectionData UserData
|
||||
-> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData)
|
||||
-> AffectionData
|
||||
-> MVar (SystemState Entity (AffectionState AffectionData IO), StateData)
|
||||
-> MVar (Float, T.Text)
|
||||
-> IO ()
|
||||
loadMapFork ud ad future progress = do
|
||||
|
|
@ -144,7 +129,8 @@ loadMapFork ud ad future progress = do
|
|||
( p + increment
|
||||
, "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, _) ->
|
||||
( p + increment
|
||||
, "Registering copiers into WorldState"
|
||||
|
|
@ -352,7 +338,7 @@ loadMapFork ud ad future progress = do
|
|||
then Nothing
|
||||
else a)
|
||||
(M.toList inter)
|
||||
putMVar future (nws, MainData
|
||||
void $ putMVar future (nws, MainData
|
||||
{ mapMat = mat
|
||||
, imgMat = retMat
|
||||
, reachPoints = V.fromList rps
|
||||
|
|
@ -360,11 +346,11 @@ loadMapFork ud ad future progress = do
|
|||
, roomGraph = gr
|
||||
})
|
||||
|
||||
movePlayerKbd :: KeyboardMessage -> Affection UserData ()
|
||||
movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
|
||||
movePlayerKbd :: UserData -> KeyboardMessage -> Affection ()
|
||||
movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeW = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
(V2 vx _) <- query xyvel
|
||||
|
|
@ -374,12 +360,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
|
|||
return $ unchanged
|
||||
{ xyvel = Set $ V2 vx ry
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeS = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
(V2 vx _) <- query xyvel
|
||||
|
|
@ -389,12 +373,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
|
|||
return $ unchanged
|
||||
{ xyvel = Set $ V2 vx ry
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeA = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
(V2 _ vy) <- query xyvel
|
||||
|
|
@ -404,12 +386,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
|
|||
return $ unchanged
|
||||
{ xyvel = Set $ V2 rx vy
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeD = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
(V2 _ vy) <- query xyvel
|
||||
|
|
@ -419,16 +399,14 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
|
|||
return $ unchanged
|
||||
{ xyvel = Set $ V2 rx vy
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
| otherwise = return ()
|
||||
movePlayerKbd _ = return ()
|
||||
movePlayerKbd _ _ = return ()
|
||||
|
||||
movePlayer2 :: ActionMessage -> Affection UserData ()
|
||||
movePlayer2 (ActionMessage mov _) = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
movePlayer2 :: UserData -> ActionMessage -> Affection ()
|
||||
movePlayer2 ud (ActionMessage mov _) = do
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
V2 vx vy <- query xyvel
|
||||
|
|
@ -440,14 +418,12 @@ movePlayer2 (ActionMessage mov _) = do
|
|||
ActRight f -> V2 f vy
|
||||
_ -> V2 vx vy
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
|
||||
playerInteract2 :: ActionMessage -> Affection UserData ()
|
||||
playerInteract2 (ActionMessage ActActivate _) = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $ do
|
||||
playerInteract2 :: UserData -> ActionMessage -> Affection ()
|
||||
playerInteract2 ud (ActionMessage ActActivate _) = do
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $ do
|
||||
pdata <- efor allEnts $ do
|
||||
with player
|
||||
with pos
|
||||
|
|
@ -478,22 +454,21 @@ playerInteract2 (ActionMessage ActActivate _) = do
|
|||
mapM_ (\(t, s, e) ->
|
||||
setEntity e =<< objectTransition t s True e (Just pent)
|
||||
) relEnts
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
playerInteract2 _ = return ()
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
playerInteract2 _ _ = return ()
|
||||
|
||||
drawMap :: Affection UserData ()
|
||||
drawMap = do
|
||||
ud <- getAffection
|
||||
drawMap :: UserData -> Affection ()
|
||||
drawMap ud = do
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
let ctx = nano ud
|
||||
case stateData ud of
|
||||
case sData of
|
||||
None -> liftIO $ do
|
||||
progress <- readMVar (stateProgress ud)
|
||||
drawLoadScreen ud progress
|
||||
_ -> do
|
||||
dt <- getDelta
|
||||
(_, dat) <- yieldSystemT (worldState ud) $ do
|
||||
(_, dat) <- yieldSystemT wState $ do
|
||||
efor allEnts $ do
|
||||
with pos
|
||||
pos' <- query pos
|
||||
|
|
@ -534,10 +509,10 @@ drawMap = do
|
|||
([], [], [])
|
||||
dat
|
||||
V2 pr pc = playerPos
|
||||
MainData _ _ _ _ gr = stateData ud
|
||||
MainData _ _ _ _ gr = sData
|
||||
seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr)
|
||||
room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
|
||||
mat = imgMat (stateData ud)
|
||||
mat = imgMat sData
|
||||
cols = fromIntegral (ncols mat)
|
||||
rows = fromIntegral (nrows mat)
|
||||
tileWidth = 64 :: Double
|
||||
|
|
@ -545,8 +520,8 @@ drawMap = do
|
|||
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
|
||||
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
|
||||
partposanims = M.fromList
|
||||
(nrows $ mapMat $ stateData ud)
|
||||
(ncols $ mapMat $ stateData ud)
|
||||
(nrows $ mapMat sData)
|
||||
(ncols $ mapMat sData)
|
||||
((reverse . fst)
|
||||
(Prelude.foldl
|
||||
(\(done, proc) coord ->
|
||||
|
|
@ -555,8 +530,8 @@ drawMap = do
|
|||
)
|
||||
([], posanims)
|
||||
((,)
|
||||
<$> [1 .. (nrows $ mapMat $ stateData ud)]
|
||||
<*> [1 .. (ncols $ mapMat $ stateData ud)]
|
||||
<$> [1 .. (nrows $ mapMat sData)]
|
||||
<*> [1 .. (ncols $ mapMat sData)]
|
||||
)
|
||||
)
|
||||
)
|
||||
|
|
@ -634,7 +609,8 @@ drawMap = do
|
|||
closePath ctx
|
||||
) posActions
|
||||
fontSize ctx 20
|
||||
fontFace ctx (assetFonts ud Map.! FontBedstead)
|
||||
aFonts <- readMVar (assetFonts ud)
|
||||
fontFace ctx (aFonts Map.! FontBedstead)
|
||||
textAlign ctx (S.fromList [AlignCenter,AlignTop])
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
textBox ctx 0 0 200 (
|
||||
|
|
@ -656,14 +632,14 @@ drawTile
|
|||
-> Int
|
||||
-> Maybe ImgId
|
||||
-> IO ()
|
||||
drawTile ud ctx posanims pr pc row col img =
|
||||
do
|
||||
drawTile ud ctx posanims pr pc row col img = do
|
||||
let (bef, beh) = L.partition delimiter sorted
|
||||
aImages <- readMVar (assetImages ud)
|
||||
save ctx
|
||||
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))
|
||||
((assetImages ud Map.!) <$> case img of
|
||||
((aImages Map.!) <$> case img of
|
||||
Just ImgEmpty -> Nothing
|
||||
_ -> img
|
||||
)
|
||||
|
|
@ -726,29 +702,30 @@ drawTile ud ctx posanims pr pc row col img =
|
|||
drawAnim (V2 nr nc, as, _) factor = do
|
||||
let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32
|
||||
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 dt = do
|
||||
ud <- getAffection
|
||||
if stateData ud == None
|
||||
updateMap :: UserData -> Double -> Affection ()
|
||||
updateMap ud dt = do
|
||||
osData <- liftIO $ readMVar (stateData ud)
|
||||
if osData == None
|
||||
then do
|
||||
mstart <- liftIO $ tryTakeMVar (stateMVar ud)
|
||||
case mstart of
|
||||
Just (nws, mendat) -> do
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
, stateData = mendat
|
||||
, state = Main WorldMap
|
||||
}
|
||||
updateMap 0.1
|
||||
updateMap 0.1
|
||||
updateMap 0.1
|
||||
updateMap 19
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
void $ liftIO $ swapMVar (stateData ud) mendat
|
||||
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
||||
updateMap ud 0.1
|
||||
updateMap ud 0.1
|
||||
updateMap ud 0.1
|
||||
updateMap ud 19
|
||||
liftIO $ logIO A.Debug "Loaded game data"
|
||||
Nothing -> return ()
|
||||
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
|
||||
with obstacle
|
||||
with pos
|
||||
|
|
@ -762,8 +739,8 @@ updateMap dt = do
|
|||
fact' <- fromMaybe 1 <$> queryMaybe velFact
|
||||
xyv2 <- queryMaybe xyvel
|
||||
stat <- query anim
|
||||
let an = assetAnimations ud Map.! asId stat
|
||||
mat = mapMat (stateData ud)
|
||||
let an = aAnim Map.! asId stat
|
||||
mat = mapMat sData
|
||||
ntime = asElapsedTime stat + dt
|
||||
npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel')
|
||||
dpos@(V2 dpr dpc) = npos - pos'
|
||||
|
|
@ -789,7 +766,7 @@ updateMap dt = do
|
|||
(fromMaybe [] $ collisionObstacle <$> M.unsafeGet
|
||||
(min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr)
|
||||
(min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc)
|
||||
(imgMat (stateData ud)))
|
||||
(imgMat sData))
|
||||
(Prelude.map snd $ Prelude.filter
|
||||
(\((V2 br bc), _) ->
|
||||
floor pr + dr == floor br &&
|
||||
|
|
@ -899,14 +876,12 @@ updateMap dt = do
|
|||
objectAction dt t s e
|
||||
) tses
|
||||
(nws2, _) <- yieldSystemT nws $ updateNPCs
|
||||
(imgMat $ stateData ud)
|
||||
(mapMat $ stateData ud)
|
||||
(imgMat sData)
|
||||
(mapMat sData)
|
||||
nws
|
||||
(V.filter
|
||||
(\p -> pointType p /= RoomExit)
|
||||
(reachPoints $ stateData ud)
|
||||
(reachPoints sData)
|
||||
)
|
||||
dt
|
||||
putAffection ud
|
||||
{ worldState = nws2
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws2
|
||||
|
|
|
|||
|
|
@ -10,9 +10,10 @@ import Linear hiding (rotate, translation)
|
|||
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (isNothing, isJust)
|
||||
import Data.String
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Control.Monad
|
||||
|
||||
-- internal imports
|
||||
|
|
@ -22,108 +23,94 @@ import Util
|
|||
import Menu.Adjust
|
||||
import MainGame.WorldMap
|
||||
|
||||
loadMenu :: Affection UserData ()
|
||||
loadMenu = do
|
||||
ud <- getAffection
|
||||
ad <- get
|
||||
loadMenu :: UserData -> Affection ()
|
||||
loadMenu ud = do
|
||||
let (Subsystems _ m k j t) = subsystems ud
|
||||
uu1 <- partSubscribe j joystickConnect
|
||||
uu2 <- partSubscribe j joystickDisconnect
|
||||
uu3 <- partSubscribe j emitJoyActionMessage
|
||||
uu4 <- partSubscribe k emitKbdActionMessage
|
||||
uu5 <- partSubscribe t handleActionMessages
|
||||
uu6 <- partSubscribe m handleClicks
|
||||
uu1 <- partSubscribe j (joystickConnect ud)
|
||||
uu2 <- partSubscribe j (joystickDisconnect ud)
|
||||
uu3 <- partSubscribe j (emitJoyActionMessage ud)
|
||||
uu4 <- partSubscribe k (emitKbdActionMessage ud)
|
||||
uu5 <- partSubscribe t (handleActionMessages ud)
|
||||
uu6 <- partSubscribe m (handleClicks ud)
|
||||
-- uu6 <- partSubscribe k emitKbdActionMessage
|
||||
partUnSubscribe j (joyUUID ud)
|
||||
putAffection ud
|
||||
{ uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
|
||||
, state = Menu Connect
|
||||
, stateData = MenuData (V2 0 0) S 0 0
|
||||
, joyCache = []
|
||||
}
|
||||
mapM_ (partEmit j) (joyCache ud)
|
||||
juuid <- liftIO $ readMVar (joyUUID ud)
|
||||
partUnSubscribe j juuid
|
||||
cache <- liftIO $ readMVar (joyCache ud)
|
||||
void $ liftIO $ swapMVar (uuid ud) [ uu1, uu2, uu3, uu4, uu5, uu6 ]
|
||||
void $ liftIO $ swapMVar (state ud) (Menu Connect)
|
||||
void $ liftIO $ swapMVar (stateData ud) (MenuData (V2 0 0) S 0 0)
|
||||
void $ liftIO $ swapMVar (joyCache ud) []
|
||||
mapM_ (partEmit j) cache
|
||||
|
||||
joystickConnect :: JoystickMessage -> Affection UserData ()
|
||||
joystickConnect msg = do
|
||||
ud <- getAffection
|
||||
when (controls ud == NoController) $ do
|
||||
joystickConnect :: UserData -> JoystickMessage -> Affection ()
|
||||
joystickConnect ud msg = do
|
||||
ctrls <- liftIO $ readMVar (controls ud)
|
||||
when (ctrls == NoController) $ do
|
||||
mjoy <- joystickAutoConnect msg
|
||||
maybe (return ()) (\joy -> do
|
||||
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
|
||||
liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show ident)
|
||||
putAffection ud
|
||||
{ controls = Joystick joy
|
||||
, translation = JoyTranslation defaultJoyTranslation
|
||||
}
|
||||
liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show (ident :: Int))
|
||||
void $ liftIO $ swapMVar (controls ud) (Joystick joy)
|
||||
void $ liftIO $ swapMVar (translation ud) (JoyTranslation defaultJoyTranslation)
|
||||
) mjoy
|
||||
|
||||
joystickDisconnect :: JoystickMessage -> Affection UserData ()
|
||||
joystickDisconnect msg = do
|
||||
ud <- getAffection
|
||||
case controls ud of
|
||||
joystickDisconnect :: UserData -> JoystickMessage -> Affection ()
|
||||
joystickDisconnect ud msg = do
|
||||
ctrls <- liftIO $ readMVar (controls ud)
|
||||
case ctrls of
|
||||
Joystick joy -> do
|
||||
njoys <- joystickAutoDisconnect [joy] msg
|
||||
when (null njoys) $ do
|
||||
liftIO $ logIO A.Debug $ "Joystick disconnected"
|
||||
putAffection ud
|
||||
{ controls = NoController
|
||||
, translation = NoTranslation
|
||||
}
|
||||
void $ liftIO $ swapMVar (controls ud) NoController
|
||||
void $ liftIO $ swapMVar (translation ud) NoTranslation
|
||||
_ -> return ()
|
||||
|
||||
handleActionMessages :: ActionMessage -> Affection UserData ()
|
||||
handleActionMessages (ActionMessage ActActivate _) = do
|
||||
ud <- getAffection
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
handleActionMessages :: UserData -> ActionMessage -> Affection ()
|
||||
handleActionMessages ud (ActionMessage ActActivate _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
|
||||
{ activate = 0.5
|
||||
}
|
||||
}
|
||||
handleActionMessages (ActionMessage ActSwitchMap _) = do
|
||||
ud <- getAffection
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
)
|
||||
handleActionMessages ud (ActionMessage ActSwitchMap _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
|
||||
{ switchMap = 0.5
|
||||
}
|
||||
}
|
||||
handleActionMessages (ActionMessage (ActUp f) _) = do
|
||||
ud <- getAffection
|
||||
let V2 vx _ = velocity $ stateData ud
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
)
|
||||
handleActionMessages ud (ActionMessage (ActUp f) _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
||||
let V2 vx _ = velocity dat
|
||||
in return dat
|
||||
{ velocity = (V2 vx (-f))
|
||||
}
|
||||
}
|
||||
handleActionMessages (ActionMessage (ActDown f) _) = do
|
||||
ud <- getAffection
|
||||
let V2 vx _ = velocity $ stateData ud
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
)
|
||||
handleActionMessages ud (ActionMessage (ActDown f) _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
||||
let V2 vx _ = velocity dat
|
||||
in return dat
|
||||
{ velocity = (V2 vx f)
|
||||
}
|
||||
}
|
||||
handleActionMessages (ActionMessage (ActLeft f) _) = do
|
||||
ud <- getAffection
|
||||
let V2 _ vy = velocity $ stateData ud
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
)
|
||||
handleActionMessages ud (ActionMessage (ActLeft f) _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
||||
let V2 _ vy = velocity dat
|
||||
in return dat
|
||||
{ velocity = (V2 (-f) vy)
|
||||
}
|
||||
}
|
||||
handleActionMessages (ActionMessage (ActRight f) _) = do
|
||||
ud <- getAffection
|
||||
let V2 _ vy = velocity $ stateData ud
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
)
|
||||
handleActionMessages ud (ActionMessage (ActRight f) _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
||||
let V2 _ vy = velocity dat
|
||||
in return dat
|
||||
{ velocity = (V2 f vy)
|
||||
}
|
||||
}
|
||||
)
|
||||
|
||||
handleClicks :: MouseMessage -> Affection UserData ()
|
||||
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
|
||||
ud <- getAffection
|
||||
rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
|
||||
case controls ud of
|
||||
handleClicks :: UserData -> MouseMessage -> Affection ()
|
||||
handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do
|
||||
rels <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords cpos)
|
||||
ctrls <- liftIO $ readMVar (controls ud)
|
||||
case ctrls of
|
||||
Joystick _ -> do
|
||||
when (arrowUp rels) adjustKbdUp
|
||||
when (arrowDown rels) adjustKbdDown
|
||||
|
|
@ -133,40 +120,36 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
|
|||
when (buttonSwitchMap rels) adjustKbdSwitchMap
|
||||
when (buttonPlay rels) enterGame
|
||||
NoController -> do
|
||||
when (kbdIcon rels) $
|
||||
putAffection ud
|
||||
{ controls = Keyboard
|
||||
, translation = KbdTranslation defaultKbdTranslation
|
||||
}
|
||||
when (kbdIcon rels) $ do
|
||||
void $ liftIO $ swapMVar (controls ud) Keyboard
|
||||
void $ liftIO $ swapMVar (translation ud) (KbdTranslation defaultKbdTranslation)
|
||||
Keyboard -> do
|
||||
when (kbdIcon rels) $
|
||||
putAffection ud
|
||||
{ controls = NoController
|
||||
, translation = NoTranslation
|
||||
}
|
||||
when (kbdIcon rels) $ do
|
||||
void $ liftIO $ swapMVar (controls ud) NoController
|
||||
void $ liftIO $ swapMVar (translation ud) NoTranslation
|
||||
when (buttonPlay rels) enterGame
|
||||
where
|
||||
adjustKbdUp = do
|
||||
fullClean
|
||||
loadAdjust (ActUp 1) Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud (ActUp 1) Keyboard (loadMenu ud)
|
||||
adjustKbdDown = do
|
||||
fullClean
|
||||
loadAdjust (ActDown 1) Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud (ActDown 1) Keyboard (loadMenu ud)
|
||||
adjustKbdLeft = do
|
||||
fullClean
|
||||
loadAdjust (ActLeft 1) Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud (ActLeft 1) Keyboard (loadMenu ud)
|
||||
adjustKbdRight = do
|
||||
fullClean
|
||||
loadAdjust (ActRight 1) Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud (ActRight 1) Keyboard (loadMenu ud)
|
||||
adjustKbdActivate = do
|
||||
fullClean
|
||||
loadAdjust ActActivate Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud ActActivate Keyboard (loadMenu ud)
|
||||
adjustKbdSwitchMap = do
|
||||
fullClean
|
||||
loadAdjust ActSwitchMap Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud ActSwitchMap Keyboard (loadMenu ud)
|
||||
enterGame = do
|
||||
fullClean
|
||||
loadMap
|
||||
fullClean ud
|
||||
loadMap ud
|
||||
arrowUp (V2 rx ry) =
|
||||
rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
|
||||
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
|
||||
kbdIcon (V2 rx ry) =
|
||||
rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720
|
||||
handleClicks _ = return ()
|
||||
handleClicks _ _ = return ()
|
||||
|
||||
updateMenu :: Double -> Affection UserData ()
|
||||
updateMenu dt = do
|
||||
ud <- getAffection
|
||||
case stateData ud of
|
||||
updateMenu :: UserData -> Double -> Affection ()
|
||||
updateMenu ud dt = do
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
case sData of
|
||||
MenuData _ _ _ _ ->
|
||||
putAffection ud
|
||||
{ stateData = MenuData
|
||||
(velocity $ stateData ud)
|
||||
(rotation $ stateData ud)
|
||||
(max 0 ((activate $ stateData ud) - dt))
|
||||
(max 0 ((switchMap $ stateData ud) - dt))
|
||||
}
|
||||
void $ liftIO $ swapMVar (stateData ud) (
|
||||
MenuData
|
||||
(velocity sData)
|
||||
(rotation sData)
|
||||
(max 0 ((activate sData) - dt))
|
||||
(max 0 ((switchMap sData) - dt))
|
||||
)
|
||||
_ -> return ()
|
||||
|
||||
drawMenu :: Affection UserData ()
|
||||
drawMenu = do
|
||||
ud <- getAffection
|
||||
case stateData ud of
|
||||
drawMenu :: UserData -> Affection ()
|
||||
drawMenu ud = do
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
aIcons <- liftIO $ readMVar (assetIcons ud)
|
||||
case sData of
|
||||
MenuData _ _ _ _ ->
|
||||
liftIO $ do
|
||||
let ctx = nano ud
|
||||
controller = controls ud
|
||||
controller <- readMVar (controls ud)
|
||||
save 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
|
||||
Joystick _ -> IconContrGreen
|
||||
_ -> IconContrBlue
|
||||
|
|
@ -219,17 +204,17 @@ drawMenu = do
|
|||
closePath ctx
|
||||
fill 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
|
||||
Keyboard -> IconKbdGreen
|
||||
_ -> IconKbdBlue
|
||||
) 1
|
||||
rect ctx 650 620 80 80
|
||||
fillPaint ctx cpaint
|
||||
fillPaint ctx cpaint2
|
||||
closePath ctx
|
||||
fill ctx
|
||||
when (controller /= NoController) $ do
|
||||
let V2 vx vy = velocity $ stateData ud
|
||||
let V2 vx vy = velocity sData
|
||||
beginPath ctx
|
||||
roundedRect ctx 140 110 1000 500 25
|
||||
strokeWidth ctx 5
|
||||
|
|
@ -240,7 +225,7 @@ drawMenu = do
|
|||
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) $
|
||||
rot = fmap (fromIntegral . floor) $
|
||||
V2 0 120 `rotVec` deg :: V2 Int
|
||||
save ctx
|
||||
translate ctx (px + 50) (py + 50)
|
||||
|
|
@ -254,7 +239,7 @@ drawMenu = do
|
|||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust (ActUp _) _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
|
@ -276,7 +261,7 @@ drawMenu = do
|
|||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust (ActLeft _) _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
|
@ -298,7 +283,7 @@ drawMenu = do
|
|||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust (ActUp _) _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
|
@ -320,7 +305,7 @@ drawMenu = do
|
|||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust (ActLeft _) _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
|
@ -336,20 +321,20 @@ drawMenu = do
|
|||
_ ->
|
||||
return ()
|
||||
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
|
||||
fillPaint ctx apaint
|
||||
closePath ctx
|
||||
fill ctx
|
||||
restore ctx
|
||||
) [0, 90, 180, 270]
|
||||
when (activate (stateData ud) > 0) $ do
|
||||
when (activate sData > 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 650 160 150 50 10
|
||||
fill ctx
|
||||
closePath ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust ActActivate _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
|
@ -368,13 +353,13 @@ drawMenu = do
|
|||
fillColor ctx (rgb 255 255 255)
|
||||
textBox ctx 650 175 150 "Activate"
|
||||
closePath ctx
|
||||
when (switchMap (stateData ud) > 0) $ do
|
||||
when (switchMap sData > 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 650 220 150 50 10
|
||||
fill ctx
|
||||
closePath ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust ActSwitchMap _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ module Navigation where
|
|||
import Affection as A
|
||||
|
||||
import Data.Matrix as M
|
||||
import Data.Maybe (isJust, catMaybes)
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
-- internal imports
|
||||
|
||||
|
|
|
|||
|
|
@ -13,26 +13,26 @@ import MainGame.WorldMap
|
|||
import MainGame.MindMap
|
||||
import Util
|
||||
|
||||
instance StateMachine State UserData where
|
||||
instance StateMachine UserData State where
|
||||
smLoad Load = loadLoad
|
||||
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
|
||||
|
||||
smUpdate Load = updateLoad
|
||||
smUpdate (Menu Connect) = updateMenu
|
||||
smUpdate (Menu (Adjust _ _)) = const (return ())
|
||||
smUpdate (Menu (Adjust _ _)) = const $ const (return ())
|
||||
smUpdate (Main WorldMap) = updateMap
|
||||
smUpdate (Main MindMap) = updateMind
|
||||
|
||||
smDraw Load = drawLoad
|
||||
smDraw (Menu Connect) = drawMenu
|
||||
smDraw (Menu (Adjust _ _)) = drawMenu >> drawAdjust
|
||||
smDraw (Menu (Adjust _ _)) = (\ud -> drawMenu ud >> drawAdjust (nano ud))
|
||||
smDraw (Main WorldMap) = drawMap
|
||||
smDraw (Main MindMap) = drawMind
|
||||
|
||||
smEvent _ evs = do
|
||||
Subsystems w m k j _ <- subsystems <$> getAffection
|
||||
smEvent _ ud evs = do
|
||||
let Subsystems w m k j _ = subsystems ud
|
||||
_ <- consumeSDLEvents j =<<
|
||||
consumeSDLEvents k =<<
|
||||
consumeSDLEvents w =<<
|
||||
|
|
|
|||
|
|
@ -45,6 +45,7 @@ data UserData = UserData
|
|||
, window :: MVar (Maybe SDL.Window)
|
||||
, joyCache :: MVar [JoystickMessage]
|
||||
, joyUUID :: MVar UUID
|
||||
, doNextStep :: MVar Bool
|
||||
}
|
||||
|
||||
data Controller
|
||||
|
|
|
|||
Loading…
Reference in a new issue