diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index cc6805d43..4af2c75c4 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -4,8 +4,7 @@ module Dodge.Annotation , module Dodge.Annotation ) where import Dodge.RandomHelp -import Dodge.Layout.Tree.Polymorphic -import Dodge.Layout.Tree.Either +import Dodge.Tree import Dodge.Room import Dodge.Annotation.Data diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index bf5637483..c78456b18 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -839,7 +839,6 @@ data Goal newtype Zone a = Zone { _znObjects :: IM.IntMap (IM.IntMap a) } - makeLenses ''World makeLenses ''Cloud makeLenses ''Creature diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index d628ce460..2dac13a31 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -8,10 +8,8 @@ import Dodge.Data import Dodge.Creature.State.Data import Dodge.Room import Dodge.Placement.Instance.Button -import Dodge.Layout.Tree.Polymorphic -import Dodge.Layout.Tree.Either +import Dodge.Tree import Dodge.Annotation -import Dodge.Layout.Tree.Shift import Dodge.Creature import Dodge.LevelGen.Data import Dodge.LevelGen.Switch @@ -106,7 +104,7 @@ layoutLevelFromSeed i seed = do let rmtree = inorderNumberTree $ evalState initialRoomTree g putStrLn "Abstract layout: " putStrLn $ compactDrawTree $ fmap (show . snd) rmtree - mrs <- positionRooms rmtree + mrs <- positionRoomsFromTree rmtree case mrs of Just rs -> do putStrLn $ "After " ++ show i' diff --git a/src/Dodge/Layout/Tree.hs b/src/Dodge/Layout/Tree.hs deleted file mode 100644 index 8e38939b4..000000000 --- a/src/Dodge/Layout/Tree.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-| -Combining and composing trees. --} -module Dodge.Layout.Tree - where ---import Data.Tree ---import Control.Monad.State ---import System.Random - diff --git a/src/Dodge/Layout/Tree/Either.hs b/src/Dodge/Layout/Tree/Either.hs deleted file mode 100644 index b73c1fa50..000000000 --- a/src/Dodge/Layout/Tree/Either.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-| -Combining and composing trees with 'Either' nodes. --} -module Dodge.Layout.Tree.Either - ( expandTreeBy - , appendEitherTree - , connectRoom - , connectTrunk - , deadRoom - , linkEitherTrees - ) where -import Data.Tree - --- | 'Left' elements get new children as given by the node function, --- 'Right' elements inherit the children from the base tree -expandTreeBy - :: (a -> Tree (Either b b)) -- ^ Node function - -> Tree a -- ^ Base tree - -> Tree b -expandTreeBy f (Node x []) = fmap removeEither (f x) -expandTreeBy f (Node x xs) = appendAndRemove $ f x - where - appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys) - appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs) - --- | Appends a second either forest at the 'Right' elements of a first either --- tree. --- Makes such 'Right' elements into 'Left's. -appendEitherTree - :: Tree (Either a a) -- ^ The first tree - -> [Tree (Either a a)] -- ^ The forest to append - -> Tree (Either a a) -appendEitherTree (Node (Left x) ts) ts' = Node (Left x) $ map (`appendEitherTree` ts') ts -appendEitherTree (Node (Right x) _) ts' = Node (Left x) ts' - -linkEitherTrees :: [Tree (Either a a)] -> Tree (Either a a) -linkEitherTrees (t:s:ts) = linkEitherTrees (appendEitherTree t [s]:ts) -linkEitherTrees [t] = t -linkEitherTrees [] = error "tried to concatenate an empty list of either trees" - -removeEither :: Either p p -> p -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 single Either connection at the end of a tree. --} -connectTrunk :: Tree a -> Tree (Either a a) -connectTrunk (Node x (t:ts)) = Node (Left x) (connectTrunk t : map (fmap Left) ts) -connectTrunk (Node x []) = Node (Right x) [] - -{- | -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/GenerateStructure.hs b/src/Dodge/Layout/Tree/GenerateStructure.hs deleted file mode 100644 index ad734ef52..000000000 --- a/src/Dodge/Layout/Tree/GenerateStructure.hs +++ /dev/null @@ -1,46 +0,0 @@ -{- -Procedural generation of tree structures. - -A /trunk/ refers to the successive first nodes in lists of children. --} -module Dodge.Layout.Tree.GenerateStructure - where -import Dodge.RandomHelp - -import Data.Tree -import Control.Monad.State -import System.Random -{- Single branched tree (a trunk). -} -treePath :: Int -> Tree () -treePath 0 = Node () [] -treePath x = Node () [treePath (x-1)] -{- Adds a branch at a certain point down a trunk. -} -addBranchAt - :: Int -- ^ Depth to add branch at - -> Tree () -- ^ Branch to add - -> Tree () -- ^ Starting tree - -> Tree () -addBranchAt 0 b (Node () xs) = Node () (xs ++ [b]) -addBranchAt i b (Node () (x:xs)) - = Node () (addBranchAt (i-1) b x : xs) -addBranchAt _ _ _ = error "Trying to add a branch too far along a tree" -{- Randomly generate a tree containing a maximum of three nodes. -} -smallBranch :: RandomGen g => State g (Tree ()) -smallBranch = takeOne - [ treePath 0 - , treePath 1 - , treePath 2 - , addBranchAt 0 (treePath 0) (treePath 1) - ] - -{- -Randomly generate a small tree. --} -aTreeStrut :: RandomGen g => State g (Tree ()) -aTreeStrut = do - d <- state $ randomR (9,11:: Int) - nbs <- state $ randomR (2,4) - bds <- takeN nbs [1 .. d - 1] - bs <- replicateM nbs smallBranch - let trunk = treePath d - return $ foldr (uncurry addBranchAt) trunk $ zip bds bs diff --git a/src/Dodge/Layout/Tree/Polymorphic.hs b/src/Dodge/Layout/Tree/Polymorphic.hs deleted file mode 100644 index f3eaecbfe..000000000 --- a/src/Dodge/Layout/Tree/Polymorphic.hs +++ /dev/null @@ -1,158 +0,0 @@ -{- -Helpers for the manipulation of rose trees. -Throughout, the _trunk_ refers to successive first children in the tree. -For example, in the tree - -> Node a [ Node b [], Node c [Node d []] ] - -the nodes in the trunk are [a,b] (note that d is not the first child of b). - -} -module Dodge.Layout.Tree.Polymorphic - ( applyToRoot - , treeFromPost - , treeFromTrunk - , splitTrunk - , applyToRandomNode - , addToTrunk - , inorderNumberTree - ) - where -import Dodge.RandomHelp - -import Data.Tree -import Control.Monad.State -import System.Random - -{- | -Creates a linear tree. -Safe. --} -treeFromPost :: [a] -> a -> Tree a -treeFromPost [] y = Node y [] -treeFromPost (x:xs) y = Node x [treeFromPost xs y] - -{- | -Creates a tree with one trunk branch, -input as a list, that ends in another tree. --} -treeFromTrunk - :: [a] -- ^ The trunk - -> Tree a -- ^ The end of the tree - -> Tree a -treeFromTrunk [] t = t -treeFromTrunk (x:xs) t = Node x [treeFromTrunk xs t] - -{- | -Applies a function to the root of a tree. --} -applyToRoot :: (a -> a) -> Tree a -> Tree a -applyToRoot f (Node t ts) = Node (f t) ts - --- find use for? ----- | Consider defining this using generalised recursion patterns ---treeSize :: Tree a -> Int ---treeSize = length . flatten - -{- | -Applies a function to a specific node determined by a list of indices. -Unsafe (partial function). --} -applyToNode :: [Int] -> (a -> a) -> Tree a -> Tree a -applyToNode [] f t = applyToRoot f t -applyToNode (i:is) f (Node x xs) = Node x (ys ++ [applyToNode is f z] ++ zs) - where - (ys, z:zs) = splitAt i xs - --- do not delete: find use for ---{- | ---Applies a function to the first node along a trunk that satisfies a given property. ----} ---applyToSubTrunkBy :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> Tree a ---applyToSubTrunkBy cond f (Node x (t:ts)) --- | cond x = f (Node x (t:ts)) --- | otherwise = Node x (applyToSubTrunkBy cond f t : ts) ---applyToSubTrunkBy _ _ t = t - --- find use for? ---zipTree :: Tree a -> Tree b -> Tree (a,b) ---zipTree (Node x xs) (Node y ys) = Node (x,y) $ zipWith zipTree xs ys - -{- | -Makes each node into its child number, i.e. the index it has -in the list of children of its parent. --} -treeChildNums :: Tree a -> Tree Int -treeChildNums = setRoot 0 - where - setRoot :: Int -> Tree a -> Tree Int - setRoot i (Node _ xs) = Node i (zipWith setRoot [0..] xs) - -{- | -Makes each node into its path, i.e. the list of indices that, -when followed from the root, lead to the node. --} -treePaths :: Tree a -> Tree [a] -treePaths (Node x xs) = (x :) <$> Node [] (map treePaths xs) - -{- | -Picks a random path in the tree. -Uniform probability that the path leads to any specific node. --} -randomPath :: RandomGen g => Tree a -> State g [Int] -randomPath = takeOne . flatten . treePaths . treeChildNums - -{- | -Apply a function to the value of a node; -the node is picked uniformly at random. --} -applyToRandomNode :: RandomGen g => (a -> a) -> Tree a -> State g (Tree a) -applyToRandomNode f t = do - p <- randomPath t - return $ applyToNode p f t - -{- | -Add a forest to the end of a tree (along the trunk). --} -addToTrunk :: Tree a -> [Tree a] -> Tree a -addToTrunk (Node x []) f = Node x f -addToTrunk (Node x (t:ts)) f = Node x (addToTrunk t f : ts) - -{- | -Find the depth of a tree along the trunk. --} -trunkDepth :: Tree a -> Int -trunkDepth (Node _ []) = 0 -trunkDepth (Node _ (x:_)) = trunkDepth x + 1 - -{- | -Split a tree at a given point along its trunk. --} -splitTrunkAt - :: Int -- ^ Split depth - -> Tree a -> (Tree a, [Tree a]) -splitTrunkAt 0 (Node x xs) = (Node x [],xs) -splitTrunkAt i (Node y (x:xs)) = - let (t, ts) = splitTrunkAt (i-1) x - in (Node y (t : xs) , ts) -splitTrunkAt _ (Node _ []) = error "Trying to split to short a trunk" - -{- | -Split a tree at a random point along its trunk. --} -splitTrunk :: RandomGen g => Tree a -> State g (Tree a, [Tree a]) -splitTrunk t = do - i <- state $ randomR (0, trunkDepth t) - return $ splitTrunkAt i t - --- untested -inorderNumberTree :: Tree a -> Tree (a,Int) -inorderNumberTree = fst . f 0 - where - f i (Node x ts) = - let (ts',i') = g (i+1) ts - in (Node (x,i) ts', i') - g i (t:ts) = - let (t',i') = f i t - (ts',i'') = g i' ts - in (t': ts', i'') - g i [] = ([], i) diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs deleted file mode 100644 index cca4aadee..000000000 --- a/src/Dodge/Layout/Tree/Shift.hs +++ /dev/null @@ -1,58 +0,0 @@ -{- | Given a tree of rooms, tries to shift them into place in such a way that their -links connect and that none of them clip. -Creates a list of rooms; after this step the structure is determined by the actual positions of rooms. -} -module Dodge.Layout.Tree.Shift - ( positionRooms - ) where -import Dodge.LevelGen.Data -import Dodge.Room.Link -import Dodge.Layout.Tree.Polymorphic -import Geometry.ConvexPoly -import Geometry.Data - -import Data.Tree -import Data.Sequence hiding (zipWith) -import Data.List (delete) -import Data.Bifunctor -import Control.Lens hiding (Empty, (<|) , (|>)) - -type RoomInt = (Room,Int) - -positionRooms :: Tree RoomInt -> IO (Maybe [Room]) -positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty - -posRms :: [ConvexPoly] - -> RoomInt - -> [Tree RoomInt] - -> Seq (Tree RoomInt) - -> IO (Maybe [Room]) -posRms bounds (parent,_) [] st = case st of - Empty -> return $ Just [] - Node childi ts :<| tseq - -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi ts tseq -posRms bounds parenti (t@(Node (_,i') _):ts) tseq = do - putStr $ "Trying to place room " ++ show i' ++ ": " - tryLinks 0 (_rmLinks parent) - where - parent = fst parenti - tryLinks _ [] = putStrLn "all links tried" >> return Nothing - tryLinks j (l:ls) - | clipping = tryLinks (j+1) ls - | otherwise = do - putStrLn $ "placing at link " ++ show j - mayrs <- posRms (convexBounds ++ bounds) (first upr parenti) ts (tseq |> shiftedt) - case mayrs of - Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls - Just rs -> return (Just rs) - where - convexBounds = map pointsToPoly $ _rmBound r' - clipping = or (convexPolysOverlap <$> convexBounds <*> bounds) - upr rm = lnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :) - l' = shiftLinkBy (_rmShift parent) l - r' = doRoomShift . fst $ rootLabel shiftedt - shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t - -lnkEff :: (Point2,Float) -> Room -> Room -lnkEff x rm = case _rmLinkEff rm of - (eff:effs) -> eff x $ rm & rmLinkEff .~ effs - _ -> rm diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs index a6e2dde59..47da6e9d0 100644 --- a/src/Dodge/Room/Boss.hs +++ b/src/Dodge/Room/Boss.hs @@ -12,7 +12,7 @@ import Dodge.Room.Path --import Dodge.LevelGen.Data import Dodge.Creature import Dodge.RandomHelp -import Dodge.Layout.Tree.Polymorphic +import Dodge.Tree import Geometry import Data.Tree diff --git a/src/Dodge/Room/Branch.hs b/src/Dodge/Room/Branch.hs index 249008b26..1b62c7aad 100644 --- a/src/Dodge/Room/Branch.hs +++ b/src/Dodge/Room/Branch.hs @@ -9,7 +9,7 @@ import Dodge.Room.Door import Dodge.Room.Link import Dodge.Room.Procedural --import Dodge.LevelGen.Data -import Dodge.Layout.Tree.Polymorphic +import Dodge.Tree import Control.Monad.State import System.Random diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index d57cb4b38..d2310e3f0 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -12,7 +12,7 @@ import Dodge.Room.Corridor --import Dodge.Default.Wall import Dodge.RandomHelp import Dodge.Creature -import Dodge.Layout.Tree.Polymorphic +import Dodge.Tree import Data.Tree import Control.Monad.State diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 239907be3..17d00fffe 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -8,8 +8,7 @@ import Dodge.Room.Foreground import Dodge.LevelGen.Data import Dodge.RandomHelp import Dodge.Default.Wall -import Dodge.Layout.Tree.Polymorphic -import Dodge.Layout.Tree.Either +import Dodge.Tree import Dodge.Placement.Instance --import Dodge.LevelGen.Data import Dodge.Room.Procedural diff --git a/src/Dodge/Room/RunPast.hs b/src/Dodge/Room/RunPast.hs index e18c0d689..c082b5878 100644 --- a/src/Dodge/Room/RunPast.hs +++ b/src/Dodge/Room/RunPast.hs @@ -13,7 +13,7 @@ import Dodge.Room.Corridor --import Dodge.Room.RoadBlock import Dodge.PlacementSpot import Dodge.Placement.Instance -import Dodge.Layout.Tree.Polymorphic +import Dodge.Tree import Dodge.Item.Random --import Dodge.Item.Weapon.SprayGuns --import Dodge.Item.Weapon.Grenade diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index ca22d5ab8..b1100c7da 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -5,7 +5,7 @@ import Dodge.PlacementSpot import Dodge.Room.RunPast import Dodge.Data import Dodge.Default -import Dodge.Layout.Tree.Either +import Dodge.Tree import Dodge.RandomHelp import Dodge.Room.Door import Dodge.Room.Corridor @@ -15,7 +15,6 @@ import Dodge.Room.Procedural import Dodge.Room.Foreground import Dodge.Room.RoadBlock import Dodge.Placement.Instance -import Dodge.Layout.Tree.Polymorphic import Dodge.Item.Random import Dodge.Item.Weapon.BulletGuns import Dodge.Item.Weapon.Utility