module NPC where import Affection as A import qualified Data.Matrix as M import Data.Map.Strict as Map hiding (filter, null) import Data.Ecstasy as E import Control.Monad.IO.Class (MonadIO(..)) import Control.Concurrent.MVar import Control.Concurrent (forkOS) import Linear import System.Random import NanoVG hiding (V2(..)) -- internal imports import Navigation import Util import Types.UserData import Types.Interior import Types.Map import Types.ReachPoint 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 placeNPCs :: M.Matrix (Maybe ImgId) -> M.Matrix TileState -> [ReachPoint] -> [Graph] -> Int -> Affection UserData [V2 Double] placeNPCs imgmat tilemat rp gr 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)) && tilemat M.! (r, c) == Hall then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc) else do i <- liftIO $ randomRIO (0, length nonexits - 1) doPlace (nr + 1) ((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc) else return acc applRooms row col = (filter (\r -> graphIsRoom r && inBounds (V2 row col) (bounds r)) gr) nonexits = filter (\p -> pointType p /= RoomExit ) rp updateNPCs :: MonadIO m => M.Matrix (Maybe ImgId) -> [ReachPoint] -> Double -> SystemT Entity m () updateNPCs imgmat rp dt = emap allEnts $ do with npcState with vel with pos npcState' <- query npcState case npcState' of NPCStanding ttl future -> do let nttl = ttl - dt if nttl > 0 then return $ unchanged { npcState = Set $ NPCStanding nttl future , vel = Set $ V2 0 0 } else do mpath <- liftIO $ tryTakeMVar future case mpath of Just path -> return $ unchanged { npcState = Set $ NPCWalking path } Nothing -> return $ unchanged { npcState = Set $ NPCStanding 1 future } NPCWalking path -> do pos' <- query pos 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 return $ unchanged { npcState = Set $ NPCWalking (tail path) } else return $ unchanged { vel = Set $ (* 2) <$> signorm (itarget - pos') } else do ttl <- liftIO $ randomRIO (5, 30) future <- liftIO $ newEmptyMVar _ <- liftIO $ forkOS $ getPath (fmap floor pos') future rp imgmat return $ unchanged { npcState = Set $ NPCStanding ttl future } 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