Fix---at least partially---level generation bug

src/Dodge/Data.hs

@@ -613,19 +613,10 @@ data PlacementSpot = PS
     , _psRot :: Float
     , _psType :: PSType
     }
-data Room = Room
-    { _rmPolys  :: [Poly]
-    , _rmLinks  :: [(Point2,Float)]
-    , _rmPath :: [(Point2, Point2)]
-    , _rmPS :: [PlacementSpot]
-    , _rmBound :: Poly
-    }
 
 data SubNode a = SN a | InLink | OutLink
 
-data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
 
-makeLenses ''RoomLink
 makeLenses ''World
 makeLenses ''Cloud
 makeLenses ''Creature
@@ -652,7 +643,6 @@ makeLenses ''PressPlate
 makeLenses ''Button
 makeLenses ''PSType
 makeLenses ''PlacementSpot
-makeLenses ''Room
 
 numColor :: Int -> Color
 numColor 0  = (1,0,0,1) 

src/Dodge/Event/Keyboard.hs

@@ -6,6 +6,7 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.CreatureAction
 import Dodge.LoadConfig
+import Dodge.Event.Test
 
 import SDL
 import Data.Maybe
@@ -46,9 +47,6 @@ spaceAction w = case listToMaybe $ _closeActiveObjects w of
     Just (Right but) -> _btEvent but but w
     Nothing -> w
 
-testEvent :: World -> World
-testEvent w = w
-
 pauseGame :: World -> World
 pauseGame w = w {_menuState = PauseMenu}
 

src/Dodge/Event/Test.hs

@@ -0,0 +1,98 @@
+module Dodge.Event.Test
+    ( testEvent
+    )
+  where
+import Dodge.Data
+import Dodge.Base
+import Dodge.Default
+
+import Picture
+import Geometry
+
+import qualified Data.IntMap as IM
+import Control.Lens
+
+testEvent :: World -> World
+testEvent w = over walls (IM.union testWalls) w
+  where
+    k = newKey $ _walls w
+    setKeys = zipWith (\i wl -> wl & wlID .~ i) [k..]
+
+    testWalls = IM.fromList $ zip [k..] $ setKeys (startWalls ++ errorWalls ++ (errorWall : polyWalls) ++ endWalls)
+
+    polyPairs = makeLoopPairs 
+        $ reverse [(-340.0,59.999996),(-374.64102,79.99999),(-340.0,100.0)]
+--        [(4172.5835,2597.1892),(3855.1414,2597.1895),(3855.141,2324.7563),(4172.5835,2324.756)]
+    polyWalls = map (wallWithCol red . flat2) polyPairs
+ 
+    errorWallPair = 
+        (9,[(-340.0,60.0),(-320.0,60.0)])
+--        (48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
+    errorWall = wallWithCol green $ snd errorWallPair
+
+    errorWallPairs = 
+        [(1,[(-400.0,59.999996),(-340.0,60.0)])
+        ,(12,[(-340.0,60.0),(-340.0,59.999996)])
+        ]
+--        [(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)])
+--        ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
+--        ]
+    errorWalls = map (wallWithCol blue . snd) errorWallPairs
+    
+    startWallPairs = 
+        [(0,[(-320.0,60.0),(-320.0,100.0)])
+        ,(1,[(-400.0,59.999996),(-320.0,60.0)])
+        ,(2,[(-400.0,100.0),(-400.0,59.999996)])
+        ,(3,[(-320.0,100.0),(-400.0,100.0)])
+        ,(4,[(-260.0,60.0),(-225.35898,80.0)])
+        ,(5,[(-260.0,100.0),(-260.0,60.0)])
+        ,(6,[(-225.35898,80.0),(-260.0,100.0)])
+        ]
+--        [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)])
+--        ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)])
+--        ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)])
+--        ,(19,[(3875.1414,2552.548),(3895.1414,2587.1892)])
+--        ,(32,[(3855.1414,2587.1892),(3875.1414,2552.548)])
+--        ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)])
+--        ,(37,[(3895.1414,2587.1892),(3895.1414,2647.1892)])
+--        ,(38,[(3855.1414,2647.1892),(3855.1414,2587.1892)])
+--        ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)])
+--        ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
+--        ]
+    startWalls = map (wallWithCol yellow . snd) startWallPairs
+    
+    endWalls = map (wallWithCol (withAlpha 0.2 orange) . snd) endWallPairs
+    endWallPairs = 
+        [(0,[(-320.0,60.0),(-320.0,100.0)])
+        ,(1,[(-400.0,59.999996),(-340.0,60.0)])
+        ,(2,[(-400.0,100.0),(-400.0,59.999996)])
+        ,(3,[(-320.0,100.0),(-340.0,100.0)])
+        ,(4,[(-260.0,60.0),(-225.35898,80.0)])
+        ,(5,[(-260.0,100.0),(-260.0,60.0)])
+        ,(6,[(-225.35898,80.0),(-260.0,100.0)])
+        ,(9,[(-340.0,60.0),(-320.0,60.0)])
+        ,(11,[(-340.0,100.0),(-400.0,100.0)])
+        ,(12,[(-340.0,60.0),(-340.0,59.999996)])
+        ]
+--        [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)])
+--        ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)])
+--        ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)])
+--        ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)])
+--        ,(38,[(3855.1414,2647.1892),(3855.1414,2598.1895)])
+--        ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)])
+--        ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
+--        ,(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)])
+--        ,(45,[(3895.1414,2597.1895),(3895.1414,2647.1892)])
+--        ,(46,[(4172.5835,2324.756),(4172.5835,2597.1892)])
+--        ,(47,[(3855.141,2324.7563),(4172.5835,2324.756)])
+--        ,(48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
+--        ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
+--        ,(50,[(3855.1414,2598.1895),(3855.1414,2597.1895)])
+--        ,(51,[(4172.5835,2597.1892),(3895.1414,2597.1895)])
+--        ]
+
+--flat2 :: (a,a) -> [a]
+--flat2 (x,y) = [x,y]
+
+wallWithCol :: Color -> [Point2] -> Wall
+wallWithCol col ps = defaultWall & wlLine .~ ps & wlColor .~ col & wlSeen .~ True

