190 lines
6.6 KiB
Haskell
190 lines
6.6 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Layout
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.LevelGen
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.LevelGen.StaticWalls
|
|
import Dodge.LevelGen.Pathing
|
|
import Dodge.Wall.Zone
|
|
import Dodge.Placements.Spot
|
|
import Dodge.RandomHelp
|
|
import Dodge.Zone
|
|
import Dodge.GameRoom
|
|
import Dodge.Bounds
|
|
--import Dodge.RandomHelp
|
|
--import Dodge.Graph
|
|
import Dodge.Layout.Tree.Polymorphic (applyToRoot)
|
|
import Dodge.Room.Data
|
|
import Dodge.Room.AddTile
|
|
import Dodge.Default.Wall
|
|
import Geometry
|
|
--import Geometry.Data
|
|
import Dodge.Room.Link
|
|
import qualified IntMapHelp as IM
|
|
--import Dodge.Debug.LinkDecoration
|
|
import Picture.Data
|
|
import Tile
|
|
import Polyhedra
|
|
import Polyhedra.Data
|
|
|
|
import Data.List (nubBy, partition,mapAccumR)
|
|
import Control.Monad.State
|
|
import Control.Lens
|
|
import System.Random
|
|
import Data.Tree
|
|
--import Data.Graph.Inductive.Graph (labNodes)
|
|
--import qualified Data.Map as M
|
|
import Data.Foldable
|
|
import qualified Control.Foldl as L
|
|
import Data.Maybe
|
|
|
|
generateLevelFromRoomList :: State StdGen [Room] -> World -> World
|
|
generateLevelFromRoomList gr w
|
|
= initWallZoning
|
|
. setupWorldBounds
|
|
. flip (foldr $ flip placeSpot) plmnts
|
|
$ w { _walls = wallsFromRooms rs
|
|
, _floorTiles = floorsFromRooms rs
|
|
, _gameRooms = gameRoomsFromRooms rs
|
|
, _pathGraph = path
|
|
, _pathGraphP = pairPath
|
|
}
|
|
where
|
|
path = pairsToGraph dist pairPath
|
|
pairPath = concatMap _rmPath rs
|
|
plmnts = concat . snd $ mapAccumR assignPlacementSpots (_randGen w) rs
|
|
rs = zipWith addTile zs . evalState gr $ _randGen w
|
|
zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
|
|
|
|
-- the idea is to allow use of link coordinates for placements
|
|
-- though the implementation is clunky
|
|
-- this should PutNothing if there are no links available
|
|
-- first it takes the random placements and derandomises them
|
|
-- then it deals with link placement spots
|
|
assignPlacementSpots :: StdGen -> Room -> (StdGen, [((Point2,Float),Placement)])
|
|
assignPlacementSpots g rm = (g', map (_rmShift rm,) $ plmnts ++ plmnts')
|
|
where
|
|
(randPlmnts, detPlmnts) = partition isRand (_rmPS rm)
|
|
isRand RandomPlacement{} = True
|
|
isRand _ = False
|
|
(unrandPlmnts, g'') = runState (mapM _unRandomPlacement randPlmnts) g
|
|
(lnkplmnts, plmnts) = partition islnk (unrandPlmnts ++ detPlmnts)
|
|
islnk Placement{_placementSpot=PSLnk{}} = True
|
|
islnk _ = False
|
|
(shuffledLnks,g') = runState (shuffle $ _rmLinks rm) g''
|
|
(_,plmnts') = mapAccumR f (map (invShiftLinkBy $ _rmShift rm) shuffledLnks) lnkplmnts
|
|
f lnks plmnt =
|
|
let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks
|
|
thepair = _psLinkShift (_placementSpot plmnt) x
|
|
in (xs++ys, updatePS (updatePSLnkUsing thepair) plmnt)
|
|
|
|
updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot
|
|
updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
|
|
updatePSLnkUsing _ ps = ps
|
|
|
|
setupWorldBounds :: World -> World
|
|
setupWorldBounds w = w
|
|
& worldBounds . bdMinX .~ f minx
|
|
& worldBounds . bdMaxX .~ f maxx
|
|
& worldBounds . bdMinY .~ f miny
|
|
& worldBounds . bdMaxY .~ f maxy
|
|
where
|
|
f = fromMaybe 0
|
|
ps = IM.map (fst . _wlLine) $ _walls w
|
|
(minx,maxx,miny,maxy) = L.fold ((,,,)
|
|
<$> L.premap fstV2 L.minimum
|
|
<*> L.premap fstV2 L.maximum
|
|
<*> L.premap sndV2 L.minimum
|
|
<*> L.premap sndV2 L.maximum
|
|
) ps
|
|
|
|
polyhedrasToEdges :: [Polyhedra] -> [Point3]
|
|
polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
|
|
|
|
initWallZoning :: World -> World
|
|
initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~ IM.empty) (_walls w)
|
|
--initWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w
|
|
-- where
|
|
-- wallInZone wl = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl)
|
|
|
|
makePath :: Tree Room -> [(Point2,Point2)]
|
|
makePath = concatMap _rmPath . flatten
|
|
|
|
-- consider nubbing walls after dividing them
|
|
wallsFromTree :: Tree Room -> IM.IntMap Wall
|
|
wallsFromTree t =
|
|
-- createInnerWalls
|
|
divideWalls
|
|
. assignKeys
|
|
. removeInverseWalls
|
|
. foldl' (flip 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}
|
|
|
|
wallsFromRooms :: [Room] -> IM.IntMap Wall
|
|
wallsFromRooms =
|
|
-- divideWalls .
|
|
IM.fromList . zipWith f [0..] . removeInverseWalls
|
|
. foldl' (flip cutWalls) [] . concatMap _rmPolys
|
|
where
|
|
f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})
|
|
|
|
gameRoomsFromRooms :: [Room] -> [GameRoom]
|
|
gameRoomsFromRooms = map f
|
|
where
|
|
f rm = GameRoom
|
|
{ _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
|
|
++ map fst (_rmLinks rm)
|
|
, _grViewpointsEx = map fst (_rmUsedLinks rm)
|
|
, _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints
|
|
. concat $ _rmBound rm ++ _rmPolys rm
|
|
, _grDir = snd . head $ _rmUsedLinks rm
|
|
, _grName = _rmName rm
|
|
}
|
|
closePoints x y = roundPoint2 x == roundPoint2 y
|
|
|
|
floorsFromRooms :: [Room] -> [(Point3,Point3)]
|
|
floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)
|
|
|
|
divideWall :: Wall -> [Wall]
|
|
divideWall wl
|
|
= let (a,b) = _wlLine wl
|
|
ps = divideLine (zoneSize * 2) a b
|
|
in zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)
|
|
|
|
divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
|
divideWallIn wl wls =
|
|
let (wl':newWls) = divideWall wl
|
|
k = IM.newKey wls
|
|
newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
|
|
in foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls')
|
|
|
|
divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
|
|
divideWalls wls = foldl' (flip 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
|
|
|
|
shiftRoomTree :: Tree Room -> Tree Room
|
|
shiftRoomTree (Node t []) = Node t []
|
|
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 ( V2 0 0 -.- rotateV (pi-a) p , 0) $ shiftRoomBy (V2 0 0,pi-a) r
|
|
where
|
|
(p,a) = last $ _rmLinks r
|