Improvements to rooms and view distances

src/Dodge/Data.hs

@@ -386,7 +386,6 @@ data Targeting
         , _tgDraw   :: Int -> Item -> Creature -> World -> Picture
         , _tgID     :: Maybe Int
         , _tgActive :: Bool
-        , _tgPoints :: [Point2]
         }
 data ModuleSlot
     = ModBullet

src/Dodge/Floor.hs

@@ -34,7 +34,7 @@ import System.Random
 initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithCorridors $ treeFromTrunk 
     [[AnoApplyInt 0 startRoom]
-    , [SpecificRoom $ fmap (return . PassDown) longRoom]
+--    , [SpecificRoom $ fmap (return . PassDown) longRoom]
     , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
     , [SpecificRoom randomChallenges]
     , [AnoApplyInt 1 lasSensorTurretTest]

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -57,23 +57,21 @@ defaultTargeting = TargetingOnHeld
     , _tgDraw = \_ _ _ _ -> mempty
     , _tgID = Nothing
     , _tgActive = False
-    , _tgPoints = []
     }
 targetLaser :: Targeting
 targetLaser = defaultTargeting
     & tgUpdate  .~ targetLaserUpdate
-    & tgDraw    .~ targetLaserDraw
 targetRBPress :: Targeting
 targetRBPress = defaultTargeting
-    & tgUpdate  .~ targetRBPressUpdate
+    & tgUpdate  .~ targetUpdateWith targetRBPressUpdate
     & tgDraw    .~ targetSimpleDraw
 targetRBCreature :: Targeting
 targetRBCreature = defaultTargeting
-    & tgUpdate  .~ targetRBCreatureUpdate
+    & tgUpdate  .~ targetUpdateWith targetRBCreatureUpdate
     & tgDraw    .~ targetRBCreatureDraw
 targetCursor :: Targeting
 targetCursor = defaultTargeting
-    & tgUpdate  .~ targetCursorUpdate
+    & tgUpdate  .~ targetUpdateWith targetCursorUpdate
     & tgDraw    .~ targetSimpleDraw
 targetSimpleDraw :: Int -> Item -> Creature -> World -> Picture
 targetSimpleDraw _ it _ w = fromMaybe mempty $ do
@@ -101,31 +99,32 @@ targetRBCreatureDraw _ it _ w = fromMaybe mempty $ do
     thecolor | _tgActive $ _itTargeting it = red
         | otherwise = blue
 
-targetCursorUpdate :: Item -> Creature -> World -> Targeting -> (World,Targeting)
-targetCursorUpdate _ _ w t
-    | SDL.ButtonRight `S.member` _mouseButtons w = (,) w $ t
+targetUpdateWith :: (World -> Targeting -> Targeting)
+    -> Item -> Creature -> World -> Targeting -> (World,Targeting)
+targetUpdateWith f _ _ w t = (w, f w t)
+
+targetCursorUpdate :: World -> Targeting -> Targeting
+targetCursorUpdate w t
+    | SDL.ButtonRight `S.member` _mouseButtons w = t
         & tgPos . _Just .~ mouseWorldPos w
         & tgActive .~ True
-    | otherwise = (,) w $ t & tgPos %~ const Nothing
+    | otherwise = t & tgPos %~ const Nothing
         & tgActive .~ False
 
-targetRBPressUpdate :: Item -> Creature -> World -> Targeting -> (World,Targeting)
-targetRBPressUpdate _ _ w t
-    | SDL.ButtonRight `S.member` _mouseButtons w = (w,t
+targetRBPressUpdate :: World -> Targeting -> Targeting
+targetRBPressUpdate w t
+    | SDL.ButtonRight `S.member` _mouseButtons w = t
         & tgPos %~ maybe (Just $ mouseWorldPos w) Just
         & tgActive .~ True
-        )
-    | otherwise = (w,t & tgPos %~ const Nothing
+    | otherwise = t & tgPos %~ const Nothing
         & tgActive .~ False
-        )
 
-targetRBCreatureUpdate :: Item -> Creature -> World -> Targeting -> (World,Targeting)
-targetRBCreatureUpdate _ _ w t
+targetRBCreatureUpdate :: World -> Targeting -> Targeting
+targetRBCreatureUpdate w t
     | SDL.ButtonRight `S.member` _mouseButtons w && isJust (t ^? tgID . _Just)
