General improvement to shadows

src/Dodge/LevelGen.hs

@@ -6,6 +6,7 @@ module Dodge.LevelGen
     , createInnerWalls
     , checkWalls
     , nubWalls
+    , pairsToGraph
     )
     where
 
@@ -14,6 +15,7 @@ import Dodge.Base
 import Dodge.SoundLogic
 import Dodge.Prototypes
 import Dodge.LevelGen.Block
+import Dodge.LevelGen.Pathing
 
 import Dodge.LevelGen.StaticWalls
 
@@ -78,7 +80,10 @@ placeSpot ps w = case ps of
         -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
 
     PS {_psPos = p, _psRot = rot, _psType = PutBlock (hp:hps) col ps} 
-        -> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w
+        -> putBlock(map (shiftPointBy (p,rot)) ps) hp col False hps w
+
+    PS {_psPos = p, _psRot = rot, _psType = PutBlockWall (hp:hps) col ps} 
+        -> putBlockWallPart (map (shiftPointBy (p,rot)) ps) hp col False hps w
 
     PS {_psPos = p, _psRot = rot, _psType = PutBtDoor c bp f a b} 
         -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) 
@@ -121,10 +126,6 @@ instance Shiftable PlacementSpot where
     translateS p' (PS p r x) = PS (p +.+ p') r x
     rotateS    r' (PS p r x) = PS (rotateV r' p) (r + r') x
 
-pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
-pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs)
-                           pairs' = map (\(x,y)->(x,y,f x y)) pairs
-                       in  undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs'
 
 makeButton :: Color -> (World -> World) -> Button
 makeButton c eff = Button
@@ -295,24 +296,6 @@ triggerDoorPane c cond n [a,b] [a',b'] = Door
 addAutoDoor :: Point2 -> Point2 -> World -> World
 addAutoDoor a b = over walls (autoDoorAt a b)
 
-removePathsCrossing :: Point2 -> Point2 -> World -> World
-removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
-                            $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
-                            w
-    where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
-          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
-          newGraph = pairsToGraph dist pg'
-
-putBlockWallPart :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
-putBlockWallPart (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
-    where pairs = zip (p:ps) (ps ++ [p])
-          wWithBlock = addBlock (p:ps) i c b is w
-
-putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
-putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
-    where pairs = zip (p:ps) (ps ++ [p])
-          wWithBlock = addBlock (p:ps) i c b is w
-
 putWindowBlock :: Point2 -> Point2 -> World -> World
 putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
     where d = dist a b