starting NPCs

src/NPC.hs

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

src/Test.hs

@@ -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
+    efor $ \_ -> do
-          with player
+      with player
-          pos' <- E.get pos
+      pos' <- E.get pos
-          pure 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_
+  mapM_ (\(i, ls) -> mapM_
-      (\(j, t) -> drawTile
+    (\(j, t) -> do
-        (assetImages ud) ctx pr pc i j t)
+      liftIO $ drawTile
-        (reverse $ zip [1..] ls))
+        (assetImages ud) ctx pr pc i j t
-      (zip [1..] (toLists mat))
+      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])

src/Types/UserData.hs

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

tracer-game.cabal

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