Add laser central room, using new placement/roompos functionality

2021-11-21 17:44:32 +00:00
parent 48cd59069c
commit 2f3896345d
12 changed files with 127 additions and 76 deletions
@@ -526,6 +526,12 @@ data Modification
        , _mdPoint3 :: Point3
        , _mdBool   :: Bool
        }
+    | ModIDID
+        { _mdID     :: Int
+        , _mdExternalID1 :: Int
+        , _mdExternalID2 :: Int
+        , _mdUpdate :: Modification -> World -> World
+        }
 data Prop 
    = Projectile    
        { _pjPos :: Point2
@@ -36,8 +36,8 @@ data PSType = PutCrit {_unPutCrit :: Creature}
 -- maybe there is a monadic implementation of this?
 data PlacementSpot 
    = PS { _psPos :: Point2 , _psRot :: Float }
-    | PSLnk 
-        { _psLnkShift       :: RoomPos -> Maybe PlacementSpot
+    | PSPos 
+        { _psLnkShift       :: RoomPos -> Maybe (PlacementSpot, RoomPos)
        , _psLnkRoomEff     :: RoomPos -> Room -> Room
        , _psLnkFallback    :: Maybe Placement
        }
@@ -12,6 +12,7 @@ import ShapePicture

 import Data.Maybe
 import Control.Lens
+import qualified Data.IntMap.Strict as IM

 triggerSwitchSPic :: (Button -> SPic) -> PlacementSpot -> Placement
 triggerSwitchSPic sdraw ps = psPtCont ps (PutTrigger (const False))
@@ -56,7 +57,9 @@ putLitButtonID col p a subpl = mntLSOn aShape (Just col) ls p'' (addZ 40 p')
    changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
    ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }

-putLitButOnPos :: Color -> (RoomPos -> Maybe PlacementSpot) -> (Int -> Maybe Placement) -> Placement
+putLitButOnPos :: Color 
+    -> (RoomPos -> Maybe (PlacementSpot,RoomPos)) 
+    -> (Int -> Maybe Placement) -> Placement
 putLitButOnPos col f subpl 
    = plSpot .~ thePS $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
    $ \plmnt -> let lsid = fromJust $ _plMID plmnt
@@ -65,9 +68,29 @@ putLitButOnPos col f subpl
  where
    changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
    ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
-    thePS = PSLnk f (const id) Nothing
+    thePS = PSPos f (const id) Nothing

-putLitButOnPosExtTrig :: Color -> (RoomPos -> Maybe PlacementSpot) -> Placement
+-- creates a lit external trigger, passes the trigger placement forward
+extTrigLitPos :: PlacementSpot -> (Placement -> Maybe Placement) -> Placement
+extTrigLitPos ps f = psPtCont ps (PutTrigger (const False))
+    $ \tp -> Just $ pContID (ps' tp) (PutLS thels)
+    $ \lsid -> Just $ pContID (ps' tp) (PutMod $ themod lsid tp)
+    $ const (f tp)
+  where
+    ps' tp = _plSpot tp
+    themod lsid tp = ModIDID
+        {_mdID = 0
+        ,_mdExternalID1 = lsid
+        ,_mdExternalID2 = fromJust $ _plMID tp
+        ,_mdUpdate = \md w -> if (_triggers w IM.! _mdExternalID2 md) w
+            then w & lightSources . ix (_mdExternalID1 md) . lsIntensity .~ V3 0 0.5 0
+            else w & lightSources . ix (_mdExternalID1 md) . lsIntensity .~ V3 0.5 0 0
+        }
+    thels = defaultLS {_lsIntensity = V3 0.5 0 0, _lsPos = V3 0 0 78, _lsRad = 75}
+
+putLitButOnPosExtTrig :: Color 
+   -> (RoomPos -> Maybe (PlacementSpot,RoomPos)) 
+   -> Placement
 putLitButOnPosExtTrig col f 
    = psPtCont thePS (PutTrigger (const False))
    $ \tp -> Just $ plSpot .~ _plSpot tp $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
@@ -80,4 +103,4 @@ putLitButOnPosExtTrig col f
    oneff tid = triggers . ix tid .~ const True
    changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
    ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
-    thePS = PSLnk f (const id) Nothing
+    thePS = PSPos f (const id) Nothing
@@ -80,10 +80,12 @@ vShape wallpos (V3 x y z) =
 mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
 mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing)

-mntLSCond :: (Point2 -> Point3 -> Shape) -> (RoomPos -> Maybe PlacementSpot) -> Placement
+mntLSCond :: (Point2 -> Point3 -> Shape) 
+    -> (RoomPos -> Maybe (PlacementSpot,RoomPos)) 
+    -> Placement
 mntLSCond shp shift = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $ 
    mntLS shp 0 (V3 0 (-40) 90)
-    & plSpot .~ PSLnk shift (const id) Nothing
+    & plSpot .~ PSPos shift (const id) Nothing
    -- note that this perhaps pushes the vshape light out too far

 mntLight :: Point2 -> Point2 -> Placement
@@ -91,14 +93,15 @@ mntLight a b = RandomPlacement $ do
    shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
    return $ mntLS shp a (addZ 90 b)

-mntLightLnkCond :: (RoomPos -> Maybe PlacementSpot) -> Placement
+mntLightLnkCond :: (RoomPos -> Maybe (PlacementSpot,RoomPos)) 
+    -> Placement
 mntLightLnkCond f = RandomPlacement $ do
    shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
    return $ mntLSCond shp f

-unusedLnkToPS :: RoomPos -> Maybe PlacementSpot
+unusedLnkToPS :: RoomPos -> Maybe (PlacementSpot,RoomPos)
 unusedLnkToPS rp = case rp of
-    UnusedLink p a -> Just $ PS p a
+    UnusedLink p a -> Just (PS p a,PosPl p a)
    _ -> Nothing

 spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
@@ -14,17 +14,18 @@ import Data.Either

 damageSensor 
    :: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage
+    -> (Machine -> World -> World)
    -> Point2 -> Float -> Placement
-damageSensor damF p r = pContID (PS p r) ( PutLS theLS)
+damageSensor damF upf p r = pContID (PS p r) ( PutLS theLS)
    $ \lsid -> jsps p r $ PutMachine yellow (reverse $ square wdth) defaultMachine
        { _mcDraw = sensorSPic 
-        , _mcUpdate = sensorUpdate damF
+        , _mcUpdate = \mc w -> upf mc $ sensorUpdate damF mc w
        , _mcLSs = [lsid]
        }
  where
    theLS = defaultLS { _lsPos = V3 0 0 30 , _lsIntensity = 0.1 }

-lightSensor :: Point2 -> Float -> Placement
+lightSensor :: (Machine -> World -> World) -> Point2 -> Float -> Placement
 lightSensor = damageSensor senseLasering

 senseLasering :: DamageType -> Either Int Int
@@ -34,7 +34,7 @@ import Data.Bifunctor
 placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] )
 placeSpot (w,rm) plmnt = case plmnt of
    Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
-    Placement{_plSpot = PSLnk extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
+    Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
    Placement{} ->
        let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
            newplmnt = plmnt & plMID ?~ i
@@ -52,12 +52,12 @@ placeSpot (w,rm) plmnt = case plmnt of

 -- this should be tidied up
 placeSpotUsingLink :: World -> Room -> Placement 
-    -> (RoomPos -> Maybe PlacementSpot)
+    -> (RoomPos -> Maybe (PlacementSpot,RoomPos))
    -> (RoomPos -> Room -> Room)
    -> Maybe Placement
    -> ((World, Room), [Placement])
 placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
-    Just (ps,pos,newrmpos) -> placeSpot (w, eff pos $ rm & rmPos .~ newrmpos) (plmnt & plSpot .~ ps)
+    Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps)
    Nothing -> case fallback of
        Nothing -> ((w,rm),[plmnt])
        Just plmnt' -> placeSpot (w,rm) plmnt'
@@ -65,7 +65,7 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r
    searchedPoss [] = error "no correct pos type for lnk placement"
    searchedPoss (pos:poss) = case extract pos of
        Nothing -> second (pos:) <$> searchedPoss poss
-        Just ps -> Just ( ps,pos, poss)
+        Just (ps,rmpos) -> Just ( ps,rmpos:poss)

 placeSpotRoomRand :: Room -> Int -> Placement -> World -> ((World,Room),[Placement])
 placeSpotRoomRand rm i plmnt w =
@@ -7,27 +7,30 @@ import System.Random

 -- TODO rename to any unused link facing out
 anyLnkOutPS :: PlacementSpot
-anyLnkOutPS = PSLnk f (const id) Nothing
+anyLnkOutPS = PSPos f (const id) Nothing
  where
-    f (UnusedLink p a) = Just $ PS p a
+    f (UnusedLink p a) = Just (PS p a, PosPl p a)
    f _ = Nothing
    
 fstLnkOut :: PlacementSpot
-fstLnkOut = PSLnk f (const id) Nothing
+fstLnkOut = PSPos f (const id) Nothing
  where
-    f (OutLink 0 p a) = Just $ PS p a
+    f (OutLink 0 p a) = Just (PS p a, PosPl p a)
    f _ = Nothing

 anyLnkInPS :: Float -- ^ amount to shift inward
    -> PlacementSpot
-anyLnkInPS x = PSLnk f (const id) Nothing
+anyLnkInPS x = PSPos f (const id) Nothing
  where
-    f (UnusedLink v a) = Just $ PS (v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)) (a+ pi)
+    f (UnusedLink v a) = Just (PS v' a' ,PosPl v' a')
+      where
+        v' = v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)
+        a' = a + pi
    f _ = Nothing

