Add tree structure generation

src/Dodge/Layout/Tree/Annotate.hs

@@ -0,0 +1,24 @@
+{-
+Annotating tree structures with desired properties for rooms.
+-}
+module Dodge.Layout.Tree.Annotate
+    where
+import Dodge.RandomHelp
+import Dodge.Layout.Tree.Polymorphic
+
+import Data.Tree
+import Control.Monad.State
+import System.Random
+
+data Annotation
+    = Lock Int
+    | Key  Int
+
+addLock :: RandomGen g => Int -> Tree [Annotation] -> State g (Tree [Annotation])
+addLock i t = do
+    (beforeLock, afterLock) <- splitTrunk t
+    newBefore <- applyToRandomNode (Key i :) beforeLock
+    return $ addToTrunk newBefore [Node [Lock i] afterLock]
+
+--annoToRoom :: RandomGen g => [Annotation] -> State g (Either Room Room)
+--annoToRoom as = undefined

src/Dodge/Layout/Tree/Either.hs

@@ -0,0 +1,22 @@
+{-|
+Combining and composing trees with 'Either' nodes.
+-}
+module Dodge.Layout.Tree.Either
+    ( expandTreeBy
+    ) 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)
+
+removeEither (Left y)  = y
+removeEither (Right y) = y

src/Dodge/Layout/Tree/GenerateStructure.hs

@@ -0,0 +1,56 @@
+{-
+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)
+
+{-
+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,5)
+    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

@@ -0,0 +1,111 @@
+module Dodge.Layout.Tree.Polymorphic
+    where
+import Dodge.RandomHelp
+
+import Data.Tree
+import Control.Monad.State
+import System.Random
+
+{-
+Creates a linear tree.
+Safe.
+-}
+treePost :: [a] -> a -> Tree a
+treePost []     y = Node y []
+treePost (x:xs) y = Node x [treePost xs y]
+
+{-
+Creates a tree with one trunk branch, 
+input as a list, that ends in another tree.
+-}
+treeTrunk 
+    :: [a]      -- ^ The trunk
+    -> Tree a   -- ^ The end of the tree
+    -> Tree a
+treeTrunk [] t     = t
+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
+
+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
+
+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 t = setRoot 0 t
+  where 
+    setRoot :: Int -> Tree a -> Tree Int
+    setRoot i (Node x 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) = fmap (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 a node 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.
+-}
+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:xs)) = trunkDepth x + 1
+
+{-
+Split a tree at a given point along its trunk.
+-}
+splitTrunkAt :: Int -> 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)
+
+{-
+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
+