Generalise pathing, usable with flying creatures

src/Dodge/Creature/Action.hs

@@ -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
+--    | isWalkable cpos p w = gotowards p
-    | otherwise = case pointTowardsImpulse cpos p w of
+    | 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

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

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

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

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

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

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

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

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

@@ -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 :: Creature -> World -> Action
---chooseMovementPistol cr w =
+-- chooseMovementPistol cr w =
 --    chooseMovementPistol' cr w
 --        `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
 --
---chooseMovementPistol' :: Creature -> World -> Action
+-- chooseMovementPistol' :: Creature -> World -> Action
---chooseMovementPistol' cr w =
+-- 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 :: Creature -> Creature -> Action
---retreatActionsPistol tcr cr =
+-- 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 :: Action
---retreatFireLauncher =
+-- retreatFireLauncher =
 --    ImpulsesList ([UseItem] : replicate 20 [Turn 0.16])
 --        `DoActionThen` holsterWeapon
 --        `DoActionThen` ImpulsesList (replicate 30 [MoveForward 3])

src/Dodge/Path.hs

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

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

@@ -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 ::
+plMachine :: Machine -> Maybe Item -> GenWorld -> (Int, GenWorld)
-    Machine ->
-    Maybe Item ->
-    GenWorld ->
-    (Int, GenWorld)
 plMachine mc mitm gw =
     ( mcid
     , gw

src/Dodge/Render/ShapePicture.hs

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

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

@@ -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, deadEndPSType (PutCrit chaseCrit)]
-                , treePost [triggerDoorRoom i1, critDeadEnd]
+                , treePost [triggerDoorRoom i1, deadEndPSType (PutCrit hoverCrit)]
                 , return $ cleatOnward $ triggerDoorRoom i1
                 ]
   where

src/Dodge/TestString.hs

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

@@ -17,6 +17,7 @@ module Dodge.WorldEvent.ThingsHit (
     crWlPbHitZ,
     wlsHitUnsorted,
     isWalkable,
+    isFlyable,
 ) where
 
 import ListHelp