-                = (w,t & updatePos
+                = t & updatePos
         & tgActive .~ True
-        )
-    | otherwise = (,) w $ t & tgID .~ fmap _crID (creatureNearPointI 3 mwp w)
+    | otherwise = t & tgID .~ fmap _crID (creatureNearPointI 3 mwp w)
         & updatePos
         & tgActive .~ False
   where
@@ -134,31 +133,13 @@ targetRBCreatureUpdate _ _ w t
     posFromMaybeID Nothing = Nothing
     posFromMaybeID (Just i) = w ^? creatures . ix i . crPos
 
-targetLaserDraw :: Int -> Item -> Creature -> World -> Picture
-targetLaserDraw _ it _ _ = mempty 
---  fromMaybe mempty $ do
---    ps <- it ^? itTargeting . tgPoints
---    return $ setLayer 1 $ pictures
---        [ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 5 ps
---        , setDepth 19.5 . color (brightX 5 1 col)  $ thickLine 1  ps
---        ]
---  where
---    wpammo = _itConsumption it
---    reloadFrac 
---        | _ammoLoaded wpammo == 0 = 1
---        | otherwise = case _reloadState wpammo of
---            Just' rs -> fromIntegral rs / fromIntegral (_reloadTime wpammo)
---            Nothing' -> 1
---    col = mixColors reloadFrac (1-reloadFrac) red green
 targetLaserUpdate :: Item -> Creature -> World -> Targeting -> (World,Targeting)
-targetLaserUpdate _ cr w t
+targetLaserUpdate it cr w t
     | crIsAiming cr = (addLaserPic w,t
         & tgPos    .~ fmap fst mp
-        & tgPoints .~ sp:ps
         & tgActive .~ True
         )
     | otherwise = (w,t & tgPos %~ const Nothing
-        & tgPoints .~ []
         & tgActive .~ False
         )
   where
@@ -167,8 +148,15 @@ targetLaserUpdate _ cr w t
     ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos w -.- sp)
     addLaserPic = instantParticles .:~ Particle
         { _ptDraw = const $ setLayer 1 $ pictures
-            [ setDepth 19   . color (brightX 0 0.5 red) $ thickLine 5 (sp:ps)
-            , setDepth 19.5 . color (brightX 5 1 red)  $ thickLine 1  (sp:ps)
+            [ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 5 (sp:ps)
+            , setDepth 19.5 . color (brightX 5 1 col)  $ thickLine 1  (sp:ps)
             ]
         , _ptUpdate = ptSimpleTime 1
         }
+    wpammo = _itConsumption it
+    reloadFrac 
+        | _ammoLoaded wpammo == 0 = 1
+        | otherwise = case _reloadState wpammo of
+            Just' rs -> fromIntegral rs / fromIntegral (_reloadTime wpammo)
+            Nothing' -> 1
+    col = mixColors reloadFrac (1-reloadFrac) blue red

src/Dodge/Layout.hs

@@ -201,7 +201,8 @@ gameRoomsFromRooms = fmap gameRoomFromRoom
 gameRoomFromRoom :: Room -> GameRoom
 gameRoomFromRoom rm = GameRoom
     { _grViewpoints = map doshift $ _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
-    , _grViewpointsEx = concatMap unpos (_rmPos rm)
+        ++ mapMaybe filterUnusedLinks (_rmPos rm)
+    , _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm)
     , _grBound = map doshift $ expandPolyCorners 50 . convexHullSafe . nubBy closePoints 
         . concat $ _rmBound rm ++ _rmPolys rm
     , _grDir   = getDir $ _rmPos rm
@@ -214,9 +215,11 @@ gameRoomFromRoom rm = GameRoom
         [p +.+ 10 *.* unitVectorAtAngle a
         ,p -.- 10 *.* unitVectorAtAngle a
         ]
-    unpos (UsedOutLink _ _ p a) = doubleShift p a
-    unpos (UsedInLink  _ p a) = doubleShift p a
-    unpos _ = []
+    filterUnusedLinks (UnusedLink p _) = Just p
+    filterUnusedLinks _ = Nothing
+    filterUsedLinks (UsedOutLink _ _ 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 (UsedInLink  _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
     undir _ = Nothing

src/Dodge/LockAndKey.hs

@@ -6,6 +6,7 @@ import Dodge.Room
 import Dodge.RandomHelp
 import Dodge.Creature
 import Dodge.Item.Craftable
+import Dodge.Item.Weapon.BulletGun.Rod
 --import Dodge.Item.Equipment
 
 import System.Random
@@ -15,7 +16,7 @@ lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State
 lockRoomKeyItems = 
     [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD] )
     ,(const slowDoorRoomRunPast, return MINIGUN)
---    ,(longRoom or something, [sniper])
+    ,(const longRoomRunPast, takeOne [SNIPERRIFLE,FLATSHIELD])
     ]
 
 itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))]
