Start to implement lock and key system

src/Dodge/Room/Boss.hs

@@ -7,6 +7,8 @@ import Dodge.Data
 import Dodge.Room.Data
 import Dodge.Room.Placement
 import Dodge.LevelGen.Data
+import Dodge.Creature
+import Dodge.RandomHelp
 import Geometry
 
 import Control.Monad.State
@@ -40,3 +42,13 @@ roomOctogon x = Room
 
 bossRoom :: RandomGen g => Creature -> State g Room
 bossRoom cr = pure $ roomOctogon 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
+
+armouredChasers :: RandomGen g => State g Room
+armouredChasers = do
+    ps <- takeN 5 [(x,y) | x <- [-200,-120 .. 200] ,y <- [-200,-120 .. 200] ]
+    as <- replicateM 5 . state $ randomR (0,2*pi)
+    let theCrits = zipWith3 (\p a c -> PS p a (PutCrit armourChaseCrit)) ps as cs
+    pure $ roomOctogon 300 & rmPS %~ (++ theCrits)
+  where
+    cs = (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [0]) 
+            : replicate 4 (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [1])

src/Dodge/Room/Branch.hs

@@ -21,7 +21,7 @@ branchRectWith t = do
     y <- state $ randomR (100,200)
     b <- t
     root <- randomiseOutLinks $ roomRectAutoLinks x y
-    return $ Node (Left root) [Node (Right door) [], fmap rToL $ treeTrunk [Left door] b]
+    return $ Node (Left root) [Node (Right door) [], fmap rToL $ treeFromTrunk [Left door] b]
         where rToL :: Either a a -> Either a a
               rToL (Right r) = Left r
               rToL (Left r)  = Left r

src/Dodge/Room/Data.hs

@@ -7,6 +7,15 @@ import Geometry
 
 import Control.Lens
 
+{- 
+The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room.
+Link pairs contain a position and rotation to attach to another room;
+0 is for links going to another room to the north, pi/2 for links going to a room to the west, etc.
+TODO : Explain path, does it need both directions?
+Placement spots allow things to be put in the room during level generation.
+Room bounds between a new room and previously placed rooms are checked during level generation,
+assigning no bounds will allow rooms to overlap.
+ -}
 data Room = Room
     { _rmPolys  :: [ [Point2] ]
     , _rmLinks  :: [(Point2,Float)]
@@ -14,21 +23,4 @@ data Room = Room
     , _rmPS :: [PlacementSpot]
     , _rmBound :: [Point2]
     }
-data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
-
 makeLenses ''Room
-makeLenses ''RoomLink
-
--- want to split a room into its dimensions and contents
-
-data Room' = Room'
-    { _dimensions   :: Dimensions
-    , _contents     :: [PlacementSpot]
-    }
-
-data Dimensions = Dimensions
-    { _dmPolys  :: [[Point2]]
-    , _dmLinks  :: [(Point2,Float)]
-    , _dmPath   :: [(Point2, Point2)]
-    , _dmBound  :: [Point2]
-    }

src/Dodge/Room/LockAndKeyList.hs

@@ -0,0 +1,19 @@
+module Dodge.Room.LockAndKeyList
+    where
+import Dodge.Room.Data
+import Dodge.Room.RoadBlock
+import Dodge.Room.Boss
+
+import Control.Monad.State
+import System.Random
+import Data.Tree
+
+lockAndKeyRoomList :: RandomGen g => 
+    [   (State g (Tree (Either Room Room))
+        ,State g (Tree (Either Room Room))
+        )                                   ]
+lockAndKeyRoomList =
+    [   ( fmap (pure . Right) armouredCorridor
+        , fmap (pure . Left) armouredChasers
+        )
+    ]

src/Dodge/Room/Placement.hs

@@ -3,18 +3,20 @@ module Dodge.Room.Placement
   where
 import Dodge.Data
 import Dodge.LevelGen.Data
-import Picture
+import Dodge.Room.Data
 import Dodge.Creature.Inanimate
-
+import Picture
 import Geometry
 
+import Data.List
+import Control.Lens
+
 
 putLamp = PutCrit lamp
 
 singleBlock :: Point2 -> [PlacementSpot]
 singleBlock a = [PS a 0 $ PutBlock [5,20,20] (greyN 0.5)
                                         $ reverse $ rectNSWE 10 (-10) (-10) 10]
-
 {-
 Places a line of blocks between two points.
 Width 9, also extends out from each point by 9.
@@ -88,3 +90,31 @@ baseWindowPane = Block
     , _blShadows = []
     , _blDegrades = [5,5]
     }
