adding player sprite and handling

This commit is contained in:
nek0 2018-05-21 00:40:40 +02:00
parent e8847f2aa0
commit b72f2f744b
6 changed files with 125 additions and 36 deletions

View file

@ -79,7 +79,7 @@ let
f = { mkDerivation, astar, base, containers, linear f = { mkDerivation, astar, base, containers, linear
, matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers , matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers
, vector , vector, JuicyPixels, JuicyPixels-extra, bytestring
}: }:
mkDerivation { mkDerivation {
pname = "tracer-game"; pname = "tracer-game";
@ -90,7 +90,8 @@ let
enableExecutableProfiling = true; enableExecutableProfiling = true;
executableHaskellDepends = [ executableHaskellDepends = [
affectionNeko astar base containers ecstasyNeko linear matrix nanovgNeko affectionNeko astar base containers ecstasyNeko linear matrix nanovgNeko
OpenGL random sdl2 stm text unordered-containers vector OpenGL random sdl2 stm text unordered-containers vector JuicyPixels
JuicyPixels-extra bytestring
]; ];
license = stdenv.lib.licenses.gpl3; license = stdenv.lib.licenses.gpl3;
}; };

View file

@ -10,9 +10,13 @@ import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import NanoVG hiding (V2(..), V3(..)) import NanoVG hiding (V2(..), V3(..))
import NanoVG.Internal.Image (ImageFlags(..))
import Linear import Linear
import Codec.Picture as CP
import Codec.Picture.Extra
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -22,6 +26,7 @@ import qualified Data.Set as S
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe import Data.Maybe
import Data.ByteString.Lazy (toStrict)
import System.Exit (exitFailure) import System.Exit (exitFailure)
@ -72,12 +77,14 @@ load = do
when (any isNothing mimgs) $ do when (any isNothing mimgs) $ do
logIO Error "Failed to load image assets" logIO Error "Failed to load image assets"
exitFailure exitFailure
playerImgs <- loadPlayerSprite "assets/intruder.png" 64 74 nvg
(zipWith (\a b -> (a, [b])) [0..] [ImgIntrE .. ImgIntrNE])
let imgs = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mimgs let imgs = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mimgs
return UserData return UserData
{ state = Menu { state = Menu
, subsystems = subs , subsystems = subs
, assetImages = M.fromList , assetImages = M.fromList
imgs (imgs ++ playerImgs)
, assetFonts = M.fromList , assetFonts = M.fromList
[ (FontBedstead, "bedstead") [ (FontBedstead, "bedstead")
] ]
@ -86,3 +93,31 @@ load = do
, worldState = ws , worldState = ws
, stateData = None , stateData = None
} }
loadPlayerSprite
:: FilePath -- Path to spritemap
-> Int -- width of single sprite
-> Int -- height of single sprite
-> Context -- Nanovg context
-> [(Int, [ImgId])] -- [(picture row, Image IDs)]
-> IO [(ImgId, NanoVG.Image)]
loadPlayerSprite fp w h nvg rids = do
eimg <- readImage fp
case eimg of
Left err -> do
logIO Error err
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
ret <- mapM (\(row, ids) -> do
mapM (\(num, id) -> do
let cr = crop (num * w) (row * h) w h img
mresimg <- createImageMem nvg (ImagePremultiplied) (toStrict $ encodePng cr)
case mresimg of
Nothing -> do
logIO Error ("Failed to load: " ++ fp ++ " " ++ show id)
exitFailure
Just resimg -> return (id, resimg)
) (zip [0..] ids)
) rids
return $ concat ret

View file

@ -3,6 +3,7 @@ module NPC where
import Affection as A import Affection as A
import qualified Data.Matrix as M import qualified Data.Matrix as M
import Data.Map.Strict as Map hiding (filter, null)
import Data.Ecstasy as E import Data.Ecstasy as E
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
@ -26,18 +27,19 @@ import Types.Map
import Types.ReachPoint import Types.ReachPoint
drawNPCs drawNPCs
:: Context :: Map ImgId Image
-> Context
-> UserData -> UserData
-> [V2 Double] -> [(V2 Double, Direction)]
-> Double -> Double
-> Double -> Double
-> Int -> Int
-> Int -> Int
-> Maybe ImgId -> Maybe ImgId
-> IO () -> IO ()
drawNPCs ctx ud npcposs prow pcol row col img = do drawNPCs ai ctx ud npcposrots prow pcol row col img = do
let fnpcposs = filter let fnpcposrots = filter
(\(V2 nr nc) -> (\((V2 nr nc, dir)) ->
let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32 let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32
y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16 y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16
in ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) && in ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
@ -48,18 +50,23 @@ drawNPCs ctx ud npcposs prow pcol row col img = do
all (\m -> pcol < (fromIntegral (floor pcol :: Int)) + m) maxcs)) && all (\m -> pcol < (fromIntegral (floor pcol :: Int)) + m) maxcs)) &&
(floor nr == row && floor nc == col) (floor nr == row && floor nc == col)
) )
npcposs npcposrots
mapM_ mapM_
(\(V2 nr nc) -> do (\((V2 nr nc, dir)) -> do
let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32 let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32
y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16 y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16
beginPath ctx beginPath ctx
circle ctx x y 5 paint <- imagePattern ctx (x - 32) (y - 58) 64 74 0
closePath ctx (ai Map.! (dirToImgId dir)) 1
fillColor ctx (rgba 255 0 0 255) rect ctx (x - realToFrac (tileWidth / 2)) (y - 58)
(realToFrac tileWidth) 74
fillPaint ctx paint
-- circle ctx x y 5
-- closePath ctx
-- fillColor ctx (rgba 255 0 0 255)
fill ctx fill ctx
) )
fnpcposs fnpcposrots
where where
tileWidth = 64 :: Double tileWidth = 64 :: Double
tileHeight = 32 :: Double tileHeight = 32 :: Double

