Some cleanup, sidetracked from inter-room placements

src/Dodge/Data.hs

@@ -63,6 +63,7 @@ data World = World
     , _machines             :: IM.IntMap Machine
     , _blocks               :: IM.IntMap Block
     , _coordinates          :: IM.IntMap Point2
+    , _triggers             :: IM.IntMap (World -> Bool)
     , _wallsZone            :: Zone (IM.IntMap Wall)
     , _floorItems           :: IM.IntMap FloorItem
     , _floorTiles           :: [(Point3,Point3)]

src/Dodge/Default/Room.hs

@@ -8,15 +8,17 @@ defaultRoom :: Room
 defaultRoom = Room
     { _rmPolys  = []
     , _rmLinks  = []
-    , _rmUsedLinks  = []
+    , _rmPos    = []
     , _rmPath   = []
     , _rmPmnts  = []
-    , _rmPartialPmnts = IM.empty
+    , _rmTriggerPmnts = IM.empty
-    , _rmLabelledPmnts = IM.empty
+    , _rmTriggers = IM.empty
     , _rmBound  = []
     , _rmFloor  = []
     , _rmName   = "defaultRoom"
     , _rmShift  = (V2 0 0 , 0)
     , _rmViewpoints = []
     , _rmRandPSs = []
+    , _rmLabel    = Nothing
+    , _rmTakeFrom = Nothing
     }

src/Dodge/Default/World.hs

@@ -40,6 +40,7 @@ defaultWorld = World
     , _machines = IM.empty
     , _doors = IM.empty
     , _coordinates  = IM.empty
+    , _triggers     = IM.empty
     , _wallsZone = Zone IM.empty
     , _floorItems = IM.empty
     , _floorTiles = []

src/Dodge/Floor.hs

@@ -1,6 +1,5 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
-{- |
+{- | The tree of rooms that make up a level. -}
-The tree of rooms that make up a level. -}
 module Dodge.Floor
     ( layoutLevelFromSeed
     ) where
@@ -34,33 +33,23 @@ import Data.Sequence hiding (zipWith)
 import Data.Maybe
 
 initialAnoTree :: RandomGen g => Tree [Annotation g]
-initialAnoTree =
+initialAnoTree = padSucWithCorridors $ treeFromTrunk 
-    let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom]
-        t' = padWithCorridors struct
-    in treeFromTrunk 
     [[StartRoom]
-            ,[Corridor]
     ,[SpecificRoom $ return $ connectRoom lasTunnel ]
-            ,[Corridor]
     ,[SpecificRoom $ fmap connectRoom slowDoorRoom ]
     ,[Corridor]
     ,[Corridor]
-            ,[Corridor]
     ,[SpecificRoom $ fmap connectRoom roomCCrits]
-            ,[Corridor]
     ,[AirlockAno]
     ,[Corridor]
-            ,[Corridor]
 ----    ,[SpecificRoom roomCCrits]
 ----    ,[Corridor]
-----            ,[Corridor]
 ----    ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
 ----        & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit 
 ----                    ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit 
 ----                    ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit 
 ----                    ]++)
 ----     ]
-----            --,[Corridor]
 ----    --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
 ----    --    & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
 ----    -- ]
@@ -68,10 +57,8 @@ initialAnoTree =
 ----        & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
 ----     ]
 ----    ,[Corridor]
-----            ,[Corridor]
 --    --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers]
 ---    ,[SpecificRoom $ pure $ (pure . Right) (twinSlowDoorRoom 80 200 40)]
----            ,[Corridor]
 ---    ,[DoorAno]
 ---    ,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit]
 ---    ,[SpecificRoom blockedCorridor]
@@ -82,24 +69,23 @@ initialAnoTree =
 ---    ,[FirstWeapon]
 ---    ,[CorridorDebug]
 ---    ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]
-            ,[Corridor]
     ,[OrAno 
         [[SpecificRoom $ branchRectWith $ fmap (fmap Left) armouredChasers]
         ,[BossAno $ addArmour launcherCrit & crHP +~ 800
             & crState . crDropsOnDeath .~ DropSpecific [0] ]
         ]
      ]
