Nub close points for game room boundaries

src/Dodge/Config/Data.hs

@@ -21,6 +21,7 @@ data Configuration = Configuration
     , _debug_noclip         :: Bool
     , _debug_cr_status      :: Bool
     , _debug_view_boundaries :: Bool
+    , _debug_pathing :: Bool
     }
   deriving (Generic, Show)
 makeLenses ''Configuration
@@ -46,4 +47,5 @@ defaultConfig = Configuration
     , _debug_noclip         = False
     , _debug_cr_status      = False
     , _debug_view_boundaries = False
+    , _debug_pathing    = False
     }

src/Dodge/Item/Weapon/AutoGun.hs

@@ -65,7 +65,7 @@ autoGun = defaultAutoGun
     }
 autoGunPic :: Item -> SPic
 autoGunPic it =
-    ( (colorSH red $ prismPoly 
+    ( colorSH red (prismPoly 
         (map (addZ 5) $ rectNESW 2 12 (-2) (-8))
         (map (addZ 0) $ rectNESW 4 12 (-4) (-12))
         )

src/Dodge/Layout.hs

@@ -25,7 +25,7 @@ import Tile
 import Polyhedra
 import Polyhedra.Data
 
-import Data.List (nub)
+import Data.List (nubBy)
 import Control.Monad.State
 import Control.Lens
 import System.Random
@@ -123,10 +123,12 @@ gameRoomsFromRooms = map f
     f rm = GameRoom
         { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
         , _grViewpointsEx = map fst (_rmLinks rm)
-        , _grBound = expandPolyByFixed 100 . convexHullSafe . nub . concat $ _rmBound rm ++ _rmPolys rm
+        , _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints 
+            . concat $ _rmBound rm ++ _rmPolys rm
         , _grDir   = snd . last $ _rmLinks rm
         , _grName  = _rmName rm
         }
+    closePoints x y = dist x y < 1
 
 floorsFromRooms :: [Room] -> [(Point3,Point3)]
 floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)

src/Dodge/LevelGen/Data.hs

@@ -49,7 +49,7 @@ jsps0 :: PSType -> Maybe Placement
 jsps0 pst = Just $ sPS (V2 0 0) 0 pst
 
 sps0 :: PSType -> Placement
-sps0 pst = sPS (V2 0 0) 0 pst
+sps0 = sPS (V2 0 0) 0
 
 jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
 jspsJ p a pst plm = Just $ Placement (PS p a pst) $ \_ -> Just plm

src/Dodge/Menu.hs

@@ -18,7 +18,6 @@ import Dodge.Initialisation
 import Preload.Update
 import Dodge.Base.Window
 import Dodge.SoundLogic
---import Picture
 
 import Control.Lens
 optionMenu :: ScreenLayer
@@ -30,13 +29,15 @@ optionMenu = OptionScreen
     }
 optionsOptions :: [MenuOption]
 optionsOptions =
-    [ Toggle ScancodeV (pushScreen soundMenu)    (const "VOLUME")
+    [ anOption ScancodeV soundMenu      "VOLUME"
-    , Toggle ScancodeG (pushScreen graphicsMenu) (const "GRAPHICS")
+    , anOption ScancodeG graphicsMenu   "GRAPHICS"
-    , Toggle ScancodeP (pushScreen gameplayOptionsMenu) (const "GAMEPLAY")
+    , anOption ScancodeP gameplayMenu   "GAMEPLAY"
-    , Toggle ScancodeD (pushScreen debugOptionsMenu) (const "DEBUG OPTIONS")
+    , anOption ScancodeD debugMenu      "DEBUG OPTIONS"
     ]
-debugOptionsMenu :: ScreenLayer
+  where
-debugOptionsMenu  = OptionScreen
+    anOption scode submenu t = Toggle scode (pushScreen submenu) (const t)
+debugMenu :: ScreenLayer
+debugMenu  = OptionScreen
     { _scTitle = const "OPTIONS:GAMEPLAY"
     , _scOptions = debugMenuOptions
     , _scDefaultEff = popScreen . writeConfig
@@ -44,21 +45,16 @@ debugOptionsMenu  = OptionScreen
     }
 debugMenuOptions :: [MenuOption]
 debugMenuOptions =
-    [ Toggle ScancodeF 
+    [ doption ScancodeF debug_seconds_frame "SHOW SECONDS/FRAME" _debug_seconds_frame
-        (Just . (config . debug_seconds_frame %~ not))
+    , doption ScancodeC debug_noclip "NOCLIP" _debug_noclip
-        (\w -> "SHOW SECONDS/FRAME:" ++ show (_debug_seconds_frame $ _config w))
+    , doption ScancodeS debug_cr_status "SHOW CREATURE STATUS" _debug_cr_status
-    , Toggle ScancodeC 
+    , doption ScancodeV debug_view_boundaries "SHOW VIEW BOUNDARIES" _debug_view_boundaries
-        (Just . (config . debug_noclip %~ not))
+    , doption ScancodeP debug_pathing "SHOW PATHING" _debug_pathing
-        (\w -> "NOCLIP:" ++ show (_debug_noclip $ _config w))
-    , Toggle ScancodeS 
-        (Just . (config . debug_cr_status %~ not))
-        (\w -> "SHOW CREATURE STATUS:" ++ show (_debug_cr_status $ _config w))
-    , Toggle ScancodeV
-        (Just . (config . debug_view_boundaries %~ not))
-        (\w -> "SHOW VIEW BOUNDARIES:" ++ show (_debug_view_boundaries $ _config w))
     ]
-gameplayOptionsMenu :: ScreenLayer
+  where
-gameplayOptionsMenu  = OptionScreen
+    doption scode l t rec = Toggle scode (Just . (config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config w))
+gameplayMenu :: ScreenLayer
+gameplayMenu  = OptionScreen
     { _scTitle = const "OPTIONS:GAMEPLAY"
     , _scOptions = gameplayMenuOptions
     , _scDefaultEff = popScreen . writeConfig
@@ -66,15 +62,12 @@ gameplayOptionsMenu  = OptionScreen
     }
 gameplayMenuOptions :: [MenuOption]
 gameplayMenuOptions =
-    [ Toggle 
+    [ option ScancodeR rotate_to_wall "ROTATE TO WALL" _rotate_to_wall
-        ScancodeR 
+    , option ScancodeS show_sound     "SHOW VISUAL SOUNDS" _show_sound
-        (Just . (config . rotate_to_wall %~ not))
-        (\w -> "ROTATE TO WALL:" ++ show (_rotate_to_wall $ _config w))
-    , Toggle 
-        ScancodeS 
-        (Just . (config . show_sound %~ not))
-        (\w -> "SHOW VISUAL SOUNDS:" ++ show (_show_sound $ _config w))
     ]
+  where
+    option scode l t rec = Toggle scode (Just . (config . l %~ not)) 
+        (\w -> t ++ ":" ++ show (rec $ _config w))
 
 soundMenu :: ScreenLayer
 soundMenu = OptionScreen

src/Dodge/Render/Picture.hs

@@ -7,6 +7,7 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.Base.Window
 import Dodge.Zone
+import Dodge.Graph
 import Dodge.Picture
 import Dodge.Picture.SizeInvariant
 import Dodge.Picture.Layer
@@ -43,6 +44,7 @@ worldPictures w = pictures
     ,concatMapPic drawWallFloor $ wallFloorsToDraw w
     ,soundPics w
     ,viewBoundaries w
+    ,drawPathing w
     ]
   where
     crIsClose cr = dist (_crPos cr) camCen < winSize
@@ -68,15 +70,15 @@ customMouseCursor w =
 
 testPic :: World -> Picture
 testPic _ = []
---testPic w = setLayer 5 $ color green (concatMap (polygonWire . _grBound) grs)
---    <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
---  where
---    p = _crPos $ you w
---    grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
 --  where
 --    thepic = setDepth 20 . color green . polygon $ rectNSEW 5 (-5) (-5) (5)
 --testPic _ = blank
---testPic w = color green . pictures . map (flip thickLine 5 . tflat2) . graphToEdges $ _pathGraph w
+--testPic w = 
+drawPathing :: World -> Picture
+drawPathing w
+    | _debug_pathing (_config w) 
+        = color green . pictures . map (flip thickLine 5 . tflat2) . graphToEdges $ _pathGraph w
+    | otherwise = []
 viewBoundaries :: World -> Picture
 viewBoundaries w
     | _debug_view_boundaries (_config w) 

src/Dodge/Room/Link.hs

@@ -66,7 +66,7 @@ shiftRoomBy :: (Point2,Float) -> Room -> Room
 shiftRoomBy shift r = r
     & rmPolys %~ fmap (map (shiftPointBy shift))
     & rmLinks %~ fmap (shiftLinkBy shift)
-    & rmPath  %~ map (shiftPathPointBy shift)
+    & rmPath  %~ map (shiftPathBy shift)
     & rmBound %~ fmap (map (shiftPointBy shift))
     & rmShift %~ shiftLinkBy shift
     & rmFloor %~ map 
@@ -82,8 +82,8 @@ shiftLinkBy
     -> (Point2,Float)
 shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
 
-shiftPathPointBy  
+shiftPathBy  
     :: (Point2,Float) 
     -> (Point2,Point2) 
     -> (Point2,Point2) 
-shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
+shiftPathBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)

src/Dodge/Room/Procedural.hs

@@ -69,51 +69,35 @@ roomRect x y xn yn = defaultRoom
 {- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size.  -}
 roomRectAutoLinks :: Float -> Float -> Room
 roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
-
-
 {- Combines two rooms into one room.
 Combines into one big bound, concatenates the rest.  -}
 combineRooms :: Room -> Room -> Room
 combineRooms r r' = defaultRoom
     { _rmPolys = _rmPolys r ++ _rmPolys r'
     , _rmLinks = _rmLinks r ++ _rmLinks r'
-    , _rmPath  = _rmPath  r ++ _rmPath  r'
+    , _rmPath  = map (shiftPathBy $ _rmShift r) (_rmPath  r )
+                    ++ map (shiftPathBy $ _rmShift r') (_rmPath  r')
     , _rmPS    = map (shiftPlacement $ _rmShift r) (_rmPS r) 
                     ++ map (shiftPlacement $ _rmShift r') (_rmPS r')
     , _rmBound = _rmBound r ++ _rmBound r'
     , _rmFloor = _rmFloor r ++ _rmFloor r'
     , _rmShift  = (V2 0 0 , 0)
     }
---{- The top fourth of a room of a given height.  -}
---fourth 
---    :: Float -- ^ Distance from center of room to top edge
---    -> Room
---fourth w = Room
---    { _rmPolys  = [ [(0,0),(w,w),(-w,w)] ]
---    , _rmLinks  = [((0,w), 0)]
---    , _rmPath   = [((0,w),(0,0)),((0,0),(0,w))]
---    , _rmPS     = 
---        [sPS (0,w/2) 0 putLamp
---        ]
---    , _rmBound  = [[(0,0),(w,w),(-w,w)]]
---    }
 {- Randomly generate a top fourth of a room possibly with a wall.
 Add a light and a 'PutNothing' placement.  -}
-fourthWall :: RandomGen g => Float -> State g Room
+quarterRoomFlat :: RandomGen g => Float -> State g Room
-fourthWall w = do
+quarterRoomFlat w = do
     b <- takeOne 
-        [   [ sPS (V2 (20-w) (w-40)) 0  putLamp
+        [   [ mountedLightV (V2 0 w) (V3 0 (w-20) 70)
-            , sPS (V2 0 40)      0  putLamp
+            , mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
             , sPS (V2 (w-20) (w-20)) pi PutNothing
             , blockLine (V2 (w/2) (w/2)) (V2 (w/2) w)
             ]
-        ,   [ sPS (V2 (20-w) (w-40)) 0  putLamp
+        ,   [ mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
-            , sPS (V2 0 40)      0  putLamp
             , sPS (V2 (w-20) (w-20)) pi PutNothing
             , blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))
             ]
-        ,   [ sPS (V2 (20-w) (w-40)) 0  putLamp
+        ,   [ mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
-            , sPS (V2 0 20)      0  putLamp
             , sPS (V2 (w-20) (w-20)) pi PutNothing
             , blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
             , blockLine (V2 (-29) w) (V2 0 (w/2))
@@ -130,27 +114,20 @@ fourthWall w = do
 fourthCornerWall :: RandomGen g => Float -> State g Room
 fourthCornerWall w = do
     b <- takeOne 
-        [   [ sPS (V2 (10-w) w)  0 putLamp
+        [   [ mountedLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
-            , sPS (V2 (w-10) w) 0 putLamp
-            , sPS (V2 0 10)    0 putLamp
-            , sPS (V2 0 (2*w-20)) pi PutNothing
             , blockLine (V2 (w/2) (w/2)) (V2 0 w)
             , blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w)
+            , sPS (V2 20     (2*w-40)) pi PutNothing
             ]
-        ,   [ sPS (V2 0 (3*w/2))  0 putLamp
+        ,   [ mountedLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
-            , sPS (V2 (w-10) w) 0 putLamp
-            , sPS (V2 (10-w) (w-20)  ) 0  putLamp
-            , sPS (V2 0       10     ) 0  putLamp
-            , sPS (V2 0      (2*w-20)) pi PutNothing
             , blockLine (V2 (w/2)      (w/2)) (V2 0 w)
             , blockLine (V2 (negate w)  w   ) (V2 0 w)
-            ]
-        ,   [ sPS (V2 (10-w)  w      ) 0 putLamp
-            , sPS (V2 (w-10)  w      ) 0 putLamp
-            , sPS (V2 0      10      ) 0 putLamp
             , sPS (V2 20     (2*w-40)) pi PutNothing
+            ]
+        ,   [ mountedLight (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20)  (1.3*w-20) 70)
             , blockLine (V2 (w/2) (w/2)) (V2 0 w)
             , blockLine (V2 0 w) (V2 0 (w*2))
+            , sPS (V2 20     (2*w-40)) pi PutNothing
             ]
         ]
     pure $ defaultRoom
@@ -159,7 +136,9 @@ fourthCornerWall w = do
             [(V2 (w/2) (3*w/2), negate $ pi/4)
             ,(V2 (negate $ w/2) (3*w/2), pi/4)
             ]
-        , _rmPath   = [(V2 0 w,V2 0 0),(V2 0 0,V2 0 w)]
+        , _rmPath   = [(V2 0 0,V2 w 0)
+            ,(V2 0 0,V2 w w)
+            ]
         , _rmPS     = b
         , _rmBound  = [map toV2 [(w,w),(0,2*w),(-w,w)]]
         }
@@ -185,7 +164,7 @@ shufflePlacements r = do
 Tight corridors, random placements. -}
 randomFourCornerRoom :: RandomGen g => State g Room
 randomFourCornerRoom = do
-    corners <- replicateM 4 . join $ takeOne [fourthWall 100, fourthCornerWall 100]
+    corners <- replicateM 4 . join $ takeOne [quarterRoomFlat 100, fourthCornerWall 100]
     nItms <- state $ randomR (1,2)
     itms <- takeN nItms $ fmap PutFlIt $ [autoRadar,autoSonar,remoteLauncher,jetPack,blinkGun] ++ replicate 5 (medkit 500)
     nCrits <- state $ randomR (1,3)
@@ -193,11 +172,11 @@ randomFourCornerRoom = do
         ++ replicate 20 chaseCrit
     randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<< 
         ( shufflePlacements
+        . over rmPS ( sps0 putLamp :)
         . foldr1 combineRooms 
         $ zipWith (\r a -> shiftRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
         )
-{- | Creates room with a central vault with doors around it.
+{- | Creates room with a central vault with doors around it.  -}
--}
 centerVaultRoom
     :: Float    -- ^ Width
     -> Float    -- ^ Height
@@ -214,20 +193,16 @@ centerVaultRoom w h d = do
             ]
         , _rmPath   = []
         , _rmPS     = 
-            [sps0 $ PutWall (rectNSEW ( d) (d - 30) ( d) (d - 30)) defaultWall
+            [sps0 $ PutWall (rectNSEW   d  (d - 30)   d  (d - 30)) defaultWall
-            ,sps0 $ PutWall (rectNSEW ( d) (d - 30) (-d) (30 - d)) defaultWall
+            ,sps0 $ PutWall (rectNSEW   d  (d - 30) (-d) (30 - d)) defaultWall
-            ,sps0 $ PutWall (rectNSEW (-d) (30 - d) ( d) (d - 30)) defaultWall
+            ,sps0 $ PutWall (rectNSEW (-d) (30 - d)   d  (d - 30)) defaultWall
             ,sps0 $ PutWall (rectNSEW (-d) (30 - d) (-d) (30 - d)) defaultWall
---            ,sps0 $ PutForeground $ girder 55 10 10 (V2 (-w) (h/2)) (V2 w (h/2))
             ,sps0 $ PutForeground $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h))
---            ,mountedLight (V2 (-w) (h/2-20)) (V3 (20-w) (h/2-20) 70)
---            ,mountedLight (V2   w  (h/2-20)) (V3 (w-20) (h/2-20) 70)
---            ,mountedLightV (V2 0  (d-20)) (V3 0 0 70)
             ]
             ++ map (\a -> mountedLightV (rotateV a $ V2 0  d) (rotate3z a $ V3 0 (d+30) 70))
                 [0,0.5*pi,pi,1.5*pi]
-            ++ concat (map (\r -> map (shiftPlacement (V2 0 0,r)) $ theDoor) 
+            ++ concatMap (\r -> map (shiftPlacement (V2 0 0,r)) theDoor) 
-                        [0,pi/2,pi,3*pi/2])
+                        [0,pi/2,pi,3*pi/2]
         , _rmBound  = [rectNSWE h (-h) (-w) w]
         }
   where
@@ -235,8 +210,6 @@ centerVaultRoom w h d = do
     theDoor = 
         [ Placement (PS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col red id id)
             $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSingleDoor col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
-            $          sPS (V2 0 (d-10)) 0 (PutSingleDoor col (cond' btid) (V2   21  0) (V2 0 0) 2)
+            $          sPS   (V2 0 (d-10)) 0 (PutSingleDoor col (cond' btid) (V2   21  0) (V2 0 0) 2)
         ]
-    --cond i w' = or $ M.lookup (DoorNumOpen i) (_worldState w')
     cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
-