Continue work on chasm rooms

2025-10-03 11:52:49 +01:00
parent 7e3614c9c8
commit 5c22ca6662
11 changed files with 426 additions and 326 deletions
@@ -1,12 +1,23 @@
 module Dodge.Room.Tutorial where

 import Control.Monad
+--import Dodge.Room.Corridor
+--import Dodge.Room.Door
+--import Dodge.Room.Link
+
+--import Dodge.Room.RoadBlock
+
+--import Dodge.Tree
+
+--import Padding
+
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntSet as IS
+import Data.Maybe (mapMaybe)
 import qualified Data.Set as S
-import ShortShow
-import Dodge.Data.MTRS
-import Dodge.Room.Room
 import Dodge.Cleat
 import Dodge.Data.GenWorld
+import Dodge.Data.MTRS
 import Dodge.Default.Terminal
 import Dodge.Item.Ammo
 import Dodge.Item.Held.Cane
@@ -19,25 +30,20 @@ import Dodge.Room.Door
 import Dodge.Room.LasTurret
 import Dodge.Room.Link
 import Dodge.Room.Ngon
--import Dodge.Room.Corridor
--import Dodge.Room.Door
--import Dodge.Room.Link
 import Dodge.Room.Procedural
 import Dodge.Room.RezBox
 import Dodge.Room.RoadBlock
+import Dodge.Room.Room
 import Dodge.Room.Warning
--import Dodge.Room.RoadBlock
 import Dodge.RoomLink
 import Dodge.Terminal
 import Dodge.Tree.Compose
--import Dodge.Tree
 import Geometry
 import LensHelp
--import Padding
+import Linear
 import RandomHelp
+import ShortShow
 import TreeHelp
-import qualified Data.IntSet as IS
-import qualified Data.IntMap.Strict as IM

 --import Data.List (intersperse)

@@ -54,141 +60,188 @@ tutAnoTree = do
        ----        , AnTree $ weaponTut
        ]

-foldMTRS :: [State LayoutVars (MetaTree Room String)] 
-    -> State LayoutVars (MetaTree Room String)
-foldMTRS  xs = do
+foldMTRS ::
+    [State LayoutVars (MetaTree Room String)] ->
+    State LayoutVars (MetaTree Room String)
+foldMTRS xs = do
    ys <- sequence xs
    return $ foldr1 attachOnward' ys

-setRoomInt :: Room -> State LayoutVars (Int,Room)
+setRoomInt :: Room -> State LayoutVars (Int, Room)
 setRoomInt x = do
    i <- nextLayoutInt
-    return (i,x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
+    return (i, x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
  where
    f i rid _ gw = gw & genInts . at i ?~ (gw ^?! genRooms . ix rid . rmMID . _Just)

-setTreeInts :: Tree Room -> State LayoutVars ([Int],Tree Room)
+setTreeInts :: Tree Room -> State LayoutVars ([Int], Tree Room)
 setTreeInts x = do
    y <- traverse setRoomInt x
-    return (foldMap ((:[]) . fst) y, fmap snd y)
+    return (foldMap ((: []) . fst) y, fmap snd y)

 tutDrop :: State LayoutVars (MetaTree Room String)
 tutDrop = do
    x <- shuffleLinks =<< roomNgon 6 100
    i <- nextLayoutInt
    --let y = decontamRoom i
-    (j,y) <- setRoomInt (decontamRoom i)
+    (j, y) <- setRoomInt (decontamRoom i)
    rm <- roomRectAutoLinks 40 100
    return $
        tToBTree "TutDrop" $
            treePost
-                [x & rmInPmnt .:~ (0,t j), y, cleatOnward rm]
+                [x & rmInPmnt .:~ (0, t j), y, cleatOnward rm]
  where
-    t j = \ gw -> let x = gw ^? genInts . ix j
-        in putMessageTerminal
-            terminalColor
-            (defaultTerminal & tmBootLines .~ ss <> tlSetStatus (TerminalPressTo $ show x <>"QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
-            & plSpot .~ rprBoolShift isUnusedLnk 
-                (\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi/2), a), S.singleton UsedPosLow))
+    t j = \gw ->
+        let x = gw ^? genInts . ix j
+         in putMessageTerminal
+                terminalColor
+                (defaultTerminal & tmBootLines .~ ss <> tlSetStatus (TerminalPressTo $ show x <> "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
+                & plSpot
+                    .~ rprBoolShift
+                        isUnusedLnk
+                        (\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi / 2), a), S.singleton UsedPosLow))
    ss =
