Commit before unifying positions

src/Dodge/Layout.hs

@@ -3,8 +3,10 @@ module Dodge.Layout
     where
 import Dodge.Data
 import Dodge.LevelGen
+import Dodge.LevelGen.Data
 import Dodge.LevelGen.StaticWalls
 import Dodge.LevelGen.Pathing
+import Dodge.Placements.Spot
 import Dodge.Base
 import Dodge.Zone
 import Dodge.GameRoom
@@ -25,7 +27,7 @@ import Tile
 import Polyhedra
 import Polyhedra.Data
 
-import Data.List (nubBy)
+import Data.List (nubBy, partition,mapAccumR)
 import Control.Monad.State
 import Control.Lens
 import System.Random
@@ -50,10 +52,25 @@ generateLevelFromRoomList gr w
   where
     path = pairsToGraph dist pairPath
     pairPath = concatMap _rmPath rs
-    plmnts = concatMap (\r -> map (_rmShift r ,) (_rmPS r)) rs
+    plmnts = concatMap (\r -> map (_rmShift r ,) (assignPlacementSpots r)) rs
-    rs = zipWith addTile zs rs'
+    rs = zipWith addTile zs . evalState gr $ _randGen w
     zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
-    rs' = evalState gr $ _randGen w
+
+assignPlacementSpots :: Room -> [Placement]
+assignPlacementSpots rm = plmnts ++ plmnts'
+  where
+    (lnkplmnts, plmnts) = partition islnk (_rmPS rm)
+    islnk Placement{_placementSpot=PSLnk{}} = True
+    islnk _ = False
+    (_,plmnts') = mapAccumR f (_rmLinks rm) lnkplmnts
+    f lnks plmnt = 
+        let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks
+            thepair = _psLinkShift (_placementSpot plmnt) x
+        in (xs++ys, updatePS (updatePSLnkUsing thepair) plmnt)
+
+updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot
+updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
+updatePSLnkUsing _ ps = ps
 
 setupWorldBounds :: World -> World
 setupWorldBounds w = w
@@ -106,10 +123,10 @@ wallsFromTree t =
 wallsFromRooms :: [Room] -> IM.IntMap Wall
 wallsFromRooms =
 --    divideWalls .
-    IM.fromList . zip [0..] . zipWith f [0..] . removeInverseWalls 
+    IM.fromList . zipWith f [0..] . removeInverseWalls 
         . foldl' (flip cutWalls) [] . concatMap _rmPolys
   where
-    f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}
+    f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})
 
 gameRoomsFromRooms :: [Room] -> [GameRoom]
 gameRoomsFromRooms = map f

src/Dodge/LevelGen.hs

@@ -26,12 +26,12 @@ placeSpot :: World -> ((Point2,Float) , Placement) -> World
 placeSpot w (shift, plmnt@Placement{}) =
     let (i,w') =  placeSpotID (shiftPSBy shift (_placementSpot plmnt)) (_psType plmnt) w
     in  maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i)
-placeSpot w (shift, PlacementPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))
+placeSpot w (shift, PlacementUsingPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))
 
 shiftPlacement :: (Point2,Float) -> Placement -> Placement
 shiftPlacement shift (Placement ps pt f) = Placement (shiftPSBy shift ps) pt
      (fmap (fmap $ shiftPlacement shift) f)
-shiftPlacement shift (PlacementPos p f) = PlacementPos (shiftPoint3By shift p)
+shiftPlacement shift (PlacementUsingPos p f) = PlacementUsingPos (shiftPoint3By shift p)
      (fmap (shiftPlacement shift) f)
 
 shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
@@ -59,10 +59,7 @@ placeSpotID ps pt w = case pt of
     PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
     PutBlock{} -> error "messed up block placement somehow"
     PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
-    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
+    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
-      where 
-        qs = map doShift ps'
-        rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ loopPairs qs
     PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
     PutNothing -> (0,w)
     PutID i -> (i, w)
@@ -72,6 +69,11 @@ placeSpotID ps pt w = case pt of
     rot = _psRot ps
     doShift = shiftPointBy (p,rot)
 
+placeWallPoly :: [Point2] -> Wall -> World -> World
+placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
+  where
+    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
+
 shiftPointBy :: (Point2,Float) -> Point2 -> Point2
 shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
 

src/Dodge/LevelGen/Data.hs

@@ -28,16 +28,17 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutNothing
     | PutID { _putID :: Int}
 -- maybe there is a monadic implementation of this?