-            ,[Corridor]
 --    ,[SpecificRoom $ fmap (pure . Right) armouredCorridor]
     ,[Corridor]
     ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
     ] 
-            t'
+    $ treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] 
+                                [EndRoom]
 
 {- | A test level tree. -}
 initialRoomTree :: RandomGen g => State g (Tree Room)
 initialRoomTree = do
-    expandTreeBy id <$> mapM annoToRoomTree initialAnoTree
+    expandTreeBy id <$> mapM anoToRoomTree initialAnoTree
 
 layoutLevelFromSeed :: Int -> Int -> IO [Room]
 layoutLevelFromSeed i seed = do

src/Dodge/Layout.hs

@@ -10,8 +10,6 @@ import Dodge.Wall.Zone
 import Dodge.Zone
 import Dodge.GameRoom
 import Dodge.Bounds
---import Dodge.RandomHelp
---import Dodge.Graph
 import Dodge.Layout.Tree.Polymorphic (applyToRoot)
 import Dodge.Room.Data
 import Dodge.Room.AddTile
@@ -117,10 +115,10 @@ gameRoomsFromRooms = map f
     f rm = GameRoom
         { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
             ++ map fst (_rmLinks rm)
-        , _grViewpointsEx = mapMaybe unpos (_rmUsedLinks rm)
+        , _grViewpointsEx = mapMaybe unpos (_rmPos rm)
         , _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints 
             . concat $ _rmBound rm ++ _rmPolys rm
-        , _grDir   = getDir $ _rmUsedLinks rm
+        , _grDir   = getDir $ _rmPos rm
         , _grName  = _rmName rm
         }
     closePoints x y = roundPoint2 x == roundPoint2 y

src/Dodge/Layout/Tree/Annotate.hs

@@ -1,8 +1,5 @@
-{- |
+{- | Annotating tree structures with desired properties for rooms.  -}
-Annotating tree structures with desired properties for rooms.
+module Dodge.Layout.Tree.Annotate where
--}
-module Dodge.Layout.Tree.Annotate
-    where
 import Dodge.Data
 import Dodge.RandomHelp
 import Dodge.Layout.Tree.Polymorphic
@@ -23,6 +20,7 @@ import Dodge.Room.Teleport
 import Data.Tree
 import Control.Monad.State
 import System.Random
+import Control.Lens
 
 data Annotation g
     = Lock Int
@@ -40,6 +38,8 @@ data Annotation g
     | SpecificRoom (State g (Tree (Either Room Room)))
     | BossAno Creature
     | TreasureAno [Creature] [Item]
+    | SetLabel Int (State g Room)
+    | UseLabel Int (State g Room)
 
 addLock :: RandomGen g => Int -> Tree [Annotation g] -> State g (Tree [Annotation g])
 addLock i t = do
@@ -49,6 +49,9 @@ addLock i t = do
 {- | Add one corridor between each parent-child link of a tree of annotations.  -}
 padWithCorridors :: Tree [Annotation g] -> Tree [Annotation g]
 padWithCorridors (Node x xs) = Node [Corridor] [Node x (map padWithCorridors xs)]
+padSucWithCorridors :: Tree [Annotation g] -> Tree [Annotation g]
+padSucWithCorridors (Node x xs) = Node x (map padWithCorridors xs)
+
 {- Add one to three corridors between each parent-child link of a tree of annotations.  -}
 randomPadCorridors :: RandomGen g => Tree [Annotation g] -> State g (Tree [Annotation g])
 randomPadCorridors  (Node x xs) = do
@@ -60,11 +63,17 @@ roomThenCorridor :: RandomGen g => Room -> State g (Tree (Either Room Room))
 roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r]) 
                                 (randomiseOutLinks corridor)
 {- | Create a random room tree structure from a list of annotations.  -}
-annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
+anoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
-annoToRoomTree anos = case anos of
+anoToRoomTree anos = case anos of
+    [SetLabel i randrm] -> do
+        rm <- randrm
+        return . connectRoom $ rm & rmLabel ?~ i
+    [UseLabel i randrm] -> do
+        rm <- randrm
+        return $ connectRoom $ rm & rmTakeFrom ?~ i
     [OrAno as] -> do
         a <- takeOne as
