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