+
+{-
+Replaces instances of a given 'PutID' with 'PSType's drawn from a list.
+-}
+replacePutID 
+    :: Int      -- ^ The id of 'PutID' to be replaced
+    -> [PSType] -- ^ List of replacements
+    -> Room 
+    -> Room
+replacePutID i psts r =
+    r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & psType .~ pt)) psts
+
+{-
+Partition a list by a predicate, apply a zip to those elements 
+that satisfy the predicate, concatenate 
+the new zipped list and the other (unchanged) half.
+-}
+subZipWith 
+    :: (a -> Bool)      -- ^ Filter: elements to apply zip to
+    -> (a -> b -> a)    -- ^ Combining function
+    -> [a]              -- ^ List to be partition
+    -> [b]              -- ^ Modifying list
+    -> [a]
+subZipWith f g xs ys =
+    let (zs,ws) = partition f xs
+    in  zipWith g zs ys ++ ws
+
+isPutID i ps = Just i == ps ^? psType . putID

src/Dodge/Room/RoadBlock.hs

@@ -0,0 +1,48 @@
+{-
+Connecting rooms designed with a pass-through technique in mind.
+-}
+module Dodge.Room.RoadBlock
+    where
+import Geometry
+import Dodge.Room.Data
+import Dodge.Room.Link
+import Dodge.Room.Placement
+import Dodge.LevelGen.Data
+import Dodge.RandomHelp
+import Dodge.Creature
+
+import Data.Tree
+import Control.Monad.State
+import System.Random
+
+armouredCorridor :: RandomGen g => State g Room
+armouredCorridor = fmap (replacePutID 0 [PutCrit $ addArmour autoCrit]) litCorridor90
+
+{-
+A corridor of random length with a 90 degree link at the end.
+-}
+litCorridor90 :: RandomGen g => State g Room
+litCorridor90 = do
+    h <- state $ randomR (500,800)
+    let poly = rectNSWE h 0 0 40
+        poly2 = rectNSWE (h-60) (h-100) (-60) 5
+    pure $ Room
+        { _rmPolys = [poly,poly2]
+        , _rmLinks = [ ((40,h - 80), -pi/2)
+                     , ((20,     0), pi)
+                     ]
+        , _rmPath  = concatMap doublePair 
+            [((20,0),(20,h-40))
+            ,(( 0,h-40),(20,h-40))
+            ,((40,h-40),(20,h-40))
+            ]
+        , _rmPS    = 
+            [ PS (20,h-5) 0 $ putLamp
+            , windowLine (0,h-20) (40,h-20)
+            , PS (-50,h-85) 0 $ putLamp
+            , windowLine (0-40,h-60) (0-40,h-100)
+            , PS ( 20,h-40) 0 $ PutID 0
+            , PS (-20,h-80) 0 $ PutID 2
+            ]
+        , _rmBound = poly
+        }

src/Dodge/Room/Treasure.hs

@@ -5,10 +5,14 @@ Typically dead ends.
 module Dodge.Room.Treasure
     where
 import Geometry
+import Dodge.Data
 import Dodge.Room.Data
+import Dodge.Room.Placement
 import Dodge.LevelGen.Data
 
+import Data.List
 import Control.Monad.State
+import Control.Lens
 import System.Random
 
 {-
@@ -21,18 +25,24 @@ triLootRoom
     -> Float    -- Height
     -> State g Room
 triLootRoom w h = pure $ Room
-    { _rmPolys  = [poly]
-    , _rmLinks  = [((0,10),pi)]
-    , _rmPath   = doublePair ((0,10),(0,h/2))
+    { _rmPolys  = [ tri
+                  , base
+                    ]
+    , _rmLinks  = [((0,-80),pi)]
+    , _rmPath   = doublePair ((0,-80),(0,h/2))
     , _rmPS     =
         [PS (15-w,15) 0 $ PutID 0
-        ,PS (w-15,15) 0 $ PutID 0
-        ,PS (0,h-15) 0   $ PutID 2
+        ,PS (w-15,15) pi $ PutID 0
+        ,PS (0,h-35)  0 $ PutID 2
+        ,PS (-5,h-10)  0 putLamp
+        ,PS (5,h-10)  0 putLamp
+        ,PS (0,h-15)  0 putLamp
+        ,PS (0,-60)  0 putLamp
         ]
-    , _rmBound  = poly
+    , _rmBound  = convexHull $ tri ++ base
     }
   where
-    poly = 
+    tri = 
         [ ( -w,30)
         , ( -w, 0)
         , (  w, 0)
@@ -40,3 +50,10 @@ triLootRoom w h = pure $ Room
         , ( 20, h)
         , (-20, h)
         ]
+    base = rectNSWE 20 (-80) (-20) 20
+
+lootRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
+lootRoom crs itms = do
+    let w = 300
+        h = 700
+    fmap (replacePutID 0 (map PutCrit crs) . replacePutID 2 (map PutFlIt itms)) $ triLootRoom w h