View file

@ -63,6 +63,7 @@ loadMap = do
{ pos = Just (V2 20.5 20.5) { pos = Just (V2 20.5 20.5)
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
, player = Just () , player = Just ()
, rot = Just SE
} }
void $ mapM_ (\npcpos@(V2 nr nc) -> do void $ mapM_ (\npcpos@(V2 nr nc) -> do
-- ttl <- liftIO $ randomRIO (5, 30) -- ttl <- liftIO $ randomRIO (5, 30)
@ -72,7 +73,8 @@ loadMap = do
createEntity $ newEntity createEntity $ newEntity
{ pos = Just (V2 (nr + 0.5) (nc + 0.5)) { pos = Just (V2 (nr + 0.5) (nc + 0.5))
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
, velFact = Just fact , velFact = Just fact
, rot = Just SE
, npcState = Just (NPCStanding 0 future) , npcState = Just (NPCStanding 0 future)
} }
) npcposs ) npcposs
@ -128,20 +130,23 @@ drawMap :: Affection UserData ()
drawMap = do drawMap = do
ud <- getAffection ud <- getAffection
dt <- getDelta dt <- getDelta
(_, (playerPos, npcposs)) <- liftIO $ yieldSystemT (worldState ud) $ do (_, (playerPos, playerRot, npcposrots)) <- liftIO $ yieldSystemT (worldState ud) $ do
pc <- efor allEnts $ do (pc, dir) <- fmap head $ efor allEnts $ do
with player with player
with pos with pos
with rot
pos' <- query pos pos' <- query pos
pure pos' rot' <- query rot
pure (pos', rot')
-- (_, npcposs) <- yieldSystemT (worldState ud) $ do -- (_, npcposs) <- yieldSystemT (worldState ud) $ do
npcs <- efor allEnts $ do npcsrots <- efor allEnts $ do
with npcState with npcState
with pos with pos
pos' <- query pos pos' <- query pos
pure pos' rot' <- query rot
return (pc, npcs) pure (pos', rot')
let V2 pr pc = head playerPos return (pc, dir, npcsrots)
let V2 pr pc = playerPos
mat = imgMat (stateData ud) mat = imgMat (stateData ud)
ctx = nano ud ctx = nano ud
cols = fromIntegral (ncols mat) cols = fromIntegral (ncols mat)
@ -167,9 +172,8 @@ drawMap = do
fill ctx fill ctx
mapM_ (\(i, ls) -> mapM_ mapM_ (\(i, ls) -> mapM_
(\(j, t) -> do (\(j, t) -> do
drawTile drawTile (assetImages ud) ctx pr pc i j t (dirToImgId playerRot)
(assetImages ud) ctx pr pc i j t drawNPCs (assetImages ud) ctx ud npcposrots pr pc i j t
drawNPCs ctx ud npcposs pr pc i j t
) )
(reverse $ zip [1..] ls)) (reverse $ zip [1..] ls))
(zip [1..] (toLists mat)) (zip [1..] (toLists mat))
@ -182,6 +186,14 @@ drawMap = do
updateMap :: Double -> Affection UserData () updateMap :: Double -> Affection UserData ()
updateMap dt = do updateMap dt = do
let direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0
then toEnum (
let xuu = floor
((((acos ((vel' `dot` V2 0 1) / sqrt (vel' `dot` vel'))) /
pi) + 0.25) * 4 )
xu = if vr < 0 then 7 - xuu else xuu
in A.log A.Debug ("xu: " ++ show xu) xu)
else rot'
ud <- getAffection ud <- getAffection
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
emap allEnts $ do emap allEnts $ do
@ -189,21 +201,26 @@ updateMap dt = do
with vel with vel
with velFact with velFact
with pos with pos
with rot
pos'@(V2 pr pc) <- query pos pos'@(V2 pr pc) <- query pos
vel' <- query vel vel' <- query vel
rot' <- query rot
fact' <- query velFact fact' <- query velFact
let npos@(V2 nr nc) = pos' + fmap (* (dt * fact')) vel' let npos@(V2 nr nc) = pos' + fmap (* (dt * fact')) vel'
dpos = npos - pos' dpos = npos - pos'
ent = unchanged ent = unchanged
{ pos = Set $ npos { pos = Set $ npos
, rot = Set $ direction vel' rot'
} }
return ent return ent
emap allEnts $ do emap allEnts $ do
with player with player
with vel with vel
with pos with pos
with rot
pos'@(V2 pr pc) <- query pos pos'@(V2 pr pc) <- query pos
vel' <- query vel vel'@(V2 vr vc) <- query vel
rot' <- query rot
let npos@(V2 nr nc) = pos' + fmap (* dt) vel' let npos@(V2 nr nc) = pos' + fmap (* dt) vel'
dpos@(V2 dpr dpc) = npos - pos' dpos@(V2 dpr dpc) = npos - pos'
len = sqrt (dpos `dot` dpos) len = sqrt (dpos `dot` dpos)
@ -250,6 +267,8 @@ updateMap dt = do
) )
(A.log A.Verbose (show lll ++ " " ++ show len) lll) (A.log A.Verbose (show lll ++ " " ++ show len) lll)
) )
, rot = Set (A.log A.Debug ("dir: " ++ show (direction vel' rot'))
(direction vel' rot'))
} }
return ent return ent
updateNPCs updateNPCs
@ -271,8 +290,9 @@ drawTile
-> Int -> Int
-> Int -> Int
-> Maybe ImgId -> Maybe ImgId
-> ImgId
-> IO () -> IO ()
drawTile ai ctx pr pc row col img = drawTile ai ctx pr pc row col img playerImg =
when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) && when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
(realToFrac x < 1280 && realToFrac (y - (74 - realToFrac tileHeight)) < 720)) $ (realToFrac x < 1280 && realToFrac (y - (74 - realToFrac tileHeight)) < 720)) $
do do
@ -330,9 +350,13 @@ drawTile ai ctx pr pc row col img =
drawPlayer = do drawPlayer = do
when (floor pr == row && floor pc == col) $ do when (floor pr == row && floor pc == col) $ do
beginPath ctx beginPath ctx
circle ctx 640 360 5 paint <- imagePattern
closePath ctx ctx 608 302 64 74 0 (ai Map.! playerImg) 1
fillColor ctx (rgba 0 255 255 255) rect ctx 608 302 64 74
fillPaint ctx paint
-- circle ctx 640 360 5
-- closePath ctx
-- fillColor ctx (rgba 0 255 255 255)
fill ctx fill ctx
checkBoundsCollision checkBoundsCollision