@@ -39,6 +40,10 @@ itemRooms =
         ,roomsContaining $ map makeTypeCraft [DRUM,DRUM,PLATE]
         ]
       )
+    , (SNIPERRIFLE   , join $ takeOne 
+        [roomsContaining [sniperRifle]
+        ]
+      )
     ]
 
 roomsContaining :: RandomGen g => [Item] -> State g (SubCompTree Room)

src/Dodge/PlacementSpot.hs

@@ -27,6 +27,15 @@ unusedSpotAwayFromInLink x = PSPos f (const id) Nothing
       where
         inlinkposs = usedRoomInLinkPoss r
 
+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)
+        _ -> Nothing
+      where
+        inlinkposs = usedRoomInLinkPoss r
+
 usedRoomInLinkPoss :: Room -> [Point2]
 usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
   where

src/Dodge/Room.hs

@@ -11,6 +11,7 @@ module Dodge.Room
     , module Dodge.Room.Door
     , module Dodge.Room.Airlock
     , module Dodge.Room.LongDoor
+    , module Dodge.Room.LongRoom
     , module Dodge.Room.Branch
     , module Dodge.Room.Teleport
     , module Dodge.Room.Start
@@ -33,3 +34,4 @@ import Dodge.Room.Link
 import Dodge.Room.Door
 import Dodge.Room.Airlock
 import Dodge.Room.LongDoor
+import Dodge.Room.LongRoom

src/Dodge/Room/LongDoor.hs

@@ -21,11 +21,11 @@ import Dodge.Creature
 import Dodge.LightSource
 import Picture
 import Geometry
+import LensHelp
 
 import qualified Data.Set as S
 import Data.Tree
 import System.Random
-import Control.Lens
 import Control.Monad.State
 --import Data.Tree
 import qualified Data.IntMap as IM
@@ -95,14 +95,12 @@ southPillarsRoom x y h = do
 addSouthPillars :: RandomGen g => Float -> Float -> Room -> State g Room
 addSouthPillars x h r = do
     let pillarsa = []
-        pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
-           ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
-           ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
-           ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
+        pillarsb = concat [putBlockRect (i*x/5-20) (i*x/5+20) (h/2-20) (h/2+20)
+            | i <- map fromIntegral [1..4::Int]]
         pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
            ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
     pillars <- takeOne [pillarsa, pillarsb, pillarsc]
-    return $ r & rmPmnts %~ (++ pillars)
+    return $ r & rmPmnts .++~ pillars
 
 addButtonSlowDoor :: RandomGen g => Float -> Float -> Room -> State g Room
 addButtonSlowDoor x h rm = do
@@ -111,10 +109,9 @@ addButtonSlowDoor x h rm = do
        ,( V2 (x/2+50) 5,0::Float)
        ]
     thePlacement <- takeOne [butDoor butPos butRot ]
-    shuffleLinks $ setOutLinksPD aboveH $ setInLinksPD belowH (rm 
-        & rmPmnts %~ (thePlacement :)
-        & rmBound %~ (openDoorBound :)
-        )
+    shuffleLinks $ setOutLinksPD aboveH $ setInLinksPD belowH $ rm 
+        & rmPmnts .:~ thePlacement
+        & rmBound .:~ openDoorBound
   where
     openDoorBound = rectNSEW (h + 5) (h - 5) (-x/2) (3*x/2)
     belowH y = (sndV2 . fst) y < h - 40
@@ -149,9 +146,7 @@ slowDoorRoom = do
 slowDoorRoomRunPast :: RandomGen g => State g (SubCompTree Room)
 slowDoorRoomRunPast = do
     r <- slowDoorRoom
-    return $ treeFromTrunk [PassDown door]
-        (Node (PassDown r)
-            [ singleUseAll door
-            , return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink)
-            ]
-        )
+    return $ treeFromTrunk [PassDown door] $ Node (PassDown r)
+        [ singleUseAll door
+        , return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink)
+        ]