-        [makeTermLine "--------------------------------------------"
-        ,makeTermLine "YOU CAN ONLY CARRY A LIMITED AMOUNT OF ITEMS"
-        ,makeTermLine "--------------------------------------------"
-        ]
-        <> tlSetStatus (TerminalPressTo "CONTINUE") <>
-        [ makeTermLine "USE [F] TO DROP SINGLE ITEMS"
-        ,makeTermLine "--------------------------------------------"
-        ]
-        <> tlSetStatus (TerminalPressTo "CONTINUE") <>
-        [ makeTermLine "YOU CAN SELECT AND MOVE MULTIPLE ITEMS"
-        , makeTermLine "                             WITH THE MOUSE"
-        , makeTermLine "-------------------------------------------"
+        [ makeTermLine "--------------------------------------------"
+        , makeTermLine "YOU CAN ONLY CARRY A LIMITED AMOUNT OF ITEMS"
+        , makeTermLine "--------------------------------------------"
        ]
+            <> tlSetStatus (TerminalPressTo "CONTINUE")
+            <> [ makeTermLine "USE [F] TO DROP SINGLE ITEMS"
+               , makeTermLine "--------------------------------------------"
+               ]
+            <> tlSetStatus (TerminalPressTo "CONTINUE")
+            <> [ makeTermLine "YOU CAN SELECT AND MOVE MULTIPLE ITEMS"
+               , makeTermLine "                             WITH THE MOUSE"
+               , makeTermLine "-------------------------------------------"
+               ]

 cChasm :: State LayoutVars Room
 cChasm = do
-    x <- state $ randomR (150,300)
-    y <- state $ randomR (150,300)
+    x <- state $ randomR (150, 300)
+    y <- state $ randomR (150, 300)
    roomRectAutoLinks x y
        <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
        <&> rmLinks %~ setInLinks (isCornerLink SouthWest)
-        <&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y-50) 50 0 (x-50))]
+        <&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y -50) 50 0 (x -50))]

 lChasm :: State LayoutVars Room
 lChasm = do
-    x <- state $ randomR (150,300)
-    y <- state $ randomR (150,300)
+    x <- state $ randomR (150, 300)
+    y <- state $ randomR (150, 300)
    roomRectAutoLinks x y
        <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
        <&> rmLinks %~ setInLinks (isCornerLink SouthEast)
-        <&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y-50) 0 0 (x-50))]
+        <&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y -50) 0 0 (x -50))]

 zChasm :: Float -> State LayoutVars Room
 zChasm z = do
-    x <- state $ randomR (150,300)
-    y <- state $ randomR (150,300)
+    x <- state $ randomR (150, 300)
+    y <- state $ randomR (150, 300)
    roomRectAutoLinks x y
        <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
        <&> rmLinks %~ setInLinks (isCornerLink SouthEast)