View file

@ -62,6 +62,14 @@ data ImgId
| ImgMiscTable3 | ImgMiscTable3
| ImgMiscTable4 | ImgMiscTable4
| ImgMiscTableCorner | ImgMiscTableCorner
| ImgIntrE
| ImgIntrSE
| ImgIntrS
| ImgIntrSW
| ImgIntrW
| ImgIntrNW
| ImgIntrN
| ImgIntrNE
deriving (Show, Eq, Ord, Enum) deriving (Show, Eq, Ord, Enum)
isWall :: ImgId -> Bool isWall :: ImgId -> Bool
@ -136,14 +144,25 @@ data FontId
deriving (Show, Eq, Ord, Enum) deriving (Show, Eq, Ord, Enum)
data Direction data Direction
= N = NE
| W
| S
| E | E
| NW
| SW
| NE
| SE | SE
| S
| SW
| W
| NW
| N
deriving (Show, Eq, Ord, Enum)
dirToImgId :: Direction -> ImgId
dirToImgId E = ImgIntrE
dirToImgId SE = ImgIntrSE
dirToImgId S = ImgIntrS
dirToImgId SW = ImgIntrSW
dirToImgId W = ImgIntrW
dirToImgId NW = ImgIntrNW
dirToImgId N = ImgIntrN
dirToImgId NE = ImgIntrNE
data Entity f = Entity data Entity f = Entity
{ pos :: Component f 'Field (V2 Double) { pos :: Component f 'Field (V2 Double)

View file

@ -49,6 +49,9 @@ executable tracer-game
, vector , vector
, astar , astar
, unordered-containers , unordered-containers
, JuicyPixels
, JuicyPixels-extra
, bytestring
hs-source-dirs: src hs-source-dirs: src
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
default-language: Haskell2010 default-language: Haskell2010