Create new files

src/Dodge/Creature/Memory.hs

@@ -0,0 +1,2 @@
+module Dodge.Creature.Memory
+    where

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

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

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

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))
+               ]
+