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]

src/Picture/Base.hs

@@ -58,22 +58,27 @@ polygonWire :: [Point2] -> Picture
 {-# INLINE polygonWire #-}
 polygonWire ps = line (ps ++ [head ps])
 
+picFormat :: [Verx] -> Picture
+picFormat = S.each
+
 -- | Expects clockwise input.
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
-polygon = S.each . map f . polyToTris
+polygon = picFormat . map f . polyToTris
   where
     f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum
 
+
+
 polygonZ :: [Point2] -> Float -> Picture
 {-# INLINE polygonZ #-}
-polygonZ ps z = S.each . map (f . zeroZ) $ polyToTris ps
+polygonZ ps z = picFormat . map (f . zeroZ) $ polyToTris ps
   where
     f pos = Verx pos black [z] BottomLayer polyzNum
 
 polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
-polygonCol = S.each . polyToTris . map f
+polygonCol = picFormat . polyToTris . map f
   where
     f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer polyNum
 
@@ -83,7 +88,7 @@ poly3 = poly3Col . map (, black)
 
 poly3Col :: [(Point3,RGBA)] -> Picture
 {-# INLINE poly3Col #-}
-poly3Col = S.each . map f . polyToTris
+poly3Col = picFormat . map f . polyToTris
   where
     f (pos,col) = Verx pos col [] BottomLayer polyNum
 
@@ -122,7 +127,7 @@ bezierQuad cola colc ra rc a b c
     fc' = extrapolate cIn aIn bIn
 
 bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
-bzhelp = S.each . map f
+bzhelp = picFormat . map f
   where
     f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] BottomLayer bezNum
 
@@ -215,7 +220,7 @@ circleSolid = circleSolidCol white white
 
 circleSolidCol :: Color -> Color -> Float -> Picture
 {-# INLINE circleSolidCol #-}
-circleSolidCol colC colE r = S.each $ map f
+circleSolidCol colC colE r = picFormat $ map f
     [(V3 (-r)   r  0, colC)
     ,(V3 (-r) (-r) 0, colE)
     ,(V3   r  (-r) 0, black)
@@ -237,7 +242,7 @@ stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0,100..]
 
 text :: String -> Picture
 {-# INLINE text #-}
-text = S.each . map f . stringToList
+text = picFormat . map f . stringToList
   where
     f (pos,col,V2 a b) = Verx pos col [a,b] BottomLayer textNum
 
@@ -319,7 +324,7 @@ thickArc startA endA rad wdth
 
 thickArcHelp :: Float -> Float -> Float -> Float -> Picture
 {-# INLINE thickArcHelp #-}
-thickArcHelp startA endA rad wdth = S.each $ map f
+thickArcHelp startA endA rad wdth = picFormat $ map f
     [  (V3 0 0 0,black,V3 0 0 wdth)
     ,(V3 xa ya 0,black,V3 1 0 wdth)
     ,(V3 xb yb 0,black,V3 1 1 wdth)

src/Picture/Data.hs

@@ -46,6 +46,7 @@ textNum     = ShadNum 3
 arcNum      = ShadNum 4
 ellNum      = ShadNum 5
 type Picture = Stream (Of Verx) IO ()
+type Picture' = [Verx]
 flat2 :: V2 a -> [a]
 flat2 (V2 x y) = [x,y]
 flat3 :: V3 a -> [a]