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

Allow for random choice between placements in different rooms

Browse Source
This commit is contained in:
justin
2021-11-26 12:20:20 +00:00
parent aad79bdf25
commit 123bcd2c94
27 changed files with 260 additions and 191 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+1 -1
View File
@@ -110,7 +110,7 @@ data World = World
, _lClickHammer :: HammerPosition , _lClickHammer :: HammerPosition
, _distortions :: [Distortion] , _distortions :: [Distortion]
, _worldBounds :: Bounds , _worldBounds :: Bounds
, _gameRooms :: [GameRoom] , _gameRooms :: [GameRoom] -- consider using and IntMap
, _keyConfig :: KeyConfigSDL , _keyConfig :: KeyConfigSDL
, _config :: Configuration , _config :: Configuration
, _preloadData :: PreloadData , _preloadData :: PreloadData
src/Dodge/Default/Room.hs
+3
View File
@@ -26,4 +26,7 @@ defaultRoom = Room
, _rmStartWires = IM.empty , _rmStartWires = IM.empty
, _rmEndWires = IM.empty , _rmEndWires = IM.empty
, _rmConnectsTo = S.singleton OutLink , _rmConnectsTo = S.singleton OutLink
, _rmMID = Nothing
, _rmMParent = Nothing
, _rmChildren = []
} }
src/Dodge/Floor.hs
+21 -56
View File
@@ -1,36 +1,35 @@
{-# OPTIONS_GHC -Wno-unused-imports #-} --{-# OPTIONS_GHC -Wno-unused-imports #-}
{- | The tree of rooms that make up a level. -} {- | The tree of rooms that make up a level. -}
module Dodge.Floor module Dodge.Floor
( layoutLevelFromSeed ( initialRoomTree
) where ) where
import Geometry.Data --import Geometry.Data
import Dodge.Data --import Dodge.Data
import Dodge.LockAndKey import Dodge.LockAndKey
import Dodge.Creature.State.Data --import Dodge.Creature.State.Data
import Dodge.Room import Dodge.Room
import Dodge.Placement.Instance.Button --import Dodge.Placement.Instance.Button
import Dodge.Tree import Dodge.Tree
import Dodge.Annotation import Dodge.Annotation
import Dodge.Creature --import Dodge.Creature
import Dodge.LevelGen.Data --import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch --import Dodge.LevelGen.Switch
import Dodge.Item.Weapon.Launcher --import Dodge.Item.Weapon.Launcher
import Dodge.PlacementSpot --import Dodge.PlacementSpot
import Dodge.RoomPos --import Dodge.RoomPos
import Dodge.Room.RunPast --import Dodge.Room.RunPast
import MonadHelp --import MonadHelp
import Data.Tree import Data.Tree
import Color --import Color
import Dodge.Wire --import Dodge.Wire
import Control.Lens --import Control.Lens
import Control.Monad.State import Control.Monad.State
import Control.Monad.Loops --import Control.Monad.Loops
import System.Random import System.Random
import Data.Sequence hiding (zipWith) --import Data.Sequence hiding (zipWith)
import Data.Maybe --import Data.Maybe
import qualified Data.IntMap.Strict as IM --import qualified Data.IntMap.Strict as IM
initialAnoTree :: RandomGen g => Tree [Annotation g] initialAnoTree :: RandomGen g => Tree [Annotation g]
initialAnoTree = padSucWithCorridors $ treeFromTrunk initialAnoTree = padSucWithCorridors $ treeFromTrunk
@@ -98,38 +97,4 @@ initialRoomTree :: RandomGen g => State g (Tree Room)
initialRoomTree = do initialRoomTree = do
expandTree <$> mapM anoToRoomTree initialAnoTree expandTree <$> mapM anoToRoomTree initialAnoTree
layoutLevelFromSeed :: Int -> Int -> IO [Room]
layoutLevelFromSeed i seed = do
let i' = i + 1
putStrLn $ "Generating level with seed " ++ show seed
let g = mkStdGen seed
let rmtree = inorderNumberTree $ evalState initialRoomTree g
putStrLn "Abstract layout: "
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
mrs <- positionRoomsFromTree rmtree
case mrs of
Just rs -> do
putStrLn $ "After " ++ show i'
++ " attempt(s), Successful generation of level with seed "
++ show seed
--return (fmap setLastLinkToUsed rs)
putStrLn $ show (Prelude.length rs) ++ " rooms in total"
return rs
Nothing -> do
putStr $ "Level generation with seed " ++ show seed ++ " failed: "
let (seed',_) = random g
layoutLevelFromSeed i' seed'
compactDrawTree :: Tree String -> String
compactDrawTree = unlines . compactDraw
compactDraw :: Tree String -> [String]
compactDraw (Node x [Node y ts]) = compactDraw (Node (x++","++y) ts)
compactDraw (Node x ts0) = lines x ++ drawSubTrees ts0
where
drawSubTrees [] = []
drawSubTrees [t] =
"|" : compactDraw t
drawSubTrees (t:ts) =
"|" : shift "+- " "| " (compactDraw t) ++ drawSubTrees ts
shift first other = zipWith (++) (first : repeat other)
src/Dodge/Layout.hs
+42 -18
View File
@@ -15,6 +15,7 @@ import Dodge.GameRoom
import Dodge.Bounds import Dodge.Bounds
import Dodge.Default.Wall import Dodge.Default.Wall
import Dodge.Room.Link import Dodge.Room.Link
import Dodge.Randify
import Geometry import Geometry
import Geometry.Vector3D import Geometry.Vector3D
import Geometry.ConvexPoly import Geometry.ConvexPoly
@@ -35,35 +36,41 @@ import Data.Maybe
import Data.Function import Data.Function
import Control.Monad.State import Control.Monad.State
generateLevelFromRoomList :: [Room] -> World -> World generateLevelFromRoomList :: IM.IntMap Room -> World -> World
generateLevelFromRoomList gr' w generateLevelFromRoomList gr' w
= initWallZoning = initWallZoning
. setupWorldBounds . setupWorldBounds
. placeWires . placeWires
. doAfterPlacements
. doPartialPlacements . doPartialPlacements
. doExtendedPlacements . doExtendedPlacements
. flip (mapAccumR doRoomPlacements) rs' . doIndividualPlacements
. worldToGenWorld -- . flip (mapAccumR doRoomPlacements) (IM.elems rs')
. worldToGenWorld rs'
$ w { _walls = wallsFromRooms rs $ w { _walls = wallsFromRooms rs
, _floorTiles = floorsFromRooms rs , _floorTiles = floorsFromRooms rs
, _gameRooms = gameRoomsFromRooms rs' , _gameRooms = gameRoomsFromRooms (IM.elems rs')
, _pathGraph = path , _pathGraph = path
, _pathGraphP = pairPath , _pathGraphP = pairPath
} }
where where
path = pairsToGraph dist pairPath path = pairsToGraph dist pairPath
pairPath = concatMap _rmPath rs pairPath = concatMap _rmPath rs
zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w rs = map doRoomShift $ IM.elems rs'
rs = map doRoomShift rs' rs'= mapM (shuffleRoomPos >=> addRandomTile) gr' & evalState $ _randGen w
rs' = mapM shuffleRoomPos (zipWith addTile zs gr') & evalState $ _randGen w
addRandomTile :: RandomGen g => Room -> State g Room
addRandomTile r = do
z <- state $ randomR (0,63)
return $ addTile z r
shuffleRoomPos :: RandomGen g => Room -> State g Room shuffleRoomPos :: RandomGen g => Room -> State g Room
shuffleRoomPos rm = do shuffleRoomPos rm = do
newPos <- shuffle $ _rmPos rm newPos <- shuffle $ _rmPos rm
return $ rm & rmPos .~ newPos return $ rm & rmPos .~ newPos
placeWires :: (GenWorld,[Room])-> World placeWires :: GenWorld -> World
placeWires (w,rms) = foldr placeRoomWires (_gWorld w) rms placeWires w = foldr placeRoomWires (_gWorld w) $ _gRooms w
placeRoomWires :: Room -> World -> World placeRoomWires :: Room -> World -> World
placeRoomWires rm w = IM.foldr ($) w placeRoomWires rm w = IM.foldr ($) w
@@ -91,8 +98,18 @@ placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape
rightpleftq x = isRHS rmcen p x && isLHS rmcen q x rightpleftq x = isRHS rmcen p x && isLHS rmcen q x
rs = _rmShift rm rs = _rmShift rm
doPartialPlacements :: ( (IM.IntMap [Placement],GenWorld) , [Room] ) -> (GenWorld,[Room]) doAfterPlacements :: GenWorld -> GenWorld
doPartialPlacements ((im,w),rms) = mapAccumR (doPartialPlacement im) w rms doAfterPlacements gw = foldr doAfterPlacement gw (_gPlacements gw)
doAfterPlacement :: [(Placement,Int)] -> GenWorld -> GenWorld
doAfterPlacement pmntis gw = gRandify gw $ do
(pmnt,i) <- takeOne pmntis
let (newgw,rm) = fst $ placeSpot (gw,_gRooms gw IM.! i) pmnt
return $ newgw & gRooms . ix i .~ rm
doPartialPlacements :: ( IM.IntMap [Placement],GenWorld) -> GenWorld
doPartialPlacements (im,w) = let (gw,rms) = mapAccumR (doPartialPlacement im) w (_gRooms w)
in gw {_gRooms = rms}
doPartialPlacement :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room) doPartialPlacement :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room)
doPartialPlacement im w rm = case _rmPartPmnt rm of doPartialPlacement im w rm = case _rmPartPmnt rm of
@@ -101,8 +118,9 @@ doPartialPlacement im w rm = case _rmPartPmnt rm of
Nothing -> (w, rm) Nothing -> (w, rm)
Just i -> fst $ placeSpot (w,rm) (fi (im IM.! i)) Just i -> fst $ placeSpot (w,rm) (fi (im IM.! i))
doExtendedPlacements :: (GenWorld,[Room]) -> ( (IM.IntMap [Placement], GenWorld) , [Room] ) doExtendedPlacements :: GenWorld -> ( IM.IntMap [Placement], GenWorld)
doExtendedPlacements (w,rms) = mapAccumR doExtendedPlacement (IM.empty,w) rms doExtendedPlacements w = let ((pmnts,gw),rms) = mapAccumR doExtendedPlacement (IM.empty,w) (_gRooms w)
in (pmnts,gw{_gRooms = rms})
doExtendedPlacement :: (IM.IntMap [Placement], GenWorld) -> Room doExtendedPlacement :: (IM.IntMap [Placement], GenWorld) -> Room
-> ( (IM.IntMap [Placement], GenWorld) , Room ) -> ( (IM.IntMap [Placement], GenWorld) , Room )
@@ -113,6 +131,10 @@ doExtendedPlacement (im,w) rm = case _rmExtPmnt rm of
Just i -> let ((neww,newrm),plmnts) = placeSpot (w,rm) plmnt Just i -> let ((neww,newrm),plmnts) = placeSpot (w,rm) plmnt
in ( (IM.insert i plmnts im, neww) , newrm ) in ( (IM.insert i plmnts im, neww) , newrm )
doIndividualPlacements :: GenWorld -> GenWorld
doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_gRooms gw)
in gw' {_gRooms = rms}
doRoomPlacements :: GenWorld -> Room -> (GenWorld, Room) doRoomPlacements :: GenWorld -> Room -> (GenWorld, Room)
doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm
@@ -142,16 +164,18 @@ initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~
--makePath = concatMap _rmPath . flatten --makePath = concatMap _rmPath . flatten
wallsFromRooms :: [Room] -> IM.IntMap Wall wallsFromRooms :: [Room] -> IM.IntMap Wall
wallsFromRooms = wallsFromRooms = -- divideWalls .
-- divideWalls . IM.fromAscList
IM.fromList . zipWith f [0..] . removeInverseWalls . zipWith f [0..]
. foldl' (flip cutWalls) [] . concatMap _rmPolys . removeInverseWalls
. foldl' (flip cutWalls) []
. concatMap _rmPolys
where where
f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i}) f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})
-- TODO sort out shifting before or after etc -- TODO sort out shifting before or after etc
gameRoomsFromRooms :: [Room] -> [GameRoom] gameRoomsFromRooms :: [Room] -> [GameRoom]
gameRoomsFromRooms = map gameRoomFromRoom gameRoomsFromRooms = fmap gameRoomFromRoom
gameRoomFromRoom :: Room -> GameRoom gameRoomFromRoom :: Room -> GameRoom
gameRoomFromRoom rm = GameRoom gameRoomFromRoom rm = GameRoom
src/Dodge/LevelGen.hs
+43
View File
@@ -8,10 +8,14 @@ import Dodge.Floor
import Dodge.Layout import Dodge.Layout
import Dodge.Initialisation import Dodge.Initialisation
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.LevelGen.Data
import Dodge.Tree
import Data.Tree
import System.Random import System.Random
import Control.Lens import Control.Lens
import Control.Monad.State import Control.Monad.State
import qualified Data.IntMap.Strict as IM
generateWorldFromSeed :: Int -> IO World generateWorldFromSeed :: Int -> IO World
generateWorldFromSeed i = do generateWorldFromSeed i = do
@@ -21,3 +25,42 @@ generateWorldFromSeed i = do
randomCompass :: World -> World randomCompass :: World -> World
randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w) randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w)
layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room)
layoutLevelFromSeed i seed = do
let i' = i + 1
putStrLn $ "Generating level with seed " ++ show seed
let g = mkStdGen seed
let rmtree = inorderNumberTree $ evalState initialRoomTree g
putStrLn "Abstract layout: "
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
mrs <- positionRoomsFromTree rmtree
case mrs of
Just rs -> do
putStrLn $ "After " ++ show i'
++ " attempt(s), Successful generation of level with seed "
++ show seed
--return (fmap setLastLinkToUsed rs)
putStrLn $ show (Prelude.length rs) ++ " rooms in total"
return . IM.fromList $ map reversePair rs
Nothing -> do
putStr $ "Level generation with seed " ++ show seed ++ " failed: "
let (seed',_) = random g
layoutLevelFromSeed i' seed'
reversePair :: (a,b) -> (b,a)
reversePair (a,b) = (b,a)
compactDrawTree :: Tree String -> String
compactDrawTree = unlines . compactDraw
compactDraw :: Tree String -> [String]
compactDraw (Node x [Node y ts]) = compactDraw (Node (x++","++y) ts)
compactDraw (Node x ts0) = lines x ++ drawSubTrees ts0
where
drawSubTrees [] = []
drawSubTrees [t] =
"|" : compactDraw t
drawSubTrees (t:ts) =
"|" : shift "+- " "| " (compactDraw t) ++ drawSubTrees ts
shift first other = zipWith (++) (first : repeat other)
src/Dodge/LevelGen/Data.hs
+19 -15
View File
@@ -21,19 +21,18 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutButton Button | PutButton Button
| PutProp Prop | PutProp Prop
| PutFlIt Item | PutFlIt Item
| PutPressPlate PressPlate | PutPPlate PressPlate
| PutBlock BlockMaterial [Int] Wall [Point2] | PutBlock BlockMaterial Int [Int] Wall [Point2]
| PutCoordinate Point2 | PutCoord Point2
| PutMod Modification | PutMod Modification
| PutTrigger (World -> Bool) | PutTrigger (World -> Bool)
| PutLineBlock Wall BlockMaterial Float Float Point2 Point2 | PutLineBlock Wall BlockMaterial Float Float Point2 Point2
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
| PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float | PutSlideDr Bool Color (World -> Bool) Point2 Point2 Float
| PutDoor Color (World -> Bool) [(Point2,Point2)] | PutDoor Color (World -> Bool) [(Point2,Point2)]
| RandPS (State StdGen PSType) | RandPS (State StdGen PSType)
| PutForeground Shape | PutShape Shape
| PutWorldUpdate (PlacementSpot -> World -> World) | PutWorldUpdate (PlacementSpot -> World -> World)
| AddToPList Int PSType
| PutNothing | PutNothing
| PutID { _putID :: Int} | PutID { _putID :: Int}
-- maybe there is a monadic implementation of this? -- maybe there is a monadic implementation of this?
@@ -49,15 +48,16 @@ data PlacementSpot
{ _psRoomRandPointNum :: Int { _psRoomRandPointNum :: Int
, _psRandShift :: (Point2,Float) -> PlacementSpot , _psRandShift :: (Point2,Float) -> PlacementSpot
} }
data Placement = Placement data Placement
{ _plSpot :: PlacementSpot = Placement
, _plType :: PSType { _plSpot :: PlacementSpot
, _plMID :: Maybe Int , _plType :: PSType
, _plIDCont :: Placement -> Maybe Placement , _plMID :: Maybe Int
} , _plIDCont :: Placement -> Maybe Placement
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position }
| RandomPlacement {_unRandomPlacement :: State StdGen Placement} | PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
| RandomPlacement {_unRandomPlacement :: State StdGen Placement}
| PickOnePlacement Int Placement
{- The '_rmPolys' lists which polygons should be cut out to form the indestructible walls of the room. {- The '_rmPolys' lists which polygons should be cut out to form the indestructible walls of the room.
Link pairs contain a position and rotation to attach to another room; Link pairs contain a position and rotation to attach to another room;
@@ -89,6 +89,9 @@ data Room = Room
, _rmStartWires :: IM.IntMap RoomWire , _rmStartWires :: IM.IntMap RoomWire
, _rmEndWires :: IM.IntMap RoomWire , _rmEndWires :: IM.IntMap RoomWire
, _rmConnectsTo :: S.Set RoomLinkType , _rmConnectsTo :: S.Set RoomLinkType
, _rmMID :: Maybe Int
, _rmMParent :: Maybe Int
, _rmChildren :: [Int]
} }
data RoomLink = RoomLink data RoomLink = RoomLink
{ _rlType :: S.Set RoomLinkType { _rlType :: S.Set RoomLinkType
@@ -212,6 +215,7 @@ addPlmnt pl pl2 = case pl2 of
(PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f) (PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f)
(RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp (RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
(Placement ps pt mi f) -> Placement ps pt mi (fmap g f) (Placement ps pt mi f) -> Placement ps pt mi (fmap g f)
PickOnePlacement {} -> error "not written how to combine PickOnePlacement with others yet"
where where
g Nothing = Just pl g Nothing = Just pl
g (Just pl') = Just $ addPlmnt pl pl' g (Just pl') = Just $ addPlmnt pl pl'
src/Dodge/LevelGen/LevelStructure.hs
+8 -2
View File
@@ -12,7 +12,13 @@ import Control.Lens
data GenWorld = GenWorld data GenWorld = GenWorld
{ _gWorld :: World { _gWorld :: World
, _gPlacements :: IM.IntMap [Placement] , _gPlacements :: IM.IntMap [(Placement,Int)]
, _gRooms :: IM.IntMap Room
}
worldToGenWorld :: IM.IntMap Room -> World -> GenWorld
worldToGenWorld rms w = GenWorld
{ _gWorld = w
, _gPlacements = IM.empty
, _gRooms = rms
} }
worldToGenWorld w = GenWorld w IM.empty
makeLenses ''GenWorld makeLenses ''GenWorld
src/Dodge/Placement/Instance/Door.hs
+4 -4
View File
@@ -15,8 +15,8 @@ putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a
putDoubleDoorThen :: Bool -> Color -> (World -> Bool) putDoubleDoorThen :: Bool -> Color -> (World -> Bool)
-> Point2 -> Point2 -> Float -> Maybe Placement -> Placement -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed) putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDr pathing col cond a half speed)
$ Placement (PS (V2 0 0) 0) ( PutSlideDoor pathing col cond b half speed) Nothing $ const mayp $ Placement (PS (V2 0 0) 0) ( PutSlideDr pathing col cond b half speed) Nothing $ const mayp
where where
half = 0.5 *.* (a +.+ b) half = 0.5 *.* (a +.+ b)
@@ -33,8 +33,8 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a)
switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeSwitch col red id id) switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeSwitch col red id id)
$ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2) $ \btid -> jsps0J (PutSlideDr False col (cond btid) dra drc 2)
$ sps0 (PutSlideDoor False col (cond btid) drb drc 2) $ sps0 (PutSlideDr False col (cond btid) drb drc 2)
where where
drc = 0.5 *.* (dra +.+ drb) drc = 0.5 *.* (dra +.+ drb)
cond btid w' = _btState (_buttons w' IM.! btid) == BtOn cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
src/Dodge/Placement/Instance/LightSource.hs
+4 -4
View File
@@ -20,7 +20,7 @@ mntLSOn
-> Maybe Color -- ^ describing a possible color override for the shape -> Maybe Color -- ^ describing a possible color override for the shape
-> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement -> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
= ps0jPushPS (PutForeground . setCol $ shapeF wallp lsp) = ps0jPushPS (PutShape . setCol $ shapeF wallp lsp)
. pt0 (PutLS $ ls {_lsPos = lsp'}) . pt0 (PutLS $ ls {_lsPos = lsp'})
where where
lsp' = lsp -.-.- V3 x y 1 lsp' = lsp -.-.- V3 x y 1
@@ -106,20 +106,20 @@ unusedLnkToPS rp _ = case rp of
spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
spanLSLightI ls h a b = ps0j (PutLS ls {_lsPos = V3 x y h}) spanLSLightI ls h a b = ps0j (PutLS ls {_lsPos = V3 x y h})
$ sps0 $ PutForeground $ thinHighBar h a b $ sps0 $ PutShape $ thinHighBar h a b
where where
V2 x y = 0.5 *.* (a +.+ b) V2 x y = 0.5 *.* (a +.+ b)
spanLS :: LightSource -> Point2 -> Point2 -> Placement spanLS :: LightSource -> Point2 -> Point2 -> Placement
spanLS ls a b = Placement (PS (V2 x y) 0) (PutLS ls) Nothing spanLS ls a b = Placement (PS (V2 x y) 0) (PutLS ls) Nothing
$ const $ Just $ sps0 $ PutForeground $ thinHighBar h a b $ const $ Just $ sps0 $ PutShape $ thinHighBar h a b
where where
V3 _ _ h = _lsPos ls + 5 V3 _ _ h = _lsPos ls + 5
V2 x y = 0.5 *.* (a +.+ b) V2 x y = 0.5 *.* (a +.+ b)
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-5)) 0) spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y (h-5)) 0)
$ sps0 $ PutForeground $ thinHighBar h a b $ sps0 $ PutShape $ thinHighBar h a b
where where
V2 x y = 0.5 *.* (a +.+ b) V2 x y = 0.5 *.* (a +.+ b)
src/Dodge/Placement/Instance/Tank.hs
+6 -6
View File
@@ -12,7 +12,7 @@ import Color
roundTank :: Color -> Float -> Float -> Placement roundTank :: Color -> Float -> Float -> Placement
roundTank col x y = shiftPlacement (V2 x y,0) $ ps0j roundTank col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col $ (PutShape $ colorSH col $
upperPrismPoly 31 thecircle upperPrismPoly 31 thecircle
<> foldMap toprail ( take 8 [0,pi/4..]) <> foldMap toprail ( take 8 [0,pi/4..])
) )
@@ -23,7 +23,7 @@ roundTank col x y = shiftPlacement (V2 x y,0) $ ps0j
roundTankCross :: Color -> Float -> Float -> Placement roundTankCross :: Color -> Float -> Float -> Placement
roundTankCross col x y = shiftPlacement (V2 x y,0) $ ps0j roundTankCross col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col $ (PutShape $ colorSH col $
upperPrismPoly 31 thecircle upperPrismPoly 31 thecircle
<> thinHighBar 31 (V2 20 0) (V2 (-20) 0) <> thinHighBar 31 (V2 20 0) (V2 (-20) 0)
<> thinHighBar 31 (V2 0 20) (V2 0 (-20)) <> thinHighBar 31 (V2 0 20) (V2 0 (-20))
@@ -34,7 +34,7 @@ roundTankCross col x y = shiftPlacement (V2 x y,0) $ ps0j
tankRectCross :: Float -> Float -> Color -> Float -> Float -> Placement tankRectCross :: Float -> Float -> Color -> Float -> Float -> Placement
tankRectCross w h col x y = shiftPlacement (V2 x y,0) $ ps0j tankRectCross w h col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col $ (PutShape $ colorSH col $
upperPrismPoly 31 therect upperPrismPoly 31 therect
<> thinHighBar 31 (V2 w 0) (V2 (-w) 0) <> thinHighBar 31 (V2 w 0) (V2 (-w) 0)
<> thinHighBar 31 (V2 0 h) (V2 0 (-h)) <> thinHighBar 31 (V2 0 h) (V2 0 (-h))
@@ -49,7 +49,7 @@ tankSquareCross = tankRectCross 20 20
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 (PutShape $ colorSH col
$ upperPrismPoly 31 therect $ upperPrismPoly 31 therect
<> foldMap f [(w',-w',h',h'),(w',-w',-h',-h'),(w',w',h',-h'),(-w',-w',h',-h')] <> foldMap f [(w',-w',h',h'),(w',-w',-h',-h'),(w',w',h',-h'),(-w',-w',h',-h')]
) )
@@ -65,7 +65,7 @@ tankSquare = tankRect 20 20
tankRectEmboss :: Float -> Float -> Color -> Float -> Float -> Placement tankRectEmboss :: Float -> Float -> Color -> Float -> Float -> Placement
tankRectEmboss w h col x y = shiftPlacement (V2 x y,0) $ ps0j tankRectEmboss w h col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col $ (PutShape $ colorSH col $
upperPrismPoly 31 therect upperPrismPoly 31 therect
<> embossingR <> embossingR
<> rotateSH pi embossingR <> rotateSH pi embossingR
@@ -84,7 +84,7 @@ tankSquareEmboss = tankRectEmboss 20 20
tankRectEmboss4 :: Float -> Float -> Color -> Float -> Float -> Placement tankRectEmboss4 :: Float -> Float -> Color -> Float -> Float -> Placement
tankRectEmboss4 w h col x y = shiftPlacement (V2 x y,0) $ ps0j tankRectEmboss4 w h col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col $ (PutShape $ colorSH col $
upperPrismPoly 31 therect upperPrismPoly 31 therect
<> foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)] <> foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
) )
src/Dodge/Placement/Instance/Wall.hs
+4 -4
View File
@@ -11,7 +11,7 @@ import Data.List
import Control.Lens import Control.Lens
heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement
heightWallPS spot h ps = psj spot (PutForeground . colorSH col $ upperPrismPoly h ps) heightWallPS spot h ps = psj spot (PutShape . colorSH col $ upperPrismPoly h ps)
$ sps spot $ PutWall ps theWall $ sps spot $ PutWall ps theWall
where where
col = _wlColor defaultWall col = _wlColor defaultWall
@@ -22,7 +22,7 @@ heightWallPS spot h ps = psj spot (PutForeground . colorSH col $ upperPrismPoly
} }
heightWall :: Float -> [Point2] -> Placement heightWall :: Float -> [Point2] -> Placement
heightWall h ps = ps0j (PutForeground . colorSH col $ upperPrismPoly h ps) heightWall h ps = ps0j (PutShape . colorSH col $ upperPrismPoly h ps)
$ sps0 $ PutWall ps theWall $ sps0 $ PutWall ps theWall
where where
col = _wlColor defaultWall col = _wlColor defaultWall
@@ -33,7 +33,7 @@ heightWall h ps = ps0j (PutForeground . colorSH col $ upperPrismPoly h ps)
} }
midWall :: [Point2] -> Placement midWall :: [Point2] -> Placement
midWall ps = ps0j (PutForeground . colorSH col $ upperPrismPoly 50 ps) midWall ps = ps0j (PutShape . colorSH col $ upperPrismPoly 50 ps)
$ sps0 $ PutWall ps theWall $ sps0 $ PutWall ps theWall
where where
col = _wlColor defaultWall col = _wlColor defaultWall
@@ -47,7 +47,7 @@ midWall ps = ps0j (PutForeground . colorSH col $ upperPrismPoly 50 ps)
singleBlock :: Point2 -> [Placement] singleBlock :: Point2 -> [Placement]
singleBlock a = singleBlock a =
[sPS a 0 [sPS a 0
$ PutBlock StoneBlock [5,20,20] baseBlockPane $ PutBlock StoneBlock 5 [20,20] baseBlockPane
$ reverse $ reverse
$ square 10 $ square 10
] ]
src/Dodge/Placement/PlaceSpot.hs
+52 -38
View File
@@ -22,6 +22,7 @@ import Shape
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import Color import Color
import Data.Maybe
import System.Random import System.Random
import Control.Monad.State import Control.Monad.State
import Control.Lens import Control.Lens
@@ -34,23 +35,34 @@ placeSpot :: (GenWorld,Room) -> Placement -> ( (GenWorld,Room), [Placement] )
placeSpot (w,rm) plmnt = case plmnt of placeSpot (w,rm) plmnt = case plmnt of
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
Placement{} -> Placement{} -> placePlainPSSpot w rm plmnt shift
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
newplmnt = plmnt & plMID ?~ i
in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
where
recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
in (wr,newplmnt:newplmnts)
-- (placeSpot (w',rm)) (_plIDCont plmnt i)
PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p)) PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
RandomPlacement rplmnt -> placeSpot (w & gWorld . randGen .~ g,rm) plmnt' RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm
where PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), [])
(plmnt', g) = runState rplmnt (_randGen $ _gWorld w)
where where
shift = _rmShift rm shift = _rmShift rm
placePickOne :: Int -> Placement -> Room -> GenWorld -> GenWorld
placePickOne i pl rm w = w & gPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld,Room),[Placement])
placeRandomPlacement rplmnt w rm = placeSpot (w & gWorld . randGen .~ g,rm) plmnt'
where
(plmnt', g) = runState rplmnt (_randGen $ _gWorld w)
placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room),[Placement])
placePlainPSSpot w rm plmnt shift =
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
newplmnt = plmnt & plMID ?~ i
in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
where
recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
in (wr,newplmnt:newplmnts)
-- this should be tidied up -- this should be tidied up
placeSpotUsingLink :: GenWorld -> Room -> Placement placeSpotUsingLink :: GenWorld
-> Room
-> Placement
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
-> (RoomPos -> Room -> Room) -> (RoomPos -> Room -> Room)
-> Maybe Placement -> Maybe Placement
@@ -66,44 +78,47 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r
Nothing -> second (pos:) <$> searchedPoss poss Nothing -> second (pos:) <$> searchedPoss poss
Just (ps,rmpos) -> Just ( ps,rmpos:poss) Just (ps,rmpos) -> Just ( ps,rmpos:poss)
placeSpotRoomRand :: Room -> Int -> ((Point2,Float) -> PlacementSpot) placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot)
-> Placement -> GenWorld -> ((GenWorld,Room),[Placement]) -> Placement -> GenWorld -> ((GenWorld,Room),[Placement])
placeSpotRoomRand rm i f plmnt w = placeSpotRoomRand rm i f plmnt w =
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gWorld w) let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gWorld w)
in placeSpot (w & gWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps) in placeSpot (w & gWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps)
-- the Int here is some id that is assigned when the placement is placed -- the Int here is some id that is assigned when the placement is placed
placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld) placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
placeSpotID ps pt w = case pt of placeSpotID ps pt w = case pt of
PutTrigger cond -> placeNewInto triggers cond w PutTrigger cnd -> placeNewInto triggers cnd w
PutMod modi -> plNewUpID modifications mdID modi w PutMod mdi -> plNewUpID modifications mdID mdi w
PutProp prop -> plNewUpID props pjID (mvProp p rot prop) w PutProp prp -> plNewUpID props pjID (mvProp p rot prp) w
PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w
PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w PutMachine col pps mc -> placeMachine col (map doShift pps) mc p rot w
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
PutPressPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
RandPS rgen -> evaluateRandPS rgen ps w RandPS rgn -> evaluateRandPS rgn ps w
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w PutCoord cp -> placeNewInto coordinates (doShift cp) w
PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w PutSlideDr pth col f a b spd
PutBlock bm (hp:hps) wl ps' -> placeBlock (map doShift ps') hp wl hps bm w -> placeSlideDoor pth col f (doShift a) (doShift b) spd w
PutBlock{} -> error "messed up block placement somehow" PutBlock bm hp hps wl ps'
-> placeBlock (map doShift ps') hp wl hps bm w
PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w) PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w)
PutForeground sh -> (0,w & gWorld . foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)) PutShape sh -> placeShape sh p rot w
PutNothing -> (0,w) PutNothing -> (0,w)
PutID i -> (i, w) PutID i -> (i, w)
PutWorldUpdate f -> (0,w & gWorld %~ f ps) PutWorldUpdate f -> (0,w & gWorld %~ f ps)
where where
p@(V2 px py) = _psPos ps p@(V2 px py) = _psPos ps
p' = V3 px py 0 p' = V3 px py 0
rot = _psRot ps rot = _psRot ps
doShift = shiftPointBy (p,rot) doShift = shiftPointBy (p,rot)
placeShape :: Shape -> Point2 -> Float -> GenWorld -> (Int, GenWorld)
placeShape sh p rot w =
(0, w & gWorld . foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> GenWorld -> (Int,GenWorld) evaluateRandPS :: State StdGen PSType -> PlacementSpot -> GenWorld -> (Int,GenWorld)
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set (gWorld . randGen) g w) evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set (gWorld . randGen) g w)
where where
@@ -114,7 +129,6 @@ placeWallPoly ps wl = gWorld %~ (rmCrossPaths . over walls (addWalls ps wl))
where where
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
addWalls qs wl wls = foldr (addPane wl) wls pairs addWalls qs wl wls = foldr (addPane wl) wls pairs
where where
@@ -134,7 +148,7 @@ placeNewInto :: ALens' World (IM.IntMap a)
-> (Int,GenWorld) -> (Int,GenWorld)
placeNewInto l x w = (i,w & gWorld . l #%~ IM.insert i x) placeNewInto l x w = (i,w & gWorld . l #%~ IM.insert i x)
where where
i = IM.newKey $ (_gWorld w) ^# l i = IM.newKey $ _gWorld w ^# l
-- | place an new object into an intmap and update its id -- | place an new object into an intmap and update its id
plNewUpID :: ALens' World (IM.IntMap a) plNewUpID :: ALens' World (IM.IntMap a)
@@ -144,7 +158,7 @@ plNewUpID :: ALens' World (IM.IntMap a)
-> (Int,GenWorld) -> (Int,GenWorld)
plNewUpID l li x w = (i,w & gWorld . l #%~ IM.insert i (x & li #~ i)) plNewUpID l li x w = (i,w & gWorld . l #%~ IM.insert i (x & li #~ i))
where where
i = IM.newKey $ (_gWorld w) ^# l i = IM.newKey $ _gWorld w ^# l
mvProp :: Point2 -> Float -> Prop -> Prop mvProp :: Point2 -> Float -> Prop -> Prop
mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a )) mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
src/Dodge/Placement/PlaceSpot/Block.hs
+1 -1
View File
@@ -73,7 +73,7 @@ placeLineBlock
-> GenWorld -> GenWorld
-> (Int, GenWorld) -> (Int, GenWorld)
placeLineBlock basePane bm blockWidth depth a b gw = ( 0 placeLineBlock basePane bm blockWidth depth a b gw = ( 0
, gw & gWorld .~ (removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls) , gw & gWorld .~ removePathsCrossing a b (foldr insertWall (insertBlocks w) listWalls)
) )
where where
w = _gWorld gw w = _gWorld gw
src/Dodge/Placement/Shift.hs
+1
View File
@@ -17,3 +17,4 @@ shiftPlacement shift plmnt = case plmnt of
PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p) PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
(fmap (shiftPlacement shift) f) (fmap (shiftPlacement shift) f)
RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
PickOnePlacement i pl -> PickOnePlacement i (shiftPlacement shift pl)
src/Dodge/Randify.hs
+11
View File
@@ -0,0 +1,11 @@
module Dodge.Randify where
import Dodge.Data
import Dodge.LevelGen.LevelStructure
import System.Random
import Control.Monad.State
import Control.Lens
gRandify :: GenWorld -> State StdGen GenWorld -> GenWorld
gRandify gw mw = let (gw',g) = runState mw (_randGen $ _gWorld gw)
in gw' & gWorld . randGen .~ g
src/Dodge/Room/Airlock.hs
+2 -2
View File
@@ -31,7 +31,7 @@ airlock0 = defaultRoom
$ \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 (V2 (-2) 30) (V2 (-2) 70) ,spanLightI (V2 (-2) 30) (V2 (-2) 70)
,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50) ,sps0 $ PutShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
] ]
, _rmBound = [rectNSWE 75 15 0 40] , _rmBound = [rectNSWE 75 15 0 40]
} }
@@ -91,7 +91,7 @@ airlockZ = defaultRoom
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 = mntLS vShape (V2 90 60) (V3 90 40 50) `addPlmnt` mntLS vShape (V2 90 60) (V3 90 80 50) cenlight = mntLS vShape (V2 90 60) (V3 90 40 50) `addPlmnt` mntLS vShape (V2 90 60) (V3 90 80 50)
cornlight = mntLS vShape (V2 0 120) (V3 30 90 50) `addPlmnt` mntLS vShape (V2 180 120) (V3 150 90 50) cornlight = mntLS vShape (V2 0 120) (V3 30 90 50) `addPlmnt` mntLS vShape (V2 180 120) (V3 150 90 50)
`addPlmnt` sps0 (PutForeground (thinHighBar 50 (V2 30 90) (V2 150 90))) `addPlmnt` sps0 (PutShape (thinHighBar 50 (V2 30 90) (V2 150 90)))
lighting = RandomPlacement $ takeOne [cenlight,cornlight] lighting = RandomPlacement $ takeOne [cenlight,cornlight]
airlock90 :: Room airlock90 :: Room
src/Dodge/Room/LasTurret.hs
+2 -2
View File
@@ -36,7 +36,7 @@ cenLasTur = roomNgon 8 200 & rmPmnts .~
lightSensInsideDoor :: Room -> Room lightSensInsideDoor :: Room -> Room
lightSensInsideDoor rm = rm lightSensInsideDoor rm = rm
& rmPmnts %~ ( (psPt atFstLnkOut $ PutForeground $ colorSH yellow $ & rmPmnts %~ ( (psPt atFstLnkOut $ PutShape $ colorSH yellow $
thinHighBar 0 (V2 20 (-1)) (V2 20 (-100)) thinHighBar 0 (V2 20 (-1)) (V2 20 (-100))
<> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100)) <> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100))
<> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)) : ) <> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)) : )
@@ -51,7 +51,7 @@ lightSensInsideDoor rm = rm
lightSensByDoor :: Room -> Room lightSensByDoor :: Room -> Room
lightSensByDoor rm = rm lightSensByDoor rm = rm
& rmPmnts %~ ( & rmPmnts %~ (
[ psPt atFstLnkOut $ PutForeground $ colorSH yellow [ psPt atFstLnkOut $ PutShape $ colorSH yellow
$ barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80) $ barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)
, heightWallPS (atNthLnkOutShiftInward 1 100) 30 (rectNSEW 10 (-10) 20 (-20)) , heightWallPS (atNthLnkOutShiftInward 1 100) 30 (rectNSEW 10 (-10) 20 (-20))
, heightWallPS (atFstLnkOutShiftInward 100) 30 (rectNSEW 10 (-10) 20 (-20)) , heightWallPS (atFstLnkOutShiftInward 100) 30 (rectNSEW 10 (-10) 20 (-20))
src/Dodge/Room/Link.hs
+1 -1
View File
@@ -20,7 +20,7 @@ module Dodge.Room.Link
, restrictRMInLinksPD , restrictRMInLinksPD
) where ) where
import Dodge.ShiftPoint import Dodge.ShiftPoint
import Dodge.Placement.PlaceSpot --import Dodge.Placement.PlaceSpot
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.RandomHelp import Dodge.RandomHelp
import Geometry import Geometry
src/Dodge/Room/LongDoor.hs
+2 -2
View File
@@ -44,8 +44,8 @@ twinSlowDoorRoom w h x = defaultRoom
, _rmPath = [] , _rmPath = []
, _rmPmnts = , _rmPmnts =
[ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
$ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed) $ \btid -> jsps0J (PutSlideDr False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
$ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed) $ ps0 (PutSlideDr False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
$ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0)) $ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0))
$ \lsid -> jsps0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight $ \lsid -> jsps0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
] ]
src/Dodge/Room/Procedural.hs
+4 -4
View File
@@ -49,7 +49,7 @@ roomRect x y xn yn = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x ] { _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap doublePair pth , _rmPath = concatMap doublePair pth
, _rmPos = map (\p -> UnusedSpot p 0) posps , _rmPos = map (`UnusedSpot` 0) posps
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = [Tile , _rmFloor = [Tile
@@ -232,7 +232,7 @@ centerVaultRoom w h d = do
,sps0 $ PutWall (rectNSEW d (d - 30) (-d) (30 - d)) defaultWall ,sps0 $ PutWall (rectNSEW d (d - 30) (-d) (30 - d)) defaultWall
,sps0 $ PutWall (rectNSEW (-d) (30 - d) d (d - 30)) defaultWall ,sps0 $ PutWall (rectNSEW (-d) (30 - d) d (d - 30)) defaultWall
,sps0 $ PutWall (rectNSEW (-d) (30 - d) (-d) (30 - d)) defaultWall ,sps0 $ PutWall (rectNSEW (-d) (30 - d) (-d) (30 - d)) defaultWall
,sps0 $ PutForeground $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h)) ,sps0 $ PutShape $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h))
] ]
++ map (\a -> mntLS vShape (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70)) ++ map (\a -> mntLS vShape (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70))
[0,0.5*pi,pi,1.5*pi] [0,0.5*pi,pi,1.5*pi]
@@ -244,7 +244,7 @@ centerVaultRoom w h d = do
col = dim $ dim $ bright red col = dim $ dim $ bright red
theDoor = theDoor =
[ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id) [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2) $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
$ sPS (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 21 0) (V2 0 0) 2) $ sPS (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) (V2 21 0) (V2 0 0) 2)
] ]
cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
src/Dodge/Room/RezBox.hs
+3 -4
View File
@@ -49,7 +49,7 @@ rezBoxesWp = do
let aroom = rezInvBox thecol -- & rmConnectsTo .~ S.singleton (OnEdge North) let aroom = rezInvBox thecol -- & rmConnectsTo .~ S.singleton (OnEdge North)
let isnorth = S.member (OnEdge North) . _rlType let isnorth = S.member (OnEdge North) . _rlType
centralRoom <- shuffleLinks $(roomRectAutoLinks w h) {_rmPmnts = []} centralRoom <- shuffleLinks $(roomRectAutoLinks w h) {_rmPmnts = []}
& rmLinks %~ (setLinkType InLink isnorth) & rmLinks %~ setLinkType InLink isnorth
onwardpassage <- maybeBlockedPassage onwardpassage <- maybeBlockedPassage
let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom
let rezrooms = map adddoor let rezrooms = map adddoor
@@ -71,8 +71,8 @@ rezBoxesWpCrit = do
theweapon <- randBlockBreakWeapon theweapon <- randBlockBreakWeapon
--horedge <- takeOne [OnEdge North,OnEdge South] --horedge <- takeOne [OnEdge North,OnEdge South]
let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []} let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []}
onwardpassage <- fmap onwardpassage <-
(applyToCompRoot (rmConnectsTo .~ S.singleton (OnEdge West))) $ maybeBlockedPassage (applyToCompRoot (rmConnectsTo .~ S.singleton (OnEdge West))) <$> maybeBlockedPassage
let bottomEdgeTest (V2 _ y,_) = y < 1 let bottomEdgeTest (V2 _ y,_) = y < 1
aroom = rezInvBox thecol aroom = rezInvBox thecol
let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom
@@ -123,7 +123,6 @@ rezBoxes = do
, PassDown door , PassDown door
] ]
(Node (PassDown centralRoom') (replicate (n-1) dbox ++ [Node (UseAll door) []])) (Node (PassDown centralRoom') (replicate (n-1) dbox ++ [Node (UseAll door) []]))
where
rezColor :: RandomGen g => State g LightSource rezColor :: RandomGen g => State g LightSource
src/Dodge/Room/RoadBlock.hs
+1 -1
View File
@@ -74,7 +74,7 @@ blockedCorridor = do
sequence $ treeFromPost [] $ return $ UseAll $ set rmPmnts plmnts corridor sequence $ treeFromPost [] $ return $ UseAll $ set rmPmnts plmnts corridor
dirtPoly :: [Point2] -> PSType dirtPoly :: [Point2] -> PSType
dirtPoly = PutBlock DirtBlock [1] dirtWall . reverse dirtPoly = PutBlock DirtBlock 1 [] dirtWall . reverse
-- | A single corridor with a destructible block blocking it. -- | A single corridor with a destructible block blocking it.
blockedCorridorCloseBlocks :: RandomGen g => State g Room blockedCorridorCloseBlocks :: RandomGen g => State g Room
src/Dodge/Room/Room.hs
+11 -8
View File
@@ -60,8 +60,8 @@ roomPillars = roomRect 240 240 2 2
plmnts = spanLightI (V2 120 24) (V2 120 216) plmnts = spanLightI (V2 120 24) (V2 120 216)
: mntLS vShape (V2 12 12) (V3 25 25 70) : mntLS vShape (V2 12 12) (V3 25 25 70)
: mntLS vShape (V2 228 228) (V3 215 215 70) : mntLS vShape (V2 228 228) (V3 215 215 70)
: sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25)) : sps0 (PutShape $ thinHighBar 75 (V2 26 25) (V2 120 25))
: sps0 (PutForeground $ thinHighBar 75 (V2 214 215) (V2 120 215)) : sps0 (PutShape $ thinHighBar 75 (V2 214 215) (V2 120 215))
: g 180 150 90 60 : g 180 150 90 60
f a x b y = putBlockRect a x b y f a x b y = putBlockRect a x b y
g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d
@@ -150,7 +150,7 @@ miniRoom3 = do
w <- state $ randomR (300,400) w <- state $ randomR (300,400)
h <- state $ randomR (300,400) h <- state $ randomR (300,400)
let cp = V2 0 (h/2+40) let cp = V2 0 (h/2+40)
let b = PutBlock StoneBlock [5,20,20] baseBlockPane $ map toV2 [(-10,-60) let b = PutBlock StoneBlock 5 [20,20] baseBlockPane $ map toV2 [(-10,-60)
,( 10,-60) ,( 10,-60)
,( 10,-80) ,( 10,-80)
,(-10,-80) ,(-10,-80)
@@ -273,15 +273,18 @@ weaponEmptyRoom = do
weaponUnderCrits :: RandomGen g => State g (SubCompTree Room) weaponUnderCrits :: RandomGen g => State g (SubCompTree Room)
weaponUnderCrits = do weaponUnderCrits = do
let plmnts = let plmnts =
[sPS (V2 20 0) 0 $ RandPS randFirstWeapon [--sPS (V2 20 0) 0 $ RandPS randFirstWeapon
,sPS (V2 20 0) (negate $ pi/2) randC1 sPS (V2 20 0) (negate $ pi/2) randC1
,sPS (V2 20 20) (negate $ pi/2) randC1 ,sPS (V2 20 20) (negate $ pi/2) randC1
] ]
addwpat p = rmPmnts %~ ((PickOnePlacement 0 $ sPS p 0 $ RandPS randFirstWeapon) :)
let continuationRoom = treeFromTrunk let continuationRoom = treeFromTrunk
[PassDown corridorN,PassDown corridorN] [PassDown $ addwpat (V2 20 0) corridorN,PassDown $ addwpat (V2 20 0) corridorN]
(singleUseAll (set rmPmnts plmnts corridorN)) (singleUseAll (set rmPmnts plmnts corridorN))
rcp <- roomCenterPillar rcp <- roomCenterPillar
deadEndRoom' <- takeOne [roomPillars,rcp] deadEndRoom' <- takeOne
[ addwpat (V2 120 20) roomPillars
, addwpat (V2 120 20) rcp]
junctionRoom <- takeOne [PassDown tEast,PassDown tWest] junctionRoom <- takeOne [PassDown tEast,PassDown tWest]
return $ treeFromTrunk [PassDown corridorN,PassDown corridorN] return $ treeFromTrunk [PassDown corridorN,PassDown corridorN]
$ Node junctionRoom $ Node junctionRoom
@@ -313,7 +316,7 @@ weaponBetweenPillars = do
critPlacementSpots <- replicateM 2 $ randDirPS $ unusedSpotAwayFromInLink 100 critPlacementSpots <- replicateM 2 $ randDirPS $ unusedSpotAwayFromInLink 100
let plmnts = let plmnts =
sPS wpPos 0 (RandPS randFirstWeapon) : sPS wpPos 0 (RandPS randFirstWeapon) :
map (\ps -> sps ps randC1) critPlacementSpots map (`sps` randC1) critPlacementSpots
theRoom = roomPillars & rmPmnts %~ (++ plmnts) theRoom = roomPillars & rmPmnts %~ (++ plmnts)
(fmap singleUseAll . randomiseOutLinks) =<< filterLinks f theRoom (fmap singleUseAll . randomiseOutLinks) =<< filterLinks f theRoom
where where
src/Dodge/Room/Start.hs
+2 -2
View File
@@ -106,14 +106,14 @@ startRoom' = do
w <- state $ randomR (100,400) w <- state $ randomR (100,400)
h <- state $ randomR (200,400) h <- state $ randomR (200,400)
let plmnts = let plmnts =
[ sPS (V2 0 0) 0 $ PutForeground $ girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2)) [ 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) --, mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70)
, tankSquareEmboss4 (dim orange) 50 (h-60) , tankSquareEmboss4 (dim orange) 50 (h-60)
, tankSquare (dim orange) 50 50 , tankSquare (dim orange) 50 50
, tankSquare (dim orange) 50 120 , tankSquare (dim orange) 50 120
, lightSensor 10 (const id) (PS (V2 (0.8*w) (0.25*h)) 0) , lightSensor 10 (const id) (PS (V2 (0.8*w) (0.25*h)) 0)
, putLasTurret 0.005 & plSpot .~ PS (V2 (0.8*w) (0.8*h)) 0 , putLasTurret 0.005 & plSpot .~ PS (V2 (0.8*w) (0.8*h)) 0
, sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
] ]
thecol <- rezColor thecol <- rezColor
treeFromPost [PassDown $ rezBox thecol, PassDown door] . UseAll treeFromPost [PassDown $ rezBox thecol, PassDown door] . UseAll
src/Dodge/Room/Teleport.hs
+1 -1
View File
@@ -23,7 +23,7 @@ telRoomLev _ = do
w <- state $ randomR (200,300) w <- state $ randomR (200,300)
h <- state $ randomR (200,300) h <- state $ randomR (200,300)
return $ roomRectAutoLinks w h & rmPmnts .~ return $ roomRectAutoLinks w h & rmPmnts .~
[ sPS (V2 (w/2) (h/2)) 0 $ PutPressPlate telPP [ sPS (V2 (w/2) (h/2)) 0 $ PutPPlate telPP
, sPS (V2 (w/2) (h/2+ 30)) 0 putLamp , sPS (V2 (w/2) (h/2+ 30)) 0 putLamp
] ]
where where
src/Dodge/Tree/Shift.hs
+8 -5
View File
@@ -21,7 +21,7 @@ import Control.Lens hiding (Empty, (<|) , (|>))
type RoomInt = (Room,Int) type RoomInt = (Room,Int)
positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [Room]) positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [RoomInt])
positionRoomsFromTree (Node (r,i) ts) = printHeader positionRoomsFromTree (Node (r,i) ts) = printHeader
>> posRms (map pointsToPoly $ _rmBound r) (r,i) (zipCount ts) Empty >> posRms (map pointsToPoly $ _rmBound r) (r,i) (zipCount ts) Empty
@@ -29,10 +29,10 @@ posRms :: [ConvexPoly]
-> RoomInt -> RoomInt
-> [(Int,Tree RoomInt)] -- the list of children, with indices -> [(Int,Tree RoomInt)] -- the list of children, with indices
-> Seq (Tree RoomInt) -> Seq (Tree RoomInt)
-> IO (Maybe [Room]) -> IO (Maybe [RoomInt])
posRms bounds (parent,_) [] st = case st of posRms bounds (parent,i) [] st = case st of
Empty -> return $ Just [parent] Empty -> return $ Just [(parent,i)]
Node childi ts :<| tseq -> fmap (parent:) <$> posRms bounds childi (zipCount ts) tseq Node childi ts :<| tseq -> fmap ((parent,i):) <$> posRms bounds childi (zipCount ts) tseq
posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
printInfoCheckNum parenti numChild childi printInfoCheckNum parenti numChild childi
tryParentLinks outlinks tryParentLinks outlinks
@@ -61,9 +61,12 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm
& rmLinks %~ delete outlnk & rmLinks %~ delete outlnk
& rmPos %~ (uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk) :) & rmPos %~ (uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk) :)
& rmChildren %~ (snd childi :)
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
r' = doRoomShift . fst $ rootLabel shiftedt r' = doRoomShift . fst $ rootLabel shiftedt
updatechild rm = rm updatechild rm = rm
& rmMParent ?~ snd parenti
& rmMID ?~ snd childi
& rmLinks %~ delete il & rmLinks %~ delete il
& rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):) & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
. (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) ) . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) )
src/Geometry/Data.hs
+3 -10
View File
@@ -1,17 +1,8 @@
module Geometry.Data module Geometry.Data
( Point2 ( module Geometry.Data
, Point3
, Point4
, V2 (..) , V2 (..)
, V3 (..) , V3 (..)
, V4 (..) , V4 (..)
, toV2
, toV3
, toV4
, fromV3
, uncurryV
, fstV2
, sndV2
) )
where where
import Linear.V2 import Linear.V2
@@ -21,6 +12,8 @@ type Point2 = V2 Float
type Point3 = V3 Float type Point3 = V3 Float
type Point4 = V4 Float type Point4 = V4 Float
type DPoint2 = (Point2,Float)
toV2 :: (a,a) -> V2 a toV2 :: (a,a) -> V2 a
toV2 (a,b) = V2 a b toV2 (a,b) = V2 a b
toV3 :: (a,a,a) -> V3 a toV3 :: (a,a,a) -> V3 a