src/Dodge/Floor.hs

@@ -8,6 +8,7 @@ import Picture
 
 import Dodge.Data
 import Dodge.Rooms
+import Dodge.Room.Data
 import Dodge.Base
 import Dodge.Layout
 import Dodge.Creature
@@ -32,44 +33,44 @@ lev1 = do
             (
             [return $ return $ Right deadEndRoom
             ]
-            ++ [return $ connectRoom corridor
+--            ++ [return $ connectRoom corridor
-               ,return $ connectRoom door
+--               ,return $ connectRoom door
-               ,glassSwitchBack >>= randomiseLinks]
+--               ,glassSwitchBack >>= randomiseLinks]
-            ++ [return $ connectRoom corridor
+--            ++ [return $ connectRoom corridor
-               ,return $ connectRoom door]
+--               ,return $ connectRoom door]
-            ++ [miniRoom3]
+--            ++ [miniRoom3]
-            ++ [return $ connectRoom corridor
+--            ++ [return $ connectRoom corridor
-               ,return $ connectRoom door]
+--               ,return $ connectRoom door]
-            ++ [roomCCrits]
+--            ++ [roomCCrits]
-            ++ [return $ connectRoom corridor
+--            ++ [return $ connectRoom corridor
-               ,return $ connectRoom door]
+--               ,return $ connectRoom door]
-            ++[roomMiniIntro]
+--            ++[roomMiniIntro]
-            ++ [longRoom >>= randomiseLinks]
+--            ++ [longRoom >>= randomiseLinks]
-            ++ [return $ connectRoom corridor
+--            ++ [return $ connectRoom corridor
-               ,return $ connectRoom door]
+--               ,return $ connectRoom door]
             ++ firstWeapon
-            ++ [return $ connectRoom corridor
+--            ++ [return $ connectRoom corridor
-               ,return $ connectRoom door]
+--               ,return $ connectRoom door]
-            ++ [randomiseLinks =<< pistolerRoom]
+--            ++ [randomiseLinks =<< pistolerRoom]
-            ++ [return $ connectRoom door]
+--            ++ [return $ connectRoom door]
-             ++ [randomiseLinks =<< shooterRoom]
+--             ++ [randomiseLinks =<< shooterRoom]
-             ++ (replicate 3 $ randomiseLinks corridor)
+--             ++ (replicate 3 $ randomiseLinks corridor)
-            ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
+--            ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
-            ++ [return $ connectRoom corridor]
+--            ++ [return $ connectRoom corridor]
-             ++ (replicate 3 $ randomiseLinks corridor)
+--             ++ (replicate 3 $ randomiseLinks corridor)
-            ++ [return $ connectRoom corridor]
+--            ++ [return $ connectRoom corridor]
-            ++[return $ connectRoom corridor,return $ connectRoom door]
+--            ++[return $ connectRoom corridor,return $ connectRoom door]
-            ++ [shootingRange]
+--            ++ [shootingRange]
-               ++ (replicate 3 $ randomiseLinks corridor)
+--               ++ (replicate 3 $ randomiseLinks corridor)
-              ++[roomMiniIntro]
+--              ++[roomMiniIntro]
-               ++ (replicate 3 $ randomiseLinks corridor)
+--               ++ (replicate 3 $ randomiseLinks corridor)
-              ++ [return $ connectRoom corridor
+--              ++ [return $ connectRoom corridor
-                 ,return $ connectRoom door
+--                 ,return $ connectRoom door
-                 ,slowDoorRoom]
+--                 ,slowDoorRoom]
-            ++ [return $ connectRoom corridor
+--            ++ [return $ connectRoom corridor
-               ,spawnerRoom
+--               ,spawnerRoom
-               ,return $ connectRoom corridor
+--               ,return $ connectRoom corridor
-               ]
+--               ]
             )
             $ randomiseLinks corridor
 