-useLnkRoomPos :: RoomPos -> Maybe PlacementSpot
+useLnkRoomPos :: RoomPos -> Maybe (PlacementSpot,RoomPos)
 useLnkRoomPos rp = case rp of
-    (UnusedLink (V2 x y) a) -> Just $ PS (V2 x y) a
+    (UnusedLink (V2 x y) a) -> Just (PS (V2 x y) a , PosPl (V2 x y) a)
    _ -> Nothing

 psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float)
@@ -116,7 +116,8 @@ addButtonSlowDoor x h rm = do
    aboveH y = (sndV2 . fst) y > h + 40
    butDoor _ _ = putLitButOnPos col butPosCond
        $  \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
-    butPosCond (UnusedLink (V2 x' y') a') | y' < 0.5 * h = Just $ PS (V2 x' y') a'
+    butPosCond (UnusedLink (V2 x' y') a') | y' < 0.5 * h 
+                = Just (PS (V2 x' y') a' , PosPl (V2 x' y') a')
    butPosCond _ = Nothing
    --butPosCond _ = True -- y < h
    col = dim $ light red
@@ -27,6 +27,7 @@ import System.Random
 import Data.Maybe
 import Data.Tree
 import Data.Bifunctor
+import Data.List

 roomC :: RandomGen g => Float -> Float -> State g Room
 roomC w h = do
@@ -104,7 +105,7 @@ glassSwitchBack = do
    hgt <- state $ randomR (400,600)
    wllen <- state $ randomR (60,wth/2-40)
    let hf = hgt/5
-        con1 cond (UnusedLink (V2 x y) a) | cond y = Just $ PS (V2 x y) a 
+        con1 cond (UnusedLink (V2 x y) a) | cond y = Just (PS (V2 x y) a , PosPl (V2 x y) a)
        con1 _ _ = Nothing
        plmnts = 
            [ mntLightLnkCond $ con1 (< 0.5 * hgt)
@@ -226,8 +227,8 @@ roomOctogon = defaultRoom
        ,( (0,40),pi)
        ]

-roomNgon :: Int -> Room
-roomNgon n = defaultRoom
+roomNgon :: Int -> Float -> Room
+roomNgon n x = defaultRoom
    { _rmPolys = [poly]
    , _rmLinks = lnks
    , _rmPath  = [] -- TODO
@@ -241,9 +242,9 @@ roomNgon n = defaultRoom
    poly = mapMaybe 
        (\(ra,rb) -> intersectLineLine' (rotateV ra bl) (rotateV ra br) (rotateV rb bl) (rotateV rb br)) 
        $ loopPairs rots
-    bl = V2   100  100
-    br = V2 (-100) 100
-    lnks = map (\r -> (rotateV r (V2 0 100),r)) rots
+    bl = V2   x  x
+    br = V2 (-x) x
+    lnks = sortOn ((\(V2 a b) -> (negate b,a)) . fst) $ map (\r -> (rotateV r (V2 0 x),r)) rots

 allPairs :: Eq a => [a] -> [(a,a)]
 allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
@@ -1,6 +1,7 @@
 module Dodge.Room.Start 
    where
 import Dodge.LevelGen.Data
+import Dodge.PlacementSpot
 import Dodge.Room.RunPast
 import Dodge.Data
 import Dodge.Default
@@ -19,11 +20,13 @@ import Dodge.Item.Random
 import Dodge.Item.Weapon.BulletGuns
 import Dodge.Item.Weapon.Utility
 --import Dodge.LevelGen.Data
-import Geometry.Data
+--import Geometry.Data
+import Geometry
 import Padding
 import Color
 import Shape

+import Data.Maybe
 import Data.Tree
 import Control.Monad.State
 import Control.Lens
@@ -48,12 +51,27 @@ minigunfakeout = do
        `treeFromPost` Right door

 centralLasTurret :: Room
-centralLasTurret = roomNgon 8
-
+centralLasTurret = roomNgon 8 200 & rmPmnts .~
+    [ putLasTurret
+    , heightWall 30 (rectNSEW (-90) (-110) 10 (-10))
+    , spanColLightI 0.5 100 (V2 0 (-5)) (V2 0 5)
+    ]
+    & rmExtPmnt ?~
+        --extTrigLitPos (PS (V2 200 0) 0)
+        --extTrigLitPos (anyLnkInPS 5)
+        extTrigLitPos fstLnkOut
+        ( \tp -> Just $ lightSensor (upf $ fromJust $ _plMID tp) (V2 100 0) 0
+        )
+  where
+    upf trid mc w | _mcSensor mc > 90 = w & triggers . ix trid .~ const True
+        | otherwise = w
 rezThenLasTurret :: RandomGen g => State g (Tree (Either Room Room))
 rezThenLasTurret = do
-    rbox <- rezBoxStart 
-    return $ rbox `appendEitherTree` [return $ Right centralLasTurret]
+    rbox <- rezBoxStart
+    let cenroom = centralLasTurret {_rmLabel = Just 0}
+        doorroom = switchDoorRoom {_rmTakeFrom = Just 0}
+        contTree = treeFromPost [Left cenroom] (Right doorroom)
+    return $ rbox `appendEitherTree` [contTree]

 startRoom :: RandomGen g => State g (Tree (Either Room Room))
 startRoom = join $ takeOne 
@@ -193,7 +211,7 @@ startRoom' = do
            , tankSquareEmboss4 (dim orange) 50 (h-60)
            , tankSquare (dim orange) 50 50
            , tankSquare (dim orange) 50 120
-            , lightSensor (V2 (0.8*w) (0.25*h)) 0
+            , lightSensor (const id) (V2 (0.8*w) (0.25*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)
            ]
@@ -17,11 +17,9 @@ import Sound.Data
 import Geometry
 import Geometry.Vector3D

-import SDL (MouseButton (..))
 import Data.List
 import Data.Maybe
 import Data.Function
-import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map.Strict as M
 import Control.Lens
@@ -50,7 +48,7 @@ functionalUpdate w = case _menuLayers w of
        . ppEvents 
        . updateCamera
        . colCrsWalls
-        . ifConfigWallRotate
+--        . ifConfigWallRotate
        . simpleCrSprings 
        . zoneCreatures 
        . updateDoors
@@ -253,29 +251,6 @@ crCrSpring c1 c2 w
    overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
    massT    = _crMass c1 + _crMass c2

-ifConfigWallRotate :: World -> World
-ifConfigWallRotate w
-    | _rotate_to_wall (_config w) && not (ButtonRight `S.member` _mouseButtons w)
-        = rotateToOverlappingWall w
-    | otherwise = w
-
-rotateToOverlappingWall :: World -> World
-rotateToOverlappingWall w = case theWall of
-    Nothing -> w
-    Just wl -> rotateUsing ( (argV . uncurry (-.-) $ _wlLine wl) - camrot)
-  where
-    camrot = _cameraRot w
-    rotateUsing a
-        | b - b' > 0.01 = w & cameraRot +~ 0.01
-        | b - b' < negate 0.01 = w & cameraRot -~ 0.01
-        | otherwise    = w
-      where
-        b = a * (2 / pi)
-        b' = fromIntegral (round b :: Int)
-    cr = you w
-    p = _crPos cr
-    theWall = overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w)
-
 {- Finds the visible walls from a point to another point.  -}
 visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
 visibleWalls p1 p2 ws 
@@ -29,7 +29,7 @@ import qualified SDL
 {- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers; 
 update where your avatar's view is from.  -}
 updateCamera :: World -> World
-updateCamera = rotCam . moveCamera . updateScopeZoom 
+updateCamera = rotateCamera . autoZoomCamera . moveCamera . updateScopeZoom 
 {- Updte the center of the screen camera center and where your avatar's view is from in world. -}
 moveCamera :: World -> World
 moveCamera w = w 
@@ -99,8 +99,28 @@ zoomOutLongGun w
    wp = _crInv (_creatures w IM.! 0) IM.! _crInvSel (_creatures w IM.! 0)
    Just currentZoom = wp ^? itAttachment . scopeZoom

-rotCam :: World -> World
-rotCam = rotateCameraKey . autoZoomCam
+ifConfigWallRotate :: World -> World
+ifConfigWallRotate w
+    | _rotate_to_wall (_config w) && not (SDL.ButtonRight `S.member` _mouseButtons w)
+        = rotateToOverlappingWall w
+    | otherwise = w
+
+rotateToOverlappingWall :: World -> World
+rotateToOverlappingWall w = maybe w dowallrotate theWall
+  where
+    dowallrotate wl' = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot w
+    rotateUsing a
+        | b - b' > 0.01        = w & cameraRot +~ 0.01
+        | b - b' < negate 0.01 = w & cameraRot -~ 0.01
+        | otherwise            = w
+      where
+        --b = a * (2 / pi)
+        b = a * (4 / pi)
+        b' = fromIntegral (round b :: Int)
+    cr = you w
+    p = _crPos cr
+    theWall = overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w)
+

 rotateCameraBy :: Float -> World -> World
 rotateCameraBy x w = w 
@@ -108,14 +128,14 @@ rotateCameraBy x w = w
    & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
         . itAttachment . scopePos %~ rotateV x

-rotateCameraKey :: World -> World
-rotateCameraKey w
+rotateCamera :: World -> World
+rotateCamera w
    | keyl && keyr = w
-    | keyl = rotateCameraBy 0.015 w
-    | keyr = rotateCameraBy (-0.015) w
-    | otherwise = w
+    | keyl = rotateCameraBy   0.025  w
+    | keyr = rotateCameraBy (-0.025) w
+    | otherwise = ifConfigWallRotate w
  where
-    keyl = rotateCameraPlusKey (_keyConfig w) `S.member` _keys w
+    keyl = rotateCameraPlusKey  (_keyConfig w) `S.member` _keys w
    keyr = rotateCameraMinusKey (_keyConfig w) `S.member` _keys w

 zoomCamBy :: Float -> World -> World
@@ -132,8 +152,8 @@ zoomNoItem
    -> Float
 zoomNoItem = min 20 . max 0.2
 {- Automatically sets the zoom of the camera according to the surrounding walls.  -}
-autoZoomCam :: World -> World
-autoZoomCam w
+autoZoomCamera :: World -> World
+autoZoomCamera w
    | zoomInKey (_keyConfig w) `S.member` _keys w
        = zoomCamBy 0.01 w
    | zoomOutKey (_keyConfig w) `S.member` _keys w