Some cleanup, sidetracked from inter-room placements

src/Dodge/LevelGen.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
 -- | deals with placement of objects within the world
 -- after they have had their coordinates set by the layout
 module Dodge.LevelGen 
@@ -26,11 +27,16 @@ import Control.Monad.State
 import Control.Lens
 import qualified Data.IntSet as IS
 
+placeSpotRoomRand :: Room -> Int -> Placement -> World -> (World,Room)
+placeSpotRoomRand rm i plmnt w =
+    let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
+    in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
+
 placeSpot :: (World,Room) -> Placement -> (World,Room)
 placeSpot (w,rm) plmnt = case plmnt of
-    Placement{_plSpot = PSRoomRand i}
-        -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
-           in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
+    Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
+--        -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
+--           in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
     Placement{_plSpot = PSLnk{}} -> case lnks of
         ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt)
         [] -> case fallback of
@@ -77,8 +83,10 @@ shiftPSBy (pos,rot) ps = ps
 -- button ids, etc
 placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
 placeSpotID ps pt w = case pt of
+    PutTrigger cond -> placeNewInto triggers cond w
     PutProp prop -> placeProp prop p rot w
-    PutButton bt -> placeBt bt p rot w
+    --PutButton bt -> placeBt bt p rot w
+    PutButton bt -> placeNewUpdateID buttons btID (mvButton bt p rot) w
     PutFlIt itm -> placeFlIt itm p rot w
     PutCrit cr -> placeCr cr p rot w
     PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
@@ -88,7 +96,7 @@ placeSpotID ps pt w = case pt of
       where 
         (evaluatedType, g) = runState rgen (_randGen w)
     PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
-    PutCoordinate coordp -> placeCoordinate (doShift coordp) w
+    PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w
     PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
     PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
     PutBlock{} -> error "messed up block placement somehow"
@@ -129,10 +137,25 @@ addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
   where
     wlid = IM.newKey wls
 
-placeCoordinate :: Point2 -> World -> (Int,World)
-placeCoordinate p w = (i, w & coordinates %~ IM.insert i p)
+-- | generalised way of putting a new item into a lensed intmap, returning the
+-- new index as well
+placeNewInto :: ALens' World (IM.IntMap a)
+    -> a
+    -> World
+    -> (Int,World)
+placeNewInto l x w = (i,w & l #%~ IM.insert i x)
   where
-    i = IM.newKey $ _coordinates w
+    i = IM.newKey $ w ^# l
+
+-- | place an new object into an intmap and update its id
+placeNewUpdateID :: ALens' World (IM.IntMap a)
+    -> ALens' a Int
+    -> a
+    -> World
+    -> (Int,World)
+placeNewUpdateID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
+  where
+    i = IM.newKey $ w ^# l
 
 placeProp 
     :: Prop
@@ -155,8 +178,11 @@ placeBt
 placeBt bt p a w = (i , over buttons addBT w)
   where 
     i = IM.newKey $ _buttons w
-    addBT xs = IM.insert i (f bt) xs
+    addBT = IM.insert i (f bt)
     f = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) . (btID .~ i)
+
+mvButton bt p a = bt & btRot +~ a & btPos %~ ( (p +.+) . rotateV a )
+
 {- Creates a floor item at a given point.
 Assigns an id correctly.  -}
 placeFlIt
@@ -165,9 +191,8 @@ placeFlIt
     -> Float    -- ^ Rotation
     -> World
     -> (Int, World)
-placeFlIt itm p rot w = (i, w & floorItems %~ \ fis -> IM.insert i 
-    ( FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
-    ) fis
+placeFlIt itm p rot w = (i
+    , w & floorItems %~ IM.insert i FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
     )
   where
     i = IM.newKey $ _floorItems w