Add wall placement obstructions, start to generalise pictures

src/Dodge/Placement/PlaceSpot.hs

@@ -10,6 +10,7 @@ import Dodge.Data
 --import Dodge.Path
 import Dodge.Placement.PlaceSpot.Block
 import Dodge.Placement.PlaceSpot.TriggerDoor
+import Dodge.Path
 import Dodge.Default.Wall
 import Dodge.ShiftPoint
 import Dodge.Base.NewID
@@ -119,32 +120,30 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
   where 
     (evaluatedType, g) = runState rgen (_randGen w)
 
-placeWallPoly :: [Point2] -> Wall -> World -> World
-placeWallPoly ps wl = -- rmCrossPaths . 
-    over walls (placeWalls ps wl)
---  where
---    rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps
+--placeWallPoly :: [Point2] -> Wall -> World -> World
+--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
+--placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
+--placeWalls qs wl wls = foldl' (addPane wl) wls pairs
+--  where 
+--    (p:ps) = orderPolygon qs
+--    pairs = zip (ps ++ [p]) (p:ps)
+
+placeWallPoly :: [Point2] -> Wall -> World -> World
+placeWallPoly qs wl w = foldl' (addPane wl) w pairs
   where 
     (p:ps) = orderPolygon qs
     pairs = zip (ps ++ [p]) (p:ps)
 
-addPane :: Wall -> IM.IntMap Wall -> (Point2,Point2) -> IM.IntMap Wall
-addPane wl wls l = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
-  where
-    wlid = IM.newKey wls
-
----- | place an new object into an intmap and update its id
---plNewUpID :: ALens' World (IM.IntMap a)
---    -> ALens' a Int
---    -> a
---    -> World
---    -> (Int,World)
---plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
+addPane :: Wall -> World -> (Point2,Point2) -> World
+--addPane wl w l = w & walls %~ IM.insert wlid (wl { _wlLine = l, _wlID = wlid })
+addPane wl w l = w & plNew walls wlID (wl & wlLine .~ l)
+    & fst . uncurry (obstructPathsCrossing WallObstacle) l
 --  where
---    i = IM.newKey $ w ^# l
+--    wlid = IM.newKey (_walls w)
 
 mvProp :: Point2 -> Float -> Prop -> Prop
 mvProp p a = (pjRot +~ a) . (prPos %~ ( (p +.+) . rotateV a ))

src/Dodge/Room/Room.hs

@@ -325,7 +325,7 @@ spawnerRoom = do
 
 corDoor :: State StdGen (MetaTree Room String)
 corDoor = do
-    --cor <- shuffleLinks $ cleatOnward corridor
-    --return $ tToBTree "corDoor" $ treePost [door,cor]
-    cor <- shuffleLinks corridor
-    return $ tToBTree "corDoor" $ treePost [door,cor,cleatOnward door]
+    cor <- shuffleLinks $ cleatOnward corridor
+    return $ tToBTree "corDoor" $ treePost [door,cor]
+--    cor <- shuffleLinks corridor
+--    return $ tToBTree "corDoor" $ treePost [door,cor,cleatOnward door]