Add tree structure generation

src/Dodge/Layout/Generate.hs

@@ -0,0 +1,25 @@
+{-|
+Random generation of high level layout of rooms.
+-}
+module Dodge.Layout.Generate
+    where
+import Data.Tree
+import Control.Monad.State
+import System.Random
+
+generateLayout :: State g (Tree RoomProperties)
+generateLayout = undefined
+
+data RoomProperties = RProps
+    { _pickUpLevel  :: [Int]
+    , _pickUps      :: [Int]
+    }
+
+randomTreeStructure :: Int -> State g (Tree ())
+randomTreeStructure i = undefined
+
+treeMaxDepthFromTrunk :: Int -> Int -> State g (Tree ())
+treeMaxDepthFromTrunk nNodes maxDepth = do
+    undefined
+
+

src/Dodge/Layout/LockAndKey.hs

@@ -1,14 +0,0 @@
-module Dodge.Layout.LockAndKey
-  where
-
-data Key = Key Int
-
--- data Area 
---     = Area 
---         { _arID     :: Int    
---         , _arLinks  :: [Int]
---         , _arMonsters   :: [Creature]
---         , _arItems      :: [Item]
---         }
-
---generateGraph 

src/Dodge/Layout/Tree.hs

@@ -6,44 +6,4 @@ module Dodge.Layout.Tree
 import Data.Tree
 import Control.Monad.State
 import System.Random
--- | 'Left' elements get new children, 'Right' elements inherit the children from the
--- mapped over node
-expandTreeBy :: (a -> Tree (Either b b)) -> Tree a -> Tree b
-expandTreeBy f (Node x []) = fmap removeEither (f x)
-    where removeEither (Left y)  = y
-          removeEither (Right y) = y
-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)
 
-expandTreeRand :: RandomGen g => 
-        (a -> State g (Tree (Either b b))) -> Tree a -> State g (Tree b)
-expandTreeRand f (Node x []) = fmap (fmap removeEither) (f x)
-    where removeEither (Left y)  = y
-          removeEither (Right y) = y
-expandTreeRand f (Node x xs) = do
-    root <- f x
-    branches <- sequence $ map (expandTreeRand f) xs
-    return (appendAndRemove branches root)
-        where appendAndRemove :: [Tree a] -> Tree (Either a a) -> Tree a
-              appendAndRemove bran (Node (Left y) ys) = Node y (map (appendAndRemove bran) ys)
-              appendAndRemove bran (Node (Right y) _) = Node y bran
-
-collapseTree :: Tree (Tree (Either a a)) -> Tree (Either a a)
-collapseTree = g . expandTreeBy f
-    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) []
-          g (Node (Right x) xs) = Node (Left x) $ map g xs
-          g (Node y ys) = Node y $ map g ys
-
-treePost :: [a] -> a -> Tree a
-treePost []     y = Node y []
-treePost (x:xs) y = Node x [treePost xs y]
-
-treeTrunk :: [a] -> Tree a -> Tree a
-treeTrunk [] t     = t
-treeTrunk (x:xs) t = Node x [treeTrunk xs t]
-
-applyToRoot :: (a -> a) -> Tree a -> Tree a
-applyToRoot f (Node x xs) = Node (f x) xs

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
+