Merge branch 'efficientRuntime'

src/Dodge/Block.hs

@@ -1,5 +1,6 @@
 module Dodge.Block where
 import Dodge.Data
+import Dodge.Base.Collide
 import Dodge.Material
 --import Dodge.Block.Debris
 import Dodge.Zone
@@ -10,11 +11,14 @@ import RandomHelp
 import Geometry
 --import Geometry.ConvexPoly
 
+import Data.Foldable
 import Data.Function
 import Data.Maybe
 import qualified Data.IntSet as IS
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
+import qualified Streaming.Prelude as S
+import qualified Data.Graph.Inductive as FGL
 
 splinterBlock :: Block -> World -> World
 splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
@@ -45,6 +49,7 @@ destroyBlock bl w = w
     & flip (foldr unshadowBlock) (_blShadows bl)
     & _blDeath bl bl
     & deleteWallIDs wlids
+    & maybeClearPaths (_blPaths bl) -- must happen after the walls are deleted
     & blocks %~ IM.delete (_blID bl)
 --    & matDesSound (_blMaterial bl) pos
     & flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
@@ -54,6 +59,16 @@ destroyBlock bl w = w
     pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
     ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
 
+-- this does not handle eg doors blocking the path as well
+maybeClearPaths :: [(Int,Int,PathEdge)] -> World -> World
+maybeClearPaths ps w = foldl' maybeClearPath w ps
+
+maybeClearPath :: World -> (Int,Int,PathEdge) -> World
+maybeClearPath w (x,y,pe) 
+    | runIdentity . S.any_ (const True) $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w
+        = w
+    | otherwise = w & pathGraph %~ (FGL.insEdge (x,y,pe & peObstacles .~ mempty)) . FGL.delEdge (x,y) 
+
 destroyDoor :: Door -> World -> World
 destroyDoor dr w = w
     & _drDeath dr dr

src/Dodge/Data.hs

@@ -33,6 +33,7 @@ module Dodge.Data
     , module Dodge.Data.ItemAmount
     , module Dodge.RoomCluster.Data
     , module Dodge.Data.Room
+    , module Dodge.Data.PathGraph
     ) where
 import Dodge.Data.Room
 import Dodge.Data.PathGraph
@@ -148,7 +149,11 @@ data World = World
     , _shapes               :: IM.IntMap ForegroundShape
     , _corpses              :: IM.IntMap Corpse
     , _clickMousePos        :: Point2
+<<<<<<< HEAD
     , _pathGraph            :: PathGraph
+=======
+    , _pathGraph            :: Gr Point2 PathEdge
+>>>>>>> efficientRuntime
     , _pathGraphP           :: S.Set (Point2,Point2)
     , _pnZoning             :: Zoning [] (Int,Point2)
     , _peZoning             :: Zoning [] (Int,Int,PathEdge)
@@ -952,6 +957,7 @@ data Block = Block
     , _blDir        :: Float
     , _blDraw       :: Block -> SPic
     , _blDeath      :: Block -> World -> World
+    , _blPaths      :: [(Int,Int,PathEdge)]
     }
 data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady
   deriving (Eq,Ord,Show)

src/Dodge/Data/PathGraph.hs

@@ -15,6 +15,7 @@ data PathGraph = PathGraph
 data PathEdge = PathEdge
     {_peStart :: Point2
     ,_peEnd   :: Point2
+    ,_peDist  :: Float
     ,_peObstacles :: Set.Set EdgeObstacle
     }
   deriving (Eq,Ord,Show)
@@ -26,3 +27,4 @@ data EdgeObstacle
   deriving (Eq,Ord,Show,Bounded,Enum)
 
 makeLenses ''PathGraph
+makeLenses ''PathEdge

src/Dodge/Default/Block.hs

@@ -15,6 +15,7 @@ defaultBlock = Block
     , _blDraw      = const mempty
     , _blDeath     = makeBlockDebris
     , _blObstructs = []
+    , _blPaths      = []
     }
 defaultDirtBlock :: Block
 defaultDirtBlock = defaultBlock & blHP .~ 50

src/Dodge/Default/World.hs

