From 5681a37953fb8c89f7d0370dea57b1dcb40918ad Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 7 Nov 2021 19:46:14 +0000 Subject: [PATCH] Cleanup. Add room-wise random placement spots --- src/Dodge/Data.hs | 1 - src/Dodge/Default/Room.hs | 1 + src/Dodge/Floor.hs | 5 +++ src/Dodge/Item/Equipment.hs | 1 + src/Dodge/Layout.hs | 22 ++++++++-- src/Dodge/LevelGen/Data.hs | 10 +++++ src/Dodge/LevelGen/MoveDoor.hs | 40 ----------------- src/Dodge/LevelGen/TriggerDoor.hs | 24 ++--------- src/Dodge/Placements/LightSource.hs | 56 ++++++++++++++---------- src/Dodge/Room.hs | 67 ++++++++++++++++------------- src/Dodge/Room/Airlock.hs | 9 ++-- src/Dodge/Room/Boss.hs | 10 ++--- src/Dodge/Room/Corridor.hs | 2 +- src/Dodge/Room/Data.hs | 3 ++ src/Dodge/Room/Furniture.hs | 10 +++++ src/Dodge/Room/Procedural.hs | 4 +- src/Dodge/Room/RoadBlock.hs | 34 ++++++++++----- src/Dodge/Wall/Move.hs | 21 ++++++++- 18 files changed, 179 insertions(+), 141 deletions(-) delete mode 100644 src/Dodge/LevelGen/MoveDoor.hs diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 6a69a7d4a..a395b7b17 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -582,7 +582,6 @@ data Door = Door , _drStatus :: DoorStatus , _drTrigger :: World -> Bool , _drMech :: Door -> World -> World - , _drCoord :: Int } data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int deriving (Eq, Ord, Show) diff --git a/src/Dodge/Default/Room.hs b/src/Dodge/Default/Room.hs index 9db6927dc..e54f52208 100644 --- a/src/Dodge/Default/Room.hs +++ b/src/Dodge/Default/Room.hs @@ -15,4 +15,5 @@ defaultRoom = Room , _rmName = "defaultRoom" , _rmShift = (V2 0 0 , 0) , _rmViewpoints = [] + , _rmRandPSs = [] } diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index d3d49e20d..92644fa7b 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -37,6 +37,11 @@ initialRoomTree = do ,[Corridor] ,[AirlockAno] ,[Corridor] + ,[Corridor] + ,[SpecificRoom $ fmap connectRoom glassSwitchBack] + ,[Corridor] + ,[SpecificRoom $ return $ connectRoom lasTunnel ] + ,[Corridor] ,[SpecificRoom $ fmap connectRoom slowDoorRoom ] ,[Corridor] ,[Corridor] diff --git a/src/Dodge/Item/Equipment.hs b/src/Dodge/Item/Equipment.hs index 05426f803..abe7e6c68 100644 --- a/src/Dodge/Item/Equipment.hs +++ b/src/Dodge/Item/Equipment.hs @@ -56,6 +56,7 @@ flatShield = defaultEquipment { _itEquipPict = pictureWeaponOnAim flatShieldEquipSPic , _itAimStance = TwoHandFlat , _itEffect = effectOnOffEquip createShieldWall removeShieldWall + , _itName = "SHIELD" } flatShieldEquipSPic :: Item -> SPic flatShieldEquipSPic _ = diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 120ee3c20..a78daa055 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -62,23 +62,37 @@ generateLevelFromRoomList gr w -- this should PutNothing if there are no links available -- first it takes the random placements and derandomises them -- then it deals with link placement spots +-- TODO use state monad here assignPlacementSpots :: StdGen -> Room -> (StdGen, [((Point2,Float),Placement)]) -assignPlacementSpots g rm = (g', map (_rmShift rm,) $ plmnts ++ plmnts') +assignPlacementSpots g rm = (g' + , map (_rmShift rm,) + $ plmnts ++ updatedLnkPlmnts + ) where (randPlmnts, detPlmnts) = partition isRand (_rmPS rm) isRand RandomPlacement{} = True isRand _ = False - (unrandPlmnts, g'') = runState (mapM _unRandomPlacement randPlmnts) g - (lnkplmnts, plmnts) = partition islnk (unrandPlmnts ++ detPlmnts) + (unrandPlmnts, g'') = runState (mapM (derandPlacement rm) (_rmPS rm)) g + (lnkplmnts, plmnts) = partition islnk unrandPlmnts + --(lnkplmnts, plmnts) = partition islnk (unrandPlmnts ++ detPlmnts) islnk Placement{_placementSpot=PSLnk{}} = True islnk _ = False (shuffledLnks,g') = runState (shuffle $ _rmLinks rm) g'' - (_,plmnts') = mapAccumR f (map (invShiftLinkBy $ _rmShift rm) shuffledLnks) lnkplmnts + (_,updatedLnkPlmnts) = mapAccumR f (map (invShiftLinkBy $ _rmShift rm) shuffledLnks) lnkplmnts f lnks plmnt = let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks thepair = _psLinkShift (_placementSpot plmnt) x in (xs++ys, updatePS (updatePSLnkUsing thepair) plmnt) +-- I do not see an obvious way to push randomn placement spots down into recursive placements +-- So these currently only work for the "top" level +derandPlacement :: Room -> Placement -> State StdGen Placement +derandPlacement rm (RandomPlacement x) = derandPlacement rm =<< x +derandPlacement rm (Placement (PSRoomRand i) pstype cont) = do + ps <- _rmRandPSs rm !! i + return (Placement (uncurry PS ps) pstype cont) +derandPlacement _ x = return x + updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf updatePSLnkUsing _ ps = ps diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index e29bff344..191ca879d 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -33,6 +33,8 @@ data PlacementSpot | PSLnk { _psLinkTest :: (Point2,Float) -> Bool , _psLinkShift :: (Point2,Float) -> (Point2,Float) } + | PSRoomRand + { _psRoomRandPointNum :: Int } data Placement = Placement { _placementSpot :: PlacementSpot , _psType :: PSType @@ -68,6 +70,14 @@ jps0 pst = Just . Placement (PS (V2 0 0) 0) pst 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 (RandomPlacement rp) = RandomPlacement $ fmap (addPlmnt pl) rp +addPlmnt pl (Placement ps pt f) = Placement ps pt (fmap g f) + where + g Nothing = Just pl + g (Just pl') = Just $ addPlmnt pl pl' + makeLenses ''PSType makeLenses ''PlacementSpot makeLenses ''Placement diff --git a/src/Dodge/LevelGen/MoveDoor.hs b/src/Dodge/LevelGen/MoveDoor.hs deleted file mode 100644 index d7c5aa134..000000000 --- a/src/Dodge/LevelGen/MoveDoor.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Dodge.LevelGen.MoveDoor - ( zoneps - , moveDoorToward - , changeZonedWall - , mvPs - ) where -import Dodge.Data -import Dodge.Base -import Dodge.Zone -import Geometry - -import Control.Lens - -mvP :: Float -> Point2 -> Point2 -> Point2 -{-# INLINE mvP #-} -mvP !speed !ep !p = mvPointTowardAtSpeed speed ep p - -mvPs :: Float -> (Point2,Point2) -> (Point2,Point2) -> (Point2,Point2) -{-# INLINE mvPs #-} -mvPs !speed (!ex,!ey) (!sx,!sy) = (mvP speed ex sx,mvP speed ey sy) - -moveDoorToward :: Float -> (Point2,Point2) -> Wall -> Wall -{-# INLINE moveDoorToward #-} -moveDoorToward speed (ex,ey) = wlLine %~ mvPs speed (ex,ey) - -zoneps :: (Point2, Point2) -> [(Int,Int)] -{-# INLINE zoneps #-} -zoneps (a,b) - | dist a b <= 2 * zoneSize - = [zoneOfPoint $ pHalf a b] - | otherwise = map zoneOfPoint $ divideLine zoneSize a b - -changeZonedWall - :: (Wall -> Wall) - -> Int - -> (Int,Int) - -> World - -> World -changeZonedWall eff n (x,y) = over (wallsZone . znObjects) $ adjustIMZone eff x y n diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs index 8641c1d75..6cc315b58 100644 --- a/src/Dodge/LevelGen/TriggerDoor.hs +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -2,17 +2,10 @@ module Dodge.LevelGen.TriggerDoor ( placeDoor , placeSlideDoor - --, addButtonDoor ) where import Dodge.Data ---import Dodge.Base ---import Dodge.Zone import Dodge.Default.Wall import Dodge.Wall.Move -import Dodge.LevelGen.MoveDoor ---import Dodge.LevelGen.Switch ---import Dodge.LevelGen.Pathing -import Dodge.LevelGen.MoveDoor import Dodge.LevelGen.DoorPane import Picture import Geometry @@ -22,7 +15,6 @@ import Dodge.SoundLogic.LoadSound import Dodge.Data.SoundOrigin import Data.List ---import Data.Maybe import Control.Lens --import Data.Graph.Inductive hiding ((&)) import qualified Data.IntSet as IS @@ -42,7 +34,6 @@ placeDoor col cond pss w = (drid, addWalls w & doors %~ addDoor) , _drStatus = DoorInt 0 , _drTrigger = cond , _drMech = doorMechanismStepwise nsteps drid wlids pss - , _drCoord = 0 } nsteps = length pss - 1 wlids = take 4 [IM.newKey $ _walls w ..] @@ -77,7 +68,6 @@ doorMechanismStepwise nsteps drid wlids pss dr w newps = uncurry (rectanglePairs 9) (pss !! n) -- it is not at all clear that the zoning selects the correct walls --- TODO think about wall zoning, simplify! doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door -> World -> World doorMechanism drid speed wlidOpCps dr w | toOpen && dstatus /= DoorOpen = moveUpdate $ foldl' doOpen w wlidOpCps @@ -91,18 +81,11 @@ doorMechanism drid speed wlidOpCps dr w | dist (fst wlpos) (fst cpos) < 1 = doors . ix drid . drStatus .~ DoorClosed | otherwise = doors . ix drid . drStatus .~ DoorHalfway (wlid',opos,cpos) = head wlidOpCps - wlpos = _wlLine $ _walls w IM.! wlid' + wlpos = _wlLine $ _walls w IM.! wlid' toOpen = _drTrigger dr w dstatus = _drStatus dr - doOpen w' (wlid,openpos,cp) = mvDoorWithZone w' wlid openpos cp - doClose w' (wlid,_,cp) = mvDoorWithZone w' wlid cp cp - mvDoorWithZone w' wlid p zp = moveWall wlid wl newwlline w' - where - wl = _walls w' IM.! wlid - newwlline = mvPs speed p (_wlLine wl) - -- w' - -- & walls . ix wlid %~ moveDoorToward speed p - -- & (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp)) + doOpen w' (wlid,opp, _) = moveWallIDToward wlid speed opp w' + doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w' -- TODO cut pathing if not pathable, reset when opened placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World @@ -116,7 +99,6 @@ placeSlideDoor isPathable col cond a b speed w = (drid, addWalls w & doors %~ ad , _drStatus = DoorClosed , _drTrigger = cond , _drMech = doorMechanism drid speed (zip3 wlids shiftedPairs pairs) - , _drCoord = 0 } addWalls w' = foldl' addWall w' $ zip wlids pairs addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall diff --git a/src/Dodge/Placements/LightSource.hs b/src/Dodge/Placements/LightSource.hs index 9b139742c..e6a7cb46a 100644 --- a/src/Dodge/Placements/LightSource.hs +++ b/src/Dodge/Placements/LightSource.hs @@ -6,6 +6,7 @@ import Dodge.LevelGen.Data import Dodge.Room.Foreground import Dodge.Placements.Spot import Geometry +import Geometry.Vector3D import Dodge.Creature.Inanimate import Shape.Data import Dodge.Default @@ -17,17 +18,19 @@ mountLightOnShape :: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape -> Maybe Color -- ^ describing a possible color override for the shape -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement -mountLightOnShape shapeF mcol ls wallp lsp = ps0j (PutForeground . setCol $ shapeF wallp lsp) - . ps0 (PutLS $ ls {_lsPos = lsp}) +mountLightOnShape shapeF mcol ls wallp lsp@(V3 lx ly _) + = ps0j (PutForeground . setCol $ shapeF wallp lsp) + . ps0 (PutLS $ ls {_lsPos = lsp'}) where + lsp' = lsp -.-.- V3 x y 1 + -- hack! perturb the light position + V2 x y = rotateV 1 . (0.1 *.*) . normalizeV $ wallp -.- V2 lx ly setCol = maybe id colorSH mcol mountLightID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightID = mountLightOnShape f where - f wp (V3 x y z) = thinHighBar (z+5) wp pout - where - pout = V2 x y +.+ safeNormalizeV (V2 x y -.- wp) + f wp (V3 x y z) = thinHighBar z wp (V2 x y) redMID :: (Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement) -> Point2 -> Point3 -> Placement @@ -39,8 +42,8 @@ mountLight = redMID mountLightID mountLightLID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightLID = mountLightOnShape f where - f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp) - <> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos) + f wallpos (V3 x y z) = thinHighBar z wallposUp turnpos + <> thinHighBar z turnpos (V2 x y) where n = vNormal (wallpos -.- V2 x y) wallposUp = wallpos +.+ n @@ -52,9 +55,9 @@ mountLightL = redMID mountLightLID mountLightJID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightJID = mountLightOnShape f where - f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp turn1 - <> thinHighBar (z + 5) turn1 turn2 - <> thinHighBar (z + 5) turn2 (endpos `extendAway` turn2) + f wallpos (V3 x y z) = thinHighBar z wallposUp turn1 + <> thinHighBar z turn1 turn2 + <> thinHighBar z turn2 endpos where n = vNormal (wallpos -.- V2 x y) wallposUp = wallpos +.+ n @@ -69,15 +72,15 @@ mountLightJ = redMID mountLightJID mountLightlID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightlID = mountLightOnShape f where - f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp) - <> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos) + f wallpos (V3 x y z) = thinHighBar z wallposUp turnpos + <> thinHighBar z turnpos (V2 x y) where n = vNormal (V2 x y -.- wallpos) wallposUp = wallpos +.+ n turnpos = V2 x y +.+ n -mountLightll :: Point2 -> Point3 -> Placement -mountLightll = redMID mountLightlID +mountLightl :: Point2 -> Point3 -> Placement +mountLightl = redMID mountLightlID mountLightAID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightAID = mountLightOnShape f @@ -99,14 +102,23 @@ mountLightVCond f = updatePSToLevel 2 (const thePS) $ mountLightV 0 (V3 0 (-20) where thePS = PSLnk f id -mntLightCond :: ((Point2,Float) -> Bool) -> Placement -mntLightCond f = RandomPlacement $ takeOne [mountLightVCond f,mountLightACond f] +mntLight :: Point2 -> Point2 -> Placement +mntLight a b = RandomPlacement $ takeOne + [ mountLightV a (addZ 50 b) + , mountLight a (addZ 50 b) + , mountLightL a (addZ 50 b) + , mountLightJ a (addZ 50 b) + , mountLightl a (addZ 50 b) + ] + +mntLightLnkCond :: ((Point2,Float) -> Bool) -> Placement +mntLightLnkCond f = RandomPlacement $ takeOne [mountLightVCond f,mountLightACond f] mountLightVID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightVID = mountLightOnShape f where - f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (lxy `extendAway` wallposUp) - <> thinHighBar (z + 5) wallposDown (lxy `extendAway` wallposDown) + f wallpos (V3 x y z) = thinHighBar z wallposUp lxy + <> thinHighBar z wallposDown lxy where lxy = V2 x y n = vNormal (wallpos -.- lxy) @@ -117,13 +129,13 @@ mountLightV :: Point2 -> Point3 -> Placement mountLightV = redMID mountLightVID spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement -spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y h) 0) - $ sps0 $ PutForeground $ highPipe (h + 5) a b +spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y (h-5)) 0) + $ sps0 $ PutForeground $ thinHighBar h a b where V2 x y = 0.5 *.* (a +.+ b) -spanLightI :: Float -> Point2 -> Point2 -> Placement -spanLightI = spanColLightI 0.75 +spanLightI :: Point2 -> Point2 -> Placement +spanLightI = spanColLightI 0.75 50 extendAway :: Point2 -> Point2 -> Point2 extendAway p x = p +.+ safeNormalizeV (p -.- x) diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index cb1c7caa9..910f452e2 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -66,7 +66,7 @@ roomPadCut ps p = defaultRoom roomPillars :: Room roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2 where - plmnts = spanLightI 70 (V2 120 24) (V2 120 216) + plmnts = spanLightI (V2 120 24) (V2 120 216) : mountLightV (V2 12 12) (V3 25 25 70) : mountLightV (V2 228 228) (V3 215 215 70) : sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25)) @@ -100,9 +100,11 @@ glassSwitchBack = do manyDoors :: Int -> Tree (Either Room Room) manyDoors i = treeFromPost (replicate i (Left door)) $ Right door +-- TODO: partially combine a room tree into a room glassLesson :: RandomGen g => State g (Tree (Either Room Room)) glassLesson = do - corridors <- replicateM 3 $ Left <$> randomiseOutLinks corridor + i <- takeOne [1,2,3] + corridors <- replicateM i $ Left <$> randomiseOutLinks corridor return $ Node (Left botRoom) [deadRoom door,uppers, treeFromPost (Left door : corridors) $ Right door] where uppers = Node (Left door) [deadRoom topRoom] @@ -111,41 +113,48 @@ glassLesson = do botplmnts = [sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit - ,sPS (V2 50 50) 0 putLamp + ,RandomPlacement $ takeOne + [ spanLightI (V2 160 0) (V2 160 220) + , mountLightV (V2 180 200) (V3 160 180 50) + ] ] topplmnts = [windowLine (V2 100 200) (V2 100 0) ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit - ,sPS (V2 50 50) 0 putLamp + --,sPS (V2 50 50) 0 putLamp + ,RandomPlacement $ takeOne + [ spanLightI (V2 160 (-20)) (V2 160 220) + , mountLightV (V2 180 200) (V3 160 180 50) + ] ] -miniRoom1 :: RandomGen g => State g Room -miniRoom1 = do - wth <- state $ randomR (200,400) - hgt <- state $ randomR (400,600) - wllen <- state $ randomR (60,wth/2-40) - let hf = hgt/5 - cry <- randomRanges [--50+2*hf,30+3*hf - 50+3*hf,30+4*hf - ,50+4*hf,30+5*hf - ] - crx <- state $ randomR (wllen,wth-(wllen+40)) - let plmnts = [windowLine (V2 (wth-60) ( 40+hf)) (V2 wllen (40+hf)) - ,windowLine (V2 (wth-wllen) (40+2*hf)) (V2 60 (40+2*hf)) - ,windowLine (V2 (wth-60) ( 40+3*hf)) (V2 wllen (40+3*hf)) - ,windowLine (V2 (wth-wllen) (40+4*hf)) (V2 60 (40+4*hf)) - ,sPS (V2 crx cry) 0 $ PutCrit miniGunCrit - ,sPS (V2 (wth-20) (hgt/2+40)) 0 randC1 - ,sPS (V2 (wth/2) (hgt/2)) 0 putLamp - ,blockLine (V2 0 ( 40+1*hf)) (V2 wllen (40+1*hf)) - ,blockLine (V2 (wth-wllen) ( 40+2*hf)) (V2 wth (40+2*hf)) - ,blockLine (V2 0 ( 40+3*hf)) (V2 wllen (40+3*hf)) - ,blockLine (V2 (wth-wllen) ( 40+4*hf)) (V2 wth (40+4*hf)) - ] - return $ set rmPS plmnts $ shiftRoomBy (V2 0 40,0) $ roomRect wth hgt 2 4 +glassSwitchback1 :: RandomGen g => State g Room +glassSwitchback1 = do + wth <- state $ randomR (200,400) + hgt <- state $ randomR (400,600) + wllen <- state $ randomR (60,wth/2-40) + let hf = hgt/5 + cry <- randomRanges [--50+2*hf,30+3*hf + 50+3*hf,30+4*hf + ,50+4*hf,30+5*hf + ] + crx <- state $ randomR (wllen,wth-(wllen+40)) + let plmnts = [windowLine (V2 (wth-60) ( 40+hf)) (V2 wllen (40+hf)) + ,windowLine (V2 (wth-wllen) (40+2*hf)) (V2 60 (40+2*hf)) + ,windowLine (V2 (wth-60) ( 40+3*hf)) (V2 wllen (40+3*hf)) + ,windowLine (V2 (wth-wllen) (40+4*hf)) (V2 60 (40+4*hf)) + ,sPS (V2 crx cry) 0 $ PutCrit miniGunCrit + ,sPS (V2 (wth-20) (hgt/2+40)) 0 randC1 + ,sPS (V2 (wth/2) (hgt/2)) 0 putLamp + ,blockLine (V2 0 ( 40+1*hf)) (V2 wllen (40+1*hf)) + ,blockLine (V2 (wth-wllen) ( 40+2*hf)) (V2 wth (40+2*hf)) + ,blockLine (V2 0 ( 40+3*hf)) (V2 wllen (40+3*hf)) + ,blockLine (V2 (wth-wllen) ( 40+4*hf)) (V2 wth (40+4*hf)) + ] + return $ set rmPS plmnts $ shiftRoomBy (V2 0 40,0) $ roomRect wth hgt 2 4 miniTree2 :: RandomGen g => State g (Tree (Either Room Room)) -miniTree2 = miniRoom1 +miniTree2 = glassSwitchback1 >>= randomiseOutLinks >>= changeLinkTo (\p -> (sndV2 . fst) p < 70) <&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd) diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index a34bd8358..afb658087 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -30,7 +30,7 @@ airlock0 = defaultRoom [Placement (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id) $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2 $ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing - ,spanLightI 70 (V2 (-2) 30) (V2 (-2) 70) + ,spanLightI (V2 (-2) 30) (V2 (-2) 70) ,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50) ] , _rmBound = [rectNSWE 75 15 0 40] @@ -82,8 +82,7 @@ airlockZ = defaultRoom $ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps) $ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps) , sps0 $ PutWall (rectNSEW 70 50 120 60) defaultWall - , mountLightV (V2 90 60) (V3 90 40 50) - , mountLightV (V2 90 60) (V3 90 80 50) + , lighting ] , _rmBound = [ rectNSWE 120 0 0 180 ] @@ -93,6 +92,10 @@ airlockZ = defaultRoom col = dim $ dim $ bright red outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 0 (-61)) inDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 (-61) 0) + cenlight = mountLightV (V2 90 60) (V3 90 40 50) `addPlmnt` mountLightV (V2 90 60) (V3 90 80 50) + cornlight = mountLightV (V2 0 120) (V3 30 90 50) `addPlmnt` mountLightV (V2 180 120) (V3 150 90 50) + `addPlmnt` sps0 (PutForeground (thinHighBar 50 (V2 30 90) (V2 150 90))) + lighting = RandomPlacement $ takeOne [cenlight,cornlight] airlock90 :: Room airlock90 = defaultRoom diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs index 2a69ee9e1..d0c1166ad 100644 --- a/src/Dodge/Room/Boss.hs +++ b/src/Dodge/Room/Boss.hs @@ -1,6 +1,4 @@ -{- -Rooms containing particularly challenging creatures, that may drop useful loot. --} +{- Rooms containing particularly challenging creatures, that may drop useful loot. -} module Dodge.Room.Boss where import Dodge.Data @@ -37,7 +35,7 @@ roomGlassOctogon x = createPathGrid $ defaultRoom , ( V2 0 (-(x+40)), V2 0 x) ] , _rmPS = - [sPS (V2 fx fx) 0 putLamp + [sPS (V2 fx fx) 0 putLamp ,sPS (V2 (-fx) fx) 0 putLamp ,sPS (V2 fx (-fx)) 0 putLamp ,sPS (V2 (-fx) (-fx)) 0 putLamp @@ -97,8 +95,8 @@ roomCross x y = defaultRoom ] , _rmPath = [] , _rmPS = - [ spanLightI 70 (V2 (x+5) x) (V2 (x+5) (-x)) - , spanLightI 70 (V2 (-x-5) x) (V2 (-x-5) (-x)) + [ spanLightI (V2 (x+5) x) (V2 (x+5) (-x)) + , spanLightI (V2 (-x-5) x) (V2 (-x-5) (-x)) ] , _rmBound = [rectNSWE y (-y) (-x) x diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index d1852efd5..990098715 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -17,7 +17,7 @@ corridor = defaultRoom { _rmPolys = [poly] , _rmLinks = lnks , _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks - , _rmPS = [ spanLightI 50 (V2 0 40) (V2 40 40) ] + , _rmPS = [ spanLightI (V2 0 40) (V2 40 40) ] , _rmBound = [ rectNSWE 50 30 0 40 ] , _rmFloor = [makeTileFromPoly poly 2] } diff --git a/src/Dodge/Room/Data.hs b/src/Dodge/Room/Data.hs index 095cf8d59..74cd87725 100644 --- a/src/Dodge/Room/Data.hs +++ b/src/Dodge/Room/Data.hs @@ -6,6 +6,8 @@ import Dodge.LevelGen.Data import Geometry.Data import Data.Tile +import Control.Monad.State +import System.Random import Control.Lens {- The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room. @@ -27,5 +29,6 @@ data Room = Room , _rmName :: String , _rmShift :: (Point2, Float) , _rmViewpoints :: [Point2] + , _rmRandPSs :: [State StdGen (Point2,Float)] } makeLenses ''Room diff --git a/src/Dodge/Room/Furniture.hs b/src/Dodge/Room/Furniture.hs index ed02459a6..a11e27d45 100644 --- a/src/Dodge/Room/Furniture.hs +++ b/src/Dodge/Room/Furniture.hs @@ -46,6 +46,16 @@ tankRectCross w h col x y = shiftPlacement (V2 x y,0) $ ps0j tankSquareCross :: Color -> Float -> Float -> Placement tankSquareCross = tankRectCross 20 20 +lowWall :: [Point2] -> Placement +lowWall ps = ps0j (PutForeground . colorSH col $ upperPrismPoly 30 ps) + $ sps0 $ PutWall ps theWall + where + col = _wlColor defaultWall + theWall = defaultWall + { _wlOpacity = SeeAbove + , _wlDraw = False + } + tankRect :: Float -> Float -> Color -> Float -> Float -> Placement tankRect w h col x y = shiftPlacement (V2 x y,0) $ ps0j (PutForeground $ colorSH col diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 2274eaf5f..747900dec 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -71,9 +71,9 @@ roomRectAutoLinks :: Float -> Float -> Room roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)) {_rmPS = plmnts} where - plmnts = [mntLightCond (const True)] + plmnts = [mntLightLnkCond (const True)] {- Combines two rooms into one room. -Combines into one big bound, concatenates the rest. -} +Mostly involves concatenation. -} combineRooms :: Room -> Room -> Room combineRooms r r' = defaultRoom { _rmPolys = _rmPolys r ++ _rmPolys r' diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index c8ccbf273..8cedbed5e 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -1,15 +1,16 @@ -{- -Connecting rooms designed with a pass-through technique in mind. --} +{- Connecting rooms designed with a pass-through technique in mind. -} module Dodge.Room.RoadBlock where import Geometry +--import Dodge.Data import Dodge.Default.Room import Dodge.Room.Data import Dodge.Room.Link import Dodge.Placements import Dodge.Room.Corridor +import Dodge.Room.Furniture import Dodge.LevelGen.Data +--import Dodge.Default.Wall --import Dodge.RandomHelp import Dodge.Creature import Dodge.Layout.Tree.Polymorphic @@ -42,7 +43,7 @@ litCorridor90 = do ] , _rmPS = [ sPS (V2 20 (h-5)) 0 putLamp - , spanLightI 70 (V2 0 (0.4*h)) (V2 40 (0.4*h)) + , spanLightI (V2 0 (0.4*h)) (V2 40 (0.4*h)) , windowLine (V2 0 (h-20)) (V2 40 (h-20)) , sPS (V2 (-50) (h-85)) 0 putLamp , windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100)) @@ -52,11 +53,7 @@ litCorridor90 = do , _rmBound = [poly] } -noWeaponTest :: State g (Tree (Either Room Room)) -noWeaponTest = do - undefined - --- | A random length corridor with a descrutible block blocking it. +-- | A random length corridor with a destructible block blocking it. longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room)) longBlockedCorridor = do r <- state $ randomR (0,pi) @@ -68,13 +65,28 @@ longBlockedCorridor = do sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor) $ return $ Right $ set rmPS plmnts corridor --- | A single corridor with a descrutible block blocking it. +-- | A single corridor with a destructible block blocking it. blockedCorridor :: RandomGen g => State g (Tree (Either Room Room)) blockedCorridor = do r <- state $ randomR (0,pi) let plmnts = [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256) 0 ( 250/256)) $ reverse $ rectNSWE 10 (-10) (-10) 10 - ,spanLightI 55 (V2 0 15) (V2 40 15) + ,spanLightI (V2 0 15) (V2 40 15) ] sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor + +lasTunnel :: Room +lasTunnel = defaultRoom + { _rmPolys = polys + , _rmBound = polys + , _rmLinks = [(V2 20 190,1.5* pi),(V2 0 20,0.5* pi)] + , _rmPS = [putLasTurret & placementSpot .~ PS (V2 10 240) (1.5*pi) + , lowWall (rectNSEW 65 40 0 25) + , mountLightV (V2 50 10) (V3 40 20 50) + ] + } + where + polys = [rectNSWE 250 0 0 20 + , rectNSWE 80 0 0 60 + ] diff --git a/src/Dodge/Wall/Move.hs b/src/Dodge/Wall/Move.hs index 5c8d858c9..28ce486fa 100644 --- a/src/Dodge/Wall/Move.hs +++ b/src/Dodge/Wall/Move.hs @@ -1,10 +1,16 @@ +{-# LANGUAGE BangPatterns #-} module Dodge.Wall.Move - where + ( moveWallID + , moveWall + , moveWallIDToward + ) where import Dodge.Data +import Dodge.Base import Geometry import Dodge.Wall.Zone import Control.Lens +import qualified Data.IntMap.Strict as IM moveWallID :: Int -> (Point2,Point2) -> World -> World moveWallID wlid wlline w = case w ^? walls . ix wlid of Nothing -> w @@ -15,3 +21,16 @@ moveWall wlid wl wlline w = w & walls . ix wlid .~ newwl & insertWallInZones newwl where newwl = wl {_wlLine = wlline} +moveWallIDToward :: Int -> Float -> (Point2,Point2) -> World -> World +moveWallIDToward wlid speed ep w = moveWall wlid wl newwlline w + where + wl = _walls w IM.! wlid + newwlline = mvPs speed ep (_wlLine wl) + +mvP :: Float -> Point2 -> Point2 -> Point2 +{-# INLINE mvP #-} +mvP !speed !ep !p = mvPointTowardAtSpeed speed ep p + +mvPs :: Float -> (Point2,Point2) -> (Point2,Point2) -> (Point2,Point2) +{-# INLINE mvPs #-} +mvPs !speed (!ex,!ey) (!sx,!sy) = (mvP speed ex sx,mvP speed ey sy)