Ready for replacement of Either with bespoke data type for compo trees

src/Dodge/Tree.hs

@@ -0,0 +1,13 @@
+{-| Collects together tree modules. -}
+module Dodge.Tree 
+    ( module Dodge.Tree.Shift
+    , module Dodge.Tree.GenerateStructure
+    , module Dodge.Tree.Polymorphic
+    , module Dodge.Tree.Compose
+    , module Dodge.Tree.Compose.Data
+    ) where
+import Dodge.Tree.Shift
+import Dodge.Tree.GenerateStructure
+import Dodge.Tree.Polymorphic
+import Dodge.Tree.Compose
+import Dodge.Tree.Compose.Data

src/Dodge/Tree/Compose.hs

@@ -0,0 +1,97 @@
+{-| Combining and composing trees of trees.  -}
+module Dodge.Tree.Compose
+    ( expandTreeBy
+    , appendEitherTree
+    , connectRoom
+    , connectTrunk
+    , deadRoom
+    , linkEitherTrees
+
+    , expandTree
+    , singleUseAll
+    , singleUseNone
+    , passUntilUseAll
+    , chainUses
+    , useAllAtEnd
+    ) where
+import Dodge.Tree.Compose.Data
+import Data.Tree
+
+expandTree :: CompTree a -> Tree a
+expandTree (Node root extChildren) = case root of
+    Node (UseAll x)     _   -> Node x (map expandTree extChildren)
+    Node (UseSome is x) _   -> Node x (map expandTree $ map (\i -> extChildren !! i) is)
+    Node (UseNone _)    _   -> fmap _unCompose root
+    Node (PassDown x)   xs  -> Node x $ map (expandTree . (\ct -> Node ct extChildren)) xs
+    Node (SplitDown x)  xs  -> Node x $ map expandTree $ zipWith Node xs 
+            $ map (:[]) extChildren ++ repeat []
+
+-- | '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'
+passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a
+passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts'
+passUntilUseAll (Node cn ts) ts' = Node (PassDown (_unCompose cn)) $ map (`passUntilUseAll` ts') 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"
+
+chainUses :: [SubCompTree a] -> SubCompTree a
+chainUses (t:s:ts) = chainUses (passUntilUseAll t [s]:ts)
+chainUses [t] = t
+chainUses []  = error "tried to concatenate an empty list of SubCompTrees"
+
+-- this is _unCompose
+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) [] 
+
+singleUseAll :: a -> Tree (ComposingNode a)
+singleUseAll x = Node (UseAll x) []
+
+{-  |
+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) []
+
+useAllAtEnd :: Tree a -> SubCompTree a
+useAllAtEnd tree = case tree of
+    Node x (t:ts)   -> Node (PassDown x) (useAllAtEnd t : map (fmap UseNone) ts)
+    Node x []       -> Node (UseAll x) []
+
+{- |
+Make a singleton dead end of an Either Tree.
+-}
+deadRoom :: a -> Tree (Either a a)
+deadRoom r = Node (Left r) []
+
+singleUseNone :: a -> SubCompTree a
+singleUseNone x = Node (UseNone x) []

src/Dodge/Tree/Compose/Data.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Tree.Compose.Data where
+import Data.Tree
+import Control.Lens
+data ComposingNode a
+    = PassDown  {_unCompose :: a}
+    | SplitDown {_unCompose :: a}
+    | UseAll    {_unCompose :: a}
+    | UseSome   {_composeIndices :: [Int], _unCompose :: a}
+    | UseNone   {_unCompose :: a}
+type SubCompTree a = Tree (ComposingNode a)
+type CompTree a = Tree (Tree (ComposingNode a))
+makeLenses ''ComposingNode

src/Dodge/Tree/GenerateStructure.hs

@@ -0,0 +1,46 @@
+{-
+Procedural generation of tree structures.
+
+A /trunk/ refers to the successive first nodes in lists of children.
+-}
+module Dodge.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/Tree/Polymorphic.hs

@@ -0,0 +1,158 @@
+{-
+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.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/Tree/Shift.hs

@@ -0,0 +1,58 @@
+{- | 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.Tree.Shift
+    ( positionRoomsFromTree
+    ) where
+import Dodge.LevelGen.Data
+import Dodge.Room.Link
+import Dodge.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)
+
+positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [Room])
+positionRoomsFromTree (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 = doLnkEff 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
+
+doLnkEff :: (Point2,Float) -> Room -> Room
+doLnkEff x rm = case _rmLinkEff rm of
+    (eff:effs) -> eff x $ rm & rmLinkEff .~ effs
+    _ -> rm