Cleanup

src/Dodge/Data/Wall.hs

@@ -13,13 +13,11 @@ import Data.Aeson.TH
 import Dodge.Data.Material
 import Dodge.Data.Wall.Structure
 import Geometry
-import qualified Data.Set as S
 
 data Wall = Wall
     { _wlLine :: (Point2, Point2)
     , _wlID :: Int
     , _wlOpacity :: Opacity
---    , _wlPathFlag :: S.Set WallFlag
     , _wlTouchThrough :: Bool
     , _wlUnshadowed :: Bool
     , _wlRotateTo :: Bool

src/Dodge/Default/Wall.hs

@@ -9,18 +9,14 @@ module Dodge.Default.Wall (
 ) where
 
 import Control.Lens
-import qualified Data.Set as S
 import Dodge.Data.Wall
 import Geometry.Data
 
-{- Indestructible wall.  -}
 defaultWall :: Wall
 defaultWall =
     Wall
         { _wlLine = (V2 0 0, V2 50 0)
         , _wlID = 0
---        , _wlPathFlag =
---            S.fromList [minBound .. maxBound]
         , _wlOpacity = Opaque 11
         , _wlUnshadowed = True
         , _wlRotateTo = True
@@ -31,23 +27,13 @@ defaultWall =
         }
 
 defaultDoorWall :: Wall
-defaultDoorWall =
+defaultDoorWall = defaultWall & wlMaterial .~ Metal & wlOpacity .~ Opaque 0
-    defaultWall
---        & wlPathFlag . at WallNotDestrucable .~ Nothing
-        & wlMaterial .~ Metal
-        & wlOpacity .~ Opaque 0
 
 defaultAutoWall :: Wall
-defaultAutoWall =
+defaultAutoWall = defaultDoorWall & wlOpacity .~ Opaque 9
-    defaultDoorWall
-        & wlOpacity .~ Opaque 9
---        & wlPathFlag . at WallNotAutoOpen .~ Nothing
 
-{- Indestructible see-through wall.  -}
 defaultCrystalWall :: Wall
-defaultCrystalWall =
+defaultCrystalWall = defaultWall & wlOpacity .~ SeeThrough & wlMaterial .~ Crystal
-    defaultWall & wlOpacity .~ SeeThrough & wlMaterial .~ Crystal
---        & wlPathFlag . at WallBlockVisibility .~ Nothing
 
 defaultMachineWall :: Wall
 defaultMachineWall =
@@ -58,27 +44,14 @@ defaultMachineWall =
         , _wlMaterial = Metal
         , _wlTouchThrough = True
         }
---        & wlPathFlag . at WallBlockVisibility .~ Nothing
---        & wlPathFlag . at WallNotDestrucable .~ Nothing
 
 defaultDirtWall :: Wall
 defaultDirtWall =
     defaultWall
