Add missing file, workaround for placement positions bug

2022-03-08 07:59:36 +00:00
parent 79b5241c32
commit 59e6f433ff
16 changed files with 67 additions and 86 deletions
@@ -66,7 +66,7 @@ anoToRoomTree anos = case anos of
    [AirlockAno] -> airlock >>=  roomThenCorridor
    [FirstWeapon] -> do
        branchWP <- branchRectWith weaponRoom
-        blockedC <- longBlockedCorridor
+        blockedC <- longBlockedCorridor 3
        join $ takeOne $ return (passUntilUseAll branchWP [blockedC]) : replicate 5 weaponRoom
    [EndRoom] -> fmap (pure . UseAll) (telRoomLev 1)
    (SpecificRoom rt:_) -> rt
@@ -19,6 +19,7 @@ data Annotation g
    | BossAno Creature
    | TreasureAno [Creature] [Item]
    | AnoApplyInt Int (Int -> State g (SubCompTree Room))
+    | AnoNewInt (Int -> State g (SubCompTree Room))
    | PassthroughLockKeyLists Int 
        [(Int -> State g (SubCompTree Room), State g CombineType)]
        [(CombineType, State g (SubCompTree Room))]
@@ -33,8 +33,9 @@ import System.Random

 initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithCorridors $ treeFromTrunk 
-    [[AnoApplyInt 0 startRoom]
-    , [SpecificRoom $ glassLesson]
+--    [[AnoApplyInt 0 startRoom]
+    [[SpecificRoom startRoom']
+--    , [SpecificRoom $ rezThenLasTurret]
 --    , [SpecificRoom $ fmap (return . PassDown) longRoom]
    , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
    , [SpecificRoom randomChallenges]
@@ -39,6 +39,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
 -- add room effect for any placement spot?
 data PlacementSpot 
    = PS { _psPos :: Point2 , _psRot :: Float }
+    | PSNoShiftCont { _psPos :: Point2 , _psRot :: Float }
    | PSPos 
        { _psSelect     :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
        , _psRoomEff    :: RoomPos -> Room -> Room
@@ -204,8 +205,9 @@ ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (const $ Just plmnt)
 psj :: PlacementSpot -> PSType -> Placement -> Placement
 psj ps pst plmnt = Placement ps pst Nothing (const $ Just plmnt)

+-- the NoShiftCont is necessary when shifting then combining rooms
 ps0jPushPS :: PSType -> Placement -> Placement
-ps0jPushPS pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt & plSpot .~ _plSpot p)
+ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt & plSpot .~ _plSpot p)

 addPlmnt :: Placement -> Placement -> Placement
 addPlmnt pl pl2 = case pl2 of
@@ -17,6 +17,7 @@ lockRoomKeyItems =
    [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD] )
    ,(const slowDoorRoomRunPast, return MINIGUN)
    ,(const longRoomRunPast, takeOne [SNIPERRIFLE,FLATSHIELD])
+    ,(const glassLessonRunPast, takeOne [LASGUN])
    ]

 itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))]
@@ -21,6 +21,7 @@ mntLSOn
    -> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
 mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
    = ps0jPushPS (PutShape . setCol $ shapeF wallp lsp)
+    -- = ps0j (PutShape . setCol $ shapeF wallp lsp)
    . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
  where
    lsp' = lsp -.-.- V3 x y 1
@@ -54,6 +54,7 @@ placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room)
 placePlainPSSpot w rm plmnt shift = 
    let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
        newplmnt = plmnt & plMID ?~ i
+    --in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
    in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
  where
    recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
@@ -12,10 +12,10 @@ shiftPSBy (pos,rot) ps = ps
    & psRot +~ rot
 shiftPlacement :: (Point2,Float) -> Placement -> Placement
 shiftPlacement shift plmnt = case plmnt of
