Commit before changing logging of placement spots

2025-09-29 21:58:02 +01:00
parent 9ed6d75853
commit bf9a2250da
14 changed files with 294 additions and 288 deletions
@@ -76,6 +76,12 @@ data RoomPosType
    | RoomPosLab Int
    deriving (Eq, Ord, Show)

+data UsedPos
+    = UsedPosLow
+    | UsedPosMid
+    | UsedPosHigh
+    deriving (Eq, Ord, Show)
+
 makeLenses ''RoomLink
 makeLenses ''RoomPos
 makeLenses ''RoomPosType
@@ -60,8 +60,8 @@ initialRoomTree =
                                 , psPtPl anyUnusedSpot (PutCrit armourChaseCrit)
                                 ])
            , intAnno $ fmap (tToBTree "healthTest") . healthTest
-            , zoom lyGen $ 
-                (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward)
+            , zoom lyGen  
+                $ tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward
            , passthroughLockKeyLists lockRoomKeyItems itemRooms
            , randomChallenges
            , intAnno lasSensorTurretTest
@@ -4,14 +4,13 @@ module Dodge.Layout (
    tilesFromRooms,
 ) where

-import Data.List (sortOn)
 import Dodge.Path.Translate
 import qualified Control.Foldl as L
 import Control.Lens
 import Data.Foldable
 import Data.Function
 import Data.Graph.Inductive (labEdges, labNodes)
-import Data.List (nubBy)
+import Data.List (nubBy,sortOn)
 import Data.Maybe
 import Data.Tile
 --import Data.Traversable
@@ -165,6 +165,9 @@ mntLightLnkCond ps = do
    shp <- takeOne [vShape, lShape, jShape, liShape]
    return $ mntLSCond (fmap (fmap $ colorSH black) shp) ps

+mntLightLnkCond' :: PlacementSpot -> Placement
+mntLightLnkCond' = mntLSCond (fmap (fmap $ colorSH black) vShape)
+
 spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
 spanLSLightI ls h a b =
    ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h) $
@@ -23,7 +23,7 @@ import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
 import NewInt
-import System.Random
+--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
@@ -38,14 +38,17 @@ placeSpot rid w plmnt = case plmnt of
  where
    shift = _rmShift $ w ^?! genRooms . ix rid

-placePlainPSSpot 
-    :: 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 = maybe (w' & genRooms . ix rid . rmPmnts .:~ newplmnt) 
-            (recrPlace newplmnt w') (_plIDCont plmnt w' newplmnt)
-     in (f newplmnt gw)
+placePlainPSSpot :: GenWorld -> Int -> Placement -> DPoint2 -> GenWorld
+placePlainPSSpot w rid plmnt shift = case plmnt ^. plType of
+    RandPS rgn -> 
+        let (x, g) = runState rgn (w ^. gwWorld . randGen)
+        in placePlainPSSpot (w & gwWorld . randGen .~ g) rid (plmnt & plType .~ x) shift
+    _ ->
+        let (i, w') = placeSpotID rid (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
+            newplmnt = plmnt & plMID ?~ i
+            gw = maybe (w' & genRooms . ix rid . rmPmnts .:~ newplmnt) 
+                (recrPlace newplmnt w') (_plIDCont plmnt w' newplmnt)
+         in f newplmnt gw
  where
    f x gw = fromMaybe gw $ do
        j <- x ^. plExternalID
@@ -90,7 +93,8 @@ 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
-    PutButton bt -> plNewUpID (gwWorld . cWorld . lWorld . buttons) btID (mvButton p rot bt) w
+    PutButton bt -> plNewUpID (gwWorld . cWorld . lWorld . buttons) btID 
+        (mvButton p rot bt) w
    PutTerminal tm -> plNewUpID (gwWorld . cWorld . lWorld . terminals) tmID tm w
    PutFlIt itm ->
        let i = IM.newKey (w ^. gwWorld . cWorld . lWorld . items)
@@ -108,7 +112,7 @@ placeSpotID rid 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 rid rgn ps w
+    RandPS _ -> error "RandPS should not be reachable here" --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 ->
@@ -131,11 +135,12 @@ placeSpotID rid ps pt w = case pt of
    rot = _psRot ps
    doShift = shiftPointBy (p, rot)

-evaluateRandPS 
-    :: 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)
+--evaluateRandPS 
+--    :: 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)

 -- this function is the reason for the warning suppression
 -- remove the warning suppression if it changes
@@ -9,6 +9,7 @@ module Dodge.Room.Room (
    spawnerRoom,
    corDoor,
    weaponBehindPillar,
+    critsRoom,
 ) where

 import qualified Data.Set as S
@@ -73,6 +74,7 @@ glassSwitchBack = do
    wth <- state $ randomR (200, 400)
    hgt <- state $ randomR (400, 600)
    wllen <- state $ randomR (60, wth / 2 -40)
+    l1 <- mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
    let hf = hgt / 5
        awindow h xl xr = windowLine (V2 xl h) (V2 xr h)
        plmnts =
@@ -84,7 +86,8 @@ glassSwitchBack = do
            , blockLine (V2 (wth - wllen) (2 * hf)) (V2 wth (2 * hf))
            , blockLine (V2 0 (3 * hf)) (V2 wllen (3 * hf))
            , blockLine (V2 (wth - wllen) (4 * hf)) (V2 wth (4 * hf))
-            , sPS (V2 (wth / 2) (hgt / 2)) 0 putLamp
+            , l1
+--            , sPS (V2 (wth / 2) (10 + hgt / 2)) 0 putLamp
            ]
    let northPSs = do
            cry <- randomRanges [3 * hf + 10, 4 * hf -10, 4 * hf + 10, 5 * hf -10]
