Allow arbitrary changes to a room when using a link slot

src/Dodge/Default/Room.hs

@@ -2,11 +2,13 @@ module Dodge.Default.Room
     where
 import Geometry.Data
 import Dodge.LevelGen.Data
+import qualified Data.IntMap.Strict as IM
 
 defaultRoom :: Room
 defaultRoom = Room
     { _rmPolys  = []
     , _rmLinks  = []
+    , _rmLinkEff = []
     , _rmPos    = []
     , _rmPath   = []
     , _rmPmnts  = []
@@ -20,5 +22,6 @@ defaultRoom = Room
     , _rmRandPSs    = []
     , _rmLabel      = Nothing
     , _rmTakeFrom   = Nothing
-    , _rmWires      = []
+    , _rmStartWires = IM.empty
+    , _rmEndWires   = IM.empty
     }

src/Dodge/Floor.hs

@@ -18,6 +18,7 @@ import Dodge.Item.Weapon.Launcher
 import MonadHelp
 import Data.Tree
 import Color
+import Dodge.Wire
 
 import Control.Lens
 import Control.Monad.State
@@ -25,12 +26,18 @@ import Control.Monad.Loops
 import System.Random
 import Data.Sequence hiding (zipWith)
 import Data.Maybe
+import qualified Data.IntMap.Strict as IM
+
 
 initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithCorridors $ treeFromTrunk 
     [[StartRoom]
-    ,[ChainAnos [[SetLabel 0 $ return $ roomRectAutoLinks 100 100 
+    ,[ChainAnos 
-                    & rmExtPmnt ?~ externalButton red (anyLnkInPS 5) ]
+        [[SetLabel 0 $ return $ roomRectAutoLinks 100 100 
+                    & rmExtPmnt ?~ externalButton red (anyLnkInPS 5) 
+                    & rmStartWires .~ IM.fromList [(0,RoomWire 0 0)]
+                    & rmLinkEff .~ [putWireEnd 0]
+         ]
         ,[UseLabel 0 $ return switchDoorRoom]
         ]
      ]

src/Dodge/Layout.hs

@@ -7,11 +7,10 @@ import Dodge.LevelGen
 import Dodge.LevelGen.Data
 import Dodge.LevelGen.StaticWalls
 import Dodge.LevelGen.Pathing
+import Dodge.Room.Foreground
 import Dodge.Wall.Zone
 import Dodge.GameRoom
 import Dodge.Bounds
---import Dodge.LevelGen.Data
-import Dodge.Room.Foreground
 import Dodge.Default.Wall
 import Geometry
 import qualified IntMapHelp as IM
@@ -50,11 +49,15 @@ placeWires :: (World,[Room])-> World
 placeWires (w,rms) = foldr placeRoomWires w rms
 
 placeRoomWires :: Room -> World -> World
-placeRoomWires rm w = foldr placeWire w (_rmWires rm)
+placeRoomWires rm w = IM.foldr ($) w 
+    $ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm)
 
-placeWire :: RoomWire -> World -> World
+placeWire :: Room -> RoomWire -> RoomWire -> World -> World
-placeWire rw w = case rw of
+placeWire rm (RoomWire p' _) (RoomWire q' _) w = w & foregroundShape %~ (thinHighBar 40 p q <>)
-    RoomWire (p,_) (q,_) -> w & foregroundShape %~ (thinHighBar 40 p q <>)
+  where
+    rs = _rmShift rm
+    p = shiftPointBy rs p'
+    q = shiftPointBy rs q'
 
 doPartialPlacements :: ( (IM.IntMap [Placement],World) , [Room] ) -> (World,[Room])
 doPartialPlacements ((im,w),rms) = mapAccumR (doPartialPlacement im) w rms

src/Dodge/Layout/Tree/Shift.hs

@@ -8,6 +8,7 @@ import Dodge.LevelGen.Data
 import Dodge.Room.Link
 import Dodge.Layout.Tree.Polymorphic
 import Geometry.ConvexPoly
+import Geometry.Data
 
 import Data.Tree
 import Data.Sequence hiding (zipWith)
@@ -40,13 +41,18 @@ posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do
         | clipping   = tryLinks (j+1) ls
         | otherwise = do
             putStrLn $ "placing at link " ++ show j
-            mayrs <- posRms (convexBounds ++ bounds) useLink ts (tseq |> shiftedt)
+            mayrs <- posRms (convexBounds ++ bounds) newr ts (tseq |> shiftedt)
             case mayrs of
                 Nothing -> do putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
                 Just rs -> return (Just rs)
       where
         convexBounds = map pointsToPoly $ _rmBound r'
         clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
-        useLink = (r & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink (Prelude.length ts)) l :)
+        newr = (lnkEff l $ r & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :)
             , i)
         shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t
