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

Random tree structure generation of rooms

Browse Source
This commit is contained in:
jgk
2021-04-20 02:01:24 +02:00
parent 38d67520cc
commit b911a013e0
14 changed files with 407 additions and 235 deletions
Download Patch File Download Diff File Expand all files Collapse all files
package.yaml
+1 -1
View File
@@ -17,7 +17,7 @@ extra-source-files:
# To avoid duplicated efforts in documentation and dealing with the # To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is # complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file. # 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: dependencies:
- base >= 4.7 && < 5 - base >= 4.7 && < 5
src/Dodge/Base.hs
+3 -3
View File
@@ -189,11 +189,11 @@ wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-
_ -> IM.empty _ -> IM.empty
-- possible BUG, was associated with thingsHitLongLine -- 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 wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
{-# INLINE wallsAlongLine #-} {-# 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 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)) where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
kps = zoneOfLine' a b kps = zoneOfLine' a b
src/Dodge/DepthFirst.hs
+5
View File
@@ -0,0 +1,5 @@
module Dodge.DepthFirst
where
--dfs :: (a -> Bool) -> (a -> [a]) -> a -> Maybe a
--dfs cond f x
src/Dodge/Floor.hs
+65 -47
View File
@@ -1,5 +1,6 @@
module Dodge.Floor module Dodge.Floor
( lev1 ( lev1
, levx
, generateLevel , generateLevel
) )
where where
@@ -9,10 +10,14 @@ import Dodge.Data
import Dodge.Room import Dodge.Room
import Dodge.Room.Procedural import Dodge.Room.Procedural
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Link
import Dodge.Base import Dodge.Base
import Dodge.Layout import Dodge.Layout
import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Polymorphic
import Dodge.Layout.Tree.Either 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.Creature
import Dodge.SoundLogic import Dodge.SoundLogic
import Dodge.RandomHelp import Dodge.RandomHelp
@@ -20,62 +25,75 @@ import Dodge.LightSources
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Data.Tree import Data.Tree
import Data.Maybe (fromJust,isNothing)
import Control.Lens import Control.Lens
import Control.Monad.State import Control.Monad.State
import Control.Monad.Loops import Control.Monad.Loops
import System.Random 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 :: RandomGen g => State g (Tree Room)
lev1 = do 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] firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id) iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id)
$ sequence $ treePost $ sequence $ treePost
( (
[return $ return $ Right deadEndRoom [return $ return $ Right deadEndRoom
] ]
++ [return $ connectRoom corridor ++ [return $ connectRoom corridor
,return $ connectRoom door ,return $ connectRoom door
,glassSwitchBack >>= randomiseLinks] ,glassSwitchBack >>= (fmap connectRoom . randLinks)]
++ [return $ connectRoom corridor ++ [return $ connectRoom corridor
,return $ connectRoom door] ,return $ connectRoom door]
++ [miniRoom3] ++ [miniRoom3]
++ [return $ connectRoom corridor ++ [return $ connectRoom corridor
,return $ connectRoom door] ,return $ connectRoom door]
++ [roomCCrits] ++ [roomCCrits]
++ [return $ connectRoom corridor ++ [return $ connectRoom corridor
,return $ connectRoom door] ,return $ connectRoom door]
++[roomMiniIntro] ++[roomMiniIntro]
++ [longRoom >>= randomiseLinks] ++ [longRoom >>= (fmap connectRoom . randLinks)]
++ [return $ connectRoom corridor ++ [return $ connectRoom corridor
,return $ connectRoom door] ,return $ connectRoom door]
++ firstWeapon ++ firstWeapon
++ [return $ connectRoom corridor ++ [return $ connectRoom corridor
,return $ connectRoom door] ,return $ connectRoom door]
++ [randomiseLinks =<< pistolerRoom] ++ [(fmap connectRoom . randLinks) =<< pistolerRoom]
++ [return $ connectRoom door] ++ [return $ connectRoom door]
++ [randomiseLinks =<< shooterRoom] ++ [(fmap connectRoom . randLinks) =<< shooterRoom]
++ (replicate 3 $ randomiseLinks corridor) ++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
++ [return $ connectRoom corridor] ++ [return $ connectRoom corridor]
++ (replicate 3 $ randomiseLinks corridor) ++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
++ [return $ connectRoom corridor] ++ [return $ connectRoom corridor]
++[return $ connectRoom corridor,return $ connectRoom door] ++[return $ connectRoom corridor,return $ connectRoom door]
++ [shootingRange] ++ [shootingRange]
++ (replicate 3 $ randomiseLinks corridor) ++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
++[roomMiniIntro] ++[roomMiniIntro]
++ (replicate 3 $ randomiseLinks corridor) ++ (replicate 3 $ (fmap connectRoom . randLinks) corridor)
++ [return $ connectRoom corridor ++ [return $ connectRoom corridor
,return $ connectRoom door ,return $ connectRoom door
,slowDoorRoom] ,slowDoorRoom]
++ [return $ connectRoom corridor ++ [return $ connectRoom corridor
,spawnerRoom ,spawnerRoom
,return $ connectRoom corridor ,return $ connectRoom corridor
] ]
) )
$ randomiseLinks corridor $ (fmap connectRoom . randLinks) corridor
roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room)) roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room))
roomToLevel2 = join $ takeOne roomToLevel2 = join $ takeOne
src/Dodge/Initialisation.hs
+1 -1
View File
@@ -23,7 +23,7 @@ firstWorld :: IO World
firstWorld = do firstWorld = do
i <- randomRIO (0,5000) i <- randomRIO (0,5000)
putStrLn $ "Random seed for level generation: " ++ show ( i :: Int) 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 :: World
initialWorld = defaultWorld initialWorld = defaultWorld
src/Dodge/Layout.hs
+45 -59
View File
@@ -10,9 +10,11 @@ import Dodge.Base
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.Graph import Dodge.Graph
import Dodge.Layout.Tree import Dodge.Layout.Tree
import Dodge.Layout.Tree.Polymorphic (applyToRoot)
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Default import Dodge.Default
import Geometry import Geometry
import Dodge.Room.Link
import Control.Monad.State import Control.Monad.State
import Control.Lens import Control.Lens
@@ -29,24 +31,35 @@ import Data.Graph.Inductive.NodeMap
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.IntMap.Strict as IM 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 -- | connects a collection (tree) of rooms together
generateFromTree :: State StdGen (Tree Room) -> World -> World generateFromTree :: State StdGen (Tree Room) -> World -> World
generateFromTree t w = zoning $ placeSpots plmnts generateFromTree t w = updateWallZoning $ placeSpots plmnts
$ w {_walls = wallsFromTree tr, _randGen = g $ w {_walls = wallsFromTree tr
,_pathGraph = path ,_pathGraph = path
,_pathGraph' = pairGraph ,_pathGraph' = pairGraph
,_pathPoints = foldr insertPoint IM.empty (labNodes path) ,_pathPoints = foldr insertPoint IM.empty (labNodes path)
,_pathInc = pinc} ,_pathInc = pinc
}
where where
tr = evalState t $ _randGen w tr = evalState t $ _randGen w
plmnts = concatMap _rmPS $ flatten tr plmnts = concatMap _rmPS $ flatten tr
g = _randGen w
path = pairsToGraph dist pairGraph path = pairsToGraph dist pairGraph
pairGraph = makePath tr pairGraph = makePath tr
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
pinc = M.fromList $ pairsToIncidence pairGraph 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 wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
= insertIMInZone x y wlid wl = insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
@@ -54,6 +67,7 @@ generateFromTree t w = zoning $ placeSpots plmnts
wlid = _wlID wl wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1) ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
makePath :: Tree Room -> [(Point2,Point2)] makePath :: Tree Room -> [(Point2,Point2)]
makePath = concat . map _rmPath . flatten makePath = concat . map _rmPath . flatten
@@ -71,6 +85,13 @@ wallsFromTree t =
f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i} f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i}
g (x,y) = (x-3855,y - 2613) 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 :: Wall -> [Wall]
divideWall wl divideWall wl
= let (a:b:_) = _wlLine 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 insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
where f _ = IM.insert 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' -- the old version of this used a version of polysIntersect with intersectSegSeg'
boundClip :: Tree Room -> Bool boundClip :: Tree Room -> Bool
boundClip t = or $ map (uncurry polysIntersect) [(x,y) | x<- xs, y<-xs, x>y] 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 :: Tree Room -> Bool
noBoundClip = not . boundClip 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 :: Tree Room -> Tree Room
shiftRoomTree (Node t []) = Node t [] shiftRoomTree (Node t []) = Node t []
shiftRoomTree (Node t ts) = Node t $ zipWith (\l -> shiftRoomTree . onRoot (shiftRoomBy l . f)) shiftRoomTree (Node t ts) = Node t
(_rmLinks t) $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
ts (_rmLinks t)
where f r = shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0) $ shiftRoomBy ((0,0),pi-a) r ts
where (p,a) = last $ _rmLinks 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
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
src/Dodge/Layout/Tree/Annotate.hs
+11 -2
View File
@@ -5,6 +5,10 @@ module Dodge.Layout.Tree.Annotate
where where
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Polymorphic
import Dodge.Room.Procedural
import Dodge.Room.Link
import Dodge.Room.Data
import Dodge.Room
import Data.Tree import Data.Tree
import Control.Monad.State import Control.Monad.State
@@ -13,6 +17,7 @@ import System.Random
data Annotation data Annotation
= Lock Int = Lock Int
| Key Int | Key Int
| Corridor
addLock :: RandomGen g => Int -> Tree [Annotation] -> State g (Tree [Annotation]) addLock :: RandomGen g => Int -> Tree [Annotation] -> State g (Tree [Annotation])
addLock i t = do addLock i t = do
@@ -20,5 +25,9 @@ addLock i t = do
newBefore <- applyToRandomNode (Key i :) beforeLock newBefore <- applyToRandomNode (Key i :) beforeLock
return $ addToTrunk newBefore [Node [Lock i] afterLock] return $ addToTrunk newBefore [Node [Lock i] afterLock]
--annoToRoom :: RandomGen g => [Annotation] -> State g (Either Room Room) padCorridors :: Tree [Annotation] -> Tree [Annotation]
--annoToRoom as = undefined 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
src/Dodge/Layout/Tree/Either.hs
+14
View File
@@ -3,6 +3,8 @@ Combining and composing trees with 'Either' nodes.
-} -}
module Dodge.Layout.Tree.Either module Dodge.Layout.Tree.Either
( expandTreeBy ( expandTreeBy
, connectRoom
, deadRoom
) where ) where
import Data.Tree import Data.Tree
@@ -20,3 +22,15 @@ expandTreeBy f (Node x xs) = appendAndRemove $ f x
removeEither (Left y) = y removeEither (Left y) = y
removeEither (Right 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) []
src/Dodge/Layout/Tree/Polymorphic.hs
+1 -1
View File
@@ -29,7 +29,7 @@ treeTrunk (x:xs) t = Node x [treeTrunk xs t]
Applies a function to the root of a tree. Applies a function to the root of a tree.
-} -}
applyToRoot :: (a -> a) -> Tree a -> Tree a 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 treeSize = length . flatten
src/Dodge/Layout/Tree/Shift.hs
+55
View File
@@ -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
src/Dodge/Room.hs
+10 -70
View File
@@ -2,7 +2,9 @@
Specification of individual rooms. Specification of individual rooms.
-} -}
module Dodge.Room module Dodge.Room
where ( module Dodge.Room
, module Dodge.Room.Corridor
) where
import Dodge.Data import Dodge.Data
import Dodge.Item.Weapon import Dodge.Item.Weapon
import Dodge.Creature import Dodge.Creature
@@ -21,6 +23,8 @@ import Dodge.SoundLogic
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Placement import Dodge.Room.Placement
import Dodge.Room.Procedural import Dodge.Room.Procedural
import Dodge.Room.Corridor
import Dodge.Room.Link
import Geometry import Geometry
import Picture import Picture
@@ -79,63 +83,6 @@ airlock n = Room
] ]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red 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 :: Float -> Float -> Room
roomC x y = Room roomC x y = Room
{ _rmPolys = [rectNSWE y 0 0 x] { _rmPolys = [rectNSWE y 0 0 x]
@@ -143,7 +90,6 @@ roomC x y = Room
, _rmPath = [] , _rmPath = []
, _rmPS = [windowLine (x/2,0) (x/2,y-60) , _rmPS = [windowLine (x/2,0) (x/2,y-60)
] ]
--, _rmBound = rectNSWE y 0 0 x
, _rmBound = rectNSWE (y+5) (-5) (-5) (x+5) , _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
} }
where where
@@ -161,12 +107,6 @@ roomPadCut ps p = Room
, _rmPS = [] , _rmPS = []
, _rmBound = [] , _rmBound = []
} }
door :: Room door :: Room
door = Room door = Room
{ _rmPolys = [rectNSWE 40 0 0 40] { _rmPolys = [rectNSWE 40 0 0 40]
@@ -305,7 +245,7 @@ miniRoom3 = do
,PS cp (pi/8+7*pi/4) b ,PS cp (pi/8+7*pi/4) b
,PS (w/2,h/2) 0 putLamp ,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 :: Point2 -> Point2 -> Point2
rot90Around cen p = cen +.+ vNormal (p -.- cen) rot90Around cen p = cen +.+ vNormal (p -.- cen)
@@ -318,7 +258,7 @@ roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treePost
,join $ takeOne [miniTree2,glassLesson] ,join $ takeOne [miniTree2,glassLesson]
-- ,join $ takeOne [miniRoom1] -- ,join $ takeOne [miniRoom1]
] ]
$ randomiseLinks corridor $ fmap connectRoom $ randLinks corridor
where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs 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 f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
g (Node (Right x) []) = Node (Right x) [] g (Node (Right x) []) = Node (Right x) []
@@ -392,7 +332,7 @@ weaponEmptyRoom = do
,PS (w-20,20) (pi/2) $ randC1 ,PS (w-20,20) (pi/2) $ randC1
,PS (w/2,h/2) 0 $ putLamp ,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) $ set rmPS plmnts $ roomRect' w h 2 2)
@@ -437,7 +377,7 @@ weaponBetweenPillars = do
,PS crPos1 (d crPos1) $ randC1 ,PS crPos1 (d crPos1) $ randC1
,PS crPos2 (d crPos2) $ 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 where f (_,a) = a == 0
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room)) blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
@@ -708,5 +648,5 @@ spawnerRoom = do
,PS (x/2, y-10) 0 putLamp ,PS (x/2, y-10) 0 putLamp
] ]
let f ((lx,_),_) = lx < x/2-5 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 return $ treeTrunk [Left (airlock 0)] roomWithSpawner
src/Dodge/Room/Corridor.hs
+67
View File
@@ -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)
]
src/Dodge/Room/Link.hs
+57
View File
@@ -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)
src/Dodge/Update/Camera.hs
+72 -51
View File
@@ -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.Data
import Dodge.Base import Dodge.Base
@@ -18,22 +26,23 @@ updateCamera = rotCam . moveCamera . updateScopeZoom
moveCamera :: World -> World moveCamera :: World -> World
moveCamera w = w & cameraCenter .~ idealPos moveCamera w = w & cameraCenter .~ idealPos
& cameraViewFrom .~ sightFrom & cameraViewFrom .~ sightFrom
where aimRangeFactor | _cameraZoom w == 0 = 0 where
| otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w aimRangeFactor | _cameraZoom w == 0 = 0
aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1 | otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w
| otherwise = 0 aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1
ypos = _crPos $ you w | otherwise = 0
idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w) ypos = _crPos $ you w
currentOffset = currentPos -.- camCenter idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w)
idealPos = camCenter +.+ rotateV (_cameraRot w) currentOffset = currentPos -.- camCenter
(aimRangeFactor * aimingMult *.* _mousePos w) idealPos = camCenter +.+ rotateV (_cameraRot w)
currentPos = _cameraCenter w (aimRangeFactor * aimingMult *.* _mousePos w)
camCenter = ypos +.+ scope currentPos = _cameraCenter w
isCam :: Bool camCenter = ypos +.+ scope
isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera isCam :: Bool
scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera
sightFrom | isCam = camCenter scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos
| otherwise = ypos sightFrom | isCam = camCenter
| otherwise = ypos
updateScopeZoom :: World -> World updateScopeZoom :: World -> World
updateScopeZoom w updateScopeZoom w
@@ -109,42 +118,54 @@ zoomCamOut w | zoomOutKey (_keyConfig w) `S.member` _keys w
= w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01} = w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01}
| otherwise = w | otherwise = w
{-
Automatically sets the zoom of the camera according to the surrounding walls.
-}
autoZoomCam :: World -> World autoZoomCam :: World -> World
autoZoomCam w = over cameraZoom changeZoom w autoZoomCam w = over cameraZoom changeZoom w
where maxViewDistance = 800 where
camPos = _cameraViewFrom w maxViewDistance = 800
camRot = _cameraRot w camPos = _cameraViewFrom w
wallZoom = min (halfWidth w / (horizontalMax+50) ) camRot = _cameraRot w
(halfHeight w / (verticalMax+50) ) wallZoom = farWallDist camPos w
idealZoom | SDL.ButtonRight `S.member` _mouseButtons w idealZoom | SDL.ButtonRight `S.member` _mouseButtons w
= scZoom * = scZoom *
( (
min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax) min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax)
$ max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin) $ max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin)
(wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac)) (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac))
) )
| otherwise | otherwise
= min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax) = min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax)
$ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin)) $ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin))
(wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac)) (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac))
changeZoom curZoom changeZoom curZoom
| curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed | curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed
| curZoom < idealZoom - 0.01 = ((zoomInSpeed-1)*curZoom + idealZoom) / zoomInSpeed | curZoom < idealZoom - 0.01 = ((zoomInSpeed-1)*curZoom + idealZoom) / zoomInSpeed
| otherwise = idealZoom | otherwise = idealZoom
-- these speeds are inverted, larger means slower -- these speeds are inverted, larger means slower
zoomInSpeed = 25 zoomInSpeed = 25
zoomOutSpeed = 15 zoomOutSpeed = 15
zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..] scZoom = fromMaybe 1 $ yourItem w ^? itAttachment . _Just . scopeZoom
rRays = rotF [( maxViewDistance,y) | y <- zs]
lRays = rotF [(-maxViewDistance,y) | y <- zs] farWallDist :: Point2 -> World -> Float
tRays = rotF [(y, maxViewDistance) | y <- zs] farWallDist cpos w = min (halfWidth w / (horizontalMax+50) ) (halfHeight w / (verticalMax+50) )
bRays = rotF [(y,-maxViewDistance) | y <- zs] where
rotF = map (h . (+.+) camPos . rotateV (_cameraRot w)) horizontalMax = maximum $ map (h' (1,0)) rRays ++ map (h' (-1,0)) lRays
h p = fromMaybe p $ collidePointIndirect camPos p $ wallsAlongLine camPos p w verticalMax = maximum $ map (h' (0,1)) tRays ++ map (h' (0,-1)) bRays
h' x p = dotV (rotateV camRot x) (p -.- camPos) -- TODO: fix wallsAlongLine and use instead of checking against all walls
horizontalMax = maximum $ map (h' (1,0)) rRays ++ map (h' (-1,0)) lRays -- h p = fromMaybe p $ collidePointIndirect cpos p $ wallsAlongLine cpos p w
verticalMax = maximum $ map (h' (0,1)) tRays ++ map (h' (0,-1)) bRays h p = fromMaybe p . collidePointIndirect cpos p $ _walls w
scZoom = fromMaybe 1 $ yourItem w ^? itAttachment . _Just . scopeZoom 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 . (+.+) cpos . rotateV (_cameraRot w))
zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..]
maxViewDistance = 800
dirRays :: Float -> [Point2] dirRays :: Float -> [Point2]
dirRays dir = take 11 $ iterate (rotateV (0.5 * pi / 10)) $ rotateV (dir-pi*0.25) (600,0) dirRays dir = take 11 $ iterate (rotateV (0.5 * pi / 10)) $ rotateV (dir-pi*0.25) (600,0)