+-- slightly messy NoShiftCont, necessary to stop interference with ps0jPushPS
+    Placement {_plSpot = PSNoShiftCont {}} -> plmnt & plSpot %~ shiftPSBy shift 
    Placement {} -> plmnt & plSpot %~ shiftPSBy shift 
-- TODO check whether the following continuation is ever necessary
-- it can interfere with ps0jPushPS
--        & plIDCont %~ fmap (fmap $ shiftPlacement shift)
+        & plIDCont %~ fmap (fmap $ shiftPlacement shift)
    PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
        (fmap (shiftPlacement shift) f)
    RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
@@ -10,6 +10,7 @@ import System.Random
 setDirPS :: Float -> PlacementSpot -> PlacementSpot
 setDirPS a ps = case ps of
    PS p _ -> PS p a
+    PSNoShiftCont p _ -> PS p a
    PSPos f re fb -> PSPos (\rp r -> fmap (first (setDirPS a)) (f rp r)) re fb
    PSRoomRand i f -> PSRoomRand i (fmap (setDirPS a) f)

@@ -19,12 +19,10 @@ import Control.Monad.State
 --import Control.Monad.Loops
 import System.Random
 import Data.Tree
-
-- TODO: partially combine a room tree into a room
 glassLesson :: RandomGen g => State g (SubCompTree Room)
 glassLesson = do
    i <- takeOne [1,2,3]
-    corridors <- replicateM i $ PassDown <$> randomiseOutLinks corridor
+    corridors <- replicateM i $ PassDown <$> shuffleLinks corridor
    return $ Node (PassDown botRoom) 
        [ singleUseNone $ door & rmConnectsTo .~ S.singleton (LabLink 0)
        , uppers
@@ -58,3 +56,7 @@ glassLesson = do
            , mntLS vShape (V2 180 200) (V3 160 180 50)
            ]
        ]
+glassLessonRunPast :: RandomGen g => State g (SubCompTree Room)
+glassLessonRunPast = f <$> glassLesson
+  where
+    f (Node r rs) = Node r $ (return $ UseLabel 0 $ door & rmConnectsTo .~ S.singleton (OnEdge West)) : rs
@@ -20,11 +20,11 @@ import Geometry
 --import Padding
 import Color
 import Shape
+import LensHelp

 import Data.Maybe
 import Data.Tree
 import Control.Monad.State
-import Control.Lens
 import System.Random

 cenLasTur :: Room
@@ -36,46 +36,44 @@ cenLasTur = roomNgon 8 200 & rmPmnts .~

 lightSensInsideDoor :: Room -> Room
 lightSensInsideDoor rm = rm 
-    & rmPmnts %~ ( (psPt atFstLnkOut $ PutShape $ colorSH yellow $ 
+    & rmPmnts .:~ (psPt atFstLnkOut $ PutShape $ colorSH yellow $
        thinHighBar 0 (V2 20 (-1)) (V2 20 (-100))
        <> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100))
-        <> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)) : )
-    & rmExtPmnt ?~
-        extTrigLitPos (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
-        ( \tp -> Just $ lightSensor 10 (upf $ fromJust $ _plMID tp) (atFstLnkOutShiftInward 100)
-        )
+        <> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80))
+    & rmExtPmnt ?~ lasSensLightAboveDoor 10 (atFstLnkOutShiftInward 100)
+
+lasSensLightAboveDoor :: Float -> PlacementSpot -> Placement
+lasSensLightAboveDoor wth ps = extTrigLitPos 
+    (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
+    ( \tp -> Just $ lightSensor wth (upf $ fromJust $ _plMID tp) ps )
  where
    upf trid mc w | _mcSensor mc > 900 = w & triggers . ix trid .~ const True
        | otherwise = w

+
 lightSensByDoor :: Room -> Room
 lightSensByDoor rm = rm 
-    & rmPmnts %~ ( 
+    & rmPmnts .++~ 
        [ psPt atFstLnkOut $ PutShape $ colorSH yellow 
            $ barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)
        , heightWallPS (atNthLnkOutShiftInward 1 100) 30 (rectNSEW 10 (-10) 20 (-20))
-        , heightWallPS (atFstLnkOutShiftInward 100) 30 (rectNSEW 10 (-10) 20 (-20))
-        ] ++ )
-    & rmExtPmnt ?~
-        extTrigLitPos (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
-        ( \tp -> Just $ lightSensor 20 (upf $ fromJust $ _plMID tp) (atFstLnkOutShiftBy sensorshift)
-        )
+        , heightWallPS (atFstLnkOutShiftInward 100)   30 (rectNSEW 10 (-10) 20 (-20))
+        ]
+    & rmExtPmnt ?~ lasSensLightAboveDoor 20 (atFstLnkOutShiftBy sensorshift)
  where
    sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a)
