finish porting process

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

View file

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

View file

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

View file

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

View file

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

View file

@ -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
| otherwise = return ()
quitGame _ = return ()
void $ liftIO $ swapMVar (worldState ud) ws
void $ liftIO $ swapMVar (state ud) Load
smLoad Load ud
| otherwise = 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

View file

@ -15,6 +15,9 @@ import Data.String
import NanoVG hiding (V2(..))
import Control.Concurrent.MVar
import Control.Monad
-- internal imports
import Types
@ -25,145 +28,146 @@ import Collision
import Util
updateMind :: Double -> Affection UserData ()
updateMind dt = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $ do
emap allEnts $ do
with player
with xyvel
with mmvel
V2 rx ry <- query xyvel
-- let dr = (ry / sin (atan (1/2)) / 2) + rx
-- dc = rx - (ry / sin (atan (1/2)) / 2)
let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
return $ unchanged
{ mmvel = Set $ 2 * V2 dr dc
}
emap allEnts $ do
with anim
with mmpos
stat <- query anim
let an = assetAnimations ud Map.! asId stat
ntime = asElapsedTime stat + dt
nstate = if ntime > fromIntegral (asCurrentFrame stat) *
(animDuration an / fromIntegral (length $ animSprites an))
then
let nframe = asCurrentFrame stat + 1
in case animPlay an of
APLoop ->
let (nnframe, nntime) =
if nframe >= length (animSprites an)
then (0, 0)
else (nframe, ntime)
in stat
{ asCurrentFrame = nnframe
, asElapsedTime = nntime
}
APOnce ->
let nnframe = if nframe >= length (animSprites an)
then nframe - 1
else nframe
in stat
{ asCurrentFrame = nnframe
, asElapsedTime = ntime
}
else
stat
{ asElapsedTime = ntime
}
return $ unchanged
{ anim = Set nstate
}
emap allEnts $ do
with player
with mmvel
with mmpos
with rot
with anim
pos'@(V2 pr pc) <- query mmpos
vel' <- query mmvel
rot' <- query rot
stat <- query anim
let npos = pos' + fmap (* dt) vel'
dpos@(V2 dpr dpc) = npos - pos'
aId = asId stat
nstat = case aiName aId of
"walking"
| sqrt (colldpos `dot` colldpos) > 0 ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
}
}
| otherwise ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
, aiName = "standing"
}
, asCurrentFrame = 0
}
"standing"
| sqrt (colldpos `dot` colldpos) > 0 ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
, aiName = "walking"
}
, asCurrentFrame = 0
}
| otherwise ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
}
}
x -> error ("unknown animation name" ++ x)
lll = (,)
<$> (
if dpr < 0
then [(floor dpr :: Int) .. 0]
else [0 .. (ceiling dpr :: Int)])
<*> (
if dpc < 0
then [(floor dpc :: Int) .. 0]
else [0 .. (ceiling dpc :: Int)])
colldpos = dpos * Prelude.foldl
(\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
in A.log A.Verbose (fromString $ show ret) ret)
(V2 1 1)
(
concatMap
(\(dr, dc) ->
let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet
(fromIntegral $ floor pr + dr)
(fromIntegral $ floor pc + dc)
(mmImgMat (stateData ud))
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
Boundaries
(minr + fromIntegral dr, minc + fromIntegral dc)
(maxr + fromIntegral dr, maxc + fromIntegral dc)
) bs
)
lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
)
ent = unchanged
{ mmpos = Set $ pos' + colldpos
, rot = Set (fromMaybe rot' $ direction vel')
, anim = Set nstat
}
return ent
putAffection ud
{ worldState = nws
}
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
with mmvel
V2 rx ry <- query xyvel
-- let dr = (ry / sin (atan (1/2)) / 2) + rx
-- dc = rx - (ry / sin (atan (1/2)) / 2)
let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
return $ unchanged
{ mmvel = Set $ 2 * V2 dr dc
}
emap allEnts $ do
with anim
with mmpos
stat <- query anim
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))
then
let nframe = asCurrentFrame stat + 1
in case animPlay an of
APLoop ->
let (nnframe, nntime) =
if nframe >= length (animSprites an)
then (0, 0)
else (nframe, ntime)
in stat
{ asCurrentFrame = nnframe
, asElapsedTime = nntime
}
APOnce ->
let nnframe = if nframe >= length (animSprites an)
then nframe - 1
else nframe
in stat
{ asCurrentFrame = nnframe
, asElapsedTime = ntime
}
else
stat
{ asElapsedTime = ntime
}
return $ unchanged
{ anim = Set nstate
}
emap allEnts $ do
with player
with mmvel
with mmpos
with rot
with anim
pos'@(V2 pr pc) <- query mmpos
vel' <- query mmvel
rot' <- query rot
stat <- query anim
let npos = pos' + fmap (* dt) vel'
dpos@(V2 dpr dpc) = npos - pos'
aId = asId stat
nstat = case aiName aId of
"walking"
| sqrt (colldpos `dot` colldpos) > 0 ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
}
}
| otherwise ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
, aiName = "standing"
}
, asCurrentFrame = 0
}
"standing"
| sqrt (colldpos `dot` colldpos) > 0 ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
, aiName = "walking"
}
, asCurrentFrame = 0
}
| otherwise ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
}
}
x -> error ("unknown animation name" ++ x)
lll = (,)
<$> (
if dpr < 0
then [(floor dpr :: Int) .. 0]
else [0 .. (ceiling dpr :: Int)])
<*> (
if dpc < 0
then [(floor dpc :: Int) .. 0]
else [0 .. (ceiling dpc :: Int)])
colldpos = dpos * Prelude.foldl
(\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
in A.log A.Verbose (fromString $ show ret) ret)
(V2 1 1)
(
concatMap
(\(dr, dc) ->
let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet
(fromIntegral $ floor pr + dr)
(fromIntegral $ floor pc + dc)
(mmImgMat sData)
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
Boundaries
(minr + fromIntegral dr, minc + fromIntegral dc)
(maxr + fromIntegral dr, maxc + fromIntegral dc)
) bs
)
lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
)
ent = unchanged
{ mmpos = Set $ pos' + colldpos
, rot = Set (fromMaybe rot' $ direction vel')
, anim = Set nstat
}
return ent
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)))

