Refactor, try to limit dependencies

src/Dodge/Path.hs

@@ -1,43 +1,40 @@
 --{-# LANGUAGE TupleSections #-}
-module Dodge.Path 
-    ( pointTowardsImpulse
-    , makePathBetween
-    , makePathBetweenPs
---    , removePathsCrossing
-    , obstructPathsCrossing
-    , pairsToGraph
-    , getNodePos
-    , walkableNodeNear
-    , bfsNodePoints
-    , fusePairs
-    ) where
-import Dodge.Zoning.Pathing
-import Dodge.Zoning.Base
-import Dodge.Data
-import Dodge.Base.Collide
-import Geometry.Data
-import Geometry
+module Dodge.Path (
+    pointTowardsImpulse,
+    makePathBetween,
+    makePathBetweenPs,
+    --    , removePathsCrossing
+    obstructPathsCrossing,
+    pairsToGraph,
+    getNodePos,
+    walkableNodeNear,
+    bfsNodePoints,
+    fusePairs,
+) where
 
-import Data.Foldable
 import Control.Lens
-import Data.Maybe
-import Data.List
---import qualified IntMapHelp as IM
+import Data.Foldable
 import Data.Graph.Inductive hiding ((&))
-import qualified Data.Set as Set
-import Data.Set (Set)
-import qualified Data.Map.Strict as M
+import Data.List
 import Data.Map.Strict (Map)
-import StreamingHelp
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Dodge.Base.Collide
+import Dodge.Data.World
+import Dodge.Zoning.Base
+import Dodge.Zoning.Pathing
+import Geometry
 import qualified Streaming.Prelude as S
---import Data.Graph.Inductive.PatriciaTree
---import Data.Graph.Inductive.Graph hiding ((&))
+import StreamingHelp
 
 getNodePos :: Int -> World -> Maybe Point2
 getNodePos i w = _pathGraph (_cWorld w) `lab` i
 
 makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
-makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
+makePathBetween a b w = do
+    -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     na <- walkableNodeNear w a
     nb <- walkableNodeNear w b
     sp na nb (second _peDist (efilter (not . pathEdgeObstructed . (^. _3)) $ _pathGraph (_cWorld w)))
@@ -47,7 +44,6 @@ pathEdgeObstructed pe = DoorObstacle `Set.member` obs || BlockObstacle `Set.memb
   where
     obs = _peObstacles pe
 
-
 walkableNodeNear :: World -> Point2 -> Maybe Int
 {-# INLINE walkableNodeNear #-}
 walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
@@ -63,94 +59,99 @@ bfsNodePoints n w = mapMaybe (lab g) $ bfs n g
   where
     g = _pathGraph (_cWorld w)
 
-
 pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
 pointTowardsImpulse a b w = (find (flip (isWalkable a) w) . reverse) =<< makePathBetweenPs a b 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 
+--randomGraphWalk (n:ns) g = do
 --    next' <- randomGraphStepRestricted n ns g
---    case next' of 
+--    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 = 
+--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 
+--    in case mp of
 --        Nothing -> p
---        Just (n,_) -> fromJust 
+--        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 = 
+--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 
+--    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 = 
+--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 
+--randomGraphStepRestricted n notns g = do
 --    let ns = neighbors g n \\ notns
 --    i  <- state $ randomR (0,length ns - 1)
---    case ns of 
+--    case ns of
 --        [] -> return Nothing
 --        _  -> return $ Just $ ns !! i
 --
-pairsToGraph :: Set.Set (Point2,Point2) -> (Map (V2 Point2) (Int,Int,PathEdge),Gr Point2 PathEdge)
+pairsToGraph :: Set.Set (Point2, Point2) -> (Map (V2 Point2) (Int, Int, PathEdge), Gr Point2 PathEdge)
 pairsToGraph pairs = addEdges nodemap gr $ S.each pairs
   where
-    (nodemap,_,gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs)
+    (nodemap, _, gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs)
+
 --    let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
 --        pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
 --    in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
 
-addNodes :: StreamOf Point2 -> (Map Point2 Int,Int,Gr Point2 PathEdge)
-addNodes = runIdentity . S.fold_ f (mempty,0,Data.Graph.Inductive.empty) id
+addNodes :: StreamOf Point2 -> (Map Point2 Int, Int, Gr Point2 PathEdge)
+addNodes = runIdentity . S.fold_ f (mempty, 0, Data.Graph.Inductive.empty) id
   where
-    f (nodemap,i,gr) p = case nodemap M.!? p of
-        Just _  -> (nodemap,i,gr)
-        Nothing -> (nodemap & at p ?~i ,i+1, insNode (i,p) gr)
-addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2) 
-    -> (Map (V2 Point2) (Int,Int,PathEdge) , Gr Point2 PathEdge)
-addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id
+    f (nodemap, i, gr) p = case nodemap M.!? p of
+        Just _ -> (nodemap, i, gr)
+        Nothing -> (nodemap & at p ?~ i, i + 1, insNode (i, p) gr)
+
+addEdges ::
+    Map Point2 Int ->
+    Gr Point2 PathEdge ->
+    StreamOf (Point2, Point2) ->
+    (Map (V2 Point2) (Int, Int, PathEdge), Gr Point2 PathEdge)
+addEdges nodemap gr = runIdentity . S.fold_ f (mempty, gr) id
   where
-    f (edgemap,gr') (a,b) = (M.insert (V2 a b) theedge edgemap
+    f (edgemap, gr') (a, b) =
+        ( M.insert (V2 a b) theedge edgemap
         , insEdge theedge gr'
         )
       where
-        theedge = (g a,g b,PathEdge a b (dist a b) mempty)
+        theedge = (g a, g b, PathEdge a b (dist a b) mempty)
     g a = nodemap M.! a
 
-obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)])
-obstructPathsCrossing obstacletype sp' ep w = 
+obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> (World, [(Int, Int, PathEdge)])
+obstructPathsCrossing obstacletype sp' ep w =
     ( w & cWorld . pathGraph %~ updateedges
     , es
     )
   where
     es = filter edgecrosses $ pesNearSeg sp' ep w
-    edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe)
+    edgecrosses (_, _, pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe)
     updateedges gr = foldl' updateedge gr es
-    updateedge gr (x,y,pe) 
-        = insEdge (x,y,pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x,y) gr
+    updateedge gr (x, y, pe) =
+        insEdge (x, y, pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x, y) gr
 
 fuseFunc :: (a -> a -> Bool) -> [a] -> a -> a
 fuseFunc t xs x = fromJust . find (t x) $ nubBy t xs
 
-fusePairs :: Set (Point2,Point2) -> Set (Point2,Point2)
+fusePairs :: Set (Point2, Point2) -> Set (Point2, Point2)
 fusePairs ps = Set.map (bimap f f) ps
   where
-    f = fuseFunc (\x y -> dist x y < 2) . nub $ concatMap (\(x,y) -> [x,y]) $ toList ps
+    f = fuseFunc (\x y -> dist x y < 2) . nub $ concatMap (\(x, y) -> [x, y]) $ toList ps