-    upf trid mc w | _mcSensor mc > 900 = w & triggers . ix trid .~ const True
-        | otherwise = w

 lasSensorTurretTest :: RandomGen g => Int -> State g (SubCompTree Room)
 lasSensorTurretTest n = do
-    cenroom <- randomiseOutLinks $ (lightSensInsideDoor cenLasTur) {_rmLabel = Just n}
-    let doorroom = switchDoorRoom {_rmTakeFrom = Just n}
+    cenroom <- shuffleLinks $ lightSensInsideDoor cenLasTur & rmLabel .~ Just n
+    let doorroom = switchDoorRoom & rmTakeFrom .~ Just n
    return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)

 lasCenSensEdge :: RandomGen g => Int -> State g (SubCompTree Room)
 lasCenSensEdge n = do
-    cenroom <- randomiseOutLinks $ (lightSensByDoor cenLasTur) {_rmLabel = Just n}
+    cenroom <- shuffleLinks $ (lightSensByDoor cenLasTur) {_rmLabel = Just n}
    let doorroom = switchDoorRoom {_rmTakeFrom = Just n}
-    return $ treeFromTrunk [PassDown door] (Node (PassDown cenroom) 
-        [treeFromPost [PassDown doorroom] (UseAll door), treeFromPost [PassDown door] (UseLabel 0 corridor)
+    return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) 
+        [ treeFromPost [PassDown doorroom] (UseAll door)
+        , treeFromPost [PassDown door]     (UseLabel 0 corridor)
        ]
-        )
@@ -53,25 +53,19 @@ litCorridor90 = do
        }

 -- | A random length corridor with a destructible block blocking it.
-longBlockedCorridor :: RandomGen g => State g (SubCompTree Room)
-longBlockedCorridor = do
+longBlockedCorridor :: RandomGen g => Int -> State g (SubCompTree Room)
+longBlockedCorridor maxn = do
    r <- state $ randomR (0,pi)
-    n <- state $ randomR (0,3)
+    n <- state $ randomR (0,maxn)
    let plmnts = [sPS (V2 20 40) r $ dirtPoly $ square 10
-                 ,sPS (V2 20 15) 0 putLamp
-                 ]
-    sequence $ treeFromPost (replicate n $ PassDown <$> randomiseOutLinks corridor) 
+            ,sPS (V2 20 15) 0 putLamp
+            ]
+    sequence $ treeFromPost (replicate n $ PassDown <$> shuffleLinks corridor) 
                        $ return $ UseAll $ set rmPmnts plmnts corridor

 -- | A single corridor with a destructible block blocking it.
 blockedCorridor :: RandomGen g => State g (SubCompTree Room)
-blockedCorridor = do
-    r <- state $ randomR (0,pi)
-    let plmnts = 
-            [sPS (V2 20 40) r $ dirtPoly $ square 10
-            ,spanLightI (V2 0 15) (V2 40 15)
-            ]
-    sequence $ treeFromPost [] $ return $ UseAll $ set rmPmnts plmnts corridor
+blockedCorridor = longBlockedCorridor 0

 dirtPoly :: [Point2] -> PSType
 dirtPoly = PutBlock DirtBlock 1 [] dirtWall . reverse
