Start to rework composition of trees

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.Tree
-import Dodge.Layout.Tree.Either
 import Dodge.Room
 import Dodge.Annotation.Data
 

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

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.Tree
-import Dodge.Layout.Tree.Either
 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' 

src/Dodge/Layout/Tree.hs

@@ -1,9 +0,0 @@
-{-|
-Combining and composing trees.
--}
-module Dodge.Layout.Tree
-    where
---import Data.Tree
---import Control.Monad.State
---import System.Random
-

src/Dodge/Layout/Tree/Either.hs

@@ -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) []

src/Dodge/Layout/Tree/GenerateStructure.hs

@@ -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

src/Dodge/Layout/Tree/Polymorphic.hs

@@ -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)

src/Dodge/Layout/Tree/Shift.hs

@@ -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

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

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

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

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.Tree
-import Dodge.Layout.Tree.Either
 import Dodge.Placement.Instance
 --import Dodge.LevelGen.Data
 import Dodge.Room.Procedural

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

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