Fix basic pathing
This commit is contained in:
@@ -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.
|
||||
|
||||
@@ -49,7 +49,7 @@ chaseCrit = defaultCreature
|
||||
, _crMeleeCooldown = 0
|
||||
, _crFaction = ColorFaction green
|
||||
, _crMvType = ChaseMvType
|
||||
{ _mvSpeed = 2.5
|
||||
{ _mvSpeed = 3
|
||||
, _mvTurnRad = f
|
||||
, _mvTurnJit = 0.2
|
||||
}
|
||||
|
||||
@@ -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
|
||||
|
||||
+11
-1
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+52
-163
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+7
-1
@@ -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
|
||||
|
||||
@@ -6,6 +6,8 @@ module Dodge.Room.Procedural
|
||||
, randomFourCornerRoom
|
||||
, centerVaultRoom
|
||||
, combineRooms
|
||||
, linksAndPath
|
||||
, makeGrid
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Room.Data
|
||||
|
||||
Reference in New Issue
Block a user