-        <&> rmPmnts <>~ 
-                [sps0 $ PutChasm (rectNSWE (y/2-z) 0 0 (x-50))
-                ,sps0 $ PutChasm (rectNSWE y (y/2+z) 50 x)
+        <&> rmPmnts
+            <>~ [ sps0 $ PutChasm (rectNSWE (y / 2 - z) 0 0 (x -50))
+                , sps0 $ PutChasm (rectNSWE y (y / 2 + z) 50 x)
                ]

 midChasm :: State LayoutVars Room
 midChasm = do
-    x <- state $ randomR (200,300)
-    y <- state $ randomR (200,300)
+    x <- state $ randomR (200, 300)
+    y <- state $ randomR (200, 300)
    r <- roomRectAutoLinks x y
-    cs <- join $ takeOne [cenoct x y,censquare x y]
-    shuffleLinks $ r
-        & rmLinks %~ setOutLinks (isMidEdgeLink r North)
-        & rmLinks %~ setInLinks (isMidEdgeLink r South)
-        & rmPmnts <>~ cs
+    cs <- join $ takeOne [cenoct x y, censquare x y]
+    shuffleLinks $
+        r
+            & rmLinks %~ setOutLinks (isMidEdgeLink r North)
+            & rmLinks %~ setInLinks (isMidEdgeLink r South)
+            & rmPmnts <>~ cs
  where
    censquare x y = do
-        z <- state $ randomR (40,60)
-        return [sps0 $ PutChasm (rectNSWE (y-z) z z (x-z))]
-    cenoct x y = return 
-        [sps0 $ PutChasm $ (V2 (x/2) (y/2) +) <$> polyOrthDist 8 (min x y/2 - 25)]
+        z <- state $ randomR (40, 60)
+        return [sps0 $ PutChasm (rectNSWE (y - z) z z (x - z))]
+    cenoct x y =
+        return
+            [sps0 $ PutChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)]
+
 --    dia x y = [sps0 $ PutChasm [V2 ]

 polyChasm :: Int -> Float -> State LayoutVars Room
-polyChasm n x = roomNgon n x
+polyChasm n x =
+    shuffleLinks
+        =<< ( roomNgon n x
+                <&> rmPmnts <>~ [sps0 $ PutChasm $ polyOrthDist n (x -30)]
+                <&> rmLinks %~ setOutLinks (\rl -> rl ^. rlPos . _y > 0)
+                <&> rmLinks %~ setInLinks (\rl -> rl ^. rlPos . _y < (5 - x))
+            )
+
+polyChasmC :: Int -> Float -> State LayoutVars Room
+polyChasmC n x =
+    roomNgon n x
+        <&> rmPmnts <>~ [sps0 $ PutChasm $ rectNSWE x (60 - x) (-40) 40]
+        <&> rmLinks %~ setInLinks (\rl -> PolyEdge 1 `S.member` (rl ^. rlType))
+        <&> rmLinks %~ setOutLinks (\rl -> PolyEdge (n -1) `S.member` (rl ^. rlType))

 chasmSimpleMaze :: State LayoutVars Room
-chasmSimpleMaze = join $ takeOne 
-        [midChasm
-        ,zChasm 25
-        ,lChasm
-        ,cChasm
-        ]
+chasmSimpleMaze =
+    join $
+        takeOne
+            [ midChasm
+            , zChasm 25
+            , lChasm
+            , cChasm
+            , pc1
+            , pc2
+            ]
+  where
+    pc1 = do
+        i <- takeOne [6, 8]
+        x <- state $ randomR (100, 150)
+        polyChasm i x
+    pc2 = do
+        i <- takeOne [6, 8]
+        x <- state $ randomR (100, 150)
+        polyChasmC i x

 tutLight :: State LayoutVars (MetaTree Room String)
 tutLight = do
--    x <- roomRectAutoLinks 200 400
--    let y = x & rmLinks %~ setOutLinks (\rl -> OnEdge North `S.member` _rlType rl)
--              -- & rmLinks %~ setInLinks (\rl -> OnEdge South `S.member` _rlType rl)
--             -- & rmLinks %~ setLinkType InLink (isCornerLink SouthEast)
--              & rmLinks %~ setLinkType InLink (isMidEdgeLink x South)
    x <- chasmSimpleMaze
-    return $ tToBTree "TutLight" $ treePost [x,cleatOnward corridor]
+    y <- chasmSimpleMaze
+    return $
+        tToBTree "TutLight" $
+            treePost
+                [ x
+                , corridor & rmPmnts .~ mempty
+                , removeLights y
+                , corridor & rmPmnts .~ mempty
+                , removeLights y
+                , cleatOnward corridor & rmPmnts .~ mempty
+                ]
+
+removeLights :: Room -> Room
+removeLights = rmPmnts %~ mapMaybe f
+  where
+    f x = case x ^. plType of
+        PutLabel "light" -> Nothing
+        _ -> Just x

 tutHub :: State LayoutVars (MetaTree Room String)
 tutHub = do
-    (is,wbp) <- setTreeInts =<< critsRoom 2
+    (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)
+    let a gw =
+            analyserByNthLinkWithPrompt
+                3 --(makeTermPara $ show is <> show (getRoomsFromInts is gw)
+                --  <> getCrsFromRooms' is gw)
                []
-                (RequireDeadCreatures $ getCrsFromRooms is gw) k
+                (RequireDeadCreatures $ getCrsFromRooms is gw)
+                k
    x <-
-        shuffleLinks 
+        shuffleLinks
            . analyserByDoorWithPrompt [] (RequireEquipment (AMMOMAG DRUMMAG)) i
-            . (rmInPmnt .:~ (0,a))
+            . (rmInPmnt .:~ (0, a))
            . addDoorAtNthLinkToggleTerminal 1 ss j
            =<< roomNgon 6 100
    bcor <- treeAttachDeep (return door) <$> blockedCorridor
@@ -200,7 +253,7 @@ tutHub = do
                x
                [ treeFromPost [triggerDoorRoom i] r1
                , treeFromPost [triggerDoorRoom j] r2
-                , (rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) 
+                , (rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
                    <$> treeAttachDeep wbp bcor
                , treeFromPost [] (cleatOnward $ triggerDoorRoom k & rmInPmnt . ix 0 . _1 .~ 1)
                ]
@@ -218,12 +271,14 @@ tutHub = do
        , makeTermLine ""
        ]
    r x = roomRectAutoLinks 100 100 <&> rmPmnts .:~ sps (PS 50 0) (PutFlIt x)
-    t = 
+    t =
        putMessageTerminal
            terminalColor
            (defaultTerminal & tmBootLines .~ ss' <> tlSetStatus (TerminalPressTo "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
-            & plSpot .~ rprBoolShift isUnusedLnk 
-                (\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi/2), a),S.singleton UsedPosLow))
+            & plSpot
+                .~ rprBoolShift
+                    isUnusedLnk
+                    (\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi / 2), a), S.singleton UsedPosLow))
    ss' =
        [ makeTermLine "---------------------------------------------"
        , makeTermLine "HOLD [CAPS] AND SCROLL"
@@ -231,22 +286,22 @@ tutHub = do
        , makeTermLine "                 TO REARRANGE INVENTORY ITEMS"
        , makeTermLine "---------------------------------------------"
        ]
