Commit before changing links

appDodge/Main.hs

@@ -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

src/Dodge/Floor.hs

@@ -103,22 +103,25 @@ initialRoomTree :: RandomGen g => State g (Tree Room)
 initialRoomTree = do
     expandTreeBy id <$> mapM annoToRoomTree initialAnoTree
 
-layoutLevelFromSeed :: Int -> IO [Room]
+layoutLevelFromSeed :: Int -> Int -> IO [Room]
-layoutLevelFromSeed seed = do
+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

src/Dodge/Initialisation.hs

@@ -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
+worldFromSeed :: Int -> IO World
-firstWorld = do
+worldFromSeed i = do
---    i <- randomRIO (0,5000)
+    roomList <- layoutLevelFromSeed 0 i
-    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
     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

src/Dodge/Layout/Tree/Shift.hs

@@ -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)

src/Dodge/LevelGen.hs

@@ -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)
+           in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
-    Placement{_placementSpot = PSLnk{}} -> case lnks of
+    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
+        let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
-        in maybe (w',rm) (placeSpot (w',rm)) (_idPlacement plmnt i)
+        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

src/Dodge/LevelGen/Data.hs

@@ -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
+    | PSRoomRand { _psRoomRandPointNum :: Int }
-        { _psRoomRandPointNum :: Int }
 data Placement = Placement 
-    { _placementSpot :: PlacementSpot
+    { _plSpot   :: PlacementSpot
-    , _psType :: PSType
+    , _plType   :: PSType
-    , _idPlacement :: Int -> Maybe Placement 
+    , _plIDCont :: Int -> Maybe Placement 
     }
   | PlacementUsingPos Point3 (Point3 -> Placement)  -- allows a placement to use a shifted position
   | RandomPlacement {_unRandomPlacement :: State StdGen Placement}

src/Dodge/Menu.hs

@@ -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

src/Dodge/Placements/Wall.hs

@@ -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 =

src/Dodge/Room/Data.hs

@@ -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

src/Dodge/Room/RoadBlock.hs

@@ -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)
         ]

src/Dodge/Room/Start.hs

@@ -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)
             ] ++
             )