174 lines
6.2 KiB
Haskell
174 lines
6.2 KiB
Haskell
module Dodge.Layout
|
|
( module Dodge.Layout
|
|
, module Dodge.Layout.Tree
|
|
)
|
|
where
|
|
-- imports {{{
|
|
import Dodge.Data
|
|
import Dodge.LevelGen
|
|
import Dodge.Base
|
|
import Dodge.RandomHelp
|
|
import Dodge.Path
|
|
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.IntMap.Strict as IM
|
|
-- }}}
|
|
-- 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}
|
|
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
|
|
|
|
-- consider nubbing walls after dividing them
|
|
wallsFromTree :: Tree Room -> IM.IntMap Wall
|
|
wallsFromTree t =
|
|
createInnerWalls
|
|
. divideWalls
|
|
. assignKeys
|
|
. foldr cutWalls [] -- $ map (map (g . roundPoint2))
|
|
. map (map roundPoint2)
|
|
$ (concatMap _rmPolys $ flatten t)
|
|
where
|
|
assignKeys = IM.fromList . zip [0..] . zipWith f [0..]
|
|
f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i}
|
|
g (x,y) = (x-3855,y - 2613)
|
|
|
|
divideWall :: Wall -> [Wall]
|
|
divideWall wl
|
|
= let (a:b:_) = _wlLine wl
|
|
--ps = divideLine (zoneSize * 2) a b
|
|
ps = divideLine (zoneSize * 2) a b
|
|
in map (\(x,y) -> wl {_wlLine = [x,y]}) $ zip (init ps) (tail ps)
|
|
|
|
divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
|
divideWallIn wl wls =
|
|
let (wl':newWls) = divideWall wl
|
|
k = newKey wls
|
|
newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
|
|
in foldr (\w -> IM.insert (_wlID w) w) wls (wl':newWls')
|
|
|
|
divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
|
|
divideWalls wls = IM.foldr divideWallIn wls wls
|
|
|
|
insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
|
|
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}
|
|
|
|
|
|
-- 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]
|
|
++ map f [(ps,qs) | ps <- xs, qs <-xs, ps/=qs]
|
|
where xs = map _rmBound $ flatten t
|
|
f ([],qs) = False
|
|
f ((p:_),qs) = pointInPolygon p qs
|
|
|
|
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
|
|
|
|
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
|
|
|