Random tree structure generation of rooms
This commit is contained in:
+45
-59
@@ -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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user