From 903a79cf85301d1ec3c30deb10c7be752fd2812e Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 2 Nov 2021 22:27:19 +0000 Subject: [PATCH] Assign used links during room generation --- src/Dodge/Default/Room.hs | 1 + src/Dodge/Initialisation.hs | 4 ++-- src/Dodge/Layout.hs | 21 ++++++++------------- src/Dodge/Layout/Tree/Shift.hs | 13 ++++++++++--- src/Dodge/Machine/Sensor.hs | 5 +---- src/Dodge/Room/Data.hs | 1 + src/Dodge/Room/LongDoor.hs | 6 +++++- 7 files changed, 28 insertions(+), 23 deletions(-) diff --git a/src/Dodge/Default/Room.hs b/src/Dodge/Default/Room.hs index c65b7232a..9db6927dc 100644 --- a/src/Dodge/Default/Room.hs +++ b/src/Dodge/Default/Room.hs @@ -7,6 +7,7 @@ defaultRoom :: Room defaultRoom = Room { _rmPolys = [] , _rmLinks = [] + , _rmUsedLinks = [] , _rmPath = [] , _rmPS = [] , _rmBound = [] diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index c58198cc4..744313ea8 100644 --- a/src/Dodge/Initialisation.hs +++ b/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} diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index fcfb239ee..d69d4be81 100644 --- a/src/Dodge/Layout.hs +++ b/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 diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index 9c6095b29..6d222c98f 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/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 diff --git a/src/Dodge/Machine/Sensor.hs b/src/Dodge/Machine/Sensor.hs index 3997533db..940db2b33 100644 --- a/src/Dodge/Machine/Sensor.hs +++ b/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 diff --git a/src/Dodge/Room/Data.hs b/src/Dodge/Room/Data.hs index 207881dfd..095cf8d59 100644 --- a/src/Dodge/Room/Data.hs +++ b/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] ] diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 922720de3..4b73950b8 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/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