-        annoToRoomTree a
+        anoToRoomTree a
     [Corridor] -> pure . Right <$> randomiseOutLinks corridor
     [CorridorDebug] -> pure . Right <$> randomiseOutLinks corridorDebug
     [DoorAno] -> roomThenCorridor door

src/Dodge/Layout/Tree/Shift.hs

@@ -47,6 +47,6 @@ posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do
       where
         convexBounds = map pointsToPoly $ _rmBound r'
         clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
-        useLink = (r & rmLinks %~ delete l & rmUsedLinks %~ (uncurry (OutLink (Prelude.length ts)) l :)
+        useLink = (r & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink (Prelude.length ts)) l :)
             , i)
         shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t

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}
+    Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
-        -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
+--        -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
-           in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
+--           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)
+-- | generalised way of putting a new item into a lensed intmap, returning the
-placeCoordinate p w = (i, w & coordinates %~ IM.insert i p)
+-- 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 
+placeFlIt itm p rot w = (i
-    ( FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
+    , w & floorItems %~ IM.insert i FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
-    ) fis
     )
   where
     i = IM.newKey $ _floorItems w

src/Dodge/LevelGen/Data.hs

@@ -19,6 +19,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutPressPlate PressPlate
     | PutBlock [Int] Color [Point2]
     | PutCoordinate Point2
+    | PutTrigger (World -> Bool)
     | PutLineBlock Wall Float Float Point2 Point2
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
     | PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float
@@ -72,9 +73,10 @@ ps0j :: PSType -> Placement -> Placement
 ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst (const $ Just plmnt)
 
 addPlmnt :: Placement -> Placement -> Placement