src/Dodge/Layout.hs

@@ -10,6 +10,7 @@ import Dodge.Base
 import Dodge.RandomHelp
 import Dodge.Path
 import Dodge.Layout.Tree
+import Dodge.Room.Data
 
 import Geometry
 

src/Dodge/LevelGen.hs

@@ -4,7 +4,7 @@ module Dodge.LevelGen
     ( module Dodge.LevelGen
     , cutWalls
     , createInnerWalls
-    , checkWalls
+--    , checkWalls
     , nubWalls
     , pairsToGraph
     , makeButton
@@ -14,6 +14,7 @@ module Dodge.LevelGen
 
 import Dodge.Data
 import Dodge.Base
+import Dodge.Room.Data
 
 import Dodge.LevelGen.Block
 import Dodge.LevelGen.LineBlock

src/Dodge/LevelGen/StaticWalls.hs

@@ -18,12 +18,16 @@ import qualified Data.Set as S
 
 -- given a polygon of points and collection of walls, cuts out the polygon
 -- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points
-cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
+cutWalls' :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
-cutWalls qs walls = createPolyWalls rs  
+cutWalls' qs walls = 
+      IM.filter (not.wallIsZeroLength) 
+    . fuseWallsWith zs
+    .createPolyWalls rs  
     . IM.filter (not.wallIsZeroLength) 
     . removeWallsInPolygon ps 
     $ fuseWallsWith zs cwals
-    where (zs,cwals) = cutWallsWithPoints ps walls
+  where 
+    (zs,cwals) = cutWallsWithPoints ps walls
     ps = orderPolygon qs
     rs = orderPolygon $ nub $ zs ++ qs
 -- the overall procedure is: 
@@ -34,6 +38,30 @@ cutWalls qs walls = createPolyWalls rs
 -- also remove any walls that ended up zero length
 -- draw the required new walls along the polygon boundary
 
+cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
+cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWallsList of
+    [] -> newWalls
+    errs -> error $ "cutWalls: when cutting poly:\n" ++ show ps ++ "\nRight corner errors:\n"
+        ++ unlines (map (show . f) errs)
+        ++ "\nStart walls:\n"
+        ++ unlines (map (show . g) (IM.elems wls))
+        ++ "\nEnd walls:\n"
+        ++ unlines (map (show . g) (IM.elems newWalls))
+  where
+    newWalls = cutWalls' ps wls
+    newWallsList = IM.elems newWalls
+    g v = (_wlID v, _wlLine v)
+    f (v,vs) = (g v, map g vs)
+
+checkWallRight :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall])
+checkWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
+    [w] -> Nothing
+    wls -> Just (wl, wls)
+checkWallLeft :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall])
+checkWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
+    [w] -> Nothing
+    wls -> Just (wl,wls)
+
 createPolyWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
 createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q]))
 