@@ -138,7 +138,7 @@ miniRoom3 = do
            ] ++ 
            [ sPS cp 0 $ PutCrit miniGunCrit 
            , sPS (V2 (w/2) (h/2)) 0 putLamp ]
-    fmap singleUseAll $ randomiseOutLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h
+    fmap singleUseAll $ shuffleLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h

 rot90Around :: Point2 -> Point2 -> Point2
 rot90Around cen p = cen +.+ vNormal (p -.- cen)
@@ -23,19 +23,17 @@ import Dodge.Item.Random
 import Geometry.Data
 --import Padding
 import Color
--import Shape
+import LensHelp

 import qualified Data.Set as S
 import Data.Tree
 import Control.Monad.State
-import Control.Lens
 import System.Random
 --import qualified Data.IntMap.Strict as IM

 horEdgeTest :: (Float -> Bool) -> ((Point2,Float) -> Bool)
 horEdgeTest t (V2 x _,_) = t x

-
 roomCritLS :: RandomGen g => State g LightSource
 roomCritLS = do
    col <- takeOne [0.5, 0.6]
@@ -44,26 +42,20 @@ roomCritLS = do
    return $ lsPosColRad (V3 0 0 h) col rad

 critRoom :: Room
-critRoom = corridorWallN
-    { _rmRandPSs = [psRandRanges (15,25) (30,45) (pi,2*pi)]
-    }
+critRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15,25) (30,45) (pi,2*pi)]

 runPastRoom :: RandomGen g => Int -> State g (SubCompTree Room)
 runPastRoom i = do
    h <- state $ randomR (200,400::Float)
    theedgetest <- takeOne [horEdgeTest (<1), horEdgeTest  (>39)]
    thels <- roomCritLS
-    --theweapon <- join $ takeOne [randBlockBreakWeapon,return grenade]
    theweapon <- randBlockBreakWeapon
    cenroom <- shuffleLinks $ restrictRMInLinksPD (\(V2 _ y,_) -> y < 1)
                $ roomRectAutoLinks 40 h & rmPmnts .~ [plRRpt 0 (PutFlIt theweapon)]
    theedge <- takeOne [West,East]
    --let cenroom = filterSortOutLinksOn theedgetest ((\(V2 a b) -> (a,b)) . fst)
