Assign used links during room generation

src/Dodge/Default/Room.hs

@@ -7,6 +7,7 @@ defaultRoom :: Room
 defaultRoom = Room
     { _rmPolys  = []
     , _rmLinks  = []
+    , _rmUsedLinks  = []
     , _rmPath   = []
     , _rmPS     = []
     , _rmBound  = []

src/Dodge/Initialisation.hs

@@ -28,8 +28,8 @@ import qualified Data.Map as M
 
 firstWorld :: IO World
 firstWorld = do
---    i <- randomRIO (0,5000)
-    let i = 2
+    i <- randomRIO (0,5000)
+--    let i = 2
     putStrLn $ "Seed for level generation: " ++ show ( i :: Int)
     return $ generateLevelFromRoomList (levx 1) $ initialWorld {_randGen = mkStdGen i}
 

src/Dodge/Layout.hs

@@ -29,8 +29,6 @@ import Data.List (nubBy)
 import Control.Monad.State
 import Control.Lens
 import System.Random
---import Data.List
---import Data.Maybe
 import Data.Tree
 --import Data.Graph.Inductive.Graph (labNodes)
 --import qualified Data.Map as M
@@ -42,16 +40,12 @@ generateLevelFromRoomList :: State StdGen [Room] -> World -> World
 generateLevelFromRoomList gr w 
     = updateWallZoning 
     . setupWorldBounds
---    . initializeStaticWalls
---    . setupForegroundEdgeVerxs
     . flip (foldr $ flip placeSpot) plmnts
---    . addRoomPolyDecorations rs
---    . addRoomLinkDecorations rs
-    $ w { _walls = wallsFromRooms rs
-        , _floorTiles = floorsFromRooms rs
-        , _gameRooms  = gameRoomsFromRooms rs
-        , _pathGraph = path
-        , _pathGraphP = pairPath
+    $ w { _walls        = wallsFromRooms rs
+        , _floorTiles   = floorsFromRooms rs
+        , _gameRooms    = gameRoomsFromRooms rs
+        , _pathGraph    = path
+        , _pathGraphP   = pairPath
         }
   where
     path = pairsToGraph dist pairPath
@@ -122,10 +116,11 @@ gameRoomsFromRooms = map f
   where
     f rm = GameRoom
         { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
-        , _grViewpointsEx = map fst (_rmLinks rm)
+            ++ map fst (_rmLinks rm)
+        , _grViewpointsEx = map fst (_rmUsedLinks rm)
         , _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints 
             . concat $ _rmBound rm ++ _rmPolys rm
-        , _grDir   = snd . last $ _rmLinks rm
+        , _grDir   = snd . head $ _rmUsedLinks rm
         , _grName  = _rmName rm
         }
     closePoints x y = roundPoint2 x == roundPoint2 y

src/Dodge/Layout/Tree/Shift.hs

@@ -27,16 +27,23 @@ shiftRoomTreeSearchAll bs (Node r ts :<| ts')
     | roomIsClipping = [] -- this is called too often, but whatever
     | otherwise = case ts of
         [] -> (r :) <$> shiftRoomTreeSearchAll newBounds ts'
-        (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (rm l) ss <| (ts' |> f l s))) ls
+        (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (ts' |> f l s))) ls
   where
     convexBounds = map pointsToPoly $ _rmBound r
     ls = init $ _rmLinks r
     newBounds = convexBounds ++ bs
     roomIsClipping = or (convexPolysOverlap <$> convexBounds <*> bs)
-    rm l = r & rmLinks %~ delete l
+    useLink l = r & rmLinks %~ delete l
+        & rmUsedLinks %~ (l :)
     f l = applyToRoot (shiftRoomToLink l)
 {- |
 Depth first search of trees of rooms, maybe produces a list rooms that are not clipping.
  -}
 shiftExpandTree :: Tree Room -> Maybe [Room]
-shiftExpandTree = listToMaybe . shiftRoomTreeSearchAll [] . singleton
+shiftExpandTree = fmap (map setLastLinkToUsed) . listToMaybe . shiftRoomTreeSearchAll [] . singleton
+  where
+    setLastLinkToUsed rm = case _rmLinks rm of
+        (_:_) -> rm
+            & rmLinks %~ init
+            & rmUsedLinks %~ (last (_rmLinks rm) :)
+        _ -> rm

src/Dodge/Machine/Sensor.hs

@@ -23,10 +23,7 @@ damageSensor damF p r = Placement (PS p r) ( PutLS theLS)
         , _mcLSs = [lsid]
         }
   where
-    theLS = defaultLS
-        { _lsPos = V3 0 0 30
-        , _lsIntensity = 0.1
-        }
+    theLS = defaultLS { _lsPos = V3 0 0 30 , _lsIntensity = 0.1 }
 
 lightSensor :: Point2 -> Float -> Placement
 lightSensor = damageSensor senseLasering

src/Dodge/Room/Data.hs

@@ -19,6 +19,7 @@ assigning no bounds will allow rooms to overlap.
 data Room = Room
     { _rmPolys  :: [ [Point2] ]
     , _rmLinks  :: [(Point2,Float)]
+    , _rmUsedLinks  :: [(Point2,Float)]
     , _rmPath   :: [(Point2, Point2)]
     , _rmPS     :: [Placement]
     , _rmBound  :: [ [Point2] ]

src/Dodge/Room/LongDoor.hs

@@ -106,8 +106,12 @@ addButtonSlowDoor x h rm = do
        ,( V2 (x/2+50) 5,0)
        ]
     thePlacement <- takeOne [butDoor butPos butRot ]
-    filterLinks aboveH =<< changeLinkTo belowH (rm & rmPS %~ (thePlacement :))
+    filterLinks aboveH =<< changeLinkTo belowH (rm 
+        & rmPS %~ (thePlacement :)
+        & rmBound %~ (openDoorBound :)
+        )
   where
+    openDoorBound = rectNSEW (h + 5) (h - 5) (-x/2) (3*x/2)
     belowH y = (sndV2 . fst) y < h - 40
     aboveH y = (sndV2 . fst) y > h + 40
     butDoor bpos brot = putLitButtonID col bpos brot