-        { _wlLine = (V2 0 0, V2 50 0)
+        { _wlOpacity = Opaque 6
-        , _wlID = 0
-        , _wlOpacity = Opaque 6
         , _wlRotateTo = False
         , _wlMaterial = Dirt
         }
---        & wlPathFlag . at WallNotDestrucable .~ Nothing
 
 defaultWindow :: Wall
-defaultWindow =
+defaultWindow = defaultWall & wlOpacity .~ SeeThrough & wlMaterial .~ Glass
-    defaultWall
-        { _wlLine = (V2 0 0, V2 50 0)
-        , _wlID = 0
-        , _wlOpacity = SeeThrough
-        , _wlMaterial = Glass
-        }
---        & wlPathFlag . at WallNotDestrucable .~ Nothing
---        & wlPathFlag . at WallBlockVisibility .~ Nothing

src/Dodge/Path.hs

@@ -126,12 +126,7 @@ pairsToIncGraph pairs =
     inodes = UV.generate (length ps) (ps !!)
     ps = Set.toList $ Set.map fst pairs <> Set.map snd pairs
 
-obstructPathsCrossing ::
+obstructPathsCrossing :: S.Set EdgeObstacle -> Point2 -> Point2 -> World -> World
-    S.Set EdgeObstacle ->
-    Point2 ->
-    Point2 ->
-    World ->
-    World
 obstructPathsCrossing obs s e w = w & cWorld . incGraph %~ updateincedges
   where
     updateincedge = flip $ updateEdge (S.union obs) 
@@ -139,12 +134,6 @@ obstructPathsCrossing obs s e w = w & cWorld . incGraph %~ updateincedges
     inces = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZoning s e w
     inedgecrosses (i, j) = isJust $ intersectSegSeg s e (f i) (f j)
     f i = w ^?! cWorld . incNode . ix i
-    --es = Set.filter edgecrosses $ pesNearSeg sp ep w
---    edgecrosses (PathEdgeNodes _ _ pe) =
---        isJust $ intersectSegSeg s e (_peStart pe) (_peEnd pe)
---    updateedges gr = foldl' updateedge gr es
---    updateedge gr (PathEdgeNodes x y pe) =
---        insEdge (x, y, pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x, y) gr
 
 snapToGrid :: Set (Point2, Point2) -> Set (Point2, Point2)
 snapToGrid = Set.map (over each (fmap (fromIntegral . f)))

src/Dodge/Placement/Instance/Wall.hs

@@ -1,21 +1,23 @@
-module Dodge.Placement.Instance.Wall 
+module Dodge.Placement.Instance.Wall (
-    (invisibleWall, crystalLine, blockLine, putBlockRect
+    invisibleWall,
-    ,baseBlockPane
+    crystalLine,
-    ,midWall
+    blockLine,
-    ,windowLine
+    putBlockRect,
-    ,putBlockN
+    baseBlockPane,
-    ,putBlockV
+    midWall,
-    ,heightWallPS
+    windowLine,
-    ,replacePutID
+    putBlockN,
+    putBlockV,
+    heightWallPS,
+    replacePutID,
 ) where
 
-import qualified Data.Set as S
-import Dodge.Material.Color
 import Control.Lens
 import Data.List
 import Dodge.Data.GenWorld
 import Dodge.Default.Wall
 import Dodge.LevelGen.PlacementHelper
+import Dodge.Material.Color
 import Dodge.Placement.Instance.Block
 import Geometry
 
@@ -95,6 +97,7 @@ crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 a b
 
 baseBlockPane :: Wall
 baseBlockPane = defaultWall & wlOpacity .~ Opaque 17
+
 --    & wlPathFlag .~ S.fromList [WallBlockVisibility, WallNotAutoOpen]
 
 -- TODO find home for this

src/Dodge/Placement/PlaceSpot.hs

@@ -1,5 +1,5 @@
 --{-# LANGUAGE LambdaCase #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 {- | deals with placement of objects within the world
  after they have had their coordinates set by the layout
@@ -174,13 +174,10 @@ placeChasm gw rid ps shiftps =
 --  where
 --    (evaluatedType, g) = runState rgen (_randGen $ _gwWorld w)
 
--- this function is the reason for the warning suppression
--- remove the warning suppression if it changes
 placeWallPoly :: [Point2] -> Wall -> World -> World
-placeWallPoly qs wl w = foldl' (addPane wl) w pairs
+placeWallPoly qs wl w 
-  where
+    | (p : ps) <- orderPolygon qs = foldl' (addPane wl) w $ zip (ps ++ [p]) (p : ps)
-    (p : ps) = orderPolygon qs
+    | otherwise = error "tried to place wall poly with too few points"
-    pairs = zip (ps ++ [p]) (p : ps)
 
 addPane :: Wall -> World -> (Point2, Point2) -> World
 addPane wl w l =

src/Dodge/Room/Airlock.hs

@@ -179,8 +179,7 @@ airlockZ = do
                             l2
                             x2
                             y2
-                , -- outDoorps inDoorps
+                , sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall
-                  sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall
                 , lighting
                 ]
             , _rmBound =

src/Dodge/Room/Tutorial.hs

@@ -43,13 +43,12 @@ tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , tToBTree "lastun" . return . cleatOnward <$> cenLasTur
+--        , tToBTree "lastun" . return . cleatOnward <$> cenLasTur
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-
         , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor

src/Dodge/Update/WallDamage.hs

@@ -36,8 +36,8 @@ updateEdgeWallObs :: World -> (Int, Int) -> World
 updateEdgeWallObs w (i, j) = fromMaybe w $ do
     s <- getNodePos i w
     e <- getNodePos j w
-    --let wlflags = foldMap (^. _2 . wlPathFlag) $ wlsHitUnsorted s e w
+    let wlflags = foldMap (^. _2 . to getWallPathing) $ wlsHitUnsorted s e w
-    let wlflags = foldMap (getWallPathing . (^. _2)) $ wlsHitUnsorted s e w
     return $ w & cWorld . incGraph %~ updateEdge (f wlflags) (i, j)
   where
-    f x _ = S.map WallObstacle x
+    f x y = (S.map WallObstacle x) `S.union` 
+        (y S.\\ (S.fromList $ map WallObstacle [minBound..maxBound]))

src/Dodge/WorldEvent/ThingsHit.hs

@@ -164,7 +164,7 @@ isFlyable :: Point2 -> Point2 -> World -> Bool
 {-# INLINE isFlyable #-}
 isFlyable p1 p2 =
     not . (WallNotAutoOpen `S.member`) 
-        . foldMap (getWallPathing . (^. _2))
+        . foldMap (^. _2 . to getWallPathing)
         . wlsHitUnsorted p1 p2
 
 isWalkable :: Point2 -> Point2 -> World -> Bool