View file

@ -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,23 +632,23 @@ drawTile
-> Int
-> Maybe ImgId
-> IO ()
drawTile ud ctx posanims pr pc row col img =
do
let (bef, beh) = L.partition delimiter sorted
save ctx
mapM_ (flip drawAnim fact) beh
maybe (return ()) (draw ud x (y - 42) 64 74
(if fromMaybe False (isWall <$> img) then fact else 1))
((assetImages ud Map.!) <$> case img of
Just ImgEmpty -> Nothing
_ -> img
)
mapM_ (flip drawAnim fact) bef
restore ctx
-- when (floor pr == row && floor pc == col) $ do
-- A.logIO A.Debug ("sorted: " ++ show sorted)
-- A.logIO A.Debug ("beh: " ++ show beh)
-- A.logIO A.Debug ("bef: " ++ show bef)
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 ()) (Types.draw ud x (y - 42) 64 74
(if fromMaybe False (isWall <$> img) then fact else 1))
((aImages Map.!) <$> case img of
Just ImgEmpty -> Nothing
_ -> img
)
mapM_ (flip drawAnim fact) bef
restore ctx
-- when (floor pr == row && floor pc == col) $ do
-- A.logIO A.Debug ("sorted: " ++ show sorted)
-- A.logIO A.Debug ("beh: " ++ show beh)
-- A.logIO A.Debug ("bef: " ++ show bef)
where
delimiter (V2 nr nc, as, mbnds) =
animFloats (asId as) ||
@ -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

View file

@ -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)
{ activate = 0.5
}
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)
{ switchMap = 0.5
}
)
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)

View file

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

View file

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

View file

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