+
+lnkEff :: (Point2,Float) -> Room -> Room
+lnkEff x rm = case _rmLinkEff rm of
+    (eff:effs) -> eff x $ rm & rmLinkEff .~ effs
+    _ -> rm

src/Dodge/LevelGen.hs

@@ -48,19 +48,23 @@ placeSpot (w,rm) plmnt = case plmnt of
   where
     shift = _rmShift rm
 
+-- this should be tidied up
 placeSpotUsingLink :: World -> Room -> Placement -> ((World, Room), [Placement])
 placeSpotUsingLink w rm plmnt = case lnks of
-    ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt)
+    ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki lnk) (updatePS (f lnk) plmnt)
     [] -> case fallback of
         Nothing -> ((w,rm),[plmnt])
         Just plmnt' -> placeSpot (w,rm) plmnt'
   where
-    uselnk lnki = rm & rmLinks %~ deletei lnki
+    uselnk lnki lnk = _psLnkRoomEff rps (f' lnk rps) rm & rmLinks %~ deletei lnki
     rps = _plSpot plmnt
     fallback = _psLnkFallback rps
     test = _psLnkTest rps
     (lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..] 
         $ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w
+    f' x (PSLnk t s _ _)
+        | t x = s x
+    f' _ _ = error "wrong type of link: something is wrong"
     f x (PSLnk t s _ _)
         | t x = uncurry PS $ s x
     f _ ps = ps

src/Dodge/LevelGen/Data.hs

@@ -11,6 +11,7 @@ import Control.Lens
 import Control.Monad.State
 import System.Random
 import Data.Maybe
+import qualified Data.IntMap.Strict as IM
 --import Data.Bifunctor
 data PSType = PutCrit {_unPutCrit :: Creature}
     | PutMachine Color [Point2] Machine
@@ -119,6 +120,7 @@ assigning no bounds will allow rooms to overlap.
 data Room = Room
     { _rmPolys  :: [ [Point2] ]
     , _rmLinks  :: [(Point2,Float)]
+    , _rmLinkEff :: [(Point2,Float) -> Room -> Room]
     , _rmPos    :: [RoomPos]
     , _rmPath   :: [(Point2, Point2)]
     , _rmPmnts  :: [Placement]
@@ -132,10 +134,11 @@ data Room = Room
     , _rmRandPSs :: [State StdGen (Point2,Float)]
     , _rmLabel      :: Maybe Int
     , _rmTakeFrom   :: Maybe Int
-    , _rmWires      :: [RoomWire]
+    , _rmStartWires :: IM.IntMap RoomWire
+    , _rmEndWires   :: IM.IntMap RoomWire
     }
 data RoomWire
-    = RoomWire (Point2,Float) (Point2,Float)
+    = RoomWire Point2 Float
 data RoomPos 
     = OutLink Int    Point2  Float
     | InLink  Point2 Float

src/Dodge/Placements/Button.hs

@@ -39,4 +39,3 @@ putLitButtonID' col f subpl
     changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
     ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
     thePS = PSLnk f id (const id) Nothing
-

src/Dodge/Room/Foreground.hs

@@ -1,6 +1,5 @@
 --{-# LANGUAGE TupleSections #-}
-module Dodge.Room.Foreground
+module Dodge.Room.Foreground where
-    where
 import Picture
 import Geometry
 import Geometry.Vector3D

src/Dodge/Room/Start.hs

@@ -16,6 +16,7 @@ import Data.Tree
 import Control.Monad.State
 import Control.Lens
 import System.Random
+import qualified Data.IntMap.Strict as IM
 
 rezBox :: Room
 rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 
@@ -39,4 +40,6 @@ startRoom = do
         <$> randomiseOutLinks 
             (shiftRoomBy (V2 (-20) (-20),0) 
             $ roomRectAutoLinks w h & rmPmnts %~ (plmnts ++) 
+                & rmStartWires .~ IM.fromList [(0,RoomWire (V2 0 0) 0)]
+                & rmEndWires .~ IM.fromList [(0,RoomWire (V2 (500) 500) 0)]
             )

src/Dodge/Wire.hs

@@ -0,0 +1,10 @@
+module Dodge.Wire where
+import Dodge.LevelGen.Data
+import Dodge.Room.Link
+import Geometry
+
+import qualified Data.IntMap.Strict as IM
+import Control.Lens
+
+putWireEnd :: Int -> (Point2,Float) -> Room -> Room
+putWireEnd i pos rm = rm  & rmEndWires %~ IM.insert i (uncurry RoomWire $ invShiftLinkBy (_rmShift rm) pos)