-addPlmnt pl (PlacementUsingPos p f) = PlacementUsingPos p (fmap (addPlmnt pl) f)
+addPlmnt pl pl2 = case pl2 of
-addPlmnt pl (RandomPlacement rp) = RandomPlacement $ fmap (addPlmnt pl) rp
+    (PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f)
-addPlmnt pl (Placement ps pt f) = Placement ps pt (fmap g f)
+    (RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
+    (Placement ps pt f) -> Placement ps pt (fmap g f)
   where
     g Nothing = Just pl
     g (Just pl') = Just $ addPlmnt pl pl'

src/Dodge/Placements/Spot.hs

@@ -11,9 +11,10 @@ setPS = updatePS . const
 
 updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Placement
 updatePSToLevel 0 _ plmnt = plmnt
-updatePSToLevel i f (PlacementUsingPos p pl) = PlacementUsingPos p (fmap (updatePSToLevel i f) pl)
+updatePSToLevel i f plmnt = case plmnt of
-updatePSToLevel i f (Placement ps pt pl) = Placement (f ps) pt (fmap (fmap (updatePSToLevel (i-1) f)) pl)
+    PlacementUsingPos p pl  -> PlacementUsingPos p (fmap (updatePSToLevel i f) pl)
-updatePSToLevel i f (RandomPlacement rplmnt) = RandomPlacement $ fmap (updatePSToLevel i f) rplmnt
+    Placement ps pt pl      -> Placement (f ps) pt (fmap (fmap (updatePSToLevel (i-1) f)) pl)
+    RandomPlacement rplmnt  -> RandomPlacement $ fmap (updatePSToLevel i f) rplmnt
 
 setLocalPS :: PlacementSpot -> Placement -> Placement
 setLocalPS ps (Placement _ pt f) = Placement ps pt f
@@ -21,6 +22,7 @@ setLocalPS ps (RandomPlacement rplmnt) = RandomPlacement (fmap (setLocalPS ps) r
 setLocalPS _ plmnt = plmnt
 
 updatePS :: (PlacementSpot -> PlacementSpot) -> Placement -> Placement
-updatePS f (Placement ps pt iplmnt) = Placement (f ps) pt ((fmap . fmap $ updatePS f) iplmnt)
+updatePS f pl' = case pl' of
-updatePS f (PlacementUsingPos p plmnt) = PlacementUsingPos p (fmap (updatePS f) plmnt)
+    Placement ps pt ipl     -> Placement (f ps) pt $ (fmap . fmap $ updatePS f) ipl
-updatePS f (RandomPlacement rplmnt) = RandomPlacement (fmap (updatePS f) rplmnt)
+    PlacementUsingPos p pl  -> PlacementUsingPos p (fmap (updatePS f) pl)
+    RandomPlacement rpl     -> RandomPlacement (fmap (updatePS f) rpl)

src/Dodge/Room/Data.hs

@@ -5,6 +5,7 @@ module Dodge.Room.Data
 import Dodge.LevelGen.Data
 import Geometry.Data
 import Data.Tile
+import Dodge.Data
 
 import Control.Monad.State
 import System.Random
@@ -22,17 +23,19 @@ assigning no bounds will allow rooms to overlap.
 data Room = Room
     { _rmPolys  :: [ [Point2] ]
     , _rmLinks  :: [(Point2,Float)]
-    , _rmUsedLinks  :: [RoomPos]
+    , _rmPos    :: [RoomPos]
     , _rmPath   :: [(Point2, Point2)]
     , _rmPmnts  :: [Placement]
-    , _rmLabelledPmnts :: IM.IntMap Placement
+    , _rmTriggers :: IM.IntMap (World -> Bool)
-    , _rmPartialPmnts :: IM.IntMap (Int -> Placement)
+    , _rmTriggerPmnts :: IM.IntMap ((World -> Bool) -> Placement)
     , _rmBound  :: [ [Point2] ]
     , _rmFloor  :: [Tile]
     , _rmName   :: String
     , _rmShift  :: (Point2, Float)
     , _rmViewpoints :: [Point2]
     , _rmRandPSs :: [State StdGen (Point2,Float)]
+    , _rmLabel    :: Maybe Int
+    , _rmTakeFrom :: Maybe Int
     }
 data RoomPos 
     = OutLink Int Point2 Float

src/Dodge/Room/Door.hs

@@ -1,12 +1,13 @@
-{-
+{- Rooms that connect other rooms, blocking sight.  -}
-Rooms that connect other rooms, blocking sight.
--}
 module Dodge.Room.Door
     where
 import Geometry
 import Dodge.Room.Data
 import Dodge.Default.Room
 import Dodge.Placements
+import Color
+
+import qualified Data.IntMap.Strict as IM
 
 door :: Room
 door = defaultRoom
@@ -17,8 +18,24 @@ door = defaultRoom
     , _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
 -- note no bounds
     }
-    where lnks = [(V2 20 35,0)
+  where 
+    lnks = [(V2 20 35,0)
         ,(V2 20  5,pi)
         ]
 
 
+switchDoor :: Room
+switchDoor = defaultRoom
+    { _rmPolys = [rectNSWE 40 0 0 40]
+    , _rmLinks = lnks
+    , _rmPath  = [(V2 20 35,V2 20 5)]
+-- door extends into side walls (for shadows as rendered 12/03)
+    , _rmTriggerPmnts = IM.fromList 
+        [(0,\cond -> putDoubleDoor False red cond (V2 0 20) (V2 40 20) 2)]
+-- note no bounds
+    }
+  where 
+    lnks = [(V2 20 35,0)
+        ,(V2 20  5,pi)
+        ]
+

src/Dodge/Room/Link.hs

@@ -1,10 +1,8 @@
-{-
+{- Concerns link pairs of rooms.
-Concerns link pairs of rooms.
 Link pairs determine where rooms can attach to each other; each pair consists
 of a position and a rotation.
 The last link in the list is considered the incoming link, the other links are
-the outgoing links.
+the outgoing links.  -}
--}
 module Dodge.Room.Link
     ( shiftRoomToLink
     , shiftRoomBy
@@ -111,5 +109,5 @@ setLastLinkToUsed :: Room -> Room
 setLastLinkToUsed rm = case _rmLinks rm of
     (_:_) -> rm
         & rmLinks %~ init
-        & rmUsedLinks %~ (uncurry InLink (last (_rmLinks rm)) :)
+        & rmPos %~ (uncurry InLink (last (_rmLinks rm)) :)
     _ -> rm