Random tree structure generation of rooms
This commit is contained in:
+1
-1
@@ -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
|
||||
|
||||
+3
-3
@@ -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
|
||||
|
||||
@@ -0,0 +1,5 @@
|
||||
module Dodge.DepthFirst
|
||||
where
|
||||
|
||||
--dfs :: (a -> Bool) -> (a -> [a]) -> a -> Maybe a
|
||||
--dfs cond f x
|
||||
+30
-12
@@ -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,16 +25,29 @@ 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
|
||||
@@ -38,7 +56,7 @@ lev1 = do
|
||||
]
|
||||
++ [return $ connectRoom corridor
|
||||
,return $ connectRoom door
|
||||
,glassSwitchBack >>= randomiseLinks]
|
||||
,glassSwitchBack >>= (fmap connectRoom . randLinks)]
|
||||
++ [return $ connectRoom corridor
|
||||
,return $ connectRoom door]
|
||||
++ [miniRoom3]
|
||||
@@ -48,25 +66,25 @@ lev1 = do
|
||||
++ [return $ connectRoom corridor
|
||||
,return $ connectRoom door]
|
||||
++[roomMiniIntro]
|
||||
++ [longRoom >>= randomiseLinks]
|
||||
++ [longRoom >>= (fmap connectRoom . randLinks)]
|
||||
++ [return $ connectRoom corridor
|
||||
,return $ connectRoom door]
|
||||
++ firstWeapon
|
||||
++ [return $ connectRoom corridor
|
||||
,return $ connectRoom door]
|
||||
++ [randomiseLinks =<< pistolerRoom]
|
||||
++ [(fmap connectRoom . randLinks) =<< pistolerRoom]
|
||||
++ [return $ connectRoom door]
|
||||
++ [randomiseLinks =<< shooterRoom]
|
||||
++ (replicate 3 $ randomiseLinks corridor)
|
||||
++ [(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 $ randomiseLinks corridor)
|
||||
++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
|
||||
++ [return $ connectRoom corridor]
|
||||
++[return $ connectRoom corridor,return $ connectRoom door]
|
||||
++ [shootingRange]
|
||||
++ (replicate 3 $ randomiseLinks corridor)
|
||||
++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
|
||||
++[roomMiniIntro]
|
||||
++ (replicate 3 $ randomiseLinks corridor)
|
||||
++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
|
||||
++ [return $ connectRoom corridor
|
||||
,return $ connectRoom door
|
||||
,slowDoorRoom]
|
||||
@@ -75,7 +93,7 @@ lev1 = do
|
||||
,return $ connectRoom corridor
|
||||
]
|
||||
)
|
||||
$ randomiseLinks corridor
|
||||
$ (fmap connectRoom . randLinks) corridor
|
||||
|
||||
roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room))
|
||||
roomToLevel2 = join $ takeOne
|
||||
|
||||
@@ -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
|
||||
|
||||
+40
-54
@@ -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
|
||||
generateFromTree t w = updateWallZoning $ placeSpots plmnts
|
||||
$ w {_walls = wallsFromTree tr
|
||||
,_pathGraph = path
|
||||
,_pathGraph' = pairGraph
|
||||
,_pathPoints = foldr insertPoint IM.empty (labNodes path)
|
||||
,_pathInc = pinc}
|
||||
,_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))
|
||||
shiftRoomTree (Node t ts) = Node t
|
||||
$ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
|
||||
(_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
|
||||
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
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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) []
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
+10
-70
@@ -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
|
||||
|
||||
@@ -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)
|
||||
]
|
||||
@@ -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)
|
||||
+33
-12
@@ -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,7 +26,8 @@ updateCamera = rotCam . moveCamera . updateScopeZoom
|
||||
moveCamera :: World -> World
|
||||
moveCamera w = w & cameraCenter .~ idealPos
|
||||
& cameraViewFrom .~ sightFrom
|
||||
where aimRangeFactor | _cameraZoom w == 0 = 0
|
||||
where
|
||||
aimRangeFactor | _cameraZoom w == 0 = 0
|
||||
| otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w
|
||||
aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1
|
||||
| otherwise = 0
|
||||
@@ -109,13 +118,16 @@ 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
|
||||
where
|
||||
maxViewDistance = 800
|
||||
camPos = _cameraViewFrom w
|
||||
camRot = _cameraRot w
|
||||
wallZoom = min (halfWidth w / (horizontalMax+50) )
|
||||
(halfHeight w / (verticalMax+50) )
|
||||
wallZoom = farWallDist camPos w
|
||||
idealZoom | SDL.ButtonRight `S.member` _mouseButtons w
|
||||
= scZoom *
|
||||
(
|
||||
@@ -134,17 +146,26 @@ autoZoomCam w = over cameraZoom changeZoom w
|
||||
-- these speeds are inverted, larger means slower
|
||||
zoomInSpeed = 25
|
||||
zoomOutSpeed = 15
|
||||
zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..]
|
||||
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 . (+.+) 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
|
||||
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)
|
||||
|
||||
Reference in New Issue
Block a user