@@ -154,21 +182,20 @@ finalFuse = IM.filter (not.wallIsZeroLength) . fuseWallsWith []
 nubWalls :: IM.IntMap Wall -> IM.IntMap Wall
 nubWalls wls = IM.fromList $ nubBy ((==) `on` _wlLine . snd) $ IM.assocs wls
 
-checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall
+--checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall
-checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of
+--checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of
-    Just wl -> error $ show $ _wlLine wl
+--    Just wl -> error $ show $ _wlLine wl
-    _       -> wls
+--    _       -> wls
-
+--
-checkWalls wls | (nub $ map _wlLine $ IM.elems wls)
+--checkWalls wls | (nub $ map _wlLine $ IM.elems wls)
-                   == (map _wlLine $ IM.elems wls) = wls
+--                   == (map _wlLine $ IM.elems wls) = wls
-               | otherwise = error "hasdup"
+--               | otherwise = error "hasdup"
 
 -- idea: create inner walls to draw and to cast shadows
 createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
 createInnerWalls wls = IM.map (createInnerWall wls) wls
 
 createInnerWall :: IM.IntMap Wall -> Wall -> Wall
---createInnerWall walls wl = wl & wlLine %~ (++) [(0,0)]
 createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
   where wl0 = _wlLine wl !! 0
         wl1 = _wlLine wl !! 1
@@ -183,14 +210,16 @@ createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
 findWallLeft :: Wall -> IM.IntMap Wall -> Wall
 findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
     [w] -> w
-    wls   -> error $ "findWallLeft: is there a standalone wall? wlIDs: " ++ show (map _wlID wls)
+    wls   -> error $ "findWallLeft: " ++ show (map _wlID wls)
                                                                  ++ " wlLines: "++ show (map _wlLine wls)
 
 findWallRight :: Wall -> IM.IntMap Wall -> Wall
 findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
     [w] -> w
-    wls   -> error $ "findWallRight: is there a standalone wall? wlIDs: " ++ show (map _wlID wls)
+    wls   -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
-                                                                 ++ " wlLines: "++ show (map _wlLine wls)
+                    show (_wlLine wl) ++ "\nhas a right corner with and only with the walls "
+                    ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls)
+                    ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem"
 
 findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
 findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls

src/Dodge/Rendering/HUD.hs

@@ -102,6 +102,7 @@ mapWall w wl =
     else Nothing
   where 
     t = normalizeV (y -.- x)
+--    n2 = 2 *.* vNormal t
     n2 = 20 *.* vNormal t
     (x:y:_) = (_wlLine wl)
     c = _wlColor wl

src/Dodge/Room/Data.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Dodge.Room.Data
+  where
+
+import Dodge.Data
+import Control.Lens
+
+data Room = Room
+    { _rmPolys  :: [Poly]
+    , _rmLinks  :: [(Point2,Float)]
+    , _rmPath :: [(Point2, Point2)]
+    , _rmPS :: [PlacementSpot]
+    , _rmBound :: Poly
+    }
+data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
+
+makeLenses ''Room
+makeLenses ''RoomLink

src/Dodge/Rooms.hs

@@ -1,4 +1,8 @@
-module Dodge.Rooms where
+module Dodge.Rooms 
+--    ( module Dodge.Rooms
+--    , module Dodge.Rooms.Data
+--    )
+  where
 -- imports {{{
 import Dodge.Data
 import Dodge.Item.Weapon
@@ -12,6 +16,7 @@ import Dodge.Path
 import Dodge.Layout
 import Dodge.LightSources
 import Dodge.SoundLogic
+import Dodge.Room.Data
 
 import Dodge.Room.Placement