justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup. Add room-wise random placement spots

Browse Source
This commit is contained in:
justin
2021-11-07 19:46:14 +00:00
parent f380e140e1
commit 5681a37953
18 changed files with 179 additions and 141 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
-1
View File
@@ -582,7 +582,6 @@ data Door = Door
, _drStatus :: DoorStatus , _drStatus :: DoorStatus
, _drTrigger :: World -> Bool , _drTrigger :: World -> Bool
, _drMech :: Door -> World -> World , _drMech :: Door -> World -> World
, _drCoord :: Int
} }
data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
src/Dodge/Default/Room.hs
+1
View File
@@ -15,4 +15,5 @@ defaultRoom = Room
, _rmName = "defaultRoom" , _rmName = "defaultRoom"
, _rmShift = (V2 0 0 , 0) , _rmShift = (V2 0 0 , 0)
, _rmViewpoints = [] , _rmViewpoints = []
, _rmRandPSs = []
} }
src/Dodge/Floor.hs
+5
View File
@@ -37,6 +37,11 @@ initialRoomTree = do
,[Corridor] ,[Corridor]
,[AirlockAno] ,[AirlockAno]
,[Corridor] ,[Corridor]
,[Corridor]
,[SpecificRoom $ fmap connectRoom glassSwitchBack]
,[Corridor]
,[SpecificRoom $ return $ connectRoom lasTunnel ]
,[Corridor]
,[SpecificRoom $ fmap connectRoom slowDoorRoom ] ,[SpecificRoom $ fmap connectRoom slowDoorRoom ]
,[Corridor] ,[Corridor]
,[Corridor] ,[Corridor]
src/Dodge/Item/Equipment.hs
+1
View File
@@ -56,6 +56,7 @@ flatShield = defaultEquipment
{ _itEquipPict = pictureWeaponOnAim flatShieldEquipSPic { _itEquipPict = pictureWeaponOnAim flatShieldEquipSPic
, _itAimStance = TwoHandFlat , _itAimStance = TwoHandFlat
, _itEffect = effectOnOffEquip createShieldWall removeShieldWall , _itEffect = effectOnOffEquip createShieldWall removeShieldWall
, _itName = "SHIELD"
} }
flatShieldEquipSPic :: Item -> SPic flatShieldEquipSPic :: Item -> SPic
flatShieldEquipSPic _ = flatShieldEquipSPic _ =
src/Dodge/Layout.hs
+18 -4
View File
@@ -62,23 +62,37 @@ generateLevelFromRoomList gr w
-- this should PutNothing if there are no links available -- this should PutNothing if there are no links available
-- first it takes the random placements and derandomises them -- first it takes the random placements and derandomises them
-- then it deals with link placement spots -- then it deals with link placement spots
-- TODO use state monad here
assignPlacementSpots :: StdGen -> Room -> (StdGen, [((Point2,Float),Placement)]) 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 where
(randPlmnts, detPlmnts) = partition isRand (_rmPS rm) (randPlmnts, detPlmnts) = partition isRand (_rmPS rm)
isRand RandomPlacement{} = True isRand RandomPlacement{} = True
isRand _ = False isRand _ = False
(unrandPlmnts, g'') = runState (mapM _unRandomPlacement randPlmnts) g (unrandPlmnts, g'') = runState (mapM (derandPlacement rm) (_rmPS rm)) g
(lnkplmnts, plmnts) = partition islnk (unrandPlmnts ++ detPlmnts) (lnkplmnts, plmnts) = partition islnk unrandPlmnts
--(lnkplmnts, plmnts) = partition islnk (unrandPlmnts ++ detPlmnts)
islnk Placement{_placementSpot=PSLnk{}} = True islnk Placement{_placementSpot=PSLnk{}} = True
islnk _ = False islnk _ = False
(shuffledLnks,g') = runState (shuffle $ _rmLinks rm) g'' (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 = f lnks plmnt =
let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks
thepair = _psLinkShift (_placementSpot plmnt) x thepair = _psLinkShift (_placementSpot plmnt) x
in (xs++ys, updatePS (updatePSLnkUsing thepair) plmnt) 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 :: (Point2,Float) -> PlacementSpot -> PlacementSpot
updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
updatePSLnkUsing _ ps = ps updatePSLnkUsing _ ps = ps
src/Dodge/LevelGen/Data.hs
+10
View File
@@ -33,6 +33,8 @@ data PlacementSpot
| PSLnk { _psLinkTest :: (Point2,Float) -> Bool | PSLnk { _psLinkTest :: (Point2,Float) -> Bool
, _psLinkShift :: (Point2,Float) -> (Point2,Float) , _psLinkShift :: (Point2,Float) -> (Point2,Float)
} }
| PSRoomRand
{ _psRoomRandPointNum :: Int }
data Placement = Placement data Placement = Placement
{ _placementSpot :: PlacementSpot { _placementSpot :: PlacementSpot
, _psType :: PSType , _psType :: PSType
@@ -68,6 +70,14 @@ jps0 pst = Just . Placement (PS (V2 0 0) 0) pst
ps0j :: PSType -> Placement -> Placement ps0j :: PSType -> Placement -> Placement
ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst (const $ Just plmnt) 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 ''PSType
makeLenses ''PlacementSpot makeLenses ''PlacementSpot
makeLenses ''Placement makeLenses ''Placement
src/Dodge/LevelGen/MoveDoor.hs
-40
View File
@@ -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
src/Dodge/LevelGen/TriggerDoor.hs
+3 -21
View File
@@ -2,17 +2,10 @@
module Dodge.LevelGen.TriggerDoor module Dodge.LevelGen.TriggerDoor
( placeDoor ( placeDoor
, placeSlideDoor , placeSlideDoor
--, addButtonDoor
) where ) where
import Dodge.Data import Dodge.Data
--import Dodge.Base
--import Dodge.Zone
import Dodge.Default.Wall import Dodge.Default.Wall
import Dodge.Wall.Move 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 Dodge.LevelGen.DoorPane
import Picture import Picture
import Geometry import Geometry
@@ -22,7 +15,6 @@ import Dodge.SoundLogic.LoadSound
import Dodge.Data.SoundOrigin import Dodge.Data.SoundOrigin
import Data.List import Data.List
--import Data.Maybe
import Control.Lens import Control.Lens
--import Data.Graph.Inductive hiding ((&)) --import Data.Graph.Inductive hiding ((&))
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
@@ -42,7 +34,6 @@ placeDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
, _drStatus = DoorInt 0 , _drStatus = DoorInt 0
, _drTrigger = cond , _drTrigger = cond
, _drMech = doorMechanismStepwise nsteps drid wlids pss , _drMech = doorMechanismStepwise nsteps drid wlids pss
, _drCoord = 0
} }
nsteps = length pss - 1 nsteps = length pss - 1
wlids = take 4 [IM.newKey $ _walls w ..] wlids = take 4 [IM.newKey $ _walls w ..]
@@ -77,7 +68,6 @@ doorMechanismStepwise nsteps drid wlids pss dr w
newps = uncurry (rectanglePairs 9) (pss !! n) newps = uncurry (rectanglePairs 9) (pss !! n)
-- it is not at all clear that the zoning selects the correct walls -- 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 :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door -> World -> World
doorMechanism drid speed wlidOpCps dr w doorMechanism drid speed wlidOpCps dr w
| toOpen && dstatus /= DoorOpen = moveUpdate $ foldl' doOpen w wlidOpCps | 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 | dist (fst wlpos) (fst cpos) < 1 = doors . ix drid . drStatus .~ DoorClosed
| otherwise = doors . ix drid . drStatus .~ DoorHalfway | otherwise = doors . ix drid . drStatus .~ DoorHalfway
(wlid',opos,cpos) = head wlidOpCps (wlid',opos,cpos) = head wlidOpCps
wlpos = _wlLine $ _walls w IM.! wlid' wlpos = _wlLine $ _walls w IM.! wlid'
toOpen = _drTrigger dr w toOpen = _drTrigger dr w
dstatus = _drStatus dr dstatus = _drStatus dr
doOpen w' (wlid,openpos,cp) = mvDoorWithZone w' wlid openpos cp doOpen w' (wlid,opp, _) = moveWallIDToward wlid speed opp w'
doClose w' (wlid,_,cp) = mvDoorWithZone w' wlid cp cp doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w'
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))
-- TODO cut pathing if not pathable, reset when opened -- TODO cut pathing if not pathable, reset when opened
placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World 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 , _drStatus = DoorClosed
, _drTrigger = cond , _drTrigger = cond
, _drMech = doorMechanism drid speed (zip3 wlids shiftedPairs pairs) , _drMech = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
, _drCoord = 0
} }
addWalls w' = foldl' addWall w' $ zip wlids pairs addWalls w' = foldl' addWall w' $ zip wlids pairs
addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
src/Dodge/Placements/LightSource.hs
+34 -22
View File
@@ -6,6 +6,7 @@ import Dodge.LevelGen.Data
import Dodge.Room.Foreground import Dodge.Room.Foreground
import Dodge.Placements.Spot import Dodge.Placements.Spot
import Geometry import Geometry
import Geometry.Vector3D
import Dodge.Creature.Inanimate import Dodge.Creature.Inanimate
import Shape.Data import Shape.Data
import Dodge.Default import Dodge.Default
@@ -17,17 +18,19 @@ mountLightOnShape
:: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape :: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
-> Maybe Color -- ^ describing a possible color override for the shape -> Maybe Color -- ^ describing a possible color override for the shape
-> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightOnShape shapeF mcol ls wallp lsp = ps0j (PutForeground . setCol $ shapeF wallp lsp) mountLightOnShape shapeF mcol ls wallp lsp@(V3 lx ly _)
. ps0 (PutLS $ ls {_lsPos = lsp}) = ps0j (PutForeground . setCol $ shapeF wallp lsp)
. ps0 (PutLS $ ls {_lsPos = lsp'})
where 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 setCol = maybe id colorSH mcol
mountLightID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightID = mountLightOnShape f mountLightID = mountLightOnShape f
where where
f wp (V3 x y z) = thinHighBar (z+5) wp pout f wp (V3 x y z) = thinHighBar z wp (V2 x y)
where
pout = V2 x y +.+ safeNormalizeV (V2 x y -.- wp)
redMID :: (Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement) redMID :: (Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement)
-> Point2 -> Point3 -> Placement -> Point2 -> Point3 -> Placement
@@ -39,8 +42,8 @@ mountLight = redMID mountLightID
mountLightLID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightLID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightLID = mountLightOnShape f mountLightLID = mountLightOnShape f
where where
f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp) f wallpos (V3 x y z) = thinHighBar z wallposUp turnpos
<> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos) <> thinHighBar z turnpos (V2 x y)
where where
n = vNormal (wallpos -.- V2 x y) n = vNormal (wallpos -.- V2 x y)
wallposUp = wallpos +.+ n wallposUp = wallpos +.+ n
@@ -52,9 +55,9 @@ mountLightL = redMID mountLightLID
mountLightJID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightJID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightJID = mountLightOnShape f mountLightJID = mountLightOnShape f
where where
f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp turn1 f wallpos (V3 x y z) = thinHighBar z wallposUp turn1
<> thinHighBar (z + 5) turn1 turn2 <> thinHighBar z turn1 turn2
<> thinHighBar (z + 5) turn2 (endpos `extendAway` turn2) <> thinHighBar z turn2 endpos
where where
n = vNormal (wallpos -.- V2 x y) n = vNormal (wallpos -.- V2 x y)
wallposUp = wallpos +.+ n wallposUp = wallpos +.+ n
@@ -69,15 +72,15 @@ mountLightJ = redMID mountLightJID
mountLightlID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightlID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightlID = mountLightOnShape f mountLightlID = mountLightOnShape f
where where
f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp) f wallpos (V3 x y z) = thinHighBar z wallposUp turnpos
<> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos) <> thinHighBar z turnpos (V2 x y)
where where
n = vNormal (V2 x y -.- wallpos) n = vNormal (V2 x y -.- wallpos)
wallposUp = wallpos +.+ n wallposUp = wallpos +.+ n
turnpos = V2 x y +.+ n turnpos = V2 x y +.+ n
mountLightll :: Point2 -> Point3 -> Placement mountLightl :: Point2 -> Point3 -> Placement
mountLightll = redMID mountLightlID mountLightl = redMID mountLightlID
mountLightAID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightAID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightAID = mountLightOnShape f mountLightAID = mountLightOnShape f
@@ -99,14 +102,23 @@ mountLightVCond f = updatePSToLevel 2 (const thePS) $ mountLightV 0 (V3 0 (-20)
where where
thePS = PSLnk f id thePS = PSLnk f id
mntLightCond :: ((Point2,Float) -> Bool) -> Placement mntLight :: Point2 -> Point2 -> Placement
mntLightCond f = RandomPlacement $ takeOne [mountLightVCond f,mountLightACond f] 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 :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightVID = mountLightOnShape f mountLightVID = mountLightOnShape f
where where
f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (lxy `extendAway` wallposUp) f wallpos (V3 x y z) = thinHighBar z wallposUp lxy
<> thinHighBar (z + 5) wallposDown (lxy `extendAway` wallposDown) <> thinHighBar z wallposDown lxy
where where
lxy = V2 x y lxy = V2 x y
n = vNormal (wallpos -.- lxy) n = vNormal (wallpos -.- lxy)
@@ -117,13 +129,13 @@ mountLightV :: Point2 -> Point3 -> Placement
mountLightV = redMID mountLightVID mountLightV = redMID mountLightVID
spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y h) 0) spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y (h-5)) 0)
$ sps0 $ PutForeground $ highPipe (h + 5) a b $ sps0 $ PutForeground $ thinHighBar h a b
where where
V2 x y = 0.5 *.* (a +.+ b) V2 x y = 0.5 *.* (a +.+ b)
spanLightI :: Float -> Point2 -> Point2 -> Placement spanLightI :: Point2 -> Point2 -> Placement
spanLightI = spanColLightI 0.75 spanLightI = spanColLightI 0.75 50
extendAway :: Point2 -> Point2 -> Point2 extendAway :: Point2 -> Point2 -> Point2
extendAway p x = p +.+ safeNormalizeV (p -.- x) extendAway p x = p +.+ safeNormalizeV (p -.- x)
src/Dodge/Room.hs
+38 -29
View File
@@ -66,7 +66,7 @@ roomPadCut ps p = defaultRoom
roomPillars :: Room roomPillars :: Room
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2 roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
where 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 12 12) (V3 25 25 70)
: mountLightV (V2 228 228) (V3 215 215 70) : mountLightV (V2 228 228) (V3 215 215 70)
: sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25)) : sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25))
@@ -100,9 +100,11 @@ glassSwitchBack = do
manyDoors :: Int -> Tree (Either Room Room) manyDoors :: Int -> Tree (Either Room Room)
manyDoors i = treeFromPost (replicate i (Left door)) $ Right door 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 :: RandomGen g => State g (Tree (Either Room Room))
glassLesson = do 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] return $ Node (Left botRoom) [deadRoom door,uppers, treeFromPost (Left door : corridors) $ Right door]
where where
uppers = Node (Left door) [deadRoom topRoom] uppers = Node (Left door) [deadRoom topRoom]
@@ -111,41 +113,48 @@ glassLesson = do
botplmnts = botplmnts =
[sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall [sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
,sPS (V2 50 100) 0 $ PutCrit miniGunCrit ,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 = topplmnts =
[windowLine (V2 100 200) (V2 100 0) [windowLine (V2 100 200) (V2 100 0)
,sPS (V2 50 100) 0 $ PutCrit miniGunCrit ,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 glassSwitchback1 :: RandomGen g => State g Room
miniRoom1 = do glassSwitchback1 = do
wth <- state $ randomR (200,400) wth <- state $ randomR (200,400)
hgt <- state $ randomR (400,600) hgt <- state $ randomR (400,600)
wllen <- state $ randomR (60,wth/2-40) wllen <- state $ randomR (60,wth/2-40)
let hf = hgt/5 let hf = hgt/5
cry <- randomRanges [--50+2*hf,30+3*hf cry <- randomRanges [--50+2*hf,30+3*hf
50+3*hf,30+4*hf 50+3*hf,30+4*hf
,50+4*hf,30+5*hf ,50+4*hf,30+5*hf
] ]
crx <- state $ randomR (wllen,wth-(wllen+40)) crx <- state $ randomR (wllen,wth-(wllen+40))
let plmnts = [windowLine (V2 (wth-60) ( 40+hf)) (V2 wllen (40+hf)) 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-wllen) (40+2*hf)) (V2 60 (40+2*hf))
,windowLine (V2 (wth-60) ( 40+3*hf)) (V2 wllen (40+3*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)) ,windowLine (V2 (wth-wllen) (40+4*hf)) (V2 60 (40+4*hf))
,sPS (V2 crx cry) 0 $ PutCrit miniGunCrit ,sPS (V2 crx cry) 0 $ PutCrit miniGunCrit
,sPS (V2 (wth-20) (hgt/2+40)) 0 randC1 ,sPS (V2 (wth-20) (hgt/2+40)) 0 randC1
,sPS (V2 (wth/2) (hgt/2)) 0 putLamp ,sPS (V2 (wth/2) (hgt/2)) 0 putLamp
,blockLine (V2 0 ( 40+1*hf)) (V2 wllen (40+1*hf)) ,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 (wth-wllen) ( 40+2*hf)) (V2 wth (40+2*hf))
,blockLine (V2 0 ( 40+3*hf)) (V2 wllen (40+3*hf)) ,blockLine (V2 0 ( 40+3*hf)) (V2 wllen (40+3*hf))
,blockLine (V2 (wth-wllen) ( 40+4*hf)) (V2 wth (40+4*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 return $ set rmPS plmnts $ shiftRoomBy (V2 0 40,0) $ roomRect wth hgt 2 4
miniTree2 :: RandomGen g => State g (Tree (Either Room Room)) miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
miniTree2 = miniRoom1 miniTree2 = glassSwitchback1
>>= randomiseOutLinks >>= randomiseOutLinks
>>= changeLinkTo (\p -> (sndV2 . fst) p < 70) >>= changeLinkTo (\p -> (sndV2 . fst) p < 70)
<&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd) <&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd)
src/Dodge/Room/Airlock.hs
+6 -3
View File
@@ -30,7 +30,7 @@ airlock0 = defaultRoom
[Placement (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id) [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 $ \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 $ 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) ,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
] ]
, _rmBound = [rectNSWE 75 15 0 40] , _rmBound = [rectNSWE 75 15 0 40]
@@ -82,8 +82,7 @@ airlockZ = defaultRoom
$ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps) $ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps)
$ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps) $ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps)
, sps0 $ PutWall (rectNSEW 70 50 120 60) defaultWall , sps0 $ PutWall (rectNSEW 70 50 120 60) defaultWall
, mountLightV (V2 90 60) (V3 90 40 50) , lighting
, mountLightV (V2 90 60) (V3 90 80 50)
] ]
, _rmBound = , _rmBound =
[ rectNSWE 120 0 0 180 ] [ rectNSWE 120 0 0 180 ]
@@ -93,6 +92,10 @@ airlockZ = defaultRoom
col = dim $ dim $ bright red col = dim $ dim $ bright red
outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 0 (-61)) 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) 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 :: Room
airlock90 = defaultRoom airlock90 = defaultRoom
src/Dodge/Room/Boss.hs
+4 -6
View File
@@ -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 module Dodge.Room.Boss
where where
import Dodge.Data import Dodge.Data
@@ -37,7 +35,7 @@ roomGlassOctogon x = createPathGrid $ defaultRoom
, ( V2 0 (-(x+40)), V2 0 x) , ( V2 0 (-(x+40)), V2 0 x)
] ]
, _rmPS = , _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 ,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 = [] , _rmPath = []
, _rmPS = , _rmPS =
[ spanLightI 70 (V2 (x+5) x) (V2 (x+5) (-x)) [ spanLightI (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))
] ]
, _rmBound = , _rmBound =
[rectNSWE y (-y) (-x) x [rectNSWE y (-y) (-x) x
src/Dodge/Room/Corridor.hs
+1 -1
View File
@@ -17,7 +17,7 @@ corridor = defaultRoom
{ _rmPolys = [poly] { _rmPolys = [poly]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) 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 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
, _rmFloor = [makeTileFromPoly poly 2] , _rmFloor = [makeTileFromPoly poly 2]
} }
src/Dodge/Room/Data.hs
+3
View File
@@ -6,6 +6,8 @@ import Dodge.LevelGen.Data
import Geometry.Data import Geometry.Data
import Data.Tile import Data.Tile
import Control.Monad.State
import System.Random
import Control.Lens import Control.Lens
{- {-
The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room. 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 , _rmName :: String
, _rmShift :: (Point2, Float) , _rmShift :: (Point2, Float)
, _rmViewpoints :: [Point2] , _rmViewpoints :: [Point2]
, _rmRandPSs :: [State StdGen (Point2,Float)]
} }
makeLenses ''Room makeLenses ''Room
src/Dodge/Room/Furniture.hs
+10
View File
@@ -46,6 +46,16 @@ tankRectCross w h col x y = shiftPlacement (V2 x y,0) $ ps0j
tankSquareCross :: Color -> Float -> Float -> Placement tankSquareCross :: Color -> Float -> Float -> Placement
tankSquareCross = tankRectCross 20 20 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 :: Float -> Float -> Color -> Float -> Float -> Placement
tankRect w h col x y = shiftPlacement (V2 x y,0) $ ps0j tankRect w h col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col (PutForeground $ colorSH col
src/Dodge/Room/Procedural.hs
+2 -2
View File
@@ -71,9 +71,9 @@ roomRectAutoLinks :: Float -> Float -> Room
roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)) roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60))
{_rmPS = plmnts} {_rmPS = plmnts}
where where
plmnts = [mntLightCond (const True)] plmnts = [mntLightLnkCond (const True)]
{- Combines two rooms into one room. {- Combines two rooms into one room.
Combines into one big bound, concatenates the rest. -} Mostly involves concatenation. -}
combineRooms :: Room -> Room -> Room combineRooms :: Room -> Room -> Room
combineRooms r r' = defaultRoom combineRooms r r' = defaultRoom
{ _rmPolys = _rmPolys r ++ _rmPolys r' { _rmPolys = _rmPolys r ++ _rmPolys r'
src/Dodge/Room/RoadBlock.hs
+23 -11
View File
@@ -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 module Dodge.Room.RoadBlock
where where
import Geometry import Geometry
--import Dodge.Data
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Link import Dodge.Room.Link
import Dodge.Placements import Dodge.Placements
import Dodge.Room.Corridor import Dodge.Room.Corridor
import Dodge.Room.Furniture
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
--import Dodge.Default.Wall
--import Dodge.RandomHelp --import Dodge.RandomHelp
import Dodge.Creature import Dodge.Creature
import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Polymorphic
@@ -42,7 +43,7 @@ litCorridor90 = do
] ]
, _rmPS = , _rmPS =
[ sPS (V2 20 (h-5)) 0 putLamp [ 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)) , windowLine (V2 0 (h-20)) (V2 40 (h-20))
, sPS (V2 (-50) (h-85)) 0 putLamp , sPS (V2 (-50) (h-85)) 0 putLamp
, windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100)) , windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100))
@@ -52,11 +53,7 @@ litCorridor90 = do
, _rmBound = [poly] , _rmBound = [poly]
} }
noWeaponTest :: State g (Tree (Either Room Room)) -- | A random length corridor with a destructible block blocking it.
noWeaponTest = do
undefined
-- | A random length corridor with a descrutible block blocking it.
longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room)) longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
longBlockedCorridor = do longBlockedCorridor = do
r <- state $ randomR (0,pi) r <- state $ randomR (0,pi)
@@ -68,13 +65,28 @@ longBlockedCorridor = do
sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor) sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor)
$ return $ Right $ set rmPS plmnts 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 :: RandomGen g => State g (Tree (Either Room Room))
blockedCorridor = do blockedCorridor = do
r <- state $ randomR (0,pi) r <- state $ randomR (0,pi)
let plmnts = let plmnts =
[sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256) 0 ( 250/256)) [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256) 0 ( 250/256))
$ reverse $ rectNSWE 10 (-10) (-10) 10 $ 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 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
]
src/Dodge/Wall/Move.hs
+20 -1
View File
@@ -1,10 +1,16 @@
{-# LANGUAGE BangPatterns #-}
module Dodge.Wall.Move module Dodge.Wall.Move
where ( moveWallID
, moveWall
, moveWallIDToward
) where
import Dodge.Data import Dodge.Data
import Dodge.Base
import Geometry import Geometry
import Dodge.Wall.Zone import Dodge.Wall.Zone
import Control.Lens import Control.Lens
import qualified Data.IntMap.Strict as IM
moveWallID :: Int -> (Point2,Point2) -> World -> World moveWallID :: Int -> (Point2,Point2) -> World -> World
moveWallID wlid wlline w = case w ^? walls . ix wlid of moveWallID wlid wlline w = case w ^? walls . ix wlid of
Nothing -> w Nothing -> w
@@ -15,3 +21,16 @@ moveWall wlid wl wlline w = w & walls . ix wlid .~ newwl
& insertWallInZones newwl & insertWallInZones newwl
where where
newwl = wl {_wlLine = wlline} 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)