Add rooms, placements and room positions

src/Dodge/Layout.hs

@@ -215,16 +215,16 @@ gameRoomFromRoom rm = GameRoom
         [p +.+ 10 *.* unitVectorAtAngle a
         ,p -.- 10 *.* unitVectorAtAngle a
         ]
-    filterUnusedLinks (UnusedLink p _) = Just p
+    filterUnusedLinks (UnusedLink p _ _) = Just p
     filterUnusedLinks _ = Nothing
-    filterUsedLinks (UsedOutLink _ _ p a) = doubleShift p a
+    filterUsedLinks (UsedOutLink _ _ p a _) = doubleShift p a
-    filterUsedLinks (UsedInLink  _ p a) = doubleShift p a
+    filterUsedLinks (UsedInLink  _ p a _) = doubleShift p a
     filterUsedLinks _ = []
-    undir (UsedOutLink _ _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
+    undir (UsedOutLink _ _ _ a _) = Just $ 0.5*pi + a + snd (_rmShift rm)
-    undir (UsedInLink  _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
+    undir (UsedInLink  _ _ a _) = Just $ 0.5*pi + a + snd (_rmShift rm)
     undir _ = Nothing
     closePoints x y = roundPoint2 x == roundPoint2 y
-    getDir (UsedInLink _ _ a:_) = a  + snd (_rmShift rm)
+    getDir (UsedInLink _ _ a _:_) = a  + snd (_rmShift rm)
     getDir (_:xs) = getDir xs
     getDir _ = 0 -- fallback
 

src/Dodge/LevelGen/Data.hs

@@ -104,13 +104,15 @@ data RoomLinkType
     | InLink
     | LabLink Int
     | OnEdge CardinalPoint
-    deriving (Eq,Ord)
+    | FromSouth Int
+    | FromWest Int
+    deriving (Eq,Ord,Show)
 data CardinalPoint
     = North
     | East
     | South
     | West
-    deriving (Eq,Ord)
+    deriving (Eq,Ord,Show)
 data RoomWire
     = --RoomWire Point2 Float
      WallWire Point2 Float Float
@@ -120,32 +122,49 @@ data RoomPos
         ,_rpOutRoomID :: Int
         ,_rpPos :: Point2  
         ,_rpDir :: Float
+        ,_rpLinkType :: S.Set RoomLinkType
         }
     | UsedInLink 
         {_rpInRoomID :: Int 
         ,_rpPos :: Point2 
-        ,_rpDir ::Float
+        ,_rpDir :: Float
+        ,_rpLinkType :: S.Set RoomLinkType
         }
     | UnusedLink
         {_rpPos :: Point2 
         ,_rpDir ::Float
+        ,_rpLinkType :: S.Set RoomLinkType
+        }
+    | UsedLink
+        {_rpPos :: Point2 
+        ,_rpDir :: Float
+        ,_rpLinkType :: S.Set RoomLinkType
         }
     | UsedSpot
         {_rpPos :: Point2 
         ,_rpDir :: Float
+        ,_rpType :: S.Set RoomPosType
         }
     | UnusedSpot
         {_rpPos :: Point2 
         ,_rpDir :: Float
+        ,_rpType :: S.Set RoomPosType
         }
   deriving (Eq,Ord,Show)
 
+data RoomPosType 
+    = RoomPosOnPath
+    | RoomPosOffPath
+    | RoomPosExLink
+  deriving (Eq,Ord,Show)
+
 makeLenses ''Room
 makeLenses ''PSType
 makeLenses ''PlacementSpot
 makeLenses ''Placement
 makeLenses ''RoomLink
 makeLenses ''RoomPos
+makeLenses ''RoomPosType
 
 spNoID :: PlacementSpot -> PSType -> Placement
 spNoID ps pst = Placement ps pst Nothing (const Nothing)
@@ -196,7 +215,7 @@ jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
 jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . contToIDCont
 
 jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
-jps0PushPS pst f = Just . Placement (PS (V2 0 0) 0) pst Nothing
+jps0PushPS pst f = Just . Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
     $ \plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt
 
 ps0j :: PSType -> Placement -> Placement

src/Dodge/LockAndKey.hs

@@ -24,32 +24,52 @@ itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))]
 itemRooms = 
     [ (LAUNCHER , join $ takeOne 
         [corridorBoss launcherCrit
-        ,roomsContaining $ map makeTypeCraft [TUBE,TUBE,HARDWARE]
+        , rc $ map makeTypeCraft [TUBE,TUBE,HARDWARE]
         ] 
       )
     , (MINIGUN  , join $ takeOne [roomMiniIntro, minigunFakeout] )
     , (LASGUN   , join $ takeOne 
-        [roomsContaining $ map makeTypeCraft [PRISM,PIPE,PIPE,HARDWARE]
+        [rc $ map makeTypeCraft [PRISM,PIPE,PIPE,HARDWARE]
         ]
       )
     , (SPARKGUN   , join $ takeOne 
-        [roomsContaining $ map makeTypeCraft [TRANSFORMER,CAN,CAN]
+        [rc $ map makeTypeCraft [TRANSFORMER,CAN,CAN]
         ]
       )
     , (FLATSHIELD   , join $ takeOne 
-        [roomsContaining $ map makeTypeCraft [PLATE,PLATE]
+        [rc $ map makeTypeCraft [PLATE,PLATE]
-        ,roomsContaining $ map makeTypeCraft [DRUM,DRUM,PLATE]
+        ,rc $ map makeTypeCraft [DRUM,DRUM,PLATE]
         ]
       )
     , (SNIPERRIFLE   , join $ takeOne 
-        [roomsContaining [sniperRifle]
+        [rc [sniperRifle]
         ]
       )
     ]
+  where
+    rc its = do
+        sc <- someCrits
+        roomsContaining sc its
 
-roomsContaining :: RandomGen g => [Item] -> State g (SubCompTree Room)
+someCrits :: RandomGen g => State g [Creature]
-roomsContaining its = do
+someCrits = do
-    endroom <- randomFourCornerRoom its
+    nCrits <- state $ randomR (1,3)
+    fmap (take nCrits) . shuffle $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
+        ++ replicate 20 chaseCrit
+
+
+--addcrits :: RandomGen g => [Item] -> State g (SubCompTree Room)
+--addcrits its = do
+--    nCrits <- state $ randomR (1,3)
+--    crits <- takeN nCrits <=< shuffle $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
+--    return $ roomsContaining crits its
+
+roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (SubCompTree Room)
+roomsContaining crs its = do
+    endroom <- join $ takeOne
+        [ randomFourCornerRoomCrsIts crs its 
+        , tanksRoom crs its
+        ]
     return $ treeFromPost [] $ PassDown endroom
 
 corridorBoss :: RandomGen g => Creature -> State g (SubCompTree Room)

src/Dodge/Placement/Instance/LightSource.hs

@@ -107,13 +107,6 @@ mntLightLnkCond f = RandomPlacement $ do
     shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
     return $ mntLSCond shp f
 
-unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
-unusedLnkToPS rp _ = case rp of
-    UnusedLink p a -> Just (PS p a,UsedSpot p a)
---    UsedInLink _ p a -> Just (PS p a,UsedSpot p a)
---    UsedOutLink _ _ p a -> Just (PS p a,UsedSpot p a)
-    _ -> Nothing
-
 spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
 spanLSLightI ls h a b = ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h)
     $ sps0 $ PutShape $ thinHighBar h a b

src/Dodge/Placement/Instance/Tank.hs

@@ -1,7 +1,6 @@
 module Dodge.Placement.Instance.Tank where
 import Dodge.Data
 --import Dodge.Placement.PlaceSpot
-import Dodge.Placement.Shift
 import Dodge.LevelGen.Data
 import Dodge.Room.Foreground
 import Dodge.Default.Wall
@@ -10,90 +9,74 @@ import Shape
 import Color
 --import Quaternion
 
-roundTank :: Color -> Float -> Float -> Placement
+tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement
-roundTank col x y = shiftPlacement (V2 x y,0) $ ps0j 
+tankShape baseshape facade col col' = ps0jPushPS
-    (PutShape $ colorSH col $ 
+    (PutShape $ colorSH col (upperPrismPoly 31 baseshape) <> facade col col')
-        upperPrismPoly 31 thecircle
+    $ sps0 $ PutWall baseshape defaultWall 
-        <> foldMap toprail ( take 8 [0,pi/4..]) 
+        {_wlDraw = False, _wlColor = col, _wlRotateTo = False, _wlOpacity = SeeAbove}
-    )
+
-    $ sps0 $ PutWall thecircle defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
+roundTank :: Color -> Color -> Placement
+roundTank = tankShape (polyCirc 4 20) 
+    $ \_ c' -> colorSH c' $ foldMap toprail (take 8 [0,pi/4..]) 
   where
     toprail a = rotateSH a $ thinHighBar 31 (V2 0 20) (rotateV (pi/4) $ V2 0 20)
-    thecircle = polyCirc 4 20
 
-roundTankCross :: Color -> Float -> Float -> Placement
+roundTankCross :: Color -> Color -> Placement
-roundTankCross col x y = shiftPlacement (V2 x y,0) $ ps0j 
+roundTankCross = tankShape (polyCirc 4 20) 
-    (PutShape $ colorSH col $ 
+    $ \_ c -> colorSH c $ thinHighBar 31 (V2 20 0) (V2 (-20) 0)
-        upperPrismPoly 31 thecircle
-        <> thinHighBar 31 (V2 20 0) (V2 (-20) 0)
         <> thinHighBar 31 (V2 0 20) (V2 0 (-20))
-    )
-    $ sps0 $ PutWall thecircle defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
-  where
-    thecircle = polyCirc 4 20
 
-tankRectCross :: Float -> Float -> Color -> Float -> Float -> Placement
+tankRectCross :: Float -> Float -> Color -> Color -> Placement
-tankRectCross w h col x y = shiftPlacement (V2 x y,0) $ ps0j
+tankRectCross = tankRectDecorate $ \ w h _ c -> colorSH c $
-    (PutShape $ colorSH col $
+    thinHighBar 31 (V2 w 0) (V2 (-w) 0) 
-        upperPrismPoly 31 therect
+    <> thinHighBar 31 (V2 0 h) (V2 0 (-h))
-        <> thinHighBar 31 (V2 w 0) (V2 (-w) 0)
-        <> thinHighBar 31 (V2 0 h) (V2 0 (-h))
-    )
-    $ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
-  where
-    therect = rectWH w h
 
-tankSquareCross :: Color -> Float -> Float -> Placement
+tankSquareCross :: Color -> Color -> Placement
 tankSquareCross = tankRectCross 20 20
 
+tankRectDecorate :: (Float -> Float -> Color -> Color -> Shape) 
+    -> Float -> Float -> Color -> Color -> Placement
+tankRectDecorate f w h = tankShape (rectWH w h) (f w h)
 
-tankRect :: Float -> Float -> Color -> Float -> Float -> Placement
+tankRect :: Float -> Float -> Color -> Color -> Placement
-tankRect w h col x y = shiftPlacement (V2 x y,0) $ ps0j
+tankRect = tankRectDecorate g 
-    (PutShape $ colorSH col
-        $ upperPrismPoly 31 therect
-        <> foldMap f [(w',-w',h',h'),(w',-w',-h',-h'),(w',w',h',-h'),(-w',-w',h',-h')]
-    )
-    $ sps0 $ PutWall therect defaultWall 
-        {_wlDraw = False, _wlColor = col, _wlRotateTo = False, _wlOpacity = SeeAbove}
   where
-    therect = rectWH w h
+    g w h _ col = colorSH col $ foldMap f 
-    w' = w - 1.5
+        [(w',-w',h',h')
-    h' = h - 1.5
+        ,(w',-w',-h',-h')
-    f (a,b,c,d) = thinHighBar 31 (V2 a b) (V2 c d)
+        ,(w',w',h',-h')
+        ,(-w',-w',h',-h')
+        ]
+      where
+        w' = w - 1.5
+        h' = h - 1.5
+        f (a,c,b,d) = thinHighBar 31 (V2 a b) (V2 c d)
 
-tankSquare :: Color -> Float -> Float -> Placement
+tankSquare :: Color -> Color -> Placement
 tankSquare = tankRect 20 20
 
-tankRectEmboss :: Float -> Float -> Color -> Float -> Float -> Placement
+tankRectEmboss :: Float -> Float -> Color -> Color -> Placement
-tankRectEmboss w h col x y = shiftPlacement (V2 x y,0) $ ps0j
+tankRectEmboss = tankRectDecorate f
-    (PutShape $ colorSH col $
-        upperPrismPoly 31 therect
-        <> embossingR
-        <> rotateSH pi embossingR
-        <> thinHighBar 38 (V2 (-0.3*w) 0) (V2 (0.3*w) 0)
-    )
-    $ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
   where
-    w' = 0.3 * w
+    f w h _ c = embossingR
-    therect = rectWH w h
+        <> rotateSH pi embossingR
-    embossingR = prismPoly 
+        <> colorSH c (thinHighBar 38 (V2 (-0.3*w) 0) (V2 (0.3*w) 0))
-        [V3 w h 31,V3 w (0.3*h) 41,V3 w (-0.3*h) 41,V3 w (-h) 31]
+      where
-        [V3 w' h 31,V3 w' (0.3*h) 41,V3 w' (-0.3*h) 41,V3 w' (-h) 31]
+        w' = 0.3 * w
+        embossingR = colorSH c $ prismPoly 
+            [V3 w h 31,V3 w (0.3*h) 41,V3 w (-0.3*h) 41,V3 w (-h) 31]
+            [V3 w' h 31,V3 w' (0.3*h) 41,V3 w' (-0.3*h) 41,V3 w' (-h) 31]
 
-tankSquareEmboss :: Color -> Float -> Float -> Placement
+tankSquareEmboss :: Color -> Color -> Placement
 tankSquareEmboss = tankRectEmboss 20 20
 
-tankRectEmboss4 :: Float -> Float -> Color -> Float -> Float -> Placement
+tankRectEmboss4 :: Float -> Float -> Color -> Color -> Placement
-tankRectEmboss4 w h col x y = shiftPlacement (V2 x y,0) $ ps0j
+tankRectEmboss4 = tankRectDecorate g
-    (PutShape $ colorSH col $
-        upperPrismPoly 31 therect
-        <> foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
-    )
-    $ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
   where
-    therect = rectWH w h
+    g w h _ c = colorSH c $ foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
-    f (a,b) = translateSH (V3 (a/2) (b/2) 31) embossing
+      where
-    embossing = upperPrismPolyHalf 10 $ rectNSEW (h/2) (-h/2) (w/2) (-w/2)
+        f (a,b) = translateSH (V3 (a/2) (b/2) 31) embossing
+        embossing = upperPrismPolyHalf 10 $ rectNSEW (h/2) (-h/2) (w/2) (-w/2)
 
-tankSquareEmboss4 :: Color -> Float -> Float -> Placement
+tankSquareEmboss4 :: Color -> Color -> Placement
 tankSquareEmboss4 = tankRectEmboss4 20 20

src/Dodge/PlacementSpot.hs

@@ -2,16 +2,18 @@ module Dodge.PlacementSpot where
 import Dodge.LevelGen.Data
 import Geometry
 
+import Control.Lens
 import Data.Maybe
 import Data.Bifunctor
 import Control.Monad.State
 import System.Random
+import qualified Data.Set as S
 
 setDirPS :: Float -> PlacementSpot -> PlacementSpot
 setDirPS a ps = case ps of
     PS p _ -> PS p a
     PSNoShiftCont p _ -> PS p a
-    PSPos f re fb -> PSPos (\rp r -> fmap (first (setDirPS a)) (f rp r)) re fb
+    PSPos f rmeff fb -> PSPos (\rp r -> fmap (first (setDirPS a)) (f rp r)) rmeff fb
     PSRoomRand i f -> PSRoomRand i (fmap (setDirPS a) f)
 
 randDirPS :: RandomGen g => PlacementSpot -> State g PlacementSpot
@@ -19,23 +21,83 @@ randDirPS ps = do
     a <- state $ randomR (0,pi*2)
     return $ setDirPS a ps
 
+anyUnusedSpot :: PlacementSpot
+anyUnusedSpot = PSPos f (const id) Nothing
+  where
+    f rp _ = case rp of
+        UnusedSpot p a t -> Just (PS p a,UsedSpot p a t)
+        _ -> Nothing
+
+unusedSpotAwayFromLink :: Float -> PlacementSpot
+unusedSpotAwayFromLink x = PSPos f (const id) Nothing
+  where
+    f rp r = case rp of
+        UnusedSpot p a t
+            | all ( (>x) . dist p ) (usedRoomLinkPoss r)
+                -> Just (PS p a,UsedSpot p a t)
+        _       -> Nothing
+
+unusedOffPathAwayFromLink :: Float -> PlacementSpot
+unusedOffPathAwayFromLink x = PSPos f (const id) Nothing
+  where
+    f rp r = case rp of
+        UnusedSpot p a t
+            | all ( (>x) . dist p ) (usedRoomLinkPoss r) && RoomPosOffPath `S.member` t
+                -> Just (PS p a,UsedSpot p a t)
+        _       -> Nothing
+
 unusedSpotAwayFromInLink :: Float -> PlacementSpot
 unusedSpotAwayFromInLink x = PSPos f (const id) Nothing
   where
     f rp r = case rp of
-        UnusedSpot p a | all ( (>x) . dist p ) inlinkposs -> Just (PS p a,UsedSpot p a)
+        UnusedSpot p a t | all ( (>x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t)
         _ -> Nothing
-      where
+
-        inlinkposs = usedRoomInLinkPoss r
+twoUnusedLinks :: (PlacementSpot -> PlacementSpot -> Placement)
+    -> Placement
+twoUnusedLinks f = Placement useUnusedLink PutNothing Nothing
+    $ \pl1 -> Just $ Placement useUnusedLink PutNothing Nothing
+    $ \pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
+
+twoRoomPoss :: (RoomPos -> Bool)
+    -> (RoomPos -> Bool)
+    -> (PlacementSpot -> PlacementSpot -> Placement)
+    -> Placement
+twoRoomPoss cond1 cond2 f = Placement (useRoomPos cond1) PutNothing Nothing
+    $ \pl1 -> Just $ Placement (useRoomPos cond2) PutNothing Nothing
+    $ \pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
+
+useUnusedLink :: PlacementSpot
+useUnusedLink = PSPos unusedLnkToPS (const id) Nothing
+
+useRoomPos :: (RoomPos -> Bool) -> PlacementSpot
+useRoomPos cond = PSPos (useRoomPosCond cond) (const id) Nothing
+
+useRoomPosCond :: (RoomPos -> Bool)
+    -> RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
+useRoomPosCond t rp _
+    | t rp = Just (PS p a, UsedSpot p a (fromMaybe S.empty $ rp ^? rpType))
+    | otherwise = Nothing
+  where
+    p = _rpPos rp
+    a = _rpDir rp
+
+unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
+unusedLnkToPS = useRoomPosCond $ \rp -> case rp of
+    UnusedLink {} -> True
+    _ -> False
+
+isUnusedLinkType :: RoomLinkType -> RoomPos -> Bool
+isUnusedLinkType rlt rp = case rp of
+    UnusedLink{_rpLinkType = rlts} -> rlt `S.member` rlts
+    _ -> False
 
 unusedSpotNearInLink :: Float -> PlacementSpot
 unusedSpotNearInLink x = PSPos f (const id) Nothing
   where
     f rp r = case rp of
-        UnusedSpot p a | any ( (<x) . dist p ) inlinkposs -> Just (PS p a,UsedSpot p a)
+        UnusedSpot p a t | any ( (<x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t)
         _ -> Nothing
-      where
-        inlinkposs = usedRoomInLinkPoss r
 
 usedRoomInLinkPoss :: Room -> [Point2]
 usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
@@ -44,23 +106,31 @@ usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
         UsedInLink {} -> Just $ _rpPos rp
         _ -> Nothing
 
+usedRoomLinkPoss :: Room -> [Point2]
+usedRoomLinkPoss r = mapMaybe f $ _rmPos r
+  where
+    f rp = case rp of
+        UsedInLink {} -> Just $ _rpPos rp
+        UsedOutLink {} -> Just $ _rpPos rp
+        _ -> Nothing
+
 -- TODO rename to any unused link facing out
 anyLnkOutPS :: PlacementSpot
 anyLnkOutPS = PSPos f (const id) Nothing
   where
-    f (UnusedLink p a) _ = Just (PS p a, UsedSpot p a)
+    f (UnusedLink p a _) _ = Just (PS p a, UsedSpot p a S.empty)
     f _ _ = Nothing
     
 atFstLnkOut :: PlacementSpot
 atFstLnkOut = PSPos f (const id) Nothing
   where
-    f (UsedOutLink 0 i p a) _ = Just (PS p a, UsedOutLink 0 i p a)
+    f (UsedOutLink 0 i p a lt) _ = Just (PS p a, UsedOutLink 0 i p a lt)
     f _                     _ = Nothing
 
 atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
 atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
   where
-    f (UsedOutLink i rmid p a) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a)
+    f (UsedOutLink i rmid p a lt) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a lt)
       where
         (p',a') = theshift (p,a)
     f _ _ = Nothing
@@ -79,14 +149,14 @@ atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f
 overFstLnkOut :: PlacementSpot
 overFstLnkOut = PSPos f (const id) Nothing
   where
-    f (UsedOutLink 0 _ p a) _ = Just (PS p a, UsedSpot p a)
+    f (UsedOutLink 0 _ p a lt) _ = Just (PS p a, UsedLink p a lt)
     f _ _ = Nothing
 
 anyLnkInPS :: Float -- ^ amount to shift inward
     -> PlacementSpot
 anyLnkInPS x = PSPos f (const id) Nothing
   where
-    f (UnusedLink v a) _ = Just (PS v' a' ,UsedSpot v' a')
+    f (UnusedLink v a _) _ = Just (PS v' a' ,UsedSpot v' a' S.empty)
       where
         v' = v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)
         a' = a + pi
@@ -94,7 +164,7 @@ anyLnkInPS x = PSPos f (const id) Nothing
 
 useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
 useLnkRoomPos rp _ = case rp of
-    (UnusedLink (V2 x y) a) -> Just (PS (V2 x y) a , UsedSpot (V2 x y) a)
+    (UnusedLink (V2 x y) a lt) -> Just (PS (V2 x y) a , UsedLink (V2 x y) a lt)
     _ -> Nothing
 
 psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float)

src/Dodge/Room.hs

@@ -18,6 +18,7 @@ module Dodge.Room
     , module Dodge.Room.Boss
     , module Dodge.Room.Treasure
     , module Dodge.Room.GlassLesson
+    , module Dodge.Room.Tanks
     ) where
 import Dodge.Room.Room
 import Dodge.Room.RoadBlock
@@ -37,3 +38,4 @@ import Dodge.Room.Airlock
 import Dodge.Room.LongDoor
 import Dodge.Room.LongRoom
 import Dodge.Room.GlassLesson
+import Dodge.Room.Tanks

src/Dodge/Room/LongDoor.hs

@@ -118,8 +118,8 @@ addButtonSlowDoor x h rm = do
     aboveH y = (sndV2 . fst) y > h + 40
     butDoor _ _ = putLitButOnPos col butPosCond
         $  \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
-    butPosCond (UnusedLink (V2 x' y') a') _ | y' < 0.5 * h 
+    butPosCond (UnusedLink (V2 x' y') a' _) _ | y' < 0.5 * h 
-                = Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a')
+                = Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a' (S.singleton RoomPosExLink))
     butPosCond _ _ = Nothing
     --butPosCond _ = True -- y < h
     col = dim $ light red

src/Dodge/Room/Procedural.hs

@@ -4,6 +4,7 @@ module Dodge.Room.Procedural
     ( roomRect
     , roomRectAutoLinks
     , randomFourCornerRoom
+    , randomFourCornerRoomCrsIts
     , centerVaultRoom
     , combineRooms
     , linksAndPath
@@ -32,11 +33,13 @@ import Geometry
 import Picture
 import Data.Tile
 
+import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Control.Monad
 import Control.Monad.State
 import System.Random
+-- This will need a cleanup, but it might change a bit first
 {- A simple rectangular room with a light in the center.
 Creates links and pathfinding graph.  -}
 roomRect
@@ -49,7 +52,8 @@ roomRect x y xn yn = defaultRoom
     { _rmPolys = [rectNSWE  y 0 0 x ]
     , _rmLinks = lnks
     , _rmPath  = concatMap doublePair pth
-    , _rmPos   = map (`UnusedSpot` 0) posps
+    , _rmPos   = map (\pd -> UnusedSpot pd 0 $ S.singleton RoomPosOnPath) posps
+        ++ map (\pd -> UnusedSpot pd 0 $ S.singleton RoomPosOffPath) interposps
     , _rmPmnts    = []
     , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
     , _rmFloor = Tiled [Tile 
@@ -67,10 +71,14 @@ roomRect x y xn yn = defaultRoom
     wlnks = zip (map (+.+ V2 x 20) $ gridPoints  0  1      yd (yn+1))  (repeat (-pi/2)) 
     nlnks = zip (map (+.+ V2 20 y) $ gridPoints xd (xn+1)  0  1     )  (repeat      0 ) 
     slnks = zip (map (+.+ V2 20 0) $ gridPoints xd (xn+1)  0  1     )  (repeat     pi ) 
-    lnks = m North nlnks ++ m East elnks ++ m West wlnks ++ m South slnks
+    lnks = zipWith (m North FromWest) [0..] nlnks 
-    m edge = map (lnkBothAnd (OnEdge edge))
+        ++ zipWith (m East FromSouth) [0..] elnks
+        ++ zipWith (m West FromSouth) [0..] wlnks
+        ++ zipWith (m South FromWest) [0..] slnks
+    m edge = lnkBothAnd' (OnEdge edge)
     pth  = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
     posps = map (+.+ V2 20 20) $ gridPoints xd (xn+1) yd (yn+1)
+    interposps = map (+.+ V2 (20 + xd/2) (20 + yd/2)) $ gridPoints xd xn yd yn
 {- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size.  -}
 -- it is not clear to me that this works for very small rooms (but it does seem
 -- to do so)
@@ -80,7 +88,8 @@ roomRectAutoLinks x y = (roomRect x y xn yn)
   where
     xn = max 1 $ (ceiling x - 40) `div` 60
     yn = max 1 $ (ceiling y - 40) `div` 60
-    plmnts = [mntLightLnkCond unusedLnkToPS ]
+    plmnts = [mntLightLnkCond unusedLnkToPS
+        , mntLightLnkCond unusedLnkToPS ]
 {- Combines two rooms into one room.
  - will have to work out exactly what to do with combining links
 Mostly involves concatenation.  -}
@@ -193,9 +202,10 @@ fillNothingPlacements pst r = foldr fillNothingPlacement r pst
 {- | Randomise the ordering of placements in a room.
 Useful for randomising the position of generic placements such as 'PutNothing'. -}
 shufflePlacements :: RandomGen g => Room -> State g Room
-shufflePlacements r = do
+shufflePlacements = rmPmnts shuffle
-    newPSs <- shuffle $ _rmPmnts r
+--shufflePlacements r = do
-    return $ r & rmPmnts .~ newPSs
+--    newPSs <- shuffle $ _rmPmnts r
+--    return $ r & rmPmnts .~ newPSs
 {- | A randomly generate room based on four randomly generated corners. 
 Tight corridors, random placements. -}
 randomFourCornerRoom :: RandomGen g => [Item] -> State g Room
@@ -211,6 +221,18 @@ randomFourCornerRoom its = do
         . foldr1 combineRooms
         $ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
         )
+{- | A randomly generate room based on four randomly generated corners. 
+Tight corridors. -}
+randomFourCornerRoomCrsIts :: RandomGen g => [Creature] -> [Item] -> State g Room
+randomFourCornerRoomCrsIts crits its = do
+    corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 100]
+    itms <- shuffle its
+    randomiseAllLinks . fillNothingPlacements (map PutCrit crits ++ map PutFlIt itms) =<< 
+        ( shufflePlacements
+        . over rmPmnts ( sps0 putLamp :)
+        . foldr1 combineRooms
+        $ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
+        )
 {- | Creates room with a central vault with doors around it.  -}
 centerVaultRoom
     :: Float    -- ^ Width

src/Dodge/Room/Room.hs

@@ -24,6 +24,7 @@ import Tile
 import MonadHelp
 import LensHelp
 
+import qualified Data.Set as S
 import Control.Monad.State
 --import Control.Monad.Loops
 import System.Random
@@ -82,7 +83,7 @@ glassSwitchBack = do
     hgt <- state $ randomR (400,600)
     wllen <- state $ randomR (60,wth/2-40)
     let hf = hgt/5
-        con1 cond (UnusedLink (V2 x y) a) _ | cond y = Just (PS (V2 x y) a , UsedSpot (V2 x y) a)
+        con1 cond (UnusedLink (V2 x y) a _) _ | cond y = Just (PS (V2 x y) a , UsedSpot (V2 x y) a $ S.singleton RoomPosExLink)
         con1 _ _ _ = Nothing
         plmnts = 
             [ mntLightLnkCond $ con1 (< 0.5 * hgt)

src/Dodge/Room/Start.hs

@@ -1,7 +1,9 @@
 module Dodge.Room.Start where
+import Dodge.Data
 import Dodge.LevelGen.Data
 --import Dodge.PlacementSpot
 import Dodge.Room.RunPast
+import Dodge.Room.Tanks
 --import Dodge.RoomLink
 --import Dodge.Data
 --import Dodge.Default
@@ -14,18 +16,13 @@ import Dodge.Room.Corridor
 import Dodge.Room.Room
 import Dodge.Room.Link
 import Dodge.Room.Procedural
-import Dodge.Room.Foreground
---import Dodge.Room.RoadBlock
-import Dodge.Placement.Instance
---import Dodge.Item.Random
 import Dodge.Item.Weapon.BulletGuns
 import Dodge.Item.Weapon.Utility
+import Dodge.Item.Craftable
 --import Dodge.LevelGen.Data
 --import Geometry.Data
-import Geometry
 --import Padding
-import Color
+--import Shape
-import Shape
 import LensHelp
 
 --import Data.Maybe
@@ -90,18 +87,16 @@ rezBoxThenWeaponRoom = do
     rcol <- rezColor
     treeFromTrunk [PassDown $ rezBox rcol,PassDown door] <$> weaponRoom
 
+startCrafts :: RandomGen g => State g [Item]
+startCrafts = takeOne $ map (map makeTypeCraft)
+    [ [PIPE,PIPE,HARDWARE]
+    , [TUBE,PIPE,HARDWARE]
+    ]
+
 startRoom' :: RandomGen g => State g (SubCompTree Room)
 startRoom' = do
-    w <- state $ randomR (100,400)
+    scrafts <- startCrafts
-    h <- state $ randomR (200,400)
+    troom <- tanksRoom [] scrafts
-    let plmnts = 
-            [ sPS (V2 0 0) 0 $ PutShape $ girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2))
---            , mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70)
-            , tankSquareEmboss4 (dim orange) 50 (h-60)
-            , tankSquare (dim orange) 50 50
-            , tankSquare (dim orange) 50 120
-            , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
-            ]
     thecol <- rezColor
     treeFromPost [PassDown $ rezBox thecol, PassDown door] . UseAll 
-        <$> shuffleLinks (roomRectAutoLinks w h & rmPmnts .++~ plmnts)
+        <$> shuffleLinks troom

src/Dodge/Room/Tanks.hs

@@ -0,0 +1,48 @@
+module Dodge.Room.Tanks where
+import Dodge.Data
+import Dodge.LevelGen.Data
+import Dodge.RandomHelp
+import Dodge.Room.Procedural
+import Dodge.Room.Foreground
+--import Dodge.Room.RoadBlock
+import Dodge.Placement.Instance
+import Dodge.PlacementSpot
+--import Padding
+import Color
+--import Shape
+import LensHelp
+
+--import Data.Maybe
+--import Data.Tree
+import Control.Monad.State
+import System.Random
+import qualified Data.Set as S
+
+randomTank :: RandomGen g => State g Placement
+randomTank = takeOne $ map (\f -> f (dim orange) orange)
+    [ tankSquareEmboss4
+    , tankSquareEmboss
+    , tankSquare
+    , roundTank
+    , roundTankCross
+    , tankSquareCross
+    ]
+
+tanksRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
+tanksRoom crs its = do
+    w <- state $ randomR (100,400)
+    h <- state $ randomR (200,400)
+    ntanks  <- state $ randomR (3,6)
+    thetank <- randomTank <&> plSpot .~ unusedOffPathAwayFromLink 50
+    let room = roomRectAutoLinks w h
+        nwestlnks = length $ filter ((OnEdge West `S.member`) . _rlType) $ _rmLinks room
+    let plmnts = 
+            --[ twoRoomPoss (isUnusedLinkType (OnEdge West)) (isUnusedLinkType (OnEdge East)) $ \ps1 ps2 ->
+            [ twoRoomPoss (isUnusedLinkType (FromSouth i)) (isUnusedLinkType (FromSouth i)) $ \ps1 ps2 ->
+                sps0 $ PutShape $ girderV 96 20 10 (_psPos ps1) (_psPos ps2) 
+                | i <- [1 .. nwestlnks - 2]]
+            ++ map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its
+            ++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
+            ++ replicate ntanks thetank
+--            , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
+    return $ room & rmPmnts .++~ plmnts

src/Dodge/RoomLink.hs

@@ -100,6 +100,13 @@ lnkBothAnd rlt (p,a) = RoomLink
     , _rlDir = a
     }
 
+lnkBothAnd' :: RoomLinkType -> (Int -> RoomLinkType) -> Int -> (Point2,Float) -> RoomLink
+lnkBothAnd' rlt ltcon i (p,a) = RoomLink 
+    {_rlType = S.fromList [OutLink,InLink,rlt,ltcon i]
+    ,_rlPos = p 
+    , _rlDir = a
+    }
+
 toBothLnk :: (Point2,Float) -> RoomLink
 toBothLnk (p,a) = RoomLink 
     {_rlType = S.fromList [OutLink,InLink]

src/Dodge/Tree/Shift.hs

@@ -67,20 +67,37 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
             clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
             updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm 
                 & rmLinks    %~ delete outlnk 
-                & rmPos      .:~ uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk)
+                & rmPos      .:~ UsedOutLink
+                    { _rpChildNum = numChild 
+                    , _rpOutRoomID = snd childi
+                    , _rpPos = fst (lnkPosDir outlnk)
+                    , _rpDir = snd (lnkPosDir outlnk)
+                    , _rpLinkType = _rlType outlnk
+                    }
                 & rmChildren .:~ snd childi
             shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
             updatechild rm = rm 
                 & rmMParent ?~ snd parenti
                 & rmMID     ?~ snd childi
                 & rmLinks   %~ delete il 
-                & rmPos     .:~ uncurry (UsedInLink 0) (lnkPosDir il)
+                & rmPos     .:~ UsedInLink 
+                    { _rpInRoomID = 0
+                    , _rpPos = fst (lnkPosDir il)
+                    , _rpDir = snd (lnkPosDir il)
+                    , _rpLinkType = _rlType il
+                    }
             shiftedt = applyToRoot
                 (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) 
                 t
 
 createUnusedLinkPos :: Room -> Room
-createUnusedLinkPos rm = rm & rmPos .++~ map (uncurry UnusedLink . lnkPosDir) (_rmLinks rm)
+createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
+  where
+    f rl = UnusedLink
+        { _rpPos = _rlPos rl
+        , _rpDir = _rlDir rl
+        , _rpLinkType = _rlType rl
+        }
 
 zipCount :: [a] -> [(Int,a)]
 zipCount = Prelude.zip [0..]