diff --git a/src/Dodge/Creature/Memory.hs b/src/Dodge/Creature/Memory.hs new file mode 100644 index 000000000..1454e7116 --- /dev/null +++ b/src/Dodge/Creature/Memory.hs @@ -0,0 +1,2 @@ +module Dodge.Creature.Memory + where diff --git a/src/Dodge/Creature/Memory/Data.hs b/src/Dodge/Creature/Memory/Data.hs new file mode 100644 index 000000000..5416a5e08 --- /dev/null +++ b/src/Dodge/Creature/Memory/Data.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Creature.Memory.Data + where +import Geometry.Data + +import Control.Lens + +data MemoryState = MemoryState + { _soundsToInvestigate :: [Point2] + } + +makeLenses ''MemoryState diff --git a/src/Dodge/Creature/Perception.hs b/src/Dodge/Creature/Perception.hs new file mode 100644 index 000000000..fe554d839 --- /dev/null +++ b/src/Dodge/Creature/Perception.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TupleSections #-} +module Dodge.Creature.Perception + ( perceptionUpdate + , newSounds + ) + where +import Dodge.Data +import Dodge.Creature.Perception.Data +import Dodge.Creature.Memory.Data +import Dodge.Base.Collide +import Geometry.Vector +--import Geometry.Data +--import Sound.Data +--import StrictHelp + +import Data.Maybe +import Control.Lens +import Control.Monad.Reader +import qualified Data.IntMap.Strict as IM +import qualified Data.Map.Strict as M + +{- | Ties together (currently) an awareness and attention update -} +perceptionUpdate + :: [Int] -- ^ List of creature ids that may direct attention and awareness + -> Creature + -> Reader World Creature +perceptionUpdate is cr = basicAttentionUpdate is cr >>= basicAwarenessUpdate + >>= rememberSounds + +{- | Update a creatures awareness based upon the creatures' current direction + of attention -} +basicAwarenessUpdate + :: Creature -> Reader World Creature +basicAwarenessUpdate cr = case _crAttentionDir $ _crPerception cr of + AttentiveTo is -> pure $ cr & crPerception . crAwarenessLevel + %~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) + Fixated i -> pure $ cr & crPerception . crAwarenessLevel + %~ ( IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness) + +combineAwareness :: AwarenessLevel -> AwarenessLevel -> AwarenessLevel +combineAwareness (Suspicious x) (Suspicious y) + | x + y < 10000 = Suspicious $ x + y + | otherwise = Cognizant 5000 +combineAwareness (Suspicious x) (Cognizant y) = Cognizant $ min 10000 $ x + y +combineAwareness (Cognizant x) (Suspicious y) = Cognizant $ min 10000 $ x + y +combineAwareness (Cognizant x) (Cognizant y) = Cognizant $ min 10000 $ x + y + +{- | Decrease awareness level. Returns 'Maybe' value for use with 'IM.mapMaybe' + -} +decreaseAwareness :: AwarenessLevel -> Maybe AwarenessLevel +decreaseAwareness (Suspicious 0) = Nothing +decreaseAwareness (Suspicious x) = Just $ Suspicious (x - 50) +decreaseAwareness (Cognizant 0) = Just $ Suspicious 10000 +decreaseAwareness (Cognizant x) = Just $ Cognizant $ x - 50 + +{- | Given a fixed group of creatures, direct attention to those of them that + - are in view. -} +basicAttentionUpdate + :: [Int] -- ^ Creatures that may attract this creature's attention + -> Creature + -> Reader World Creature +basicAttentionUpdate cids cr = do + w <- ask + pure $ cr & crPerception . crAttentionDir .~ + AttentiveTo (IM.mapMaybe (newExtraAwareness cr w) $ IM.fromList $ zip cids cids) + +newExtraAwareness + :: Creature -- ^ source creature + -> World + -> Int -- ^ target creature id + -> Maybe AwarenessLevel +newExtraAwareness cr w cid + | not $ canSeeIndirect (_crID cr) cid w = Nothing + | otherwise = Just . Suspicious $ _viFOV vi ang * _viDist vi d * awakeLevelPerception cr + where + vi = _crVision $ _crPerception cr + tpos = _crPos $ _creatures w IM.! cid + cpos = _crPos cr + ang = angleVV (unitVectorAtAngle (_crDir cr)) (tpos - cpos) + d = dist tpos cpos + +awakeLevelPerception :: Creature -> Float +awakeLevelPerception cr = case _crAwakeLevel $ _crPerception cr of + Comatose -> 0 + Asleep -> 10 + Lethargic -> 100 + Vigilant -> 1000 + Overstrung -> 10000 + +newSounds :: World -> [(Point2,Float)] +newSounds = mapMaybe f . M.elems . _sounds + where + f s = Just (_soundPos s, _soundVolume s) +-- f s | _soundStatus s == JustStartedPlaying +-- = Just (_soundPos s, _soundVolume s) +-- | otherwise = Nothing + +rememberSounds :: Creature -> Reader World Creature +rememberSounds cr = do + sList <- fmap newSounds ask + return $ cr & crMemory . soundsToInvestigate .~ map fst (filter (soundIsClose cr) sList) +-- return $ cr & crMemory . soundsToInvestigate .~ [V2 0 0] + +soundIsClose :: Creature -> (Point2,Float) -> Bool +soundIsClose cr (pos,vol) = True -- vol > (_auDist . _crAudition $ _crPerception cr) (dist pos (_crPos cr)) diff --git a/src/Dodge/Creature/Perception/Data.hs b/src/Dodge/Creature/Perception/Data.hs new file mode 100644 index 000000000..9e2252466 --- /dev/null +++ b/src/Dodge/Creature/Perception/Data.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Creature.Perception.Data + ( PerceptionState (..) + , AwakeLevel (..) + , AttentionDir (..) + , AwarenessLevel (..) + , Vision (..) + , Audition (..) + -- lenses + , getAttentiveTo + , getFixated + , crAttentionDir + , crAwakeLevel + , crAwarenessLevel + , crVision + , crAudition + , viFOV + , viDist + , auDist + ) + where +import Control.Lens +import qualified Data.IntMap as IM + +data PerceptionState = PerceptionState + { _crAwakeLevel :: AwakeLevel + , _crAttentionDir :: AttentionDir + , _crAwarenessLevel :: IM.IntMap AwarenessLevel + , _crVision :: Vision + , _crAudition :: Audition + } + +data Vision = Eyes + { _viFOV :: Float -> Float + , _viDist :: Float -> Float + } +data Audition = Ears + { _auDist :: Float -> Float + } + +data AwakeLevel + = Comatose + | Asleep + | Lethargic + | Vigilant + | Overstrung + deriving (Eq,Ord,Show) + +data AttentionDir + = AttentiveTo {_getAttentiveTo :: IM.IntMap AwarenessLevel } + | Fixated {_getFixated :: Int } + +data AwarenessLevel + = Suspicious Float + | Cognizant Float + +makeLenses ''AttentionDir +makeLenses ''PerceptionState +makeLenses ''Vision +makeLenses ''Audition diff --git a/src/Dodge/Room/Path.hs b/src/Dodge/Room/Path.hs new file mode 100644 index 000000000..954038cc8 --- /dev/null +++ b/src/Dodge/Room/Path.hs @@ -0,0 +1,96 @@ +module Dodge.Room.Path + ( gridPoints + , linksAndPath + , makeGrid + , createPathGrid + ) + where +import Dodge.Data +import Dodge.Room.Data +import Dodge.LevelGen.StaticWalls +import Geometry + +import Data.Function (on) +import Data.List +import Data.Bifunctor +import Data.Maybe +import qualified Data.Tuple.Extra as Tup +import qualified Control.Foldl as L + +createPathGrid :: Room -> Room +createPathGrid rm = rm + { _rmPath = linksAndPath (_rmLinks rm) filterGrid } + where + filterGrid = filter (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid + grid = case shiftedGrid <$> minx <*> maxx <*> miny <*> maxy of + Nothing -> [] + Just xs -> xs + outerWalls = foldr cutPoly [] $ _rmPolys rm + outerPoints = map fst outerWalls + (minx, maxx, miny, maxy) = L.fold theFold outerPoints + theFold = (,,,) + <$> L.premap fstV2 L.minimum + <*> L.premap fstV2 L.maximum + <*> L.premap sndV2 L.minimum + <*> L.premap sndV2 L.maximum + +-- ?TODO? : make this minimumOn +linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)] +linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks + where + linkClosest (p,_) = doublePair (p, minimumBy (compare `on` dist p) $ map fst subpth) + +testCrossWalls + :: [(Point2,Point2)] + -> (Point2,Point2) + -> Bool +testCrossWalls wls (a,b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls + +--extra test whether both members of the path edge are in some poly +pairInPolys + :: [[Point2]] + -> (Point2,Point2) + -> Bool +pairInPolys polys (a,b) = any (pointInPolygon a) polys && any (pointInPolygon b) polys + +shiftedGrid + :: Float -- ^ x min + -> Float -- ^ x max + -> Float -- ^ y min + -> Float -- ^ y max + -> [(Point2,Point2)] +shiftedGrid xmin xmax ymin ymax = grid + where + xd = xmax - xmin + yd = ymax - ymin + xsteps = ceiling $ (xd - 40) / 60 + ysteps = ceiling $ (yd - 40) / 60 + shift p = bimap (p +.+) (p +.+) + grid = map (shift (V2 (xmin + 20) (ymin+20))) $ makeGrid 60 xsteps 60 ysteps + +-- creates a rectangular grid starting at (0,0) in the positive orthant +-- needs fixing in degenerate (xstep or ystep == 0) cases +makeGrid + :: Float -- ^ horizontal step size + -> Int -- ^ number of horizontal steps + -> Float -- ^ vertical step size + -> Int -- ^ number of vertical steps + -> [(Point2,Point2)] +makeGrid x nx y ny + = nub + . concatMap doublePair + . concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y) + $ gridPoints x nx y ny + +gridPoints :: Float -> Int -> Float -> Int -> [Point2] +gridPoints x nx y ny = [V2 a b | a <- take nx $ scanl (+) 0 $ repeat x + , b <- take ny $ scanl (+) 0 $ repeat y + ] + +makeRect :: Float -> Float -> [(Point2,Point2)] +makeRect x y = map (bimap toV2 toV2) [((0,0),(x,0)) + ,((0,0),(0,y)) + ,((x,y),(x,0)) + ,((x,y),(0,y)) + ] +