-        <> tlSetStatus (TerminalPressTo "CONTINUE") <>
-        [ makeTermLine "AMMO MAGS ARE NORMALLY LOADED BENEATH WEAPONS"
-        , makeTermLine "               .-------."
-        , makeTermLine "  BURSTRIFLE   |DRUMMAG|"
-        , makeTermLine "        <------^-------^"
-        , makeTermLine "---------------------------------------------"
-        ]
-        <> tlSetStatus (TerminalPressTo "CONTINUE") <>
-        [ makeTermLine "HOLD [RMB] TO AIM"
-        , makeTermLine "      THEN CLICK [LMB] TO FIRE LOADED WEAPONS"
-        , makeTermLine "---------------------------------------------"
-        ]
+            <> tlSetStatus (TerminalPressTo "CONTINUE")
+            <> [ makeTermLine "AMMO MAGS ARE NORMALLY LOADED BENEATH WEAPONS"
+               , makeTermLine "               .-------."
+               , makeTermLine "  BURSTRIFLE   |DRUMMAG|"
+               , makeTermLine "        <------^-------^"
+               , makeTermLine "---------------------------------------------"
+               ]
+            <> tlSetStatus (TerminalPressTo "CONTINUE")
+            <> [ makeTermLine "HOLD [RMB] TO AIM"
+               , makeTermLine "      THEN CLICK [LMB] TO FIRE LOADED WEAPONS"
+               , makeTermLine "---------------------------------------------"
+               ]

 getRoomsFromInts :: [Int] -> GenWorld -> IS.IntSet
-getRoomsFromInts is gw 
-    = foldMap IS.singleton $ IM.restrictKeys (gw ^. genInts) (IS.fromList is)
+getRoomsFromInts is gw =
+    foldMap IS.singleton $ IM.restrictKeys (gw ^. genInts) (IS.fromList is)

 getCrsFromRooms' :: [Int] -> GenWorld -> String
 getCrsFromRooms' is gw = fmap h $ show $ foldMap f (IM.restrictKeys (gw ^. genRooms) js)
