tracer/src/NPC.hs

197 lines
5.8 KiB
Haskell
Raw Normal View History

2018-04-14 09:18:37 +00:00
module NPC where
import Affection as A
import qualified Data.Matrix as M
2018-05-20 22:40:40 +00:00
import Data.Map.Strict as Map hiding (filter, null)
2018-04-14 09:18:37 +00:00
import Data.Ecstasy as E
import Data.Maybe (fromMaybe)
import Data.List (find)
2018-04-14 09:18:37 +00:00
2018-04-14 16:43:05 +00:00
import Control.Monad.IO.Class (MonadIO(..))
import Control.Concurrent.MVar
2018-05-18 18:05:21 +00:00
import Control.Concurrent (forkOS)
2018-04-14 16:43:05 +00:00
2018-04-14 09:18:37 +00:00
import Linear
import System.Random
import NanoVG hiding (V2(..))
-- internal imports
2018-04-14 11:34:28 +00:00
import Navigation
import Util
import Types
2018-04-14 09:18:37 +00:00
2018-05-30 14:20:58 +00:00
-- drawNPCs
-- :: Map ImgId Image
-- -> Context
-- -> UserData
-- -> [(V2 Double, Direction)]
-- -> Double
-- -> Double
-- -> Int
-- -> Int
-- -> Maybe ImgId
-- -> IO ()
-- drawNPCs ai ctx ud npcposrots prow pcol row col img = do
-- let fnpcposrots = filter
-- (\((V2 nr nc, dir)) ->
-- let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32
-- y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16
-- in ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
-- (realToFrac x < 1280 && realToFrac (y - (74 - realToFrac tileHeight)) < 720)) &&
-- ((all (\m -> prow > (fromIntegral (floor prow :: Int)) + m) minrs &&
-- all (\m -> pcol < (fromIntegral (floor pcol :: Int)) + m) mincs) ||
-- (all (\m -> prow > (fromIntegral (floor prow :: Int)) + m) minrs &&
-- all (\m -> pcol < (fromIntegral (floor pcol :: Int)) + m) maxcs)) &&
-- (floor nr == row && floor nc == col)
-- )
-- npcposrots
-- mapM_
-- (\((V2 nr nc, dir)) -> do
-- let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32
-- y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16
-- beginPath ctx
-- paint <- imagePattern ctx (x - 32) (y - 58) 64 74 0
-- (ai Map.! (dirToImgId dir)) 1
-- 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
-- )
-- fnpcposrots
-- where
-- tileWidth = 64 :: Double
-- tileHeight = 32 :: Double
-- mb = imgObstacle img
-- minrs = Prelude.map (fst . matmin) mb
-- maxrs = Prelude.map (fst . matmax) mb
-- mincs = Prelude.map (snd . matmin) mb
-- maxcs = Prelude.map (snd . matmax) mb
2018-04-14 09:18:37 +00:00
2018-04-14 11:34:28 +00:00
placeNPCs
:: M.Matrix (Maybe ImgId)
2018-04-14 16:43:05 +00:00
-> M.Matrix TileState
2018-04-14 11:34:28 +00:00
-> [ReachPoint]
-> [Graph]
-> Int
2018-06-07 22:29:46 +00:00
-> IO [V2 Double]
2018-04-14 16:43:05 +00:00
placeNPCs imgmat tilemat rp gr count =
2018-04-14 09:18:37 +00:00
doPlace 1 []
where
2018-06-07 22:29:46 +00:00
doPlace :: Int -> [V2 Double] -> IO [V2 Double]
2018-04-14 09:18:37 +00:00
doPlace nr acc = do
if nr <= count
then do
2018-06-07 22:29:46 +00:00
r <- randomRIO (1, M.nrows imgmat)
c <- randomRIO (1, M.ncols imgmat)
2018-04-14 11:34:28 +00:00
if null (imgObstacle $ imgmat M.! (r, c)) &&
2018-04-14 16:43:05 +00:00
tilemat M.! (r, c) == Hall
2018-04-14 09:18:37 +00:00
then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc)
2018-04-14 16:43:05 +00:00
else do
2018-06-07 22:29:46 +00:00
i <- randomRIO (0, length nonexits - 1)
2018-04-14 16:43:05 +00:00
doPlace
(nr + 1)
((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc)
2018-04-14 09:18:37 +00:00
else
return acc
2018-04-14 11:34:28 +00:00
applRooms row col =
2018-04-14 16:43:05 +00:00
(filter (\r -> graphIsRoom r && inBounds (V2 row col) (bounds r)) gr)
nonexits =
filter
(\p ->
pointType p /= RoomExit
)
rp
updateNPCs
2018-04-22 09:59:14 +00:00
:: MonadIO m
2018-04-14 16:43:05 +00:00
=> M.Matrix (Maybe ImgId)
-> [ReachPoint]
-> Double
-> SystemT Entity m ()
updateNPCs imgmat rp dt =
2018-05-17 11:06:13 +00:00
emap allEnts $ do
2018-04-14 16:43:05 +00:00
with npcState
with vel
with pos
with rot
with anim
2018-05-17 11:06:13 +00:00
npcState' <- query npcState
2018-04-14 16:43:05 +00:00
case npcState' of
NPCStanding ttl future -> do
2018-04-14 16:43:05 +00:00
let nttl = ttl - dt
if nttl > 0
then
2018-05-17 11:06:13 +00:00
return $ unchanged
{ npcState = Set $ NPCStanding nttl future
2018-04-14 16:43:05 +00:00
, vel = Set $ V2 0 0
}
else do
mpath <- liftIO $ tryTakeMVar future
case mpath of
Just path ->
2018-05-17 11:06:13 +00:00
return $ unchanged
{ npcState = Set $ NPCWalking path
}
Nothing ->
2018-05-17 11:06:13 +00:00
return $ unchanged
{ npcState = Set $ NPCStanding 1 future
}
2018-04-14 16:43:05 +00:00
NPCWalking path -> do
2018-05-17 11:06:13 +00:00
pos' <- query pos
2018-04-14 16:43:05 +00:00
if not (null path)
then do
let itarget = V2 0.5 0.5 + (fromIntegral <$> head path) :: V2 Double
if distance pos' itarget < 0.1
then
2018-05-17 11:06:13 +00:00
return $ unchanged
2018-04-14 16:43:05 +00:00
{ npcState = Set $ NPCWalking (tail path)
}
else
2018-05-17 11:06:13 +00:00
return $ unchanged
2018-05-13 20:01:05 +00:00
{ vel = Set $ (* 2) <$> signorm (itarget - pos')
2018-04-14 16:43:05 +00:00
}
else do
ttl <- liftIO $ randomRIO (5, 30)
future <- liftIO $ newEmptyMVar
rot' <- query rot
state <- query anim
let mdir =
(pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp)
2018-06-03 02:28:39 +00:00
-- _ <- liftIO $ forkOS $ getPath (fmap floor pos') future rp imgmat
_ <- liftIO $ getPath (fmap floor pos') future rp imgmat
2018-05-17 11:06:13 +00:00
return $ unchanged
{ npcState = Set $ NPCStanding ttl future
, vel = Set $ V2 0 0
, rot = Set $ fromMaybe rot' mdir
, anim = Set state
{ asId = (asId state)
{ aiDirection = fromMaybe rot' mdir
}
}
2018-04-14 16:43:05 +00:00
}
getPath
:: V2 Int
-> MVar [V2 Int]
-> [ReachPoint]
-> M.Matrix (Maybe ImgId)
-> IO ()
getPath pos' mvar rp imgmat = do
let seekRP = filter (\p -> pointType p /= RoomExit) rp
ntargeti <- randomRIO (0, length seekRP - 1)
let ntarget = pointCoord (seekRP !! ntargeti)
path = astarAppl imgmat ntarget pos'
logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget)
case path of
Nothing -> getPath pos' mvar rp imgmat
Just p -> putMVar mvar p