diff --git a/package.yaml b/package.yaml index 38619ba3f..990eb51e1 100644 --- a/package.yaml +++ b/package.yaml @@ -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 +description: Description text, TODO link to README.md dependencies: - base >= 4.7 && < 5 diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index d72a1a4b2..8ecf536ae 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -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 diff --git a/src/Dodge/DepthFirst.hs b/src/Dodge/DepthFirst.hs new file mode 100644 index 000000000..27e3b57e1 --- /dev/null +++ b/src/Dodge/DepthFirst.hs @@ -0,0 +1,5 @@ +module Dodge.DepthFirst + where + +--dfs :: (a -> Bool) -> (a -> [a]) -> a -> Maybe a +--dfs cond f x diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 86a58b43d..ea527bc73 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -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,62 +25,75 @@ 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 - ( - [return $ return $ Right deadEndRoom - ] - ++ [return $ connectRoom corridor - ,return $ connectRoom door - ,glassSwitchBack >>= randomiseLinks] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [miniRoom3] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [roomCCrits] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++[roomMiniIntro] - ++ [longRoom >>= randomiseLinks] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ firstWeapon - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [randomiseLinks =<< pistolerRoom] - ++ [return $ connectRoom door] - ++ [randomiseLinks =<< shooterRoom] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] - ++ [return $ connectRoom corridor] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom corridor] - ++[return $ connectRoom corridor,return $ connectRoom door] - ++ [shootingRange] - ++ (replicate 3 $ randomiseLinks corridor) - ++[roomMiniIntro] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom corridor - ,return $ connectRoom door - ,slowDoorRoom] - ++ [return $ connectRoom corridor - ,spawnerRoom - ,return $ connectRoom corridor - ] - ) - $ randomiseLinks corridor + $ sequence $ treePost + ( + [return $ return $ Right deadEndRoom + ] + ++ [return $ connectRoom corridor + ,return $ connectRoom door + ,glassSwitchBack >>= (fmap connectRoom . randLinks)] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++ [miniRoom3] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++ [roomCCrits] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++[roomMiniIntro] + ++ [longRoom >>= (fmap connectRoom . randLinks)] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++ firstWeapon + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++ [(fmap connectRoom . randLinks) =<< pistolerRoom] + ++ [return $ connectRoom door] + ++ [(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 $ (fmap connectRoom . randLinks) corridor) + ++ [return $ connectRoom corridor] + ++[return $ connectRoom corridor,return $ connectRoom door] + ++ [shootingRange] + ++ (replicate 3 $ (fmap connectRoom . randLinks) corridor) + ++[roomMiniIntro] + ++ (replicate 3 $ (fmap connectRoom . randLinks) corridor) + ++ [return $ connectRoom corridor + ,return $ connectRoom door + ,slowDoorRoom] + ++ [return $ connectRoom corridor + ,spawnerRoom + ,return $ connectRoom corridor + ] + ) + $ (fmap connectRoom . randLinks) corridor roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room)) roomToLevel2 = join $ takeOne diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index e90ef110b..0a648a848 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -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 diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 6b89d6b5a..7a1dde1ac 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -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 - ,_pathGraph = path - ,_pathGraph' = pairGraph - ,_pathPoints = foldr insertPoint IM.empty (labNodes path) - ,_pathInc = pinc} +generateFromTree t w = updateWallZoning $ placeSpots plmnts + $ w {_walls = wallsFromTree tr + ,_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 + +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)) - (_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 +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 ((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 diff --git a/src/Dodge/Layout/Tree/Annotate.hs b/src/Dodge/Layout/Tree/Annotate.hs index 2c8590de9..547fa747a 100644 --- a/src/Dodge/Layout/Tree/Annotate.hs +++ b/src/Dodge/Layout/Tree/Annotate.hs @@ -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 diff --git a/src/Dodge/Layout/Tree/Either.hs b/src/Dodge/Layout/Tree/Either.hs index 203b079eb..ad05f067e 100644 --- a/src/Dodge/Layout/Tree/Either.hs +++ b/src/Dodge/Layout/Tree/Either.hs @@ -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) [] diff --git a/src/Dodge/Layout/Tree/Polymorphic.hs b/src/Dodge/Layout/Tree/Polymorphic.hs index 31265ce4b..cd8f2f383 100644 --- a/src/Dodge/Layout/Tree/Polymorphic.hs +++ b/src/Dodge/Layout/Tree/Polymorphic.hs @@ -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 diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs new file mode 100644 index 000000000..8e3e5cc42 --- /dev/null +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -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 diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index b12b072c4..43e23879a 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -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 diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs new file mode 100644 index 000000000..055717ce1 --- /dev/null +++ b/src/Dodge/Room/Corridor.hs @@ -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) + ] diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs new file mode 100644 index 000000000..1fb8de1a3 --- /dev/null +++ b/src/Dodge/Room/Link.hs @@ -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) diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 452bd2fe3..b7c3be615 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -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,22 +26,23 @@ updateCamera = rotCam . moveCamera . updateScopeZoom moveCamera :: World -> World moveCamera w = w & cameraCenter .~ idealPos & cameraViewFrom .~ sightFrom - where aimRangeFactor | _cameraZoom w == 0 = 0 - | otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w - aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1 - | otherwise = 0 - ypos = _crPos $ you w - idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w) - currentOffset = currentPos -.- camCenter - idealPos = camCenter +.+ rotateV (_cameraRot w) - (aimRangeFactor * aimingMult *.* _mousePos w) - currentPos = _cameraCenter w - camCenter = ypos +.+ scope - isCam :: Bool - isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera - scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos - sightFrom | isCam = camCenter - | otherwise = ypos + where + aimRangeFactor | _cameraZoom w == 0 = 0 + | otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w + aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1 + | otherwise = 0 + ypos = _crPos $ you w + idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w) + currentOffset = currentPos -.- camCenter + idealPos = camCenter +.+ rotateV (_cameraRot w) + (aimRangeFactor * aimingMult *.* _mousePos w) + currentPos = _cameraCenter w + camCenter = ypos +.+ scope + isCam :: Bool + isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera + scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos + sightFrom | isCam = camCenter + | otherwise = ypos updateScopeZoom :: World -> World updateScopeZoom w @@ -109,42 +118,54 @@ 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 - camPos = _cameraViewFrom w - camRot = _cameraRot w - wallZoom = min (halfWidth w / (horizontalMax+50) ) - (halfHeight w / (verticalMax+50) ) - idealZoom | SDL.ButtonRight `S.member` _mouseButtons w - = scZoom * - ( - min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax) - $ max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin) - (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac)) - ) - | otherwise - = min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax) - $ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin)) - (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac)) - changeZoom curZoom - | curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed - | curZoom < idealZoom - 0.01 = ((zoomInSpeed-1)*curZoom + idealZoom) / zoomInSpeed - | otherwise = idealZoom - -- these speeds are inverted, larger means slower - zoomInSpeed = 25 - zoomOutSpeed = 15 - zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..] - 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 + where + maxViewDistance = 800 + camPos = _cameraViewFrom w + camRot = _cameraRot w + wallZoom = farWallDist camPos w + idealZoom | SDL.ButtonRight `S.member` _mouseButtons w + = scZoom * + ( + min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax) + $ max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin) + (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac)) + ) + | otherwise + = min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax) + $ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin)) + (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac)) + changeZoom curZoom + | curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed + | curZoom < idealZoom - 0.01 = ((zoomInSpeed-1)*curZoom + idealZoom) / zoomInSpeed + | otherwise = idealZoom + -- these speeds are inverted, larger means slower + zoomInSpeed = 25 + zoomOutSpeed = 15 + 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 . (+.+) 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)