justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Generalise pathing, usable with flying creatures

Browse Source
This commit is contained in:
justin
2026-04-02 19:30:44 +01:00
parent c2de804fa9
commit ff903bfb3b
19 changed files with 322 additions and 215 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Action.hs
+9 -2
View File
@@ -33,6 +33,7 @@ import qualified IntMapHelp as IM
import LensHelp
import Linear
import NewInt
import qualified Data.Set as S
-- it is desirable to be able to determine when an action is finished,
-- so that DoActionThen and the like are easy to define
@@ -113,11 +114,17 @@ performAimAt cr w tcid p = ([TurnToward tpos aimSp], [AimAt tcid tpos])
| canSee' = w ^?! cWorld . lWorld . creatures . ix tcid . crPos . _xy
| otherwise = p
crPathing :: Creature -> (Point2 -> Point2 -> World -> Bool,S.Set EdgeObstacle -> Bool)
crPathing cr = case cr ^. crStance . carriage of
Flying {} -> (isFlyable, not . S.member (WallObstacle WallNotAutoOpen))
_ -> (isWalkable, not . pathEdgeObstructed)
performPathTo :: Creature -> World -> Point2 -> ActionUpdate
performPathTo cr w p
| dist cpos p <= crRad (cr ^. crType) = mempty
| isWalkable cpos p w = gotowards p
| otherwise = case pointTowardsImpulse cpos p w of
-- | isWalkable cpos p w = gotowards p
| fst (crPathing cr) cpos p w = gotowards p
| otherwise = case uncurry pointTowardsImpulse' (crPathing cr) cpos p w of
Just q -> gotowards q
_ -> ([ChangeStrategy Flee], [])
where
src/Dodge/Creature/ChaseCrit.hs
+2 -1
View File
@@ -37,5 +37,6 @@ hoverCrit =
defaultCreature
& crName .~ "hoverCrit"
& crHP .~ HP 100
& crType .~ HoverCrit 0
& crFaction .~ ColorFaction blue
& crStance . carriage .~ Flying
& crStance . carriage .~ Flying 15
src/Dodge/Creature/HandPos.hs
+1 -1
View File
@@ -63,7 +63,7 @@ handWalkingPos b off cr = case cr ^. crStance . carriage of
| otherwise = 8 * zeroOneSmooth (i / slen)
in V3 (f sa) off 20
Floating -> V3 0 off 12
Flying -> V3 0 off 12
Flying {} -> V3 0 off 12
Boosting _ -> V3 0 off 12
zeroOneSmooth :: Float -> Float
src/Dodge/Creature/Picture.hs
+9
View File
@@ -8,6 +8,7 @@ module Dodge.Creature.Picture (
deadUpperBody,
deadFeet,
drawChaseCrit,
drawHoverCrit,
) where
import Linear
@@ -50,6 +51,14 @@ basicCrShape cr
crsize = 0.1 * crRad (cr ^. crType)
rotmdir = rotateSH (_crMvDir cr - _crDir cr)
drawHoverCrit :: Creature -> Shape
drawHoverCrit cr = colorSH (_skinUpper cskin)
(overPosSH (Q.apply tpq) $ upperBoxHalf Medium Typical 2 $ square 5)
where
cskin = crShape $ _crType cr
z = cr ^?! crStance . carriage . flyHeight
tpq = (V3 0 0 z, Q.qid)
drawChaseCrit :: Creature -> Shape
drawChaseCrit cr = mconcat
[ chaseUpperBody cr
src/Dodge/Creature/ReaderUpdate.hs
+15
View File
@@ -11,6 +11,7 @@ module Dodge.Creature.ReaderUpdate (
chaseCritMv,
setMvPos,
setViewPos,
hoverCritMv,
) where
import Control.Applicative
@@ -148,6 +149,20 @@ chaseCritMv w cr = case _apStrategy (_crActionPlan cr) of
& crIntention . mvToPoint .~ Nothing
_ -> viewTarget w cr
hoverCritMv :: World -> Creature -> Creature
hoverCritMv w cr = case _apStrategy (_crActionPlan cr) of
WarningCry -> cr
MeleeStrike -> cr
_ -> case cr ^? crIntention . mvToPoint . _Just of
Just p
| dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
cr & crActionPlan . apAction .~ [PathTo p]
| otherwise ->
cr & crActionPlan . apAction .~ [bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]]
& crActionPlan . apStrategy .~ WatchAndWait
& crIntention . mvToPoint .~ Nothing
_ -> viewTarget w cr
goToTarget :: World -> Creature -> Creature
goToTarget w cr = case cr ^? crIntention . mvToPoint . _Just of
Just p -> cr & crActionPlan . apAction .~ [PathTo p]
src/Dodge/Creature/Shape.hs
+1 -1
View File
@@ -9,7 +9,7 @@ crShape :: CreatureType -> CreatureShape
crShape = \case
Avatar{} -> Humanoid (greyN 0.9) (lightx4 black) (greyN 0.3)
ChaseCrit {} -> Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3)
HoverCrit {} -> Humanoid (greyN 0.9) (lightx4 blue) (greyN 0.3)
HoverCrit {} -> Humanoid (greyN 0.9) (light blue) (greyN 0.3)
SwarmCrit -> Humanoid (greyN 0.9) (lightx4 yellow) (greyN 0.3)
AutoCrit -> Humanoid (greyN 0.9) (lightx4 red) (greyN 0.3)
BarrelCrit {} -> Barreloid
src/Dodge/Creature/Update.hs
+6 -1
View File
@@ -56,7 +56,11 @@ updateLivingCreature cr =
ChaseCrit{} -> \w ->
crUpdate cid . performActions cid $
over (cWorld . lWorld . creatures . ix cid) (chaseCritInternal w) w
_ -> crUpdate cid
AutoCrit {} -> crUpdate cid
SwarmCrit {} -> crUpdate cid
HoverCrit {} -> \w ->
crUpdate cid . performActions cid $
over (cWorld . lWorld . creatures . ix cid) (hoverCritInternal w) w
where
cid = cr ^. crID
@@ -135,6 +139,7 @@ dropAll cr w = foldl' (flip (dropItem cr)) w . reverse . IM.keys . _unNIntMap $
chasmTestLiving :: Creature -> World -> World
chasmTestLiving cr w
| Flying {} <- cr ^. crStance . carriage = w
| Falling {} <- cr ^. crStance . carriage =
w
& tocr . crZVel -~ 0.5
src/Dodge/Data/Creature/Misc.hs
+1 -1
View File
@@ -48,7 +48,7 @@ data CreatureType
, _avPosture :: AvatarPosture
}
| ChaseCrit {_meleeCooldown :: Int}
| HoverCrit
| HoverCrit {_meleeCooldown :: Int}
| SwarmCrit
| AutoCrit
| BarrelCrit {_barrelType :: BarrelType}
src/Dodge/Data/Creature/Stance.hs
+1 -1
View File
@@ -21,7 +21,7 @@ data Stance = Stance
data Carriage
= Walking {_strideAmount :: Float, _footForward :: FootForward}
| Floating
| Flying
| Flying {_flyHeight :: Float}
| Boosting Point2
| Falling {_fallFlail :: Float, _fallFoot :: FootForward}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
src/Dodge/Humanoid.hs
+30 -10
View File
@@ -1,4 +1,7 @@
module Dodge.Humanoid (chaseCritInternal) where
module Dodge.Humanoid (
chaseCritInternal,
hoverCritInternal,
) where
import Data.Foldable
import Dodge.Creature
@@ -22,8 +25,25 @@ chaseCritInternal w cr =
, const (crVocalization %~ updateVocTimer)
]
hoverCritInternal :: World -> Creature -> Creature
hoverCritInternal w cr =
foldl'
(\c f -> f w c)
cr
[ const doStrategyActions
, overrideMeleeCloseTarget
, setViewPos
, setMvPos
, hoverCritMv
, perceptionUpdate [0]
, targetYouWhenCognizant
, const searchIfDamaged
, const (crType . meleeCooldown %~ max 0 . subtract 1)
, const (crVocalization %~ updateVocTimer)
]
updateVocTimer :: Vocalization -> Vocalization
updateVocTimer VocTimer {_vcTime=x,_vcMaxTime=y} | x < y = VocTimer (x+1) y
updateVocTimer VocTimer{_vcTime = x, _vcMaxTime = y} | x < y = VocTimer (x + 1) y
updateVocTimer _ = VocReady
-- SpreadGunAI ->
@@ -177,13 +197,13 @@ updateVocTimer _ = VocReady
-- , WaitThen 1 $ (DoImpulses [ChangeStrategy WatchAndWait])
-- ]
--chooseMovementPistol :: Creature -> World -> Action
--chooseMovementPistol cr w =
-- chooseMovementPistol :: Creature -> World -> Action
-- chooseMovementPistol cr w =
-- chooseMovementPistol' cr w
-- `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
--
--chooseMovementPistol' :: Creature -> World -> Action
--chooseMovementPistol' cr w =
-- chooseMovementPistol' :: Creature -> World -> Action
-- chooseMovementPistol' cr w =
-- takeOneWeighted
-- [chargeProb, retreatProb, strafeProb, strafeProb]
-- [ chargeActions
@@ -223,8 +243,8 @@ updateVocTimer _ = VocReady
-- yposl = ypos -.- 100 *.* vNormal (normalizeV $ ypos -.- cpos)
-- yposr = ypos +.+ 100 *.* vNormal (normalizeV $ ypos -.- cpos)
--
--retreatActionsPistol :: Creature -> Creature -> Action
--retreatActionsPistol tcr cr =
-- retreatActionsPistol :: Creature -> Creature -> Action
-- retreatActionsPistol tcr cr =
-- [TurnToward retreatOffset 0.2]
-- `DoImpulsesAlongside` 3
-- `DoReplicate` ImpulsesList (replicate 9 [Move (V2 (-3) 0)] ++ [[UseItem]])
@@ -244,8 +264,8 @@ updateVocTimer _ = VocReady
-- tpos
-- (tpos +.+ vNormal (cpos -.- tpos))
--
--retreatFireLauncher :: Action
--retreatFireLauncher =
-- retreatFireLauncher :: Action
-- retreatFireLauncher =
-- ImpulsesList ([UseItem] : replicate 20 [Turn 0.16])
-- `DoActionThen` holsterWeapon
-- `DoActionThen` ImpulsesList (replicate 30 [MoveForward 3])
src/Dodge/Path.hs
+33
View File
@@ -2,6 +2,7 @@
module Dodge.Path (
nodesNear,
pointTowardsImpulse,
pointTowardsImpulse',
makePathBetween,
makePathBetweenPs,
obstructPathsCrossing,
@@ -10,6 +11,7 @@ module Dodge.Path (
snapToGrid,
pairsToIncGraph,
getEdgesCrossing,
pathEdgeObstructed,
) where
import Dodge.WorldEvent.ThingsHit
@@ -60,15 +62,38 @@ makePathUsing t s e w = do
. IM.filter (^. seObstacles . to t) $ w ^?! cWorld . incGraph . ix i
getn i = w ^?! cWorld . incNode . ix i
makePathUsing' :: (Point2 -> Point2 -> World -> Bool)
-> (Set.Set EdgeObstacle -> Bool) -> Point2 -> Point2 -> World -> Maybe [Int]
makePathUsing' t1 t2 s e w = do
na <- nodeNear t1 w s
nb <- nodeNear t1 w e
let h i = distance (getn nb) (getn i)
(na :) . snd <$> AS.aStarAssoc getes h (== nb) na
where
getes i = IM.toList
. IM.map (^. seDist)
. IM.filter (^. seObstacles . to t2) $ w ^?! cWorld . incGraph . ix i
getn i = w ^?! cWorld . incNode . ix i
makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
makePathBetween = makePathUsing $ not . pathEdgeObstructed
makePathBetween' :: (Point2 -> Point2 -> World -> Bool) -> (Set.Set EdgeObstacle -> Bool)
-> Point2 -> Point2 -> World -> Maybe [Int]
makePathBetween' t1 t2 = makePathUsing' t1 $ t2
pathEdgeObstructed :: Set.Set EdgeObstacle -> Bool
pathEdgeObstructed pe = any (`Set.member` pe) [WallObstacle WallNotAutoOpen, ChasmObstacle]
walkableNodeNear :: World -> Point2 -> Maybe Int
{-# INLINE walkableNodeNear #-}
walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear w p
nodeNear :: (Point2 -> Point2 -> World -> Bool) -> World -> Point2 -> Maybe Int
{-# INLINE nodeNear #-}
nodeNear t w p = fmap fst . find (flip (t p) w . snd) $ nodesNear w p
-- where
-- nodesNear = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p
@@ -87,10 +112,18 @@ smallSnailInt2 =
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
makePathBetweenPs a b w = fmap (`getNodePos` w) <$> makePathBetween a b w
makePathBetweenPs' :: (Point2 -> Point2 -> World -> Bool) -> (Set.Set EdgeObstacle -> Bool)
->Point2 -> Point2 -> World -> Maybe [Point2]
makePathBetweenPs' t1 t2 a b w = fmap (`getNodePos` w) <$> makePathBetween' t1 t2 a b w
-- assumes that pathfinding is symmetric
pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs b a w
pointTowardsImpulse' :: (Point2 -> Point2 -> World -> Bool) -> (Set.Set EdgeObstacle -> Bool)
-> Point2 -> Point2 -> World -> Maybe Point2
pointTowardsImpulse' t1 t2 a b w = find (flip (t1 a) w) =<< makePathBetweenPs' t1 t2 b a w
pairsToIncGraph ::
Set.Set (Point2, Point2) ->
( UV.Vector Point2
src/Dodge/Placement/Instance/Creature.hs
+1 -1
View File
@@ -6,5 +6,5 @@ import Dodge.Data.GenWorld
import RandomHelp
randC1 :: PSType
randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit
randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 hoverCrit
--randC1 = RandPS $ takeOne $ map PutCrit [hoverCrit]
src/Dodge/Placement/PlaceSpot.hs
+1 -5
View File
@@ -176,11 +176,7 @@ mvCr p rot = (crPos . _xy .~ p) . (crOldPos . _xy .~ p) . (crDir .~ rot)
mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +) . rotateV a))
plMachine ::
Machine ->
Maybe Item ->
GenWorld ->
(Int, GenWorld)
plMachine :: Machine -> Maybe Item -> GenWorld -> (Int, GenWorld)
plMachine mc mitm gw =
( mcid
, gw
src/Dodge/Render/ShapePicture.hs
+4 -1
View File
@@ -116,7 +116,10 @@ drawCreature m cr = translateSP (_crPos cr) . rotateSP (_crDir cr) $
BarrelCrit{} -> barrelShape
LampCrit{_lampHeight = h} -> lampCrSPic h
ChaseCrit {} -> noPic $ drawChaseCrit cr
_ -> basicCrPict m cr
Avatar {} -> basicCrPict m cr
SwarmCrit -> basicCrPict m cr
AutoCrit -> basicCrPict m cr
HoverCrit{} -> noPic $ drawHoverCrit cr
barrelShape :: SPic
barrelShape = noPic $ cylinderPoly Medium Important (map (addZ 20) ps) (map (addZ 0) ps)
src/Dodge/Room/Room.hs
+4
View File
@@ -13,6 +13,7 @@ module Dodge.Room.Room (
critsRoom,
distributerRoom,
critDeadEnd,
deadEndPSType,
) where
import qualified Data.IntMap.Strict as IM
@@ -259,6 +260,9 @@ critInDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) 0 randC1]
critDeadEnd :: Room
critDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) (pi/2) randC1]
deadEndPSType :: PSType -> Room
deadEndPSType x = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) (pi/2) x]
deadEndRoom :: Room
deadEndRoom =
defaultRoom
src/Dodge/Room/Tutorial.hs
+3 -2
View File
@@ -2,6 +2,7 @@
module Dodge.Room.Tutorial where
import Dodge.Creature.ChaseCrit
import Control.Monad
import Data.Foldable
import qualified Data.IntMap.Strict as IM
@@ -338,8 +339,8 @@ chasmSpitTerminal = do
tToBTree "chasmTerm" $
Node
(addDoorToggleTerminal' i1 (PS 150 0) y')
[ treePost [triggerDoorRoom i1, critDeadEnd]
, treePost [triggerDoorRoom i1, critDeadEnd]
[ treePost [triggerDoorRoom i1, deadEndPSType (PutCrit chaseCrit)]
, treePost [triggerDoorRoom i1, deadEndPSType (PutCrit hoverCrit)]
, return $ cleatOnward $ triggerDoorRoom i1
]
where
src/Dodge/TestString.hs
+2 -1
View File
@@ -35,7 +35,8 @@ import Data.Monoid
import RandomHelp
testStringInit :: Universe -> [String]
testStringInit _ = mempty -- fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . ix 0 . crWallTouch . each)
testStringInit u = u ^.. uvWorld . cWorld . lWorld . creatures . each . crActionPlan . apAction . to show
-- fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . ix 0 . crWallTouch . each)
-- (fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crStance . carriage)
-- (fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crStance . carriage . strideAmount)
-- a <> fromMaybe [] (do
src/Dodge/WorldEvent/ThingsHit.hs
+1
View File
@@ -17,6 +17,7 @@ module Dodge.WorldEvent.ThingsHit (
crWlPbHitZ,
wlsHitUnsorted,
isWalkable,
isFlyable,
) where
import ListHelp