src/Dodge/Room/LongRoom.hs

@@ -0,0 +1,60 @@
+module Dodge.Room.LongRoom where
+import Dodge.RoomLink
+import Dodge.Tree
+--import Dodge.Default.Room
+import Dodge.Default.Wall
+import Dodge.LevelGen.Data
+import Dodge.Placement.Instance
+--import Dodge.Room.Link
+import Dodge.Room.Door
+import Dodge.Room.Corridor
+import Dodge.Room.Procedural
+--import Dodge.Layout.Tree.Either
+--import Dodge.LevelGen.Data
+--import Dodge.LevelGen.Switch
+import Dodge.RandomHelp
+import Dodge.Creature.Inanimate
+import Dodge.Creature
+--import Dodge.LightSource
+--import Picture
+import Geometry
+import LensHelp
+import Data.Tile
+
+import qualified Data.Set as S
+import Data.Tree
+import System.Random
+import Control.Monad.State
+--import Data.Tree
+--import qualified Data.IntMap as IM
+
+longRoom :: RandomGen g => State g Room
+longRoom = do
+    h <- state $ randomR (1500,1500)
+    let w = 75
+    let cond x = (sndV2 . fst) x < h - 40
+    let wlsNSEWs wln wls listew = [sps0 $ PutWall (rectNSWE wln wls wallw walle) defaultCrystalWall
+            | (wallw,walle) <- listew ]
+    let ws = wlsNSEWs (h-35) (h-135) [(-10,10) , (15,35) , (40,60) , (65,85)]
+    let wsDefense = wlsNSEWs 95 70 [(0,25) , (50,75) ]
+    brlN <- state $ randomR (0,5)
+    brlOffsets <- replicateM brlN $ randInRect (w-20) 900
+    let brls = [ sPS (p +.+ V2 10 200) 0 $ PutCrit explosiveBarrel | p <- brlOffsets ]
+    let rm = roomRect w (h+70) 1 1 & rmPolys .++~ [rectNSWE h (h-165) (-45) (w+45)]
+            & rmFloor .~ InheritFloor
+    return $ restrictInLinks cond $ rm & rmPmnts .~ ws ++ brls ++ wsDefense ++
+        [sPS (V2 crx (h-25)) 0 $ PutCrit longCrit
+                | crx <- [12.5,37.5,62.5] ] ++
+        [sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ]
+
+longRoomRunPast :: RandomGen g => State g (SubCompTree Room)
+longRoomRunPast = do
+    r <- longRoom
+    return $ treeFromTrunk [PassDown door]
+        (Node (PassDown r)
+            [ singleUseAll door
+            --, return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink)
+            , treeFromPost [PassDown $ corridor & rmConnectsTo .~ S.singleton InLink, PassDown corridor] 
+                (UseLabel 0 $ door)
+            ]
+        )

src/Dodge/Room/RezBox.hs

@@ -25,6 +25,7 @@ import Dodge.Item.Random
 --import Geometry.Data
 import Geometry
 import Padding
+import LensHelp
 --import Color
 --import Shape
 
@@ -32,7 +33,6 @@ import qualified Data.Set as S
 --import Data.Maybe
 import Data.Tree
 import Control.Monad.State
-import Control.Lens
 import System.Random
 
 rezBox :: LightSource -> Room
@@ -90,24 +90,23 @@ rezBoxesWpCrit = do
     adddoor rm = treeFromPost [PassDown $ door & rmConnectsTo .~ S.singleton (OnEdge North)] (PassDown rm)
 
 crAdd :: Room -> Room
-crAdd = rmPmnts %~ (sPS (V2 20 10) (0.5*pi) randC1 :)
+crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1
 
 rezBoxes :: RandomGen g => State g (SubCompTree Room)
 rezBoxes = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (40,40)
     thecol <- rezColor
