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

Random tree structure generation of rooms

Browse Source
This commit is contained in:
jgk
2021-04-20 02:01:24 +02:00
parent 38d67520cc
commit b911a013e0
14 changed files with 407 additions and 235 deletions
Download Patch File Download Diff File Expand all files Collapse all files
package.yaml
+1 -1
View File
@@ -17,7 +17,7 @@ extra-source-files:
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/githubuser/loop#readme>
description: Description text, TODO link to README.md
dependencies:
- base >= 4.7 && < 5
src/Dodge/Base.hs
+3 -3
View File
@@ -189,11 +189,11 @@ wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-
_ -> IM.empty
-- possible BUG, was associated with thingsHitLongLine
-- assumes _wallsZone is correct level generation
-- there is certainly a problem somewhere here: it may be in the zoning, or
-- within this function
wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
{-# INLINE wallsAlongLine #-}
--wallsAlongLine a b w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfLine a b]
-- where f i m = case IM.lookup i m of Just val -> val
-- _ -> IM.empty
wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
kps = zoneOfLine' a b
src/Dodge/DepthFirst.hs
+5
View File
@@ -0,0 +1,5 @@
module Dodge.DepthFirst
where
--dfs :: (a -> Bool) -> (a -> [a]) -> a -> Maybe a
--dfs cond f x
src/Dodge/Floor.hs
+65 -47
View File
@@ -1,5 +1,6 @@
module Dodge.Floor
( lev1
, levx
, generateLevel
)
where
@@ -9,10 +10,14 @@ import Dodge.Data
import Dodge.Room
import Dodge.Room.Procedural
import Dodge.Room.Data
import Dodge.Room.Link
import Dodge.Base
import Dodge.Layout
import Dodge.Layout.Tree.Polymorphic
import Dodge.Layout.Tree.Either
import Dodge.Layout.Tree.GenerateStructure
import Dodge.Layout.Tree.Annotate
import Dodge.Layout.Tree.Shift
import Dodge.Creature
import Dodge.SoundLogic
import Dodge.RandomHelp
@@ -20,62 +25,75 @@ import Dodge.LightSources
import Dodge.LevelGen.Data
import Data.Tree
import Data.Maybe (fromJust,isNothing)
import Control.Lens
import Control.Monad.State
import Control.Monad.Loops
import System.Random
roomTreex :: RandomGen g => State g (Maybe [Room])
roomTreex = do
struct <- aTreeStrut
let t = padCorridors $ fmap (const []) struct
fmap shiftExpandTree $ mapM annoToRoom t
levx :: RandomGen g => State g [Room]
levx = fmap fromJust $ iterateWhile isNothing roomTreex
lev1 :: RandomGen g => State g (Tree Room)
lev1 = do
struct <- aTreeStrut
let t = padCorridors $ fmap (const []) struct
fmap shiftRoomTree $ mapM annoToRoom t
lev1' :: RandomGen g => State g (Tree Room)
lev1' = do
firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id)
$ sequence $ treePost
(
[return $ return $ Right deadEndRoom
]
++ [return $ connectRoom corridor
,return $ connectRoom door
,glassSwitchBack >>= randomiseLinks]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ [miniRoom3]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ [roomCCrits]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++[roomMiniIntro]
++ [longRoom >>= randomiseLinks]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ firstWeapon
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ [randomiseLinks =<< pistolerRoom]
++ [return $ connectRoom door]
++ [randomiseLinks =<< shooterRoom]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
++ [return $ connectRoom corridor]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor]
++[return $ connectRoom corridor,return $ connectRoom door]
++ [shootingRange]
++ (replicate 3 $ randomiseLinks corridor)
++[roomMiniIntro]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor
,return $ connectRoom door
,slowDoorRoom]
++ [return $ connectRoom corridor
,spawnerRoom
,return $ connectRoom corridor
]
)
$ randomiseLinks corridor
$ sequence $ treePost
(
[return $ return $ Right deadEndRoom
]
++ [return $ connectRoom corridor
,return $ connectRoom door
,glassSwitchBack >>= (fmap connectRoom . randLinks)]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ [miniRoom3]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ [roomCCrits]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++[roomMiniIntro]
++ [longRoom >>= (fmap connectRoom . randLinks)]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ firstWeapon
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ [(fmap connectRoom . randLinks) =<< pistolerRoom]
++ [return $ connectRoom door]
++ [(fmap connectRoom . randLinks) =<< shooterRoom]
++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
++ [return $ connectRoom corridor]
++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
++ [return $ connectRoom corridor]
++[return $ connectRoom corridor,return $ connectRoom door]
++ [shootingRange]
++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
++[roomMiniIntro]
++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
++ [return $ connectRoom corridor
,return $ connectRoom door
,slowDoorRoom]
++ [return $ connectRoom corridor
,spawnerRoom
,return $ connectRoom corridor
]
)
$ (fmap connectRoom . randLinks) corridor
roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room))
roomToLevel2 = join $ takeOne
src/Dodge/Initialisation.hs
+1 -1
View File
@@ -23,7 +23,7 @@ firstWorld :: IO World
firstWorld = do
i <- randomRIO (0,5000)
putStrLn $ "Random seed for level generation: " ++ show ( i :: Int)
return $ generateFromTree lev1 $ initialWorld {_randGen = mkStdGen i}
return $ generateFromList levx $ initialWorld {_randGen = mkStdGen i}
initialWorld :: World
initialWorld = defaultWorld
src/Dodge/Layout.hs
+45 -59
View File
@@ -10,9 +10,11 @@ import Dodge.Base
import Dodge.RandomHelp
import Dodge.Graph
import Dodge.Layout.Tree
import Dodge.Layout.Tree.Polymorphic (applyToRoot)
import Dodge.Room.Data
import Dodge.Default
import Geometry
import Dodge.Room.Link
import Control.Monad.State
import Control.Lens
@@ -29,24 +31,35 @@ import Data.Graph.Inductive.NodeMap
import qualified Data.Map as M
import qualified Data.IntMap.Strict as IM
generateFromList :: State StdGen [Room] -> World -> World
generateFromList gr w = updateWallZoning
. placeSpots plmnts
$ w { _walls = wallsFromRooms rs
}
where
plmnts = concatMap _rmPS rs
rs = evalState gr $ _randGen w
-- | connects a collection (tree) of rooms together
generateFromTree :: State StdGen (Tree Room) -> World -> World
generateFromTree t w = zoning $ placeSpots plmnts
$ w {_walls = wallsFromTree tr, _randGen = g
,_pathGraph = path
,_pathGraph' = pairGraph
,_pathPoints = foldr insertPoint IM.empty (labNodes path)
,_pathInc = pinc}
generateFromTree t w = updateWallZoning $ placeSpots plmnts
$ w {_walls = wallsFromTree tr
,_pathGraph = path
,_pathGraph' = pairGraph
,_pathPoints = foldr insertPoint IM.empty (labNodes path)
,_pathInc = pinc
}
where
tr = evalState t $ _randGen w
plmnts = concatMap _rmPS $ flatten tr
g = _randGen w
path = pairsToGraph dist pairGraph
pairGraph = makePath tr
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
pinc = M.fromList $ pairsToIncidence pairGraph
zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
w
updateWallZoning :: World -> World
updateWallZoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) w
where
wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
@@ -54,6 +67,7 @@ generateFromTree t w = zoning $ placeSpots plmnts
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
makePath :: Tree Room -> [(Point2,Point2)]
makePath = concat . map _rmPath . flatten
@@ -71,6 +85,13 @@ wallsFromTree t =
f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i}
g (x,y) = (x-3855,y - 2613)
wallsFromRooms :: [Room] -> IM.IntMap Wall
wallsFromRooms =
-- divideWalls .
IM.fromList . zip [0..] . zipWith f [0..] . foldr cutWalls [] . concatMap _rmPolys
where
f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i}
divideWall :: Wall -> [Wall]
divideWall wl
= let (a:b:_) = _wlLine wl
@@ -92,28 +113,6 @@ insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntM
insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
where f _ = IM.insert y obj
randomiseLinks :: RandomGen g => Room -> State g (Tree (Either Room Room))
randomiseLinks r = do
newLinks <- shuffle $ init $ _rmLinks r
return $ connectRoom $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
randLinks :: RandomGen g => Room -> State g Room
randLinks r = do
newLinks <- shuffle $ init $ _rmLinks r
return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
filterLinks cond r = do
newLinks <- shuffle $ filter cond $ init $ _rmLinks r
return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
changeLinkTo cond r = do
l <- takeOne $ filter cond $ _rmLinks r
let newLinks = delete l (_rmLinks r) ++ [l]
return $ r {_rmLinks = newLinks}
-- the old version of this used a version of polysIntersect with intersectSegSeg'
boundClip :: Tree Room -> Bool
boundClip t = or $ map (uncurry polysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
@@ -125,37 +124,24 @@ boundClip t = or $ map (uncurry polysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
noBoundClip :: Tree Room -> Bool
noBoundClip = not . boundClip
connectRoom :: a -> Tree (Either a a)
connectRoom r = Node (Right r) []
deadRoom :: a -> Tree (Either a a)
deadRoom r = Node (Left r) []
onRoot :: (a -> a) -> Tree a -> Tree a
onRoot f (Node t ts) = Node (f t) ts
shiftRoomTree :: Tree Room -> Tree Room
shiftRoomTree (Node t []) = Node t []
shiftRoomTree (Node t ts) = Node t $ zipWith (\l -> shiftRoomTree . onRoot (shiftRoomBy l . f))
(_rmLinks t)
ts
where f r = shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0) $ shiftRoomBy ((0,0),pi-a) r
where (p,a) = last $ _rmLinks r
shiftRoomTree (Node t ts) = Node t
$ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
(_rmLinks t)
ts
shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
shiftRoomTreeConstruction (Node t []) = [Node t []]
shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f))
(_rmLinks t)
ts
where
f r = shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0) $ shiftRoomBy ((0,0),pi-a) r
where
(p,a) = last $ _rmLinks r
shiftRoomBy :: (Point2,Float) -> Room -> Room
shiftRoomBy shift@(pos,rot) r =
over rmPolys (fmap (map (shiftPointBy shift)))
$ over rmLinks (fmap (shiftLinkBy shift))
$ over rmPath (map (shiftPathPointBy shift))
$ over rmPS (fmap (shiftPSBy shift))
$ over rmBound (map (shiftPointBy shift))
r
shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
shiftPSBy (pos,rot) ps = case ps of
PS {} -> over psPos (shiftPointBy (pos,rot))
$ over psRot (+rot)
ps
src/Dodge/Layout/Tree/Annotate.hs
+11 -2
View File
@@ -5,6 +5,10 @@ module Dodge.Layout.Tree.Annotate
where
import Dodge.RandomHelp
import Dodge.Layout.Tree.Polymorphic
import Dodge.Room.Procedural
import Dodge.Room.Link
import Dodge.Room.Data
import Dodge.Room
import Data.Tree
import Control.Monad.State
@@ -13,6 +17,7 @@ import System.Random
data Annotation
= Lock Int
| Key Int
| Corridor
addLock :: RandomGen g => Int -> Tree [Annotation] -> State g (Tree [Annotation])
addLock i t = do
@@ -20,5 +25,9 @@ addLock i t = do
newBefore <- applyToRandomNode (Key i :) beforeLock
return $ addToTrunk newBefore [Node [Lock i] afterLock]
--annoToRoom :: RandomGen g => [Annotation] -> State g (Either Room Room)
--annoToRoom as = undefined
padCorridors :: Tree [Annotation] -> Tree [Annotation]
padCorridors (Node x xs) = Node [Corridor] [Node x (map padCorridors xs)]
annoToRoom :: RandomGen g => [Annotation] -> State g Room
annoToRoom [Corridor] = takeOne [corridor]
annoToRoom _ = randLinks $ roomRectAutoLinks 200 200
src/Dodge/Layout/Tree/Either.hs
+14
View File
@@ -3,6 +3,8 @@ Combining and composing trees with 'Either' nodes.
-}
module Dodge.Layout.Tree.Either
( expandTreeBy
, connectRoom
, deadRoom
) where
import Data.Tree
@@ -20,3 +22,15 @@ expandTreeBy f (Node x xs) = appendAndRemove $ f x
removeEither (Left y) = y
removeEither (Right y) = y
{-
Make a singleton connection of an Either Tree.
-}
connectRoom :: a -> Tree (Either a a)
connectRoom r = Node (Right r) []
{-
Make a singleton dead end of an Either Tree.
-}
deadRoom :: a -> Tree (Either a a)
deadRoom r = Node (Left r) []
src/Dodge/Layout/Tree/Polymorphic.hs
+1 -1
View File
@@ -29,7 +29,7 @@ treeTrunk (x:xs) t = Node x [treeTrunk xs t]
Applies a function to the root of a tree.
-}
applyToRoot :: (a -> a) -> Tree a -> Tree a
applyToRoot f (Node x xs) = Node (f x) xs
applyToRoot f (Node t ts) = Node (f t) ts
treeSize = length . flatten
src/Dodge/Layout/Tree/Shift.hs
+55
View File
@@ -0,0 +1,55 @@
module Dodge.Layout.Tree.Shift
where
import Dodge.Room.Data
import Dodge.Room.Link
import Dodge.Layout.Tree.Polymorphic
import Geometry
import Data.Tree
import Data.Sequence hiding (zipWith)
import Data.List (delete)
import Data.Maybe (listToMaybe)
import Control.Lens hiding (Empty, (<|) , (|>))
shiftRoomTreeConstruct :: [[Point2]] -> Tree Room -> Maybe (Tree Room)
shiftRoomTreeConstruct bs (Node t ts)
| roomIsClipping = Nothing
| otherwise = case children of
Nothing -> Nothing
Just ts' -> Just $ Node t ts'
where
roomIsClipping = any (polysIntersect (_rmBound t)) bs
children = sequence
$ zipWith (\l -> shiftRoomTreeConstruct (_rmBound t : bs)
. applyToRoot (shiftRoomToLink l))
(_rmLinks t)
ts
shiftRoomTreeSearch :: [[Point2]] -> Seq (Tree Room) -> Maybe [Room]
shiftRoomTreeSearch _ Empty = Just []
shiftRoomTreeSearch bs (Node r ts :<| ts')
| roomIsClipping = Nothing
| otherwise = fmap (r :) $ shiftRoomTreeSearch newBounds $ ts' >< children
where
roomIsClipping = any (polysIntersect (_rmBound r)) bs
newBounds = _rmBound r : bs
children = fromList $ zipWith (\l -> applyToRoot (shiftRoomToLink l))
(_rmLinks r)
ts
shiftRoomTreeSearchAll :: [[Point2]] -> Seq (Tree Room) -> [[Room]]
shiftRoomTreeSearchAll _ Empty = [[]]
shiftRoomTreeSearchAll bs (Node r ts :<| ts')
| roomIsClipping = [] -- this is called too often, but whatever
| otherwise = case ts of
[] -> (r :) <$> (shiftRoomTreeSearchAll newBounds $ ts')
(s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (rm l) ss <| (ts' |> f l s))) ls
where
ls = init $ _rmLinks r
newBounds = _rmBound r : bs
roomIsClipping = any (polysIntersect (_rmBound r)) bs
rm l = r & rmLinks %~ delete l
f l = applyToRoot (shiftRoomToLink l)
shiftExpandTree :: Tree Room -> Maybe [Room]
shiftExpandTree = listToMaybe . shiftRoomTreeSearchAll [] . singleton
src/Dodge/Room.hs
+10 -70
View File
@@ -2,7 +2,9 @@
Specification of individual rooms.
-}
module Dodge.Room
where
( module Dodge.Room
, module Dodge.Room.Corridor
) where
import Dodge.Data
import Dodge.Item.Weapon
import Dodge.Creature
@@ -21,6 +23,8 @@ import Dodge.SoundLogic
import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.Room.Procedural
import Dodge.Room.Corridor
import Dodge.Room.Link
import Geometry
import Picture
@@ -79,63 +83,6 @@ airlock n = Room
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
corridor :: Room
corridor = Room
{ _rmPolys = [rectNSWE 80 0 0 40
,[(0,80), (0,80) +.+ rotateV (pi/3) (40,0),(40,80)]
,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)]
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (20,60)) $ map fst lnks
, _rmPS = []
, _rmBound = rectNSWE 50 30 0 40
}
where lnks = [((20,70) ,0)
,((20,80) +.+ rotateV (0-pi/3) (-10,0), pi/6)
,((20,80) +.+ rotateV ( pi/3) ( 10,0),0-pi/6)
,((20,10) ,pi)
]
corridorN :: Room
corridorN = Room
{ _rmPolys = [rectNSWE 80 0 0 40
]
, _rmLinks = lnks
, _rmPath = pth
, _rmPS = []
, _rmBound = rectNSWE 50 30 0 40
}
where lnks = [((20,70) ,0)
,((20,10) ,pi)
]
pth = doublePair ((20,70),(20,10))
tEast :: Room
tEast = Room
{ _rmPolys = [rectNSWE 80 0 (-20) (20)
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks
, _rmPS = []
, _rmBound = rectNSWE 70 10 0 40
}
where lnks = [(( 30,60),-pi/2)
,((-30,60),pi/2)
,((0,10),pi)
]
tWest :: Room
tWest = Room
{ _rmPolys = [rectNSWE 80 0 (-20) (20)
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks
, _rmPS = []
, _rmBound = rectNSWE 70 10 0 40
}
where lnks = [((-30,60),pi/2)
,(( 30,60),-pi/2)
,((0,10),pi)
]
roomC :: Float -> Float -> Room
roomC x y = Room
{ _rmPolys = [rectNSWE y 0 0 x]
@@ -143,7 +90,6 @@ roomC x y = Room
, _rmPath = []
, _rmPS = [windowLine (x/2,0) (x/2,y-60)
]
--, _rmBound = rectNSWE y 0 0 x
, _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
}
where
@@ -161,12 +107,6 @@ roomPadCut ps p = Room
, _rmPS = []
, _rmBound = []
}
door :: Room
door = Room
{ _rmPolys = [rectNSWE 40 0 0 40]
@@ -305,7 +245,7 @@ miniRoom3 = do
,PS cp (pi/8+7*pi/4) b
,PS (w/2,h/2) 0 putLamp
]
randomiseLinks $ set rmPS plmnts $ roomRectAutoLinks w h
fmap connectRoom $ randLinks $ set rmPS plmnts $ roomRectAutoLinks w h
rot90Around :: Point2 -> Point2 -> Point2
rot90Around cen p = cen +.+ vNormal (p -.- cen)
@@ -318,7 +258,7 @@ roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treePost
,join $ takeOne [miniTree2,glassLesson]
-- ,join $ takeOne [miniRoom1]
]
$ randomiseLinks corridor
$ fmap connectRoom $ randLinks corridor
where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
g (Node (Right x) []) = Node (Right x) []
@@ -392,7 +332,7 @@ weaponEmptyRoom = do
,PS (w-20,20) (pi/2) $ randC1
,PS (w/2,h/2) 0 $ putLamp
]
randomiseLinks =<< (changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst)
(fmap connectRoom . randLinks) =<< (changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst)
$ set rmPS plmnts $ roomRect' w h 2 2)
@@ -437,7 +377,7 @@ weaponBetweenPillars = do
,PS crPos1 (d crPos1) $ randC1
,PS crPos2 (d crPos2) $ randC1
]
randomiseLinks =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars)
(fmap connectRoom . randLinks) =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars)
where f (_,a) = a == 0
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
@@ -708,5 +648,5 @@ spawnerRoom = do
,PS (x/2, y-10) 0 putLamp
]
let f ((lx,_),_) = lx < x/2-5
roomWithSpawner <- randomiseLinks =<< (filterLinks f $ set rmPS plmnts $ roomRect' x y 2 2)
roomWithSpawner <- (fmap connectRoom . randLinks) =<< (filterLinks f $ set rmPS plmnts $ roomRect' x y 2 2)
return $ treeTrunk [Left (airlock 0)] roomWithSpawner
src/Dodge/Room/Corridor.hs
+67
View File
@@ -0,0 +1,67 @@
module Dodge.Room.Corridor
where
import Dodge.Room.Data
import Geometry
corridor :: Room
corridor = Room
{ _rmPolys = [rectNSWE 80 0 0 40
,[(0,80), (0,80) +.+ rotateV (pi/3) (40,0),(40,80)]
,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)]
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (20,60)) $ map fst lnks
, _rmPS = []
, _rmBound = [] -- rectNSWE 50 30 0 40
}
where
lnks =
[((20,70) ,0)
,((20,80) +.+ rotateV (0-pi/3) (-10,0), pi/6)
,((20,80) +.+ rotateV ( pi/3) ( 10,0),0-pi/6)
,((20,10) ,pi)
]
corridorN :: Room
corridorN = Room
{ _rmPolys = [rectNSWE 80 0 0 40
]
, _rmLinks = lnks
, _rmPath = pth
, _rmPS = []
, _rmBound = rectNSWE 50 30 0 40
}
where lnks = [((20,70) ,0)
,((20,10) ,pi)
]
pth = doublePair ((20,70),(20,10))
tEast :: Room
tEast = Room
{ _rmPolys = [rectNSWE 80 0 (-20) (20)
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks
, _rmPS = []
, _rmBound = rectNSWE 70 10 0 40
}
where lnks = [(( 30,60),-pi/2)
,((-30,60),pi/2)
,((0,10),pi)
]
tWest :: Room
tWest = Room
{ _rmPolys = [rectNSWE 80 0 (-20) (20)
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks
, _rmPS = []
, _rmBound = rectNSWE 70 10 0 40
}
where
lnks =
[((-30,60),pi/2)
,(( 30,60),-pi/2)
,((0,10),pi)
]
src/Dodge/Room/Link.hs
+57
View File
@@ -0,0 +1,57 @@
module Dodge.Room.Link
where
import Dodge.LevelGen
import Dodge.LevelGen.Data
import Dodge.Room.Data
import Dodge.RandomHelp
import Geometry
import System.Random
import Control.Monad.State
import Control.Lens
import Data.List (delete)
randLinks :: RandomGen g => Room -> State g Room
randLinks r = do
newLinks <- shuffle $ init $ _rmLinks r
return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
filterLinks cond r = do
newLinks <- shuffle $ filter cond $ init $ _rmLinks r
return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
changeLinkTo cond r = do
l <- takeOne $ filter cond $ _rmLinks r
let newLinks = delete l (_rmLinks r) ++ [l]
return $ r {_rmLinks = newLinks}
{- | Move a room so that the last link in '_rmLinks' lines up to
an external point and direction.
This is intended to work when the external point is an outgoing link from another room.
-}
shiftRoomToLink :: (Point2,Float) -> Room -> Room
shiftRoomToLink l r
= shiftRoomBy l
. shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0)
$ shiftRoomBy ((0,0),pi-a) r
where
(p,a) = last $ _rmLinks r
shiftRoomBy :: (Point2,Float) -> Room -> Room
shiftRoomBy shift@(pos,rot) r =
over rmPolys (fmap (map (shiftPointBy shift)))
$ over rmLinks (fmap (shiftLinkBy shift))
$ over rmPath (map (shiftPathPointBy shift))
$ over rmPS (fmap (shiftPSBy shift))
$ over rmBound (map (shiftPointBy shift))
r
shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
shiftPSBy (pos,rot) ps = case ps of
PS {} -> over psPos (shiftPointBy (pos,rot))
$ over psRot (+rot)
ps
shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
src/Dodge/Update/Camera.hs
+72 -51
View File
@@ -1,4 +1,12 @@
module Dodge.Update.Camera where
{-
Functions controlling the movement of the screen camera:
'_cameraCenter', '_cameraZoom', _cameraRot';
and the position that the character sees from: '_cameraViewFrom'.
-}
module Dodge.Update.Camera
( updateCamera
)
where
import Dodge.Data
import Dodge.Base
@@ -18,22 +26,23 @@ updateCamera = rotCam . moveCamera . updateScopeZoom
moveCamera :: World -> World
moveCamera w = w & cameraCenter .~ idealPos
& cameraViewFrom .~ sightFrom
where aimRangeFactor | _cameraZoom w == 0 = 0
| otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w
aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1
| otherwise = 0
ypos = _crPos $ you w
idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w)
currentOffset = currentPos -.- camCenter
idealPos = camCenter +.+ rotateV (_cameraRot w)
(aimRangeFactor * aimingMult *.* _mousePos w)
currentPos = _cameraCenter w
camCenter = ypos +.+ scope
isCam :: Bool
isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera
scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos
sightFrom | isCam = camCenter
| otherwise = ypos
where
aimRangeFactor | _cameraZoom w == 0 = 0
| otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w
aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1
| otherwise = 0
ypos = _crPos $ you w
idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w)
currentOffset = currentPos -.- camCenter
idealPos = camCenter +.+ rotateV (_cameraRot w)
(aimRangeFactor * aimingMult *.* _mousePos w)
currentPos = _cameraCenter w
camCenter = ypos +.+ scope
isCam :: Bool
isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera
scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos
sightFrom | isCam = camCenter
| otherwise = ypos
updateScopeZoom :: World -> World
updateScopeZoom w
@@ -109,42 +118,54 @@ zoomCamOut w | zoomOutKey (_keyConfig w) `S.member` _keys w
= w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01}
| otherwise = w
{-
Automatically sets the zoom of the camera according to the surrounding walls.
-}
autoZoomCam :: World -> World
autoZoomCam w = over cameraZoom changeZoom w
where maxViewDistance = 800
camPos = _cameraViewFrom w
camRot = _cameraRot w
wallZoom = min (halfWidth w / (horizontalMax+50) )
(halfHeight w / (verticalMax+50) )
idealZoom | SDL.ButtonRight `S.member` _mouseButtons w
= scZoom *
(
min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax)
$ max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin)
(wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac))
)
| otherwise
= min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax)
$ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin))
(wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac))
changeZoom curZoom
| curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed
| curZoom < idealZoom - 0.01 = ((zoomInSpeed-1)*curZoom + idealZoom) / zoomInSpeed
| otherwise = idealZoom
-- these speeds are inverted, larger means slower
zoomInSpeed = 25
zoomOutSpeed = 15
zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..]
rRays = rotF [( maxViewDistance,y) | y <- zs]
lRays = rotF [(-maxViewDistance,y) | y <- zs]
tRays = rotF [(y, maxViewDistance) | y <- zs]
bRays = rotF [(y,-maxViewDistance) | y <- zs]
rotF = map (h . (+.+) camPos . rotateV (_cameraRot w))
h p = fromMaybe p $ collidePointIndirect camPos p $ wallsAlongLine camPos p w
h' x p = dotV (rotateV camRot x) (p -.- camPos)
horizontalMax = maximum $ map (h' (1,0)) rRays ++ map (h' (-1,0)) lRays
verticalMax = maximum $ map (h' (0,1)) tRays ++ map (h' (0,-1)) bRays
scZoom = fromMaybe 1 $ yourItem w ^? itAttachment . _Just . scopeZoom
where
maxViewDistance = 800
camPos = _cameraViewFrom w
camRot = _cameraRot w
wallZoom = farWallDist camPos w
idealZoom | SDL.ButtonRight `S.member` _mouseButtons w
= scZoom *
(
min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax)
$ max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin)
(wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac))
)
| otherwise
= min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax)
$ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin))
(wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac))
changeZoom curZoom
| curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed
| curZoom < idealZoom - 0.01 = ((zoomInSpeed-1)*curZoom + idealZoom) / zoomInSpeed
| otherwise = idealZoom
-- these speeds are inverted, larger means slower
zoomInSpeed = 25
zoomOutSpeed = 15
scZoom = fromMaybe 1 $ yourItem w ^? itAttachment . _Just . scopeZoom
farWallDist :: Point2 -> World -> Float
farWallDist cpos w = min (halfWidth w / (horizontalMax+50) ) (halfHeight w / (verticalMax+50) )
where
horizontalMax = maximum $ map (h' (1,0)) rRays ++ map (h' (-1,0)) lRays
verticalMax = maximum $ map (h' (0,1)) tRays ++ map (h' (0,-1)) bRays
-- TODO: fix wallsAlongLine and use instead of checking against all walls
-- h p = fromMaybe p $ collidePointIndirect cpos p $ wallsAlongLine cpos p w
h p = fromMaybe p . collidePointIndirect cpos p $ _walls w
h' x p = dotV (rotateV camRot x) (p -.- cpos)
camRot = _cameraRot w
rRays = rotF [( maxViewDistance,y) | y <- zs]
lRays = rotF [(-maxViewDistance,y) | y <- zs]
tRays = rotF [(y, maxViewDistance) | y <- zs]
bRays = rotF [(y,-maxViewDistance) | y <- zs]
rotF = map (h . (+.+) cpos . rotateV (_cameraRot w))
zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..]
maxViewDistance = 800
dirRays :: Float -> [Point2]
dirRays dir = take 11 $ iterate (rotateV (0.5 * pi / 10)) $ rotateV (dir-pi*0.25) (600,0)