Add laser central room, using new placement/roompos functionality

src/Dodge/Data.hs

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

src/Dodge/LevelGen/Data.hs

@@ -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 
+    | PSPos 
-        { _psLnkShift       :: RoomPos -> Maybe PlacementSpot
+        { _psLnkShift       :: RoomPos -> Maybe (PlacementSpot, RoomPos)
         , _psLnkRoomEff     :: RoomPos -> Room -> Room
         , _psLnkFallback    :: Maybe Placement
         }

src/Dodge/Placement/Instance/Button.hs

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

src/Dodge/Placement/Instance/LightSource.hs

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

src/Dodge/Placement/Instance/Sensor.hs

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

src/Dodge/Placement/PlaceSpot.hs

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

src/Dodge/PlacementSpot.hs

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

src/Dodge/Room/LongDoor.hs

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

src/Dodge/Room/Room.hs

@@ -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 :: Int -> Float -> Room
-roomNgon n = defaultRoom
+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
+    bl = V2   x  x
-    br = V2 (-100) 100
+    br = V2 (-x) x
-    lnks = map (\r -> (rotateV r (V2 0 100),r)) rots
+    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]

src/Dodge/Room/Start.hs

@@ -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 
+    rbox <- rezBoxStart
-    return $ rbox `appendEitherTree` [return $ Right centralLasTurret]
+    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)
             ]

src/Dodge/Update.hs

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

src/Dodge/Update/Camera.hs

@@ -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
+ifConfigWallRotate :: World -> World
-rotCam = rotateCameraKey . autoZoomCam
+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
+rotateCamera :: World -> World
-rotateCameraKey w
+rotateCamera w
     | keyl && keyr = w
-    | keyl = rotateCameraBy 0.015 w
+    | keyl = rotateCameraBy   0.025  w
-    | keyr = rotateCameraBy (-0.015) w
+    | keyr = rotateCameraBy (-0.025) w
-    | otherwise = 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
+autoZoomCamera :: World -> World
-autoZoomCam w
+autoZoomCamera w
     | zoomInKey (_keyConfig w) `S.member` _keys w
         = zoomCamBy 0.01 w
     | zoomOutKey (_keyConfig w) `S.member` _keys w