-    let bottomEdgeTest (V2 _ y,_) = y < 1
-        dbox = treeFromPost [PassDown door] (PassDown $ rezInvBox thecol)
-    centralRoom <- shuffleLinks $ setInLinksPD bottomEdgeTest
-        ((roomRectAutoLinks w h) {_rmPmnts = []})
-    let n = length $ filter bottomEdgeTest $ map lnkPosDir $_rmLinks centralRoom
---    let centralRoom' = restrictOutLinks bottomEdgeTest centralRoom
+    let bottomEdgeTest = S.member (OnEdge South) . _rlType 
+        dbox = treeFromPost [PassDown $ door & rmConnectsTo .~ S.singleton (OnEdge South)] 
+            (PassDown $ rezInvBox thecol)
+    centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []}
+            & rmLinks %~ setInLinks bottomEdgeTest
+    let n = length $ filter bottomEdgeTest $_rmLinks centralRoom
     return $ treeFromTrunk [PassDown $ rezBox thecol
         , PassDown door
         ] 
         (Node (PassDown centralRoom) (replicate (n-1) dbox ++ [Node (UseAll door) []]))
-    
 
 rezColor :: RandomGen g => State g LightSource
 rezColor = do

src/Dodge/Room/Room.hs

@@ -303,15 +303,12 @@ weaponBehindPillar  = do
 
 weaponBetweenPillars :: RandomGen g => State g (SubCompTree Room)
 weaponBetweenPillars = do
-    wpPos <- takeOne [V2 x y | x <- [20,120,220], y <- [20,120,220]]
-    critPlacementSpots <- replicateM 2 $ randDirPS $ unusedSpotAwayFromInLink 100
-    let plmnts = 
-            sPS wpPos 0 (RandPS randFirstWeapon) :
-            map (`sps` randC1) critPlacementSpots
-        theRoom = roomPillars & rmPmnts %~ (++ plmnts)
-    (fmap singleUseAll . randomiseOutLinks) =<< filterLinks f theRoom
-  where 
-    f (_,a) = a == 0
+    let wpPos = unusedSpotNearInLink 100
+    ncrits <- state $ randomR (1,3)
+    critPlacementSpots <- replicateM ncrits $ randDirPS $ unusedSpotAwayFromInLink 100
+    let theRoom = roomPillars & rmPmnts .++~
+            sps wpPos (RandPS randFirstWeapon) : map (`sps` randC1) critPlacementSpots
+    return $ singleUseAll theRoom
 
 weaponLongCorridor :: RandomGen g => State g (SubCompTree Room)
 weaponLongCorridor = do
@@ -356,24 +353,6 @@ roomCCrits :: RandomGen g => State g Room
 roomCCrits = roomC 200 200
     <&> rmPmnts %~ (replicate 20 (spNoID (PSRoomRand 0 (uncurry PS)) randC1) ++ )
 
-longRoom :: RandomGen g => State g Room
-longRoom = do
-    h <- state $ randomR (1500,1500)
-    let w = 75
-    let cond x = (sndV2 . fst) x < h - 40
-    let wlsNSEWs wln wls listew = [sps0 $ PutWall (rectNSWE wln wls wallw walle) defaultCrystalWall
-            | (wallw,walle) <- listew ]
-    let ws = wlsNSEWs (h-35) (h-135) [(-10,10) , (15,35) , (40,60) , (65,85)]
-    let wsDefense = wlsNSEWs 95 70 [(0,25) , (50,75) ]
-    brlOffsets <- replicateM 5 $ randInRect (w-20) 900
-    let brls = [ sPS (p +.+ V2 10 200) 0 $ PutCrit explosiveBarrel | p <- brlOffsets ]
-    let rm = roomRect w (h+70) 1 1 & rmPolys .++~ [rectNSWE h (h-165) (-45) (w+45)]
-            & rmFloor .~ InheritFloor
-    return $ restrictInLinks cond $ rm & rmPmnts .~ ws ++ brls ++ wsDefense ++
-        [sPS (V2 crx (h-25)) 0 $ PutCrit longCrit
-                | crx <- [12.5,37.5,62.5] ] ++
-        [sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ]
-
 doubleCorridorBarrels :: RandomGen g => State g Room
 doubleCorridorBarrels = do
     h <- state $ randomR (200,300)

src/Dodge/Update/Camera.hs

@@ -174,6 +174,7 @@ setViewDistance :: Configuration -> World -> World
 setViewDistance cfig w = w & viewDistance 
     .~ sqrt (halfWidth cfig ** 2 + halfHeight cfig ** 2) / _cameraZoom w
 
+-- TODO consider adding visible/nearby creatures as view points
 farWallDist :: Point2 -> Configuration -> World -> Float
 farWallDist p cfig w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps
   where