Commit before changing links
This commit is contained in:
+1
-1
@@ -56,7 +56,7 @@ firstWorldLoad theConfig = do
|
||||
SDL.cursorVisible $= False
|
||||
theKeyConfig <- loadKeyConfig
|
||||
pdata <- doPreload >>= applyWorldConfig theConfig
|
||||
w <- firstWorld
|
||||
w <- worldFromSeed 0
|
||||
return $ w & preloadData .~ pdata
|
||||
& keyConfig .~ theKeyConfig
|
||||
& config .~ theConfig
|
||||
|
||||
+8
-5
@@ -103,22 +103,25 @@ initialRoomTree :: RandomGen g => State g (Tree Room)
|
||||
initialRoomTree = do
|
||||
expandTreeBy id <$> mapM annoToRoomTree initialAnoTree
|
||||
|
||||
layoutLevelFromSeed :: Int -> IO [Room]
|
||||
layoutLevelFromSeed seed = do
|
||||
layoutLevelFromSeed :: Int -> Int -> IO [Room]
|
||||
layoutLevelFromSeed i seed = do
|
||||
let i' = i + 1
|
||||
putStrLn $ "Generating level with seed " ++ show seed
|
||||
let g = mkStdGen seed
|
||||
let rmtree = inorderNumberTree $ evalState initialRoomTree g
|
||||
putStrLn "Seed layout: "
|
||||
putStrLn "Abstract layout: "
|
||||
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
|
||||
mrs <- positionRooms rmtree
|
||||
case mrs of
|
||||
Just rs -> do
|
||||
putStrLn $ "Successful generation of level with seed " ++ show seed
|
||||
putStrLn $ "After " ++ show i'
|
||||
++ " attempt(s), Successful generation of level with seed "
|
||||
++ show seed
|
||||
return (fmap setLastLinkToUsed rs)
|
||||
Nothing -> do
|
||||
putStr $ "Level generation with seed " ++ show seed ++ " failed: "
|
||||
let (seed',_) = random g
|
||||
layoutLevelFromSeed seed'
|
||||
layoutLevelFromSeed i' seed'
|
||||
where
|
||||
setLastLinkToUsed rm = case _rmLinks rm of
|
||||
(_:_) -> rm
|
||||
|
||||
@@ -17,15 +17,9 @@ import qualified Data.Set as S
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import qualified Data.Map as M
|
||||
|
||||
firstWorld :: IO World
|
||||
firstWorld = do
|
||||
-- i <- randomRIO (0,5000)
|
||||
let i = 3
|
||||
--putStrLn $ "Seed for level generation: " ++ show ( i :: Int)
|
||||
-- let g = mkStdGen i
|
||||
-- (roomList,n) <- f g
|
||||
-- putStrLn $ "Had to go through "++ show n ++ " random generators"
|
||||
roomList <- layoutLevelFromSeed i
|
||||
worldFromSeed :: Int -> IO World
|
||||
worldFromSeed i = do
|
||||
roomList <- layoutLevelFromSeed 0 i
|
||||
return $ generateLevelFromRoomList roomList
|
||||
initialWorld -- note this uses a random generator defined elsewhere
|
||||
|
||||
@@ -43,7 +37,8 @@ initialWorld = defaultWorld
|
||||
, _mousePos = V2 0 0
|
||||
, _testString = testStringInit
|
||||
, _yourID = 0
|
||||
, _worldEvents = saveWorldInEmptySlot LevelStartSlot . soundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing
|
||||
, _worldEvents = saveWorldInEmptySlot LevelStartSlot
|
||||
. soundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing
|
||||
. foldr ((.) . makeStartCloudAt) id [V3 x y 5 | x <- [-5,-3..5] , y <- [-5,-3..5]]
|
||||
, _pressPlates = IM.empty
|
||||
, _buttons = IM.empty
|
||||
|
||||
@@ -55,7 +55,8 @@ posRms
|
||||
-> Seq (Tree RoomInt)
|
||||
-> IO (Maybe [Room])
|
||||
posRms _ _ [] Empty = return $ Just []
|
||||
posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq) = fmap (setLastLinkToUsed rtoadd:) <$> posRms bounds (r,i) ts tseq
|
||||
posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq)
|
||||
= fmap (setLastLinkToUsed rtoadd:) <$> posRms bounds (r,i) ts tseq
|
||||
posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do
|
||||
putStr $ "Trying to place room " ++ show i' ++ ": "
|
||||
tryLinks' (0::Int) (_rmLinks r)
|
||||
|
||||
@@ -28,17 +28,17 @@ import qualified Data.IntSet as IS
|
||||
|
||||
placeSpot :: (World,Room) -> Placement -> (World,Room)
|
||||
placeSpot (w,rm) plmnt = case plmnt of
|
||||
Placement{_placementSpot = PSRoomRand i}
|
||||
Placement{_plSpot = PSRoomRand i}
|
||||
-> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
|
||||
in placeSpot (w & randGen .~ g,rm) (plmnt & placementSpot .~ uncurry PS ps)
|
||||
Placement{_placementSpot = PSLnk{}} -> case lnks of
|
||||
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
|
||||
Placement{_plSpot = PSLnk{}} -> case lnks of
|
||||
((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt)
|
||||
[] -> case fallback of
|
||||
Nothing -> (w,rm)
|
||||
Just plmnt' -> placeSpot (w,rm) plmnt'
|
||||
where
|
||||
uselnk lnki = rm & rmLinks %~ deletei lnki
|
||||
rps = _placementSpot plmnt
|
||||
rps = _plSpot plmnt
|
||||
fallback = _psFallback rps
|
||||
test = _psLinkTest rps
|
||||
(lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..]
|
||||
@@ -49,8 +49,8 @@ placeSpot (w,rm) plmnt = case plmnt of
|
||||
invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
|
||||
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',rm) (placeSpot (w',rm)) (_idPlacement plmnt i)
|
||||
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
||||
in maybe (w',rm) (placeSpot (w',rm)) (_plIDCont plmnt i)
|
||||
PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
|
||||
RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt'
|
||||
where
|
||||
@@ -97,6 +97,7 @@ placeSpotID ps pt w = case pt of
|
||||
PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
|
||||
PutNothing -> (0,w)
|
||||
PutID i -> (i, w)
|
||||
PutWorldUpdate f -> (0,f ps w)
|
||||
where
|
||||
p@(V2 px py) = _psPos ps
|
||||
p' = V3 px py 0
|
||||
|
||||
@@ -25,6 +25,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
|
||||
| PutDoor Color (World -> Bool) [(Point2,Point2)]
|
||||
| RandPS (State StdGen PSType)
|
||||
| PutForeground Shape
|
||||
| PutWorldUpdate (PlacementSpot -> World -> World)
|
||||
| PutNothing
|
||||
| PutID { _putID :: Int}
|
||||
-- maybe there is a monadic implementation of this?
|
||||
@@ -34,12 +35,11 @@ data PlacementSpot
|
||||
, _psLinkShift :: (Point2,Float) -> (Point2,Float)
|
||||
, _psFallback :: Maybe Placement
|
||||
}
|
||||
| PSRoomRand
|
||||
{ _psRoomRandPointNum :: Int }
|
||||
| PSRoomRand { _psRoomRandPointNum :: Int }
|
||||
data Placement = Placement
|
||||
{ _placementSpot :: PlacementSpot
|
||||
, _psType :: PSType
|
||||
, _idPlacement :: Int -> Maybe Placement
|
||||
{ _plSpot :: PlacementSpot
|
||||
, _plType :: PSType
|
||||
, _plIDCont :: Int -> Maybe Placement
|
||||
}
|
||||
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
|
||||
| RandomPlacement {_unRandomPlacement :: State StdGen Placement}
|
||||
|
||||
+4
-1
@@ -18,6 +18,7 @@ import Dodge.Base.Window
|
||||
import Dodge.SoundLogic
|
||||
|
||||
import Control.Lens
|
||||
import System.Random
|
||||
|
||||
optionMenu :: ScreenLayer
|
||||
optionMenu = OptionScreen
|
||||
@@ -159,8 +160,10 @@ pauseMenuOptions =
|
||||
startNewGame :: World -> Maybe World
|
||||
startNewGame w = Just $ w
|
||||
& menuLayers .~ [WaitScreen (const "GENERATING...") 1]
|
||||
& sideEffects .~ const (firstWorld <&> keyConfig .~ _keyConfig w <&> config .~ _config w
|
||||
& sideEffects .~ const (worldFromSeed i <&> keyConfig .~ _keyConfig w <&> config .~ _config w
|
||||
<&> preloadData .~ _preloadData w) -- this kills save games etc...
|
||||
where
|
||||
i = fst $ random (_randGen w)
|
||||
|
||||
-- | hacky
|
||||
scodeToChar :: Scancode -> Char
|
||||
|
||||
@@ -89,7 +89,7 @@ replacePutID
|
||||
-> Room
|
||||
-> Room
|
||||
replacePutID i psts r =
|
||||
r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & psType .~ pt)) psts
|
||||
r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & plType .~ pt)) psts
|
||||
{- Partition a list by a predicate, apply a zip to those elements
|
||||
that satisfy the predicate, concatenate
|
||||
the new zipped list and the other (unchanged) half. -}
|
||||
@@ -104,7 +104,7 @@ subZipWith f g xs ys =
|
||||
in zipWith g zs ys ++ ws
|
||||
|
||||
isPutID :: Int -> Placement -> Bool
|
||||
isPutID i ps = Just i == ps ^? psType . putID
|
||||
isPutID i ps = Just i == ps ^? plType . putID
|
||||
|
||||
putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
|
||||
putBlockRect a x b y =
|
||||
|
||||
@@ -31,4 +31,8 @@ data Room = Room
|
||||
, _rmViewpoints :: [Point2]
|
||||
, _rmRandPSs :: [State StdGen (Point2,Float)]
|
||||
}
|
||||
data RoomPos
|
||||
= Link (Point2,Float)
|
||||
| UsedLink (Point2,Float)
|
||||
| LinkInt Int (Point2,Float)
|
||||
makeLenses ''Room
|
||||
|
||||
@@ -81,7 +81,7 @@ lasTunnel = defaultRoom
|
||||
{ _rmPolys = polys
|
||||
, _rmBound = polys
|
||||
, _rmLinks = [(V2 20 190,1.5* pi),(V2 0 20,0.5* pi)]
|
||||
, _rmPS = [putLasTurret & placementSpot .~ PS (V2 10 240) (1.5*pi)
|
||||
, _rmPS = [putLasTurret & plSpot .~ PS (V2 10 240) (1.5*pi)
|
||||
, lowWall (rectNSEW 65 40 0 25)
|
||||
, mountLightV (V2 50 10) (V3 40 20 50)
|
||||
]
|
||||
|
||||
@@ -38,7 +38,7 @@ startRoom = do
|
||||
, tankSquare (dim orange) 50 50
|
||||
, tankSquare (dim orange) 50 120
|
||||
, lightSensor (V2 (0.8*w) (0.25*h)) 0
|
||||
, putLasTurret & placementSpot .~ PS (V2 (0.8*w) (0.8*h)) 0
|
||||
, putLasTurret & plSpot .~ PS (V2 (0.8*w) (0.8*h)) 0
|
||||
, sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
|
||||
] ++
|
||||
)
|
||||
|
||||
Reference in New Issue
Block a user