@@ -255,10 +310,11 @@ getCrsFromRooms' is gw = fmap h $ show $ foldMap f (IM.restrictKeys (gw ^. genRo
    h x = x
    js = getRoomsFromInts is gw
    f rm = shortShow <$> rm ^.. rmPmnts . each . plType
-    --f rm = foldMap g $ rm ^. rmPmnts
-    --g x = case x ^. plType of
-    --    PutCrit _ -> [x ^?! plMID . _Just]
-    --    _ -> []
+
+--f rm = foldMap g $ rm ^. rmPmnts
+--g x = case x ^. plType of
+--    PutCrit _ -> [x ^?! plMID . _Just]
+--    _ -> []

 getCrsFromRooms :: [Int] -> GenWorld -> [Int]
 getCrsFromRooms is gw = foldMap f (IM.restrictKeys (gw ^. genRooms) js)
@@ -271,12 +327,13 @@ getCrsFromRooms is gw = foldMap f (IM.restrictKeys (gw ^. genRooms) js)

 sensorTut :: [TerminalLine]
 sensorTut =
-        [ makeTermLine "--------------------------------------------"
-        , makeTermLine "SOME TERMINALS DETECT EXTERNAL CONDITIONS"
-        , makeTermLine "WHILE ACTIVE THESE DISPLAY A SPINNING SYMBOL"
-        , makeTermLine "               | / - \\"
-        , makeTermLine "--------------------------------------------"
-        ]
+    [ makeTermLine "--------------------------------------------"
+    , makeTermLine "SOME TERMINALS DETECT EXTERNAL CONDITIONS"
+    , makeTermLine "WHILE ACTIVE THESE DISPLAY A SPINNING SYMBOL"
+    , makeTermLine "               | / - \\"
+    , makeTermLine "--------------------------------------------"
+    ]
+
 --        <> tlSetStatus (TerminalPressTo "CONTINUE")

 tutRezBox :: RandomGen g => State g Room
@@ -286,14 +343,16 @@ tutRezBox = do
        roomRect 40 60 1 1
            & rmPmnts
                .~ [ sPS (V2 20 1) 0 $ PutLS ls
-                   , Placement (PS 0 0) PutNothing Nothing Nothing $ \w _ -> Just $ putImmediateMessageTerminal
-                        terminalColor
-                        ( defaultTerminal & tmBootLines .~ s w
-                            <> tlSetStatus (TerminalPressTo "QUIT")
-                            <> tlDoEffect TmWdWdPowerDownTerminal
--                            <> tlDoEffect (TmWdWdLeaveTerminal "QUIT")
-                        )
-                        & plSpot .~ PS (V2 20 0) 0
+                   , Placement (PS 0 0) PutNothing Nothing Nothing $ \w _ ->
+                        Just $
+                            putImmediateMessageTerminal
+                                terminalColor
+                                ( defaultTerminal & tmBootLines .~ s w
+                                    <> tlSetStatus (TerminalPressTo "QUIT")
+                                    <> tlDoEffect TmWdWdPowerDownTerminal
+                                    --                            <> tlDoEffect (TmWdWdLeaveTerminal "QUIT")
+                                )
+                                & plSpot .~ PS (V2 20 0) 0
                   ]
            & restrictInLinks (\(V2 _ h, _) -> h < 1)
            & restrictOutLinks (\(V2 _ h, _) -> h > 59)
@@ -313,10 +372,10 @@ tutorialMessage1 i =
        <> [ makeTermLine "USE       [W]"
           , makeTermLine "        [A] [S]"
           , makeTermLine "          [D]       TO MOVE"
-    , makeTermLine "--------------------------------------------"
-            ]
-        <> tlSetStatus (TerminalPressTo "CONTINUE") <>
-           [ makeTermLine "AFTER EXITING THIS TERMINAL YOUR INVENTORY"
+           , makeTermLine "--------------------------------------------"
+           ]
+        <> tlSetStatus (TerminalPressTo "CONTINUE")
+        <> [ makeTermLine "AFTER EXITING THIS TERMINAL YOUR INVENTORY"
           , makeTermLine "        AND NEARBY OBJECTS WILL BE DISPLAYED"
           , makeTermLine "--------------------------------------------"
           ]