diff --git a/src/Dodge/Data/GenWorld.hs b/src/Dodge/Data/GenWorld.hs index 1306880d0..ffd8211e7 100644 --- a/src/Dodge/Data/GenWorld.hs +++ b/src/Dodge/Data/GenWorld.hs @@ -58,7 +58,7 @@ data PSType | PutDoor Color EdgeObstacle WdBl [(Point2, Point2)] | RandPS (State StdGen PSType) | PutForeground ForegroundShape - | PutWorldUpdate (Room -> PlacementSpot -> GenWorld -> GenWorld) + | PutWorldUpdate (Int -> PlacementSpot -> GenWorld -> GenWorld) | PutNothing | PutID {_putID :: Int} | PutChasm {_putChasmPoly :: [Point2]} diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 0b100483f..fbf423477 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -80,7 +80,7 @@ shuffleRoomPos rm = do return $ rm & rmPos .~ newPos doInPlacements :: GenWorld -> GenWorld -doInPlacements w = foldl' (\gw (i,(_,f)) -> placeSpot' i gw (f gw)) w +doInPlacements w = foldl' (\gw (i,(_,f)) -> placeSpot i gw (f gw)) w . sortOn (fst.snd) $ foldMap g $ w ^. genRooms where @@ -97,15 +97,16 @@ doIndividualPlacements :: GenWorld -> GenWorld doIndividualPlacements gw = foldl' doRoomPlacements gw (_genRooms gw) doRoomPlacements :: GenWorld -> Room -> GenWorld -doRoomPlacements w rm = foldl' (placeSpot' i) (w & genRooms . ix i . rmPmnts .~ mempty) +doRoomPlacements w rm = foldl' (placeSpot i) (w & genRooms . ix i . rmPmnts .~ mempty) $ _rmPmnts rm where i = rm ^?! rmMID . _Just -placeSpot' :: Int -> GenWorld -> Placement -> GenWorld -placeSpot' i gw x = - let (gw',r') = placeSpot (gw,(gw ^?! genRooms . ix i)) x - in gw' & genRooms . ix i .~ r' +--placeSpot' :: Int -> GenWorld -> Placement -> GenWorld +--placeSpot' = placeSpot +--placeSpot' i gw x = +-- let (gw',r') = placeSpot (gw,(gw ^?! genRooms . ix i)) x +-- in gw' & genRooms . ix i .~ r' setupWorldBounds :: World -> World setupWorldBounds w = diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 78829948f..a2495a632 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -28,64 +28,65 @@ import System.Random -- when placing a placement, we update the world and the room and assign an id -- to the placement. This id should be associated with the type of placement and -- match up with the created id for the object (creature id, flitid id, etc) -placeSpot :: (GenWorld, Room) -> Placement -> (GenWorld, Room) -placeSpot (w, rm) plmnt = case plmnt of - Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w +placeSpot :: Int -> GenWorld -> Placement -> GenWorld +--placeSpot :: (GenWorld, Room) -> Placement -> (GenWorld, Room) +placeSpot rid w plmnt = case plmnt of + Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rid i f plmnt w Placement{_plSpot = PSPos extract eff fallback} -> - placeSpotUsingLink w rm plmnt extract eff fallback - Placement{} -> placePlainPSSpot w rm plmnt shift + placeSpotUsingLink w rid plmnt extract eff fallback + Placement{} -> placePlainPSSpot w rid plmnt shift where - shift = _rmShift rm + shift = _rmShift $ w ^?! genRooms . ix rid placePlainPSSpot - :: GenWorld -> Room -> Placement -> DPoint2 -> (GenWorld, Room) -placePlainPSSpot w rm plmnt shift = - let (i, w') = placeSpotID rm (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w + :: GenWorld -> Int -> Placement -> DPoint2 -> GenWorld +placePlainPSSpot w rid plmnt shift = + let (i, w') = placeSpotID rid (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w newplmnt = plmnt & plMID ?~ i - (gw,rm') = maybe (w', rm & rmPmnts .:~ newplmnt) + gw = maybe (w' & genRooms . ix rid . rmPmnts .:~ newplmnt) (recrPlace newplmnt w') (_plIDCont plmnt w' newplmnt) - in (f newplmnt gw,rm') + in (f newplmnt gw) where f x gw = fromMaybe gw $ do j <- x ^. plExternalID return $ gw & genPmnt . at j ?~ x - recrPlace newplmnt w' pl = placeSpot (w', rm & rmPmnts .:~ newplmnt) pl + recrPlace newplmnt w' pl = placeSpot rid (w' & genRooms . ix rid . rmPmnts .:~ newplmnt) pl -- this should be tidied up placeSpotUsingLink :: GenWorld -> - Room -> + Int -> Placement -> (RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)) -> (RoomPos -> Room -> Room) -> Maybe Placement -> - (GenWorld, Room) -placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of - Just (ps, rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps) + GenWorld +placeSpotUsingLink w rid plmnt extract eff fallback = case searchedPoss (w ^?! genRooms . ix rid . rmPos) of + Just (ps, rmposs) -> placeSpot rid (w & genRooms . ix rid %~ eff (head rmposs) . (rmPos .~ rmposs)) (plmnt & plSpot .~ ps) Nothing -> case fallback of - Nothing -> (w, rm) - Just plmnt' -> placeSpot (w, rm) plmnt' + Nothing -> w + Just plmnt' -> placeSpot rid w plmnt' where searchedPoss [] = Nothing - searchedPoss (pos : poss) = case extract pos rm of + searchedPoss (pos : poss) = case extract pos (w ^?! genRooms . ix rid) of Nothing -> second (pos :) <$> searchedPoss poss Just (ps, rmpos) -> Just (ps, rmpos : poss) placeSpotRoomRand :: - Room -> + Int -> Int -> (DPoint2 -> PlacementSpot) -> Placement -> GenWorld -> - (GenWorld, Room) -placeSpotRoomRand rm i f plmnt w = - let (ps, g) = runState (_rmRandPSs rm !! i) $ w ^. gwWorld . randGen - in placeSpot (w & gwWorld . randGen .~ g, rm) (plmnt & plSpot .~ f ps) + GenWorld +placeSpotRoomRand rid i f plmnt w = + let (ps, g) = runState (_rmRandPSs (w ^?! genRooms . ix rid) !! i) $ w ^. gwWorld . randGen + in placeSpot rid (w & gwWorld . randGen .~ g) (plmnt & plSpot .~ f ps) -- the Int here is some id that is assigned when the placement is placed -placeSpotID :: Room -> PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld) -placeSpotID rm ps pt w = case pt of +placeSpotID :: Int -> PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld) +placeSpotID rid ps pt w = case pt of PutTrigger cnd -> plNewID (gwWorld . cWorld . lWorld . triggers) cnd w PutMod mdi -> plNewUpID (gwWorld . cWorld . lWorld . modifications) mdID mdi w PutProp prp -> plNewUpID (gwWorld . cWorld . lWorld . props) prID (mvProp p rot prp) w @@ -107,7 +108,7 @@ placeSpotID rm ps pt w = case pt of PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w PutPPlate pp -> plNewUpID (gwWorld . cWorld . lWorld . pressPlates) ppID (mvPP p rot pp) w - RandPS rgn -> evaluateRandPS rm rgn ps w + RandPS rgn -> evaluateRandPS rid rgn ps w PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w PutSlideDr wl dr eo off a b -> @@ -122,7 +123,7 @@ placeSpotID rm ps pt w = case pt of PutWall qs wl -> (0, over gwWorld (placeWallPoly (map doShift qs) wl) w) PutNothing -> (0, w) PutID i -> (i, w) - PutWorldUpdate f -> (0, w & f rm ps) + PutWorldUpdate f -> (0, w & f rid ps) PutChasm ps' -> (0, w & gwWorld . cWorld . chasms .:~ map doShift ps') where p@(V2 px py) = _psPos ps @@ -131,8 +132,8 @@ placeSpotID rm ps pt w = case pt of doShift = shiftPointBy (p, rot) evaluateRandPS - :: Room -> State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld) -evaluateRandPS rm rgen ps w = placeSpotID rm ps evaluatedType (set (gwWorld . randGen) g w) + :: Int -> State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld) +evaluateRandPS rid rgen ps w = placeSpotID rid ps evaluatedType (set (gwWorld . randGen) g w) where (evaluatedType, g) = runState rgen (_randGen $ _gwWorld w) diff --git a/src/Dodge/Room/Tutorial.hs b/src/Dodge/Room/Tutorial.hs index bebf540f7..a501cb967 100644 --- a/src/Dodge/Room/Tutorial.hs +++ b/src/Dodge/Room/Tutorial.hs @@ -66,7 +66,7 @@ setRoomInt x = do i <- nextLayoutInt return (i,x & rmPmnts .:~ sps0 (PutWorldUpdate (f i))) where - f i rm _ = genInts . at i ?~ (rm ^?! rmMID . _Just) + f i rid _ gw = gw & genInts . at i ?~ (gw ^?! genRooms . ix rid . rmMID . _Just) setTreeInts :: Tree Room -> State LayoutVars ([Int],Tree Room) setTreeInts x = do