diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index cbb57f718..c6ac25b45 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -41,8 +41,6 @@ generateLevelFromRoomList :: State StdGen [Room] -> World -> World generateLevelFromRoomList gr w = initWallZoning . setupWorldBounds - -- . flip (foldr $ flip placeSpot) plmnts - -- . flip (foldl' placeSpot) plmnts . flip (foldl' doRoomPlacements) rs $ w { _walls = wallsFromRooms rs , _floorTiles = floorsFromRooms rs @@ -53,12 +51,11 @@ generateLevelFromRoomList gr w where path = pairsToGraph dist pairPath pairPath = concatMap _rmPath rs - plmnts = concatMap (\rm -> map (rm,) (_rmPS rm)) rs rs = zipWith addTile zs . evalState gr $ _randGen w zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w doRoomPlacements :: World -> Room -> World -doRoomPlacements w rm = fst $ foldl' placeSpot' (w,rm) $ _rmPS rm +doRoomPlacements w rm = fst $ foldl' placeSpot (w,rm) $ _rmPS rm updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index cdb0c1356..9d3b1fd45 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -4,9 +4,8 @@ module Dodge.LevelGen ( shiftPlacement , shiftPointBy --- , placeSpot , invShiftPointBy - , placeSpot' + , placeSpot ) where import Dodge.Data import Dodge.LevelGen.Block @@ -26,25 +25,24 @@ import Color import Control.Monad.State import Control.Lens import qualified Data.IntSet as IS -import Data.List (delete) -placeSpot' :: (World,Room) -> Placement -> (World,Room) -placeSpot' (w,rm) plmnt = case plmnt of +placeSpot :: (World,Room) -> Placement -> (World,Room) +placeSpot (w,rm) plmnt = case plmnt of Placement{_placementSpot = PSRoomRand i} -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w - in placeSpot' (w & randGen .~ g,rm) (plmnt & placementSpot .~ uncurry PS ps) + in placeSpot (w & randGen .~ g,rm) (plmnt & placementSpot .~ uncurry PS ps) Placement{_placementSpot = PSLnk{}} -> case lnks of - (lnk:_) -> placeSpot' (w & randGen .~ g,uselnk lnk) (updatePS (f lnk) plmnt) + ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt) [] -> case fallback of Nothing -> (w,rm) - Just plmnt' -> placeSpot' (w,rm) plmnt' + Just plmnt' -> placeSpot (w,rm) plmnt' where - uselnk lnk = rm & rmLinks %~ delete lnk + uselnk lnki = rm & rmLinks %~ deletei lnki rps = _placementSpot plmnt fallback = _psFallback rps test = _psLinkTest rps - (lnks,g) = runState (shuffle $ filter test $ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) - $ _randGen w + (lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..] + $ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w f x (PSLnk t s _) | t x = uncurry PS $ s x f _ ps = ps @@ -52,54 +50,16 @@ placeSpot' (w,rm) plmnt = case plmnt of invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot) Placement{} -> let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot plmnt)) (_psType plmnt) w - in (maybe w' (curry (placeSpot w') rm) (_idPlacement plmnt i) , rm) - PlacementUsingPos p subpl -> placeSpot' (w,rm) (subpl (shiftPoint3By shift p)) - RandomPlacement rplmnt -> placeSpot' (w & randGen .~ g,rm) plmnt' + in maybe (w',rm) (placeSpot (w',rm)) (_idPlacement plmnt i) + PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p)) + RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt' where (plmnt', g) = runState rplmnt (_randGen w) where shift = _rmShift rm - --- potential failure cases: randomising using an already set link position --- others? -placeSpot :: World -> (Room , Placement) -> World -placeSpot w (rm, plmnt@Placement{_placementSpot=PSRoomRand i}) = - let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w - in placeSpot (w & randGen .~ g) (rm, plmnt & placementSpot .~ uncurry PS ps) -placeSpot w (rm, plmnt@Placement{_placementSpot=PSLnk{}}) - = assignPSToLnk rm plmnt w -placeSpot w (rm, plmnt@Placement{}) = - let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot plmnt)) (_psType plmnt) w - in maybe w' (curry (placeSpot w') rm) (_idPlacement plmnt i) - where - shift = _rmShift rm -placeSpot w (rm, PlacementUsingPos p subpl) = placeSpot w (rm, subpl (shiftPoint3By shift p)) - where - shift = _rmShift rm -placeSpot w (rm, RandomPlacement rplmnt) = placeSpot (w & randGen .~ g) (rm, plmnt) - where - (plmnt, g) = runState rplmnt (_randGen w) - --- this should be woven into placeSpot -assignPSToLnk :: Room -> Placement -> World -> World -assignPSToLnk rm plmnt w = case lnks of - (lnk:_) -> placeSpot (w & randGen .~ g) (uselnk lnk, updatePS (f lnk) plmnt) - [] -> case fallback of - Nothing -> w - Just plmnt' -> placeSpot w (rm,plmnt') - where - uselnk lnk = rm & rmLinks %~ delete lnk - rps = _placementSpot plmnt - fallback = _psFallback rps - test = _psLinkTest rps - (lnks,g) = runState (shuffle $ filter test $ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) - $ _randGen w - f x (PSLnk t s _) - | t x = uncurry PS $ s x - f _ ps = ps - invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float) - invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot) +deletei :: Int -> [a] -> [a] +deletei i xs = take i xs ++ drop (i+1) xs shiftPlacement :: (Point2,Float) -> Placement -> Placement shiftPlacement shift (Placement ps pt f) = Placement (shiftPSBy shift ps) pt