-data PlacementSpot = PS
+data PlacementSpot 
-    { _psPos :: Point2
+    = PS { _psPos :: Point2 , _psRot :: Float }
-    , _psRot :: Float
+    | PSLnk { _psLinkTest :: (Point2,Float) -> Bool
+            , _psLinkShift :: (Point2,Float) -> (Point2,Float)
             }
 data Placement = Placement 
     { _placementSpot :: PlacementSpot
     , _psType :: PSType
     , _idPlacement :: Int -> Maybe Placement 
     }
-  | PlacementPos Point3 (Point3 -> Placement)
+  | PlacementUsingPos Point3 (Point3 -> Placement)  -- allows a placement to use a shifted position
 
 sPS :: Point2 -> Float -> PSType -> Placement
 sPS p a pt = Placement (PS p a) pt (const Nothing)
@@ -58,7 +59,7 @@ jsps0J :: PSType -> Placement -> Maybe Placement
 jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst $ \_ -> Just plm
 
 ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
-ps0 pst = Placement (PS (V2 0 0) 0) pst
+ps0 = Placement (PS (V2 0 0) 0)
 
 jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
 jps0 pst = Just . Placement (PS (V2 0 0) 0) pst

src/Dodge/Placements/Button.hs

@@ -8,6 +8,7 @@ import Dodge.LevelGen.Data
 import Dodge.Default
 import Dodge.LevelGen.Switch
 import Dodge.Placements.LightSource
+import Dodge.Placements.Spot
 
 import Control.Lens
 
@@ -20,3 +21,12 @@ putLitButtonID col p a subpl = mountLightAID ls p'' (addZ 40 p')
     p'' = p +.+ 10 *.* vNormal (unitVectorAtAngle a)
     changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
     ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
+
+putLitButtonID' :: Color -> ((Point2,Float) -> Bool) -> (Int -> Maybe Placement) -> Placement
+putLitButtonID' col f subpl = setLocalPS thePS $ mountLightAID ls 0 (V3 20 0 40)
+    $ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = 0, _btRot = 0})
+    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 id

src/Dodge/Placements/Door.hs

@@ -17,15 +17,15 @@ putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a
 putDoubleDoorThen :: Bool -> Color -> (World -> Bool) 
     -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
 putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed)
-    $ Placement (PS (V2 0 0) 0) ( (PutSlideDoor pathing col cond b half speed)) $ const mayp
+    $ Placement (PS (V2 0 0) 0) ( PutSlideDoor pathing col cond b half speed) $ const mayp
   where
     half = 0.5 *.* (a +.+ b)
 
     
 
 putAutoDoor :: Point2 -> Point2 -> Placement
-putAutoDoor a b = PlacementPos (addZ 0 a)
+putAutoDoor a b = PlacementUsingPos (addZ 0 a)
-    $ \az -> PlacementPos (addZ 0 b)
+    $ \az -> PlacementUsingPos (addZ 0 b)
     $ \bz -> putDoubleDoor True (dim yellow) (cond az bz) a b 3
   where
     cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures

src/Dodge/Room/Airlock.hs

@@ -61,7 +61,7 @@ airlock90 = defaultRoom
          ,(V2 40 0,V2 0 40)
          ]
     , _rmPS    = 
-        [ Placement (PS (V2 120 120) (3 * pi/4)) ((PutButton $ makeSwitch col red id id))
+        [ Placement (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id)
             $ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss
         ,mountLightV (V2 20 20) (V3 70 70 50)
         ]
@@ -89,7 +89,7 @@ airlockCrystal = defaultRoom
     , _rmLinks = [(V2 20 130,0) ,(V2 20  0 ,pi) ]
     , _rmPath  = [ ]
     , _rmPS    = 
-        [ Placement (PS (V2 145 70) (pi/2)) ( (PutButton $ makeSwitch col red id id))
+        [ Placement (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id)
             $ \btid -> jsps0 $ PutDoor col (cond btid) pss
         , crystalLine (V2 0 70) (V2 40 70)
         , mountLightV (V2 150 70) (V3 110 70 70)

src/Dodge/Room/LongDoor.hs

@@ -115,6 +115,7 @@ addButtonSlowDoor x h rm = do
     belowH y = (sndV2 . fst) y < h - 40
     aboveH y = (sndV2 . fst) y > h + 40
     butDoor bpos brot = putLitButtonID col bpos brot
+    --butDoor bpos brot = putLitButtonID' col (const True)
         $  \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
     col = dim $ light red
     cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff