Add wire to central laser room

src/Dodge/Layout.hs

@@ -68,14 +68,11 @@ placeRoomWires rm w = IM.foldr ($) w
     $ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm)
 
 placeWire :: Room -> RoomWire -> RoomWire -> World -> World
-placeWire rm (WallWire p a h) wr = placeWire rm wr (RoomWire p a) .
+placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape 
-    (foregroundShape %~ (colorSH red (barPP 1.5 (addZ h p') (addZ 80 p')) <>)
+    %~ (col ( (thinHighBarChain h2 $ map (shiftPointBy rs) doOrdering) <> 
-    )
+        (barPP 1.5 (addZ h1 p) (addZ h2 p))
-  where
+        ) <>
-    p' = shiftPointBy (_rmShift rm) p
+        )
-placeWire rm rw1 rw2@WallWire{} = placeWire rm rw2 rw1
-placeWire rm (RoomWire p _) (RoomWire q _) = foregroundShape 
-    %~ ((col $ thinHighBarChain 80 $ map (shiftPointBy rs) doOrdering) <>)
   where
     --TODO use rmWalls for non convex rooms
     --rmWalls = foldr cutWalls [] (_rmPolys rm)

src/Dodge/LevelGen/Data.hs

@@ -83,8 +83,8 @@ data Room = Room
     , _rmEndWires   :: IM.IntMap RoomWire
     }
 data RoomWire
-    = RoomWire Point2 Float
+    = --RoomWire Point2 Float
-    | WallWire Point2 Float Float
+     WallWire Point2 Float Float
 data RoomPos 
     = OutLink Int    Point2  Float
     | InLink  Point2 Float
@@ -98,7 +98,6 @@ makeLenses ''PSType
 makeLenses ''PlacementSpot
 makeLenses ''Placement
 
-
 spNoID :: PlacementSpot -> PSType -> Placement
 spNoID ps pst = Placement ps pst Nothing (const Nothing)
 
@@ -108,6 +107,9 @@ pContID ps pt = Placement ps pt Nothing . intPlPlPl
 psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
 psPtCont ps pt = Placement ps pt Nothing
 
+psPt :: PlacementSpot -> PSType -> Placement
+psPt ps pt = Placement ps pt Nothing (const Nothing)
+
 sPS :: Point2 -> Float -> PSType -> Placement
 sPS p a pt = Placement (PS p a) pt Nothing (const Nothing)
 

src/Dodge/Placement/Instance/Button.hs

@@ -25,7 +25,7 @@ triggerSwitchSPic sdraw ps = psPtCont ps (PutTrigger (const False))
 
 triggerSwitchSPicLight :: (Button -> SPic) -> PlacementSpot -> Placement
 triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger (const False))
-    $ \tp -> Just $ pContID fstLnkOut (PutLS thels)
+    $ \tp -> Just $ pContID atFstLnkOut (PutLS thels)
     $ \lsid -> Just 
         $ pContID ps (PutButton (makeSwitchSPic sdraw (oneff lsid $ trigid tp) (offeff lsid $ trigid tp))) 
                     (const Nothing)

src/Dodge/Placement/Instance/Sensor.hs

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

src/Dodge/Placement/PlaceSpot.hs

@@ -85,8 +85,7 @@ shiftPSBy (pos,rot) ps = ps
     & psPos %~ shiftPointBy (pos,rot)
     & psRot %~ (+ rot)
 
--- the Int here allows for passing parameters down to other placements:
+-- the Int here is some id that is assigned when the placement is placed
--- button ids, etc
 placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
 placeSpotID ps pt w = case pt of
     PutTrigger cond -> placeNewInto triggers cond w

src/Dodge/PlacementSpot.hs

@@ -12,8 +12,28 @@ anyLnkOutPS = PSPos f (const id) Nothing
     f (UnusedLink p a) = Just (PS p a, PosPl p a)
     f _ = Nothing
     
-fstLnkOut :: PlacementSpot
+atFstLnkOut :: PlacementSpot
-fstLnkOut = PSPos f (const id) Nothing
+atFstLnkOut = PSPos f (const id) Nothing
+  where
+    f (OutLink 0 p a) = Just (PS p a, OutLink 0 p a)
+    f _ = Nothing
+
+atFstLnkOutShiftBy :: ((Point2,Float) -> (Point2,Float))
+    -> PlacementSpot
+atFstLnkOutShiftBy theshift = PSPos f (const id) Nothing
+  where
+    f (OutLink 0 p a) = Just (PS p' a', OutLink 0 p a)
+      where
+        (p',a') = theshift (p,a)
+    f _ = Nothing
+
+atFstLnkOutShiftInward :: Float -> PlacementSpot
+atFstLnkOutShiftInward x = atFstLnkOutShiftBy f
+  where
+    f (p,a) = (p +.+ rotateV a (V2 0 (negate x)),a)
+
+overFstLnkOut :: PlacementSpot
+overFstLnkOut = PSPos f (const id) Nothing
   where
     f (OutLink 0 p a) = Just (PS p a, PosPl p a)
     f _ = Nothing

src/Dodge/Room/Foreground.hs

@@ -143,9 +143,11 @@ robotArm :: Shape
 robotArm = undefined
 
 barPP :: Float -> Point3 -> Point3 -> Shape
-barPP w a b = prismPoly
+barPP w a b 
-    (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
+    | a == b = mempty
-    (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
+    | otherwise = prismPoly
+        (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
+        (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
   where
     z1 = b -.-.- a
 

src/Dodge/Room/Start.hs

@@ -54,13 +54,15 @@ centralLasTurret :: Room
 centralLasTurret = roomNgon 8 200 & rmPmnts .~
     [ putLasTurret
     , heightWall 30 (rectNSEW (-90) (-110) 10 (-10))
-    , spanColLightI 0.5 100 (V2 0 (-5)) (V2 0 5)
+    , spanColLightI 0.5 98 (V2 0 (-5)) (V2 0 5)
+    , psPt atFstLnkOut $ PutForeground $ 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 (PS (V2 200 0) 0)
+        extTrigLitPos (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18 (-2)), a)))
-        --extTrigLitPos (anyLnkInPS 5)
+        ( \tp -> Just $ lightSensor (upf $ fromJust $ _plMID tp) (atFstLnkOutShiftInward 100)
-        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
@@ -68,8 +70,8 @@ centralLasTurret = roomNgon 8 200 & rmPmnts .~
 rezThenLasTurret :: RandomGen g => State g (Tree (Either Room Room))
 rezThenLasTurret = do
     rbox <- rezBoxStart
-    let cenroom = centralLasTurret {_rmLabel = Just 0}
+    cenroom <- randomiseOutLinks $ centralLasTurret {_rmLabel = Just 0}
-        doorroom = switchDoorRoom {_rmTakeFrom = Just 0}
+    let doorroom = switchDoorRoom {_rmTakeFrom = Just 0}
         contTree = treeFromPost [Left cenroom] (Right doorroom)
     return $ rbox `appendEitherTree` [contTree]
 
@@ -211,7 +213,7 @@ startRoom' = do
             , tankSquareEmboss4 (dim orange) 50 (h-60)
             , tankSquare (dim orange) 50 50
             , tankSquare (dim orange) 50 120
-            , lightSensor (const id) (V2 (0.8*w) (0.25*h)) 0
+            , lightSensor (const id) (PS (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/Wire.hs

@@ -5,8 +5,8 @@ import Geometry
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
-putWireEnd :: Int -> (Point2,Float) -> Room -> Room
+putWireEnd :: Int -> (Point2,Float) -> Float -> Room -> Room
-putWireEnd i pos = rmEndWires %~ IM.insert i (uncurry RoomWire pos)
+putWireEnd i (p,a) h = rmEndWires %~ IM.insert i (WallWire p a h)
 
-putWireStart :: Int -> (Point2,Float) -> Room -> Room
+putWireStart :: Int -> (Point2,Float) -> Float -> Room -> Room
-putWireStart i pos = rmStartWires %~ IM.insert i (uncurry WallWire pos 10)
+putWireStart i (p,a) h = rmStartWires %~ IM.insert i (WallWire p a h)