try ecstasy

This commit is contained in:
nek0 2018-02-18 05:31:34 +01:00
parent a942776651
commit 2be7479f51
2 changed files with 77 additions and 22 deletions

View file

@ -6,10 +6,11 @@ import SDL (get, ($=))
import qualified SDL import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get) import qualified Graphics.Rendering.OpenGL as GL hiding (get)
import Control.Monad (when) import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.Matrix (toLists) import Data.Matrix (toLists)
import Data.Ecstasy as E
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
@ -29,19 +30,27 @@ loadMap = do
let fc = FloorConfig (20, 20) [(5,5), (45, 95)] (50,100) let fc = FloorConfig (20, 20) [(5,5), (45, 95)] (50,100)
(Subsystems _ m) = subsystems ud (Subsystems _ m) = subsystems ud
matrix <- liftIO $ buildHallFloorIO fc matrix <- liftIO $ buildHallFloorIO fc
nworld <- runSystemT (world ud) $ do
void $ newEntity $ defEntity
{ pos = Just (V2 20 20)
, vel = Just (V2 0 0)
, player = Just True
}
getWorld
uu <- partSubscribe m movePlayer uu <- partSubscribe m movePlayer
putAffection ud putAffection ud
{ stateData = MenuData { world = nworld
, stateData = MenuData
{ mapMat = matrix { mapMat = matrix
, initCoords = (0, 500) -- , initCoords = (0, 500)
, playerCoords = (20, 20) -- , playerCoords = (20, 20)
} }
, uuid = [uu] , uuid = [uu]
} }
relativizeMouseCoords :: V2 Int32 -> IO (V2 Double) relativizeMouseCoords :: V2 Int32 -> IO (V2 Double)
relativizeMouseCoords (V2 ix iy) = do relativizeMouseCoords (V2 ix iy) = do
(GL.Position vx vy, GL.Size vw vh) <- get GL.viewport (GL.Position vx vy, GL.Size vw vh) <- SDL.get GL.viewport
let rx = ix - vx let rx = ix - vx
ry = iy - vy ry = iy - vy
hx = fromIntegral vw / 2 hx = fromIntegral vw / 2
@ -50,19 +59,42 @@ relativizeMouseCoords (V2 ix iy) = do
dy = fromIntegral ry - hy dy = fromIntegral ry - hy
return $ V2 (dx / hx) (dy / hy) return $ V2 (dx / hx) (dy / hy)
movePlayer :: MouseMessage -> Affection UserData () mouseToPlayer :: V2 Int32 -> Affection UserData ()
movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] mv2@(V2 mx my) _) = do mouseToPlayer mv2 = do
ud <- getAffection ud <- getAffection
rela@(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2 rela@(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
let dr = (- ry) + (- rx) let dr = (- ry) + (- rx)
dc = (- rx) - (- ry) / 2 dc = (- rx) - (- ry) / 2
(pr, pc) = playerCoords $ stateData ud -- (pr, pc) = playerCoords $ stateData ud
liftIO $ traceIO $ "delta: " ++ show (V2 rx ry) nworld <- runSystemT (world ud) $ do
liftIO $ traceIO $ "movement: " ++ show (V2 dr dc) emap $ do
with player
pure $ defEntity'
{ vel = Set $ V2 dr dc
}
getWorld
putAffection ud putAffection ud
{ stateData = (stateData ud) { world = nworld
{ playerCoords = (pr - dr, pc - dc) -- stateData = (stateData ud)
} -- { playerCoords = (pr - dr, pc - dc)
-- }
}
movePlayer :: MouseMessage -> Affection UserData ()
movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m
movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
mouseToPlayer m
movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) = do
ud <- getAffection
nw <- runSystemT (world ud) $ do
emap $ do
with player
pure $ defEntity'
{ vel = Set $ V2 0 0
}
getWorld
putAffection ud
{ world = nw
} }
movePlayer _ = return () movePlayer _ = return ()
@ -73,12 +105,34 @@ drawMap = do
mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [0..] ls)) mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [0..] ls))
(zip [0..] (toLists matrix)) (zip [0..] (toLists matrix))
updateMap :: Double -> Affection UserData ()
updateMap _ = do
ud <- getAffection
nw <- runSystemT (world ud) $ do
emap $ do
with player
pos' <- E.get pos
vel' <- E.get vel
pure $ defEntity'
{ pos = Set $ pos' + vel'
}
getWorld
putAffection ud
{ world = nw
}
drawTile :: Int -> Int -> TileState -> Affection UserData () drawTile :: Int -> Int -> TileState -> Affection UserData ()
drawTile row col tile = do drawTile row col tile = do
ud <- getAffection ud <- getAffection
let ctx = nano ud playerPos <- runSystemT (world ud) $ do
(xinit, yinit) = initCoords $ stateData ud efor $ \_ -> do
(pr, pc) = playerCoords $ stateData ud with player
pos' <- E.get pos
pure pos'
let V2 pr pc = head playerPos
ctx = nano ud
-- (xinit, yinit) = initCoords $ stateData ud
-- (pr, pc) = playerCoords $ stateData ud
tileWidth = 20 :: Double tileWidth = 20 :: Double
tileHeight = 10 :: Double tileHeight = 10 :: Double
liftIO $ do liftIO $ do

View file

@ -33,8 +33,8 @@ data StateData
= None = None
| MenuData | MenuData
{ mapMat :: Matrix TileState { mapMat :: Matrix TileState
, initCoords :: (Int, Int) -- , initCoords :: (Int, Int)
, playerCoords :: (Double, Double) -- , playerCoords :: (Double, Double)
} }
data ImgId data ImgId
@ -51,10 +51,11 @@ data Direction
| SE | SE
data Entity f = Entity data Entity f = Entity
{ pos :: Component f 'Field (V2 Float) { pos :: Component f 'Field (V2 Double)
, vel :: Component f 'Field (V2 Float) , gridPos :: Component f 'Field (V2 Int)
, rot :: Component f 'Field Direction , vel :: Component f 'Field (V2 Double)
, player :: Component f 'Unique Bool , rot :: Component f 'Field Direction
, player :: Component f 'Unique Bool
} }
deriving (Generic) deriving (Generic)