From 72e29ebac3e2bf69613734b652cca04df31ed5a4 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 6 Sep 2021 11:35:30 +0100 Subject: [PATCH] Fix basic pathing --- src/Dodge/Creature/Action.hs | 8 +- src/Dodge/Creature/ChaseCrit.hs | 2 +- src/Dodge/Creature/ReaderUpdate.hs | 20 +-- src/Dodge/Graph.hs | 12 +- src/Dodge/Layout.hs | 4 + src/Dodge/Path.hs | 215 +++++++---------------------- src/Dodge/Render/Picture.hs | 8 +- src/Dodge/Room.hs | 8 +- src/Dodge/Room/Procedural.hs | 2 + 9 files changed, 86 insertions(+), 193 deletions(-) diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index 3ade8f554..43126415d 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -10,6 +10,7 @@ module Dodge.Creature.Action , pickUpItem ) where +import Dodge.Path import Dodge.Creature.Stance.Data import Dodge.WorldEvent.Shockwave import Dodge.Data @@ -60,10 +61,13 @@ performAimAt cr w tcid p = ([TurnToward tpos aimSp], Just $ AimAt tcid tpos) performPathTo :: Creature -> World -> Point2 -> OutAction performPathTo cr w p | dist cpos p < 5 = ([], Nothing) - | hasLOS cpos p w = ([MvTurnToward p,MvForward] , Just (PathTo p)) - | otherwise = ([], Nothing) + | hasLOS cpos p w = ([MvTurnToward p,MvForward,RandomTurn jit] , Just (PathTo p)) + | otherwise = case pointTowardsImpulse cpos p w of + Just q -> ([MvTurnToward q,MvForward,RandomTurn jit] , Just (PathTo p)) + _ -> ([],Nothing) where cpos = _crPos cr + jit = _mvTurnJit $ _crMvType cr {- | Performing an action means that a creature has some impulses for a frame, and updates or deletes the action itself. diff --git a/src/Dodge/Creature/ChaseCrit.hs b/src/Dodge/Creature/ChaseCrit.hs index f5605b48b..85cd1061b 100644 --- a/src/Dodge/Creature/ChaseCrit.hs +++ b/src/Dodge/Creature/ChaseCrit.hs @@ -49,7 +49,7 @@ chaseCrit = defaultCreature , _crMeleeCooldown = 0 , _crFaction = ColorFaction green , _crMvType = ChaseMvType - { _mvSpeed = 2.5 + { _mvSpeed = 3 , _mvTurnRad = f , _mvTurnJit = 0.2 } diff --git a/src/Dodge/Creature/ReaderUpdate.hs b/src/Dodge/Creature/ReaderUpdate.hs index 3e0d170c6..2e145148d 100644 --- a/src/Dodge/Creature/ReaderUpdate.hs +++ b/src/Dodge/Creature/ReaderUpdate.hs @@ -17,7 +17,6 @@ import Dodge.Creature.Test import Dodge.Creature.Volition import Dodge.Creature.AlertLevel.Data import Dodge.Base -import Dodge.Base.Collide import Geometry import FoldableHelp @@ -75,26 +74,9 @@ flockACCR cr = do goToTarget :: Creature -> Reader World Creature goToTarget cr = do - w <- ask case cr ^? crMvTarget . _Just of - Just p - | dist p cpos > _crRad cr + 10 && hasLOS p cpos w - -> pure $ cr & crActionPlan . crImpulse .~ - [ MoveForward speed - , TurnToward p (trad dirOffset) - , RandomTurn jit - ] - | dist p cpos > _crRad cr + 10 - -> pure $ cr & crActionPlan . crAction .~ [PathTo p] - where - dirOffset = abs (_crDir cr - argV (p -.- cpos)) + Just p -> pure $ cr & crActionPlan . crAction .~ [PathTo p] _ -> pure cr - where - cpos = _crPos cr - mvType = _crMvType cr - speed = _mvSpeed mvType - trad = _mvTurnRad mvType - jit = _mvTurnJit mvType doStrategyActionsR :: Creature diff --git a/src/Dodge/Graph.hs b/src/Dodge/Graph.hs index d68546d1f..7410b7764 100644 --- a/src/Dodge/Graph.hs +++ b/src/Dodge/Graph.hs @@ -1,14 +1,19 @@ +{-# LANGUAGE RankNTypes #-} module Dodge.Graph ( pairsToSCC , incidenceToFunction , pairsToIncidence + , graphToEdges ) where -- this deserves tests import Data.List.Extra -import Data.Bifunctor (first) +--import Data.Bifunctor (first) import Data.Graph import Data.Maybe +import qualified Data.Graph.Inductive.Graph as F +import qualified Data.Graph.Inductive.PatriciaTree as F +import Data.Bifunctor pairsToIncidence :: Ord a => [(a,a)] -> [(a,[a])] pairsToIncidence @@ -24,3 +29,8 @@ mkNode (x,xs) = (x,x,xs) pairsToSCC :: Ord a => [(a,a)] -> [SCC a] pairsToSCC = stronglyConnComp . map mkNode . pairsToIncidence + +graphToEdges :: forall a b . F.Gr a b -> [(a,a)] +graphToEdges g = map (bimap f f) $ F.edges g + where + f n = fromJust . lookup n $ F.labNodes g diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index b99c646c5..9777193e8 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -43,8 +43,12 @@ generateLevelFromRoomList gr w = updateWallZoning $ w { _walls = wallsFromRooms rs , _floorTiles = floorsFromRooms rs , _gameRooms = gameRoomsFromRooms rs + , _pathGraph = path + , _pathGraph' = pairPath } where + path = pairsToGraph dist pairPath + pairPath = concatMap _rmPath rs plmnts = concatMap _rmPS rs rs = zipWith addTile zs rs' zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index 1af06a62e..f95647dc5 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -1,101 +1,25 @@ -module Dodge.Path where +module Dodge.Path + ( pointTowardsImpulse + --, pointTowardsImpulse' + , makePathBetween + , makePathBetweenPs + ) + where import Dodge.Data import Dodge.Base.Collide import Dodge.Base.Zone -import Dodge.Graph -import Geometry import Data.List import Data.Maybe -import Data.Function -import Data.Graph.Inductive.PatriciaTree +--import Data.Graph.Inductive.PatriciaTree import Data.Graph.Inductive.Query.SP import Data.Graph.Inductive.Graph hiding ((&)) -import qualified Data.HashSet as HS -import qualified Data.Heap as HP -import qualified Data.Map as M import Control.Monad -import Control.Monad.State -import System.Random - -worldGraph :: World -> Point2 -> HS.HashSet Point2 -worldGraph w p = HS.unions $ (\q -> HS.fromList $ pointsAlong w p (p +.+ q)) . toV2 - <$> [(200,0),(-200,0),(0,200),(0,-200)] - -pointsAlong :: World -> Point2 -> Point2 -> [Point2] -pointsAlong w p q = divideLineFixed 50 p p' - where - p' = furthestPointWalkable p q $ wallsAlongLine p q w - -divideLineFixed :: Float -> Point2 -> Point2 -> [Point2] -divideLineFixed x a b = fmap - ( \i -> a +.+ i * x *.* normalizeV (b -.- a) ) - ns - where - numPoints = floor $ dist a b / x :: Int - ns = map fromIntegral [1 .. numPoints] +--import Control.Monad.State +--import System.Random -- ok, astar or something like it -type SearchedNodes = (HP.MinHeap (Float,(Float,[Point2])), [Point2]) - -stripRight :: Either a b -> b -stripRight (Right x) = x -stripRight _ = error "Trying to strip Right where there is a Left" - -stepPath :: (Point2 -> [Point2]) -> Point2 -> SearchedNodes -> Either [Point2] SearchedNodes -stepPath h p (nextNodes, seenNodes) = case HP.view nextNodes of - Nothing -> Left [] - Just ((_,(cost,q:qs)), nextNodes') - | q == p -> Left (q:qs) - | otherwise -> - let rs' = h q - rs = rs' \\ seenNodes - newNodes' = map (\r -> (cost + dist q r + dist r p , (cost + dist q r , r:q:qs))) rs - in Right (foldr HP.insert nextNodes' newNodes' , rs ++ seenNodes) - Just _ -> error "In step path" - -stepPath' :: (Point2 -> [Point2]) -> Point2 -> SearchedNodes -> [Point2] -stepPath' h p s = case stepPath h p s of - Left ps -> ps - Right s' -> stepPath' h p s' - -makePath' :: (Point2 -> [Point2]) -> Point2 -> Point2 -> [Point2] -makePath' h s e = stepPath' h e (HP.singleton (0,(0,[s])) , []) - -makeNode :: Point2 -> SearchedNodes -makeNode e = (HP.singleton (0,(0,[e])) , []) - - -tp1,tp2,tp3 :: Point2 -tp1 = V2 0 1 -tp2 = V2 0 20 -tp3 = V2 30 40 - -f :: Point2 -> [Point2] -f = incidenceToFunction $ pairsToIncidence - [(tp1,tp2) - ,(tp2,tp3) - ,(tp2,tp1) - ,(tp1,tp3) - ] ---g :: [(Point2,[Point2])] ---g = pairsToIncidence --- [(tp1,tp2) --- ,(tp2,tp3) --- ,(tp2,tp1) --- ,(tp1,tp3) --- ] - -pathBetween :: Point2 -> Point2 -> World -> Maybe [Point2] -pathBetween a b w = makePath' (\p -> _pathInc w M.! p) <$> a' <*> b' - where - nsa :: [Point2] - nsa = map snd $ concat $ lookLookups (zoneAroundPoint a) (_pathPoints w) - nsb = map snd $ concat $ lookLookups (zoneAroundPoint b) (_pathPoints w) - a' = find (flip (isWalkable a) w) nsa - b' = find (flip (isWalkable b) w) nsb - makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] makePathBetween a b w = join $ sp <$> fmap fst a' <*> fmap fst b' <*> return g' where @@ -105,88 +29,53 @@ makePathBetween a b w = join $ sp <$> fmap fst a' <*> fmap fst b' <*> return g' a' = find (flip (isWalkable a) w . snd) nsa b' = find (flip (isWalkable b) w . snd) nsb -ezipWith :: Monoid a => (b -> c -> d) -> Either a b -> Either a c -> Either a d -ezipWith f' (Right x) (Right y) = Right (f' x y) -ezipWith _ (Left x) (Right _) = Left x -ezipWith _ (Right _) (Left y) = Left y -ezipWith _ (Left x) (Left y) = Left (mappend x y) - -makePathBetween' :: Point2 -> Point2 -> World -> Either String [Int] -makePathBetween' a b w = - let g' = _pathGraph w - ns = labNodes g' - --nsa = _pathPoints w `ixNZ` a - --nsb = _pathPoints w `ixNZ` b - a' = case listToMaybe $ sortBy (compare `on` dist a . snd) $ filter (flip (isWalkable a) w . snd) ns of - Just p -> Right $ fst p - _ -> Left "FIRST POINT UNSEEN" - b' = case listToMaybe $ sortBy (compare `on` dist b . snd) $ filter (flip (isWalkable b) w . snd) ns of - Just p -> Right $ fst p - _ -> Left $ "SECOND POINT UNSEEN" ++ show b - in case ezipWith (\x y -> sp x y g') a' b' of - Right (Just xs) -> Right xs - Right Nothing -> Left $ "NO PATH" ++ show a ++ show b ++ show a' ++ show b' - Left m -> Left m - makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2] makePathBetweenPs a b w = mapMaybe (lab g') <$> makePathBetween b a w where g' = _pathGraph w -makePathBetweenPs' :: Point2 -> Point2 -> World -> Either String [Point2] -makePathBetweenPs' a b w = mapMaybe (lab g') <$> makePathBetween' a b w - where - g' = _pathGraph w - pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2 pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w - -pointTowardsImpulse' :: Point2 -> Point2 -> World -> Either String Point2 -pointTowardsImpulse' a b w = (maybeToEither "NOSEEPATH" . find (flip (isWalkable a) w)) =<< makePathBetweenPs' b a w -maybeToEither :: a -> Maybe b -> Either a b -maybeToEither _ (Just x) = Right x -maybeToEither y Nothing = Left y - -randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int) -randomGraphStep n g = - do let ns = neighbors g n - i <- state $ randomR (0,length ns - 1) - case ns of [] -> return Nothing - _ -> return $ Just $ ns !! i -randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int) -randomGraphStepRestricted n notns g = do - let ns = neighbors g n \\ notns - i <- state $ randomR (0,length ns - 1) - case ns of - [] -> return Nothing - _ -> return $ Just $ ns !! i - ----- continues a walk from a list of points, without repetitions ----- supposes that the list is non-empty -randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int] -randomGraphWalk (n:ns) g = do - next' <- randomGraphStepRestricted n ns g - case next' of - Nothing -> return (n:ns) - Just n' -> randomGraphWalk (n':n:ns) g -randomGraphWalk _ _ = error "Trying to walk in an empty list" - -randomPointXStepsFrom :: Int -> Point2 -> World -> Point2 -randomPointXStepsFrom i p w = - let g = _pathGraph w - ns = labNodes g - mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns - in case mp of - Nothing -> p - Just (n,_) -> fromJust - $ lab g (last $ take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w) - -randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2] -randomPointsXStepsFrom i p w = - let g = _pathGraph w - ns = labNodes g - mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns - in case mp of - Nothing -> [p] - Just (n,_) -> mapMaybe (lab g) (take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w) +------ continues a walk from a list of points, without repetitions +------ supposes that the list is non-empty +--randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int] +--randomGraphWalk (n:ns) g = do +-- next' <- randomGraphStepRestricted n ns g +-- case next' of +-- Nothing -> return (n:ns) +-- Just n' -> randomGraphWalk (n':n:ns) g +--randomGraphWalk _ _ = error "Trying to walk in an empty list" +-- +--randomPointXStepsFrom :: Int -> Point2 -> World -> Point2 +--randomPointXStepsFrom i p w = +-- let g = _pathGraph w +-- ns = labNodes g +-- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns +-- in case mp of +-- Nothing -> p +-- Just (n,_) -> fromJust +-- $ lab g (last $ take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w) +-- +--randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2] +--randomPointsXStepsFrom i p w = +-- let g = _pathGraph w +-- ns = labNodes g +-- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns +-- in case mp of +-- Nothing -> [p] +-- Just (n,_) -> mapMaybe (lab g) (take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w) +-- +--randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int) +--randomGraphStep n g = +-- do let ns = neighbors g n +-- i <- state $ randomR (0,length ns - 1) +-- case ns of [] -> return Nothing +-- _ -> return $ Just $ ns !! i +--randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int) +--randomGraphStepRestricted n notns g = do +-- let ns = neighbors g n \\ notns +-- i <- state $ randomR (0,length ns - 1) +-- case ns of +-- [] -> return Nothing +-- _ -> return $ Just $ ns !! i diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index db0b4a676..3becb287b 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -9,6 +9,7 @@ import Dodge.Picture import Dodge.Picture.Layer import Dodge.Render.HUD import Dodge.Render.MenuScreen +import Dodge.Graph import Geometry import Picture import Polyhedra.Data @@ -58,12 +59,7 @@ customMouseCursor w = $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ] testPic :: World -> Picture -testPic _ = blank - --setLayer 1 $ renderListAt 50 0 w $ map ((,white) . _grName) $ _gameRooms w - --- [ setDepth (-1) . translate 0 0.8 --- . scale 0.001 0.001 . text . show $ _crMvDir $ you w --- ] +testPic w = color green . pictures . map (flip thickLine 5 . tflat2) . graphToEdges $ _pathGraph w crDraw :: World -> Creature -> Picture crDraw w c = _crPict c c w diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 49a29dfb3..b14e6ba7f 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -16,6 +16,7 @@ import Dodge.Creature import Dodge.LevelGen.Data --import Dodge.Base import Dodge.RandomHelp +import Dodge.LevelGen import Dodge.Default.Wall --import Dodge.Path --import Dodge.Layout @@ -50,7 +51,7 @@ roomC :: Float -> Float -> Room roomC x y = defaultRoom { _rmPolys = [rectNSWE y 0 0 x] , _rmLinks = lnks - , _rmPath = [] + , _rmPath = pth , _rmPS = [windowLine (V2 (x/2) 0) (V2 (x/2) (y-60)) ] , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] @@ -61,6 +62,11 @@ roomC x y = defaultRoom ,( ( 20, 0),pi) ,( ( 0, 20),pi/2) ] + xn = 4 + yn = 4 + yd = (y - 40) / fromIntegral yn + xd = (x - 40) / fromIntegral xn + pth = linksAndPath lnks $ translateS (V2 20 20) (makeGrid xd xn yd yn) roomPadCut :: [Point2] -> Point2 -> Room roomPadCut ps p = defaultRoom diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index c8058a33d..9af544a47 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -6,6 +6,8 @@ module Dodge.Room.Procedural , randomFourCornerRoom , centerVaultRoom , combineRooms + , linksAndPath + , makeGrid ) where import Dodge.Data import Dodge.Room.Data