@@ -120,7 +123,8 @@ roomMiniIntro = do
 roomCenterPillar :: RandomGen g => State g Room
 roomCenterPillar = do
    l1 <- mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
-    l2 <- mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isOutLnk rp)
+    l2 <- mntLightLnkCond ((resetPLUse $ rprBool $ \rp _ -> isOutLnk rp)
+        & psFallback ?~ mntLightLnkCond' (resetPLUse useUnusedLnk)) 
    let plmnts =
            [ blockLine (V2 115 115) (V2 115 125)
            , blockLine (V2 125 115) (V2 125 125)
@@ -299,15 +303,16 @@ shootersRoom' = do
                   ]
        toPS x y = return (V2 x y, -0.5 * pi)
    roomRectAutoLinks w 600
-                <&> rmPmnts .~ plmnts
-                <&> rmRandPSs .~ [toPS x1 y1, toPS x2 y2, toPS x3 y3]
+        <&> rmPmnts .~ plmnts
+        <&> rmRandPSs .~ [toPS x1 y1, toPS x2 y2, toPS x3 y3]

 shootersRoom1 :: RandomGen g => State g Room
 shootersRoom1 = do
-    pl <- takeOne $
-                map
-                    (\i -> psPtPl (PSRoomRand i (uncurry PS)) (PutCrit autoCrit))
-                    [0, 1, 2]
+    pl <-
+        takeOne $
+            map
+                (\i -> psPtPl (PSRoomRand i (uncurry PS)) (PutCrit autoCrit))
+                [0, 1, 2]
    shootersRoom' <&> rmPmnts
        .:~ pl

@@ -377,5 +382,21 @@ corDoor = do
    cor <- shuffleLinks (cleatOnward corridor) <&> rmPmnts .~ []
    return $ tToBTree "corDoor" $ treePost [door, cor]

+critsPillarRoom :: Int -> State LayoutVars Room
+critsPillarRoom i = do
+    xs <- takeN i $ [V2 x y | x <- [20, 220], y <- [20, 40]] ++ [V2 120 160, V2 120 200]
+    rcp <- roomCenterPillar
+    return $ rcp & rmPmnts <>~ fmap f xs
+  where
+    f x = sPS x (argV $ V2 120 80 -.- x) randC1
+
+critsRoom :: Int -> State LayoutVars (Tree Room)
+critsRoom i =
+    join $
+        takeOne
+            --[return <$> critsPillarRoom i]
+            --[return <$> roomC 200 200]
+            [return <$> glassSwitchBack]
+
 --    cor <- shuffleLinks corridor
 --    return $ tToBTree "corDoor" $ treePost [door,cor,cleatOnward door]
@@ -41,14 +41,10 @@ import qualified Data.IntMap.Strict as IM

 tutAnoTree :: State LayoutVars MTRS
 tutAnoTree = do
-    (is,wbp) <- setTreeInts =<< weaponBehindPillar
    foldMTRS
        [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
        , corDoor
-        , tutRooms is
-        , corDoor
-        , tToBTree "critroom" <$> return wbp
-        , corDoor
+        , tutHub
        , tutDrop
        , return $ tToBTree "cor" $ return $ cleatOnward corridor
        ----        , AnTree $ pickupTut
@@ -106,22 +102,24 @@ tutDrop = do
        , makeTermLine "-------------------------------------------"
        ]

-tutRooms :: [Int] -> State LayoutVars (MetaTree Room String)
-tutRooms is = do
+tutHub :: State LayoutVars (MetaTree Room String)
+tutHub = do
+    (is,wbp) <- setTreeInts =<< critsRoom 2
    i <- nextLayoutInt
    j <- nextLayoutInt
    k <- nextLayoutInt
    let a gw = analyserByNthLinkWithPrompt 
-            3 (makeTermPara $ show is <> show (getRoomsFromInts is gw)
-                <>(getCrsFromRooms' is gw)) 
+            3 --(makeTermPara $ show is <> show (getRoomsFromInts is gw)
+              --  <> getCrsFromRooms' is gw)
+                []
                (RequireDeadCreatures $ getCrsFromRooms is gw) k
    x <-
        shuffleLinks 
-            . analyserByDoorWithPrompt sensorTut (RequireEquipment (AMMOMAG DRUMMAG)) i
+            . analyserByDoorWithPrompt [] (RequireEquipment (AMMOMAG DRUMMAG)) i
            . (rmInPmnt .:~ (0,a))
-            =<< addDoorAtNthLinkToggleTerminal 1 ss j
-            <$> roomNgon 6 100
-    bcor <- blockedCorridor
+            . addDoorAtNthLinkToggleTerminal 1 ss j
+            =<< roomNgon 6 100
+    bcor <- treeAttachDeep (return door) <$> blockedCorridor
    r1 <- r burstRifle <&> rmPmnts .:~ t
    r2 <- r (drumMag & itConsumables ?~ 500)
    return $
@@ -130,8 +128,9 @@ tutRooms is = do
                x
                [ treeFromPost [triggerDoorRoom i] r1
                , treeFromPost [triggerDoorRoom j] r2
-                , bcor
-                , treeFromPost [triggerDoorRoom k & rmInPmnt . ix 0 . _1 .~ 1] r2
+                , (rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) 
+                    <$> treeAttachDeep wbp bcor
+                , treeFromPost [] (cleatOnward $ triggerDoorRoom k & rmInPmnt . ix 0 . _1 .~ 1)
                ]
  where
    ss =
@@ -192,7 +191,7 @@ getCrsFromRooms' is gw = fmap h $ show $ foldMap f (IM.restrictKeys (gw ^. genRo
 getCrsFromRooms :: [Int] -> GenWorld -> [Int]
 getCrsFromRooms is gw = foldMap f (IM.restrictKeys (gw ^. genRooms) js)
  where
-    js = foldMap IS.singleton $ IM.restrictKeys (gw ^. genInts) (IS.fromList is)
+    js = getRoomsFromInts is gw
    f rm = foldMap g $ rm ^. rmPmnts
    g x = case x ^. plType of
        PutCrit _ -> [x ^?! plMID . _Just]
@@ -206,7 +205,7 @@ sensorTut =
        , makeTermLine "               | / - \\"
        , makeTermLine "--------------------------------------------"
        ]
-        <> tlSetStatus (TerminalPressTo "CONTINUE")
+--        <> tlSetStatus (TerminalPressTo "CONTINUE")

 tutRezBox :: RandomGen g => State g Room
 tutRezBox = do
@@ -26,6 +26,7 @@ module TreeHelp (
    updateRandNode,
    safeUpdateSingleNode,
    numTraversable,
+    treeAttachDeep,
 ) where

 import Control.Lens
@@ -188,3 +189,7 @@ numTraversable = snd . mapAccumL f 0
 -- untested
 inorderNumberTree :: Tree a -> Tree (a, Int)
 inorderNumberTree = numTraversable
+
+treeAttachDeep :: Tree a -> Tree a -> Tree a
+treeAttachDeep t (Node y (z:zs)) = Node y (treeAttachDeep t z:zs)
+treeAttachDeep t (Node y []) = Node y [t]