Fix basic pathing

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))
+    | hasLOS cpos p w = ([MvTurnToward p,MvForward,RandomTurn jit] , Just (PathTo p))
-    | otherwise       = ([], Nothing)
+    | 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. 

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
         }

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 
+        Just p -> pure $ cr & crActionPlan . crAction .~ [PathTo 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))
         _ -> pure cr
-  where
-    cpos    = _crPos cr
-    mvType  = _crMvType cr
-    speed   = _mvSpeed mvType
-    trad    = _mvTurnRad mvType
-    jit     = _mvTurnJit mvType
     
 doStrategyActionsR
     :: Creature

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

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

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 Control.Monad.State
-import System.Random
+--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]
 
 -- 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
+------ continues a walk from a list of points, without repetitions
-pointTowardsImpulse' a b w = (maybeToEither "NOSEEPATH" . find (flip (isWalkable a) w)) =<< makePathBetweenPs' b a w
+------ supposes that the list is non-empty
-
+--randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int]
-maybeToEither :: a -> Maybe b -> Either a b
+--randomGraphWalk (n:ns) g = do 
-maybeToEither _ (Just x) = Right x
+--    next' <- randomGraphStepRestricted n ns g
-maybeToEither y Nothing  = Left y
+--    case next' of 
-
+--        Nothing -> return (n:ns)
-randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int)
+--        Just n' -> randomGraphWalk (n':n:ns) g
-randomGraphStep n g = 
+--randomGraphWalk _ _ = error "Trying to walk in an empty list"
-    do let ns = neighbors g n
+--
-       i  <- state $ randomR (0,length ns - 1)
+--randomPointXStepsFrom :: Int -> Point2 -> World -> Point2
-       case ns of [] -> return Nothing
+--randomPointXStepsFrom i p w = 
-                  _  -> return $ Just $ ns !! i
+--    let g  = _pathGraph w
-randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int)
+--        ns = labNodes g
-randomGraphStepRestricted n notns g = do 
+--        mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
-    let ns = neighbors g n \\ notns
+--    in case mp of 
-    i  <- state $ randomR (0,length ns - 1)
+--        Nothing -> p
-    case ns of 
+--        Just (n,_) -> fromJust 
-        [] -> return Nothing
+--            $ lab g (last $ take i $ randomGraphWalk [n] g Data.Function.& evalState  $ _randGen w)
-        _  -> return $ Just $ ns !! i
+--
-
+--randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2]
----- continues a walk from a list of points, without repetitions
+--randomPointsXStepsFrom i p w = 
----- supposes that the list is non-empty
+--    let g  = _pathGraph w
-randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int]
+--        ns = labNodes g
-randomGraphWalk (n:ns) g = do 
+--        mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
-    next' <- randomGraphStepRestricted n ns g
+--    in case mp of 
-    case next' of 
+--        Nothing -> [p]
-        Nothing -> return (n:ns)
+--        Just (n,_) -> mapMaybe (lab g) (take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w)
-        Just n' -> randomGraphWalk (n':n:ns) g
+--
-randomGraphWalk _ _ = error "Trying to walk in an empty list"
+--randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int)
-
+--randomGraphStep n g = 
-randomPointXStepsFrom :: Int -> Point2 -> World -> Point2
+--    do let ns = neighbors g n
-randomPointXStepsFrom i p w = 
+--       i  <- state $ randomR (0,length ns - 1)
-    let g  = _pathGraph w
+--       case ns of [] -> return Nothing
-        ns = labNodes g
+--                  _  -> return $ Just $ ns !! i
-        mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
+--randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int)
-    in case mp of 
+--randomGraphStepRestricted n notns g = do 
-        Nothing -> p
+--    let ns = neighbors g n \\ notns
-        Just (n,_) -> fromJust 
+--    i  <- state $ randomR (0,length ns - 1)
-            $ lab g (last $ take i $ randomGraphWalk [n] g Data.Function.& evalState  $ _randGen w)
+--    case ns of 
-
+--        [] -> return Nothing
-randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2]
+--        _  -> return $ Just $ ns !! i
-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)

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
+testPic w = color green . pictures . map (flip thickLine 5 . tflat2) . graphToEdges $ _pathGraph w
-    --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
---    ]
 
 crDraw :: World -> Creature -> Picture
 crDraw w c = _crPict c c w

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

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