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

Add tree structure generation

Browse Source
This commit is contained in:
justin
2021-04-15 21:35:03 +02:00
parent 6119276d45
commit 38d67520cc
18 changed files with 531 additions and 153 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Layout.hs
+19 -32
View File
@@ -3,7 +3,6 @@ module Dodge.Layout
, module Dodge.Layout.Tree
)
where
-- imports {{{
import Dodge.Data
import Dodge.LevelGen
import Dodge.LevelGen.Data
@@ -13,29 +12,24 @@ import Dodge.Graph
import Dodge.Layout.Tree
import Dodge.Room.Data
import Dodge.Default
import Geometry
import Control.Monad.State
import Control.Lens
import System.Random
import Data.List
import Data.Maybe
import Data.Tree
import Data.Either
import Data.Function
import qualified Data.Map as M
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.NodeMap
import qualified Data.Map as M
import qualified Data.IntMap.Strict as IM
-- }}}
-- connects a collection (tree) of rooms together
-- | 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
@@ -43,21 +37,22 @@ generateFromTree t w = zoning $ placeSpots plmnts
,_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
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
where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
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
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
where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
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
@@ -119,14 +114,6 @@ changeLinkTo cond r = do
return $ r {_rmLinks = newLinks}
-- Left elements get new children, Right elements inherit the children from the
-- mapped over node
composeTreeWith :: (a -> Tree (Either b b)) -> Tree a -> Tree (Either b b)
composeTreeWith f (Node x []) = f x
composeTreeWith f (Node x xs) = paste xs $ f x
where paste xs (Node (Right y) _) = Node (Left y) (map (composeTreeWith f) xs)
paste xs (Node (Left y) ys) = Node (Left y) (map (paste xs) ys)
-- 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]