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

View file

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