Create new files
This commit is contained in:
@@ -0,0 +1,2 @@
|
||||
module Dodge.Creature.Memory
|
||||
where
|
||||
@@ -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
|
||||
@@ -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))
|
||||
@@ -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
|
||||
@@ -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))
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user