-    let linkcor = critRoom {_rmPmnts = 
-                    [ spanLS thels (V2 0 65) (V2 40 65)
-                    ]
-                    }
-        critroom = linkcor & rmPmnts %~ ( plRRpt 0 randC1 :)
+    let linkcor = critRoom & rmPmnts .~ [ spanLS thels (V2 0 65) (V2 40 65) ]
+        critroom = linkcor & rmPmnts .:~ plRRpt 0 randC1
        aswitchroom = corridorWallN
            {_rmExtPmnt = Just $ putLitButOnPosExtTrig red useLnkRoomPos
            ,_rmLabel = Just i
@@ -75,7 +67,6 @@ runPastRoom i = do
        critrooms :: [SubCompTree Room]
        critrooms = treeFromPost [PassDown switchdoor] (PassDown critroom) : 
            replicate (n-2) (treeFromPost [PassDown switchdoor] (PassDown linkcor))
-    return $ Node (PassDown cenroom) 
-        (map (applyToCompRoot $ rmConnectsTo .~ S.singleton (OnEdge theedge)) (controom : critrooms) 
+    return $ Node (PassDown cenroom) $ 
+        map (applyToCompRoot $ rmConnectsTo .~ S.singleton (OnEdge theedge)) (controom : critrooms) 
            ++ [return $ PassDown aswitchroom]
-        )
@@ -3,7 +3,6 @@ import Dodge.LevelGen.Data
 --import Dodge.PlacementSpot
 import Dodge.Room.RunPast
 --import Dodge.RoomLink
-import Dodge.Room.LasTurret
 --import Dodge.Data
 --import Dodge.Default
 --import Dodge.RoomLink
@@ -26,12 +25,12 @@ import Dodge.Item.Weapon.Utility
 import Geometry
 --import Padding
 import Color
-import Shape
+--import Shape
+import LensHelp

 --import Data.Maybe
 --import Data.Tree
 import Control.Monad.State
-import Control.Lens
 import System.Random
 --import qualified Data.IntMap.Strict as IM

@@ -40,30 +39,18 @@ minigunFakeout = do
    rcol <- rezColor
    ncor <- state $ randomR (0,2)
    roomwithmini <- randomiseAllLinks $ roomRectAutoLinks 150 150
-        & rmPmnts %~ (plRRpt 0 (PutFlIt $ miniGunX 6):)
-    randcors <- replicateM ncor $ (fmap PassDown . randomiseOutLinks) corridor
+        & rmPmnts .:~ plRRpt 0 (PutFlIt $ miniGunX 6)
+    randcors <- replicateM ncor $ (fmap PassDown . shuffleLinks) corridor
    return $ ([PassDown $ rezBox rcol
                ,PassDown door
                ,PassDown roomwithmini 
                ,PassDown door
                ] 
            ++ randcors
-            ++ [PassDown $ corridor & rmPmnts %~ ( plRRpt 0 (PutFlIt shrinkGun) :)
+            ++ [PassDown $ corridor & rmPmnts .:~ plRRpt 0 (PutFlIt shrinkGun)
                ,PassDown keyholeCorridor,PassDown corridor])
        `treeFromPost` UseAll door

-
-rezThenLasTurret :: RandomGen g => State g (SubCompTree Room)
-rezThenLasTurret = do
-    rbox <- rezBoxStart
-    cenroom <- randomiseOutLinks $ (lightSensInsideDoor cenLasTur) {_rmLabel = Just 0}
-    let doorroom = switchDoorRoom {_rmTakeFrom = Just 0}
-        contTree = treeFromPost [PassDown cenroom,PassDown doorroom] (UseAll door)
-    return $ rbox `passUntilUseAll` [contTree]
-
-room2 :: RandomGen g => Int -> State g (SubCompTree Room)
-room2 = lasCenSensEdge    
-
 startRoom :: RandomGen g => Int -> State g (SubCompTree Room)
 startRoom i = join $ uncurry takeOneWeighted $ unzip 
 --    [ (,) (0.5::Float) $ chainUses <$> sequence [minigunFakeout,weaponRoom]
@@ -113,13 +100,8 @@ startRoom' = do
            , tankSquareEmboss4 (dim orange) 50 (h-60)
            , tankSquare (dim orange) 50 50
            , tankSquare (dim orange) 50 120
-            , lightSensor 10 (const id) (PS (V2 (0.8*w) (0.25*h)) 0)
-            , putLasTurret 0.005 & plSpot .~ PS (V2 (0.8*w) (0.8*h)) 0
-            , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
+            --, sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
            ]
    thecol <- rezColor
    treeFromPost [PassDown $ rezBox thecol, PassDown door] . UseAll 
-        <$> randomiseOutLinks 
-            (shiftRoomBy (V2 (-20) (-20),0) 
-            ( roomRectAutoLinks w h & rmPmnts %~ (plmnts ++) 
-            ) & rmShift .~ (0,0) )
+        <$> shuffleLinks (roomRectAutoLinks w h & rmPmnts .++~ plmnts)
@@ -0,0 +1,6 @@
+module Dodge.Tile where
+--import Dodge.Data
+
+--tilePolyFromRoomPoly :: Room -> Room
+--tilePolyFromRoomPoly rm = rm & rmFloor .~ Tile
+--    { _tilePoly