@@ -76,8 +76,8 @@ defaultWorld = World
     , _clickMousePos = V2 0 0
     , _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty mempty 0 mempty
     , _pathGraphP   = mempty
-    , _pnZoning     = Zoning mempty pnZoneSize (zonePos snd)
-    , _peZoning     = Zoning mempty pnZoneSize (\x (_,_,PathEdge p q _) -> zoneOfSeg x p q)
+    , _pnZoning     = Zoning mempty wlZoneSize (zonePos snd)
+    , _peZoning     = Zoning mempty wlZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
     , _hud = HUD
         { _hudElement = DisplayInventory NoSubInventory
         , _carteCenter = V2 0 0

src/Dodge/Layout.hs

@@ -47,11 +47,11 @@ generateLevelFromRoomList gr' w = initWallZoning
         , _pathGraphP   = pairPath
         }
         & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-            (labNodes (_pgGraph path)))
+            (labNodes path))
         & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-            (labEdges (_pgGraph path)))
+            (labEdges path))
   where
-    path = pairsToGraph pairPath
+    (_,path) = pairsToGraph pairPath
     pairPath = foldMap _rmPath rs
     rs = map doRoomShift $ IM.elems rs'
     rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w

src/Dodge/Path.hs

@@ -3,11 +3,10 @@ module Dodge.Path
     ( pointTowardsImpulse
     , makePathBetween
     , makePathBetweenPs
+    , obstructPathsCrossing
     , pairsToGraph
-    , walkableNodeNear
-    , nodesNearL
     , getNodePos
-    , addObstacleCrossing'
+    , walkableNodeNear
     ) where
 import Dodge.Data
 import Dodge.Base.Collide
@@ -22,38 +21,33 @@ import Data.List
 import Data.Graph.Inductive hiding ((&))
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
+import Data.Map.Strict (Map)
+import StreamingHelp
 import qualified Streaming.Prelude as S
 import StreamingHelp
 --import Data.Graph.Inductive.PatriciaTree
 --import Data.Graph.Inductive.Graph hiding ((&))
 
 getNodePos :: Int -> World -> Maybe Point2
-getNodePos i w = _pgGraph (_pathGraph w) `lab` i
+getNodePos i w = _pathGraph w `lab` i
 
 makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
 makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
-    (na,_) <- walkableNodeNear a w
-    (nb,_) <- walkableNodeNear b w
-    sp na nb (second pathDist $ efilter noobstacle $ _pgGraph $ _pathGraph w)
+    na <- walkableNodeNear w a
+    nb <- walkableNodeNear w b
+    sp na nb (second _peDist (_pathGraph w))
   where
-    noobstacle (_,_,PathEdge _ _ s) = null s
+    --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
+--    nodesNear p = runIdentity . S.toList_ $ nearPoint _pnZoning p w
+--    walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
 
