starting NPCs

This commit is contained in:
nek0 2018-04-14 11:18:37 +02:00
parent 3100d932a7
commit 9fdb8a5e15
4 changed files with 88 additions and 11 deletions

57
src/NPC.hs Normal file
View file

@ -0,0 +1,57 @@
module NPC where
import Affection as A
import qualified Data.Matrix as M
import Data.Ecstasy as E
import Linear
import System.Random
import NanoVG hiding (V2(..))
-- internal imports
import Types.UserData
drawNPCs
:: Context
-> [V2 Double]
-> Double
-> Double
-> Int
-> Int
-> Affection UserData ()
drawNPCs ctx npcposs prow pcol row col = do
ud <- getAffection
let fnpcposs = filter
(\(V2 nr nc) -> floor nr == row && floor nc == col)
npcposs
liftIO $ mapM_
(\(V2 nr nc) -> do
let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32
y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16
beginPath ctx
circle ctx x y 5
closePath ctx
fillColor ctx (rgba 255 0 0 255)
fill ctx
)
fnpcposs
placeNPCs :: M.Matrix (Maybe ImgId) -> Int -> Affection UserData [V2 Double]
placeNPCs imgmat count =
doPlace 1 []
where
doPlace :: Int -> [V2 Double] -> Affection UserData [V2 Double]
doPlace nr acc = do
if nr <= count
then do
r <- liftIO $ randomRIO (1, M.nrows imgmat)
c <- liftIO $ randomRIO (1, M.ncols imgmat)
if null (imgObstacle $ imgmat M.! (r, c))
then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc)
else doPlace nr acc
else
return acc

View file

@ -29,6 +29,7 @@ import Interior
import Util
import Types
import Floorplan
import NPC
loadMap :: Affection UserData ()
loadMap = do
@ -49,12 +50,20 @@ loadMap = do
((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
-- liftIO $ A.logIO A.Debug (show exits)
(inter, _) <- liftIO $ placeInteriorIO mat imgmat exits gr
npcposs <- placeNPCs inter 10
(nws, _) <- yieldSystemT (worldState ud) $ do
void $ newEntity $ defEntity
{ pos = Just (V2 20.5 20.5)
, vel = Just (V2 0 0)
, player = Just True
, player = Just ()
}
void $ mapM_ (\(V2 nr nc) -> do
newEntity $ defEntity
{ pos = Just (V2 (nr + 0.5) (nc + 0.5))
, vel = Just (V2 0 0)
, npc = Just ()
}
) npcposs
uu <- partSubscribe m movePlayer
putAffection ud
{ worldState = nws
@ -107,10 +116,15 @@ drawMap = do
ud <- getAffection
dt <- getDelta
(_, playerPos) <- yieldSystemT (worldState ud) $ do
efor $ \_ -> do
with player
pos' <- E.get pos
pure pos'
efor $ \_ -> do
with player
pos' <- E.get pos
pure pos'
(_, npcposs) <- yieldSystemT (worldState ud) $ do
efor $ \_ -> do
with npc
pos' <- E.get pos
pure pos'
let V2 pr pc = head playerPos
mat = imgMat (stateData ud)
ctx = nano ud
@ -135,11 +149,15 @@ drawMap = do
closePath ctx
fillColor ctx (rgb 255 255 255)
fill ctx
mapM_ (\(i, ls) -> mapM_
(\(j, t) -> drawTile
(assetImages ud) ctx pr pc i j t)
(reverse $ zip [1..] ls))
(zip [1..] (toLists mat))
mapM_ (\(i, ls) -> mapM_
(\(j, t) -> do
liftIO $ drawTile
(assetImages ud) ctx pr pc i j t
drawNPCs ctx npcposs pr pc i j
)
(reverse $ zip [1..] ls))
(zip [1..] (toLists mat))
liftIO $ do -- draw FPS
fontSize ctx 20
fontFace ctx (assetFonts ud Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter,AlignTop])

View file

@ -147,7 +147,8 @@ data Entity f = Entity
, vel :: Component f 'Field (V2 Double)
, rot :: Component f 'Field Direction
, obstacle :: Component f 'Field (Boundaries Double)
, player :: Component f 'Unique Bool
, player :: Component f 'Unique ()
, npc :: Component f 'Field ()
}
deriving (Generic)

View file

@ -27,6 +27,7 @@ executable tracer-game
, Init
, Test
, Navigation
, NPC
, Util
default-extensions: OverloadedStrings
, DeriveGeneric