-pathDist :: PathEdge -> Float
-pathDist pe = dist (_peStart pe) (_peEnd pe)
-
-walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
+walkableNodeNear :: World -> Point2 -> Maybe Int
 {-# INLINE walkableNodeNear #-}
-walkableNodeNear p w = minStreamOn (dist p . snd) 
-    . S.filter (flip (isWalkable p) w . snd) $ nodesNear p w
-
-nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
-{-# INLINE nodesNear #-}
-nodesNear = aroundPoint _pnZoning
-
-nodesNearL :: Point2 -> World -> [(Int,Point2)]
-nodesNearL p = runIdentity . S.toList_ . nodesNear p
+walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
+  where
+    --nodesNear = runIdentity . S.toList_ $ nearPoint _pnZoning p w
+    nodesNear = runIdentity . S.toList_ $ aroundPoint _pnZoning p w
 
 makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
 makePathBetweenPs a b w = mapMaybe (lab $ _pgGraph $ _pathGraph w) <$> makePathBetween a b w
@@ -104,62 +98,40 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
 --        [] -> return Nothing
 --        _  -> return $ Just $ ns !! i
 --
-
-pairsToGraph :: Set.Set (Point2,Point2) -> PathGraph
-pairsToGraph pairset = PathGraph gr' nodemap ncount edgemap
+pairsToGraph :: Set.Set (Point2,Point2) -> (Map (V2 Point2) (Int,Int,PathEdge),Gr Point2 PathEdge)
+pairsToGraph pairs = addEdges nodemap gr $ S.each pairs
   where
-    (gr,nodemap,ncount) = insertNodes pairset
-    (gr',edgemap) = insertEdges toPathEdge gr nodemap pairset
+    (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')
 
-toPathEdge :: Point2 -> Point2 -> PathEdge
-toPathEdge sp' ep = PathEdge sp' ep mempty
-
-insertEdges :: (Point2 -> Point2 -> b) 
-    -> Gr Point2 b -> Map Point2 Int 
-    -> Set (Point2,Point2) 
-    -> (Gr Point2 b, Map (V2 Point2) (Int,Int,b))
-insertEdges efunc gr nm = runIdentity . S.fold_ (insertEdge efunc nm) (gr,mempty) id . S.each
-
-insertEdge :: Ord a => (a -> a -> c) -> Map a Int -> (Gr b c,Map (V2 a) (Int,Int,c))
-    -> (a,a)
-    -> (Gr b c,Map (V2 a) (Int,Int,c))
-insertEdge efunc nm (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
-    , M.insert (V2 a b) (f a,f b,efunc a b) em)
-  where 
-    f x = nm M.! x
-
-insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int)
-insertNodes pairset = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,mempty,0) id nodestream
+addNodes :: StreamOf Point2 -> (Map Point2 Int,Int,Gr Point2 PathEdge)
+addNodes = runIdentity . S.fold_ f (mempty,0,Data.Graph.Inductive.empty) id
   where
-    nodestream :: StreamOf Point2
-    nodestream = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
-    getnode strm (x,y) = Set.insert x $ Set.insert y strm
-    insertnode :: (Gr Point2 b,Map Point2 Int,Int) -> Point2 -> (Gr Point2 b,Map Point2 Int,Int)
-    insertnode (gr,nm,i) n = case M.lookup n nm of
-        Nothing -> (insNode (j,n) gr, M.insert n j nm, j)
-        Just _  -> (gr,nm,i)
+    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
+        , insEdge theedge gr'
+        )
       where
-        j = i + 1
+        theedge = (g a,g b,PathEdge a b (dist a b) mempty)
+    g a = nodemap M.! a
 
---pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
---pairsToGraph f pairs = undir
---    $ run_ Data.Graph.Inductive.empty 
---    $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
---  where
---    nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
---    pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
-
-addObstacleCrossing :: World -> EdgeObstacle -> Point2 -> Point2 
-    -> Gr Point2 PathEdge
-    -> Gr Point2 PathEdge
-addObstacleCrossing w eo a b gr = runIdentity $ S.fold_ updateedge gr id paths
+obstructPathsCrossing :: Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)])
+obstructPathsCrossing sp ep w = 
+    ( w & pathGraph %~ updateedges
+    , runIdentity $ S.toList_ edges
+    )
   where
-    updateedge gr' (xi,yi,PathEdge x y obs) = insEdge (xi,yi,PathEdge x y (Set.insert eo obs))
-        $ delEdge (xi,yi) gr'
-    paths = S.filter f $ nearSeg _peZoning a b w
-    f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
+    edges = S.filter edgecrosses $ nearSeg _peZoning sp ep w
+    edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp ep (_peStart pe) (_peEnd pe)
+    updateedges gr = runIdentity $ S.fold_ updateedge gr id edges
+    updateedge gr (x,y,pe) 
+        = insEdge (x,y,pe & peObstacles . at BlockObstacle .~ Just ()) $ delEdge (x,y) gr
 
-addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2 
-    -> World
-    -> World
-addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b

src/Dodge/Placement/PlaceSpot.hs

@@ -120,10 +120,10 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
     (evaluatedType, g) = runState rgen (_randGen w)
 
 placeWallPoly :: [Point2] -> Wall -> World -> World
---placeWallPoly ps wl = over walls (placeWalls ps wl)
-placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
-  where
-    rmCrossPaths w = foldr (uncurry (addObstacleCrossing' WallObstacle)) w $ loopPairs ps
+placeWallPoly ps wl = -- rmCrossPaths . 
+    over walls (placeWalls ps wl)
+--  where
+--    rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps
 
 placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
 placeWalls qs wl wls = foldl' (addPane wl) wls pairs

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -24,13 +24,13 @@ plBlock
     -> (Int,World)
 plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
 plBlock (p:ps) bl wl w = (,) blid $ w
-    & flip (foldr insertWall) wls
     & blocks . at blid ?~ bl 
         { _blID = blid
         , _blWallIDs = IS.fromList is
         , _blShadows = []
         , _blFootprint = p:ps
         }
+    & insertWalls blid wls
   where 
     blid = IM.newKey $ _blocks w
     lns = zip (p:ps) (ps ++ [p])
@@ -50,7 +50,8 @@ plLineBlock
     -> World 
     -> (Int, World)
 plLineBlock basePane blwidth a b gw = ( 0 
-    , foldr insertWall (insertBlocks gw) listWalls
+--    , foldr insertWall (insertBlocks gw) listWalls
+    , insertBlocks gw
     )
   where 
     depth = blwidth
@@ -64,13 +65,17 @@ plLineBlock basePane blwidth a b gw = ( 0
     linesAt p = loopPairs $ cornersAt p
     wlid = IM.newKey $ _walls gw
     blid = IM.newKey $ _blocks gw
-    insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block 
+    insertBlock (i,p) = 
+        insertWalls (i + blid) (makeWallAt p i)
+        . (over blocks $ IM.insert (i+blid) Block 
         { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
         , _blHP = 1000, _blShadows = shadowsAt i
         , _blDir = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
         , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
         , _blObstructs = []
+        , _blPaths = []
         , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
+        )
     insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
     ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
     visibilityAt i 
@@ -90,6 +95,12 @@ plLineBlock basePane blwidth a b gw = ( 0
         }
     listWalls = concat $ zipWith makeWallAt blockCenPs is
 
-insertWall :: Wall -> World -> World
-insertWall wl = (walls . at (_wlID wl) ?~ wl)
-    . uncurry (addObstacleCrossing' BlockObstacle) (_wlLine wl)
+-- | Must be done after inserting the block
+insertWalls :: Int -> [Wall] -> World -> World
+insertWalls blid wls w = w' & blocks . ix blid . blPaths .~ concat paths
+  where
+    (w',paths) = mapAccumR (flip insertWall) w wls
+
+insertWall :: Wall -> World -> (World,[(Int,Int,PathEdge)])
+insertWall wl = uncurry obstructPathsCrossing (_wlLine wl)
+    . (walls . at (_wlID wl) ?~ wl)

src/Dodge/Render/ShapePicture.hs

@@ -82,7 +82,7 @@ extraPics cfig w = pictures (_decorations w)
     <> concatMapPic clDraw (_clouds w      )
     <> concatMapPic ppDraw (_pressPlates w )
     <> viewClipBounds cfig w
-    <> debugDraw cfig w
+--    <> debugDraw cfig w
 
 debugDraw :: Configuration -> World -> Picture
 debugDraw cfig w = pic
@@ -122,8 +122,8 @@ drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
 drawPathBetween :: World -> Picture
 drawPathBetween w = setLayer DebugLayer
     $  color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist)
-    <> foldMap (color green . arrow sp) (nodepos =<< nodelist ^? _Just . ix 0)
-    <> foldMap (color cyan . flip arrow ep) (nodepos =<< lastOf traverse =<< nodelist ^? _Just)
+    <> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
+    <> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
   where
     nodepos = (`getNodePos` w)
     nodelist = makePathBetween sp ep w
@@ -133,9 +133,15 @@ drawPathBetween w = setLayer DebugLayer
 drawNodesNearSelect :: World -> Picture
 drawNodesNearSelect w = setLayer DebugLayer $
      runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp))
+<<<<<<< HEAD
     <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
     <> color green (drawCross sp)
     <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
+=======
+--    <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
+    <> color green (drawCross sp)
+--    <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
+>>>>>>> efficientRuntime
   where
     sp = _lSelect w