Allow for random composition of trees

src/Dodge/Annotation.hs

@@ -11,7 +11,6 @@ import Dodge.Data
 import Dodge.Annotation.Data
 --import LensHelp
 
-import Data.Tree
 import Control.Monad.State
 import System.Random
 --import Control.Lens

src/Dodge/Default/Prop.hs

@@ -0,0 +1,21 @@
+module Dodge.Default.Prop where
+import Dodge.Data
+import Geometry
+defaultProp :: Prop
+defaultProp = Projectile
+    { _prPos = V2 0 0
+    , _pjStartPos = V2 0 0
+    , _pjVel = V2 0 0
+    , _prDraw = const mempty
+    , _pjID = 0
+    , _pjUpdate = const id
+    }
+defaultShapeProp :: Prop
+defaultShapeProp = ShapeProp
+    { _prPos = 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = const id
+    , _prDraw = const mempty
+    , _prToggle = True
+    }

src/Dodge/Floor.hs

@@ -25,7 +25,6 @@ import Dodge.Data
 --import Dodge.RoomPos
 --import Dodge.Room.RunPast
 --import MonadHelp
-import Data.Tree
 import LensHelp
 import Dodge.RandomHelp
 --import Color

src/Dodge/LevelGen.hs

@@ -12,7 +12,6 @@ import Dodge.Tree
 import Geometry.ConvexPoly
 --import Dodge.LevelGen.LevelStructure
 
-import Data.Tree
 import System.Random
 import Control.Lens
 import Control.Monad.State

src/Dodge/Room/Boss.hs

@@ -18,7 +18,6 @@ import Dodge.LevelGen.StaticWalls
 import Geometry
 import LensHelp
 
-import Data.Tree
 import Control.Monad.State
 import System.Random
 roomGlassOctogon

src/Dodge/Room/Branch.hs

@@ -14,15 +14,14 @@ import Dodge.Tree
 
 import Control.Monad.State
 import System.Random
-import Data.Tree
 
 branchRectWith :: RandomGen g => State g (SubCompTree Room) ->  State g (SubCompTree Room)
 branchRectWith t = do
     x <- state $ randomR (100,200)
     y <- state $ randomR (100,200)
     b <- t
-    root <- shuffleLinks $ roomRectAutoLinks x y
+    rt <- shuffleLinks $ roomRectAutoLinks x y
-    return $ Node (PassDown root) 
+    return $ Node (PassDown rt) 
         [ Node (UseAll door) []
         , changeToPassDown <$> treeFromTrunk [PassDown door] b
         ]

src/Dodge/Room/GlassLesson.hs

@@ -20,7 +20,6 @@ import qualified Data.Set as S
 import Control.Monad.State
 --import Control.Monad.Loops
 import System.Random
-import Data.Tree
 glassLesson :: RandomGen g => State g (SubCompTree Room)
 glassLesson = do
     i <- takeOne [1,2,3]

src/Dodge/Room/LasTurret.hs

@@ -30,7 +30,6 @@ import Dodge.RandomHelp
 
 import qualified Data.Set as S
 import Data.Maybe
-import Data.Tree
 import Control.Monad.State
 import System.Random
 

src/Dodge/Room/LongDoor.hs

@@ -26,7 +26,6 @@ import LensHelp
 --import Shape
 
 import qualified Data.Set as S
-import Data.Tree
 import System.Random
 import Control.Monad.State
 import Data.Maybe

src/Dodge/Room/LongRoom.hs

@@ -24,10 +24,8 @@ import LensHelp
 import Data.Tile
 
 import qualified Data.Set as S
-import Data.Tree
 import System.Random
 import Control.Monad.State
---import Data.Tree
 --import qualified Data.IntMap as IM
 
 longRoom :: RandomGen g => State g Room

src/Dodge/Room/RezBox.hs

@@ -31,7 +31,6 @@ import LensHelp
 
 import qualified Data.Set as S
 --import Data.Maybe
-import Data.Tree
 import Control.Monad.State
 import System.Random
 

src/Dodge/Room/Room.hs

@@ -30,7 +30,6 @@ import qualified Data.Set as S
 import Control.Monad.State
 --import Control.Monad.Loops
 import System.Random
-import Data.Tree
 import Data.Bifunctor
 
 roomC :: RandomGen g => Float -> Float -> State g Room
@@ -278,7 +277,7 @@ weaponBetweenPillars = do
 
 weaponLongCorridor :: RandomGen g => State g (SubCompTree Room)
 weaponLongCorridor = do
-    root <- takeOne [tEast, tWest]
+    rt <- takeOne [tEast, tWest]
     connectingRoom <- takeOne 
         [tEast  & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)]
         ]
@@ -286,7 +285,7 @@ weaponLongCorridor = do
     i2 <- state $ randomR (2,5)
     let branch1 = treeFromTrunk (replicate i1 $ PassDown corridorN) (singleUseAll $ putCrs connectingRoom)
     let branch2 = treeFromTrunk (replicate i2 $ PassDown corridorN) (singleUseNone $ putWp corridor)
-    return $ Node (PassDown root) [branch1,branch2]
+    return $ Node (PassDown rt) [branch1,branch2]
       where 
         putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
         putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]

src/Dodge/Room/RunPast.hs

@@ -26,7 +26,6 @@ import Color
 import LensHelp
 
 import qualified Data.Set as S
-import Data.Tree
 import Control.Monad.State
 import System.Random
 --import qualified Data.IntMap.Strict as IM

src/Dodge/Tree.hs

@@ -2,12 +2,12 @@
 module Dodge.Tree 
     ( module Dodge.Tree.Shift
     , module Dodge.Tree.GenerateStructure
-    , module Dodge.Tree.Polymorphic
+    , module TreeHelp
     , module Dodge.Tree.Compose
     , module Dodge.Tree.Compose.Data
     ) where
 import Dodge.Tree.Shift
 import Dodge.Tree.GenerateStructure
-import Dodge.Tree.Polymorphic
+import TreeHelp
 import Dodge.Tree.Compose
 import Dodge.Tree.Compose.Data

src/Dodge/Tree/Compose.hs

@@ -10,16 +10,19 @@ module Dodge.Tree.Compose
     , changeToPassDown
     , overwriteLabel
     , applyToCompRoot
+    , composeTree
+    , composeTreeRand
+--    , compTree
     ) where
 import Dodge.Tree.Compose.Data
-import Dodge.Tree.Polymorphic
+import TreeHelp
 import Dodge.Base
 import LensHelp
 
+import Control.Monad.State
+import Data.Foldable
+import System.Random
 import Data.Maybe
-import Data.Tree
-import Data.Tree.Lens
---import Data.Bifunctor
 
 expandTree :: CompTree a -> Tree a
 expandTree (Node rt extChildren) = case rt of
@@ -32,11 +35,11 @@ expandTree (Node rt extChildren) = case rt of
             $ map (:[]) extChildren ++ repeat []
 
 applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a
-applyToCompRoot f = applyToRoot (unCompose %~ f)
+applyToCompRoot f = over root (unCompose %~ f)
 
 overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
 overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
-    $ updateSingleNode islabel update t
+    $ updateSingleNodes islabel update t
   where
     islabel (UseLabel j _) | i == j = True
     islabel _ = False
@@ -65,17 +68,27 @@ singleUseNone x = Node (UseNone x) []
 changeToPassDown :: ComposingNode a -> ComposingNode a
 changeToPassDown x = PassDown (_unCompose x)
 
---cTree :: Tree (a -> Maybe a, Tree a) -> Tree a
+composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a)
---cTree (Node (_,t) ch) = shiftChildren $ foldr g' (fdsa t) (map cTree ch)
+composeTreeRand (Node (_,t) ts) = attachListR t ts
 
-cTree' :: Tree (a -> Maybe a, Tree a) -> Tree a
+attachListR :: RandomGen g => Tree a -> [Tree (a -> Maybe a, Tree a)] -> State g (Tree a)
-cTree' (Node (_,t) ts) = cTree t ts
+attachListR t xs = fmap shiftChildren $ foldrM newfRand (fmap ([],) t) xs
 
-cTree :: Tree a -> [Tree (a -> Maybe a, Tree a)] -> Tree a
+newfRand :: RandomGen g => Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) 
-cTree t xs = shiftChildren $ foldr newf (fmap ([],) t) xs
+    -> State g (Tree ([Tree a],a))
+newfRand t = updateRandNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
+  where
+    upf = (t ^?! root . _1)
+    g x = fromMaybe x (upf x)
+
+composeTree :: Tree (a -> Maybe a, Tree a) -> Tree a
+composeTree (Node (_,t) ts) = attachList t ts
+
+attachList :: Tree a -> [Tree (a -> Maybe a, Tree a)] -> Tree a
+attachList t xs = shiftChildren $ foldr newf (fmap ([],) t) xs
 
 newf :: Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) -> Tree ([Tree a],a)
-newf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ cTree' t ) )
+newf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
   where
     upf = (t ^?! root . _1)
     g x = fromMaybe x (upf x)
@@ -83,25 +96,25 @@ newf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root .
 shiftChildren :: Tree ([Tree a],a) -> Tree a
 shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
 
--- hideous, but it should work
+---- hideous, but it should work
--- the idea is that the fst argument selects (and edits) a node to which all the
+---- the idea is that the fst argument selects (and edits) a node to which all the
--- children are attached
+---- children are attached
--- the tree is thus built up recursively
+---- the tree is thus built up recursively
-compTree :: Tree (a -> Maybe a, Tree (a,b)) -> Tree b
+--compTree :: Tree (a -> Maybe a, Tree (a,b)) -> Tree b
-compTree (Node (_,t) ch) = attachChildren t $ map (\t' -> (fst $ rootLabel t',compTree t')) ch
+--compTree (Node (_,t) ch) = attachChildren t $ map (\t' -> (fst $ rootLabel t',compTree t')) ch
-
+--
-chooseAttachNodes :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> [Tree (a,b,[c])]
+--chooseAttachNodes :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> [Tree (a,b,[c])]
-chooseAttachNodes (t,z) (Node (x,y,zs) ch) = case t x of
+--chooseAttachNodes (t,z) (Node (x,y,zs) ch) = case t x of
-    Just x' -> Node (x',y,(z:zs)) ch : concatMap (chooseAttachNodes (t,z)) ch
+--    Just x' -> Node (x',y,(z:zs)) ch : concatMap (chooseAttachNodes (t,z)) ch
-    Nothing -> concatMap (chooseAttachNodes (t,z)) ch
+--    Nothing -> concatMap (chooseAttachNodes (t,z)) ch
-
+--
-mAttachToNode :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> Tree (a,b,[c])
+--mAttachToNode :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> Tree (a,b,[c])
-mAttachToNode p t = fromMaybe t $ listToMaybe $ chooseAttachNodes p t
+--mAttachToNode p t = fromMaybe t $ listToMaybe $ chooseAttachNodes p t
-
+--
-moveToChildren :: Tree (a,b,[Tree b]) -> Tree b
+--moveToChildren :: Tree (a,b,[Tree b]) -> Tree b
-moveToChildren (Node (_,x,ts) ts') = Node x (map moveToChildren ts' ++ ts)
+--moveToChildren (Node (_,x,ts) ts') = Node x (map moveToChildren ts' ++ ts)
-
+--
-attachChildren :: Tree (a,b) -> [(a->Maybe a,Tree b)] -> Tree b
+--attachChildren :: Tree (a,b) -> [(a->Maybe a,Tree b)] -> Tree b
-attachChildren t = moveToChildren . foldr mAttachToNode t'
+--attachChildren t = moveToChildren . foldr mAttachToNode t'
-  where
+--  where
-    t' = fmap (\(x,y) -> (x,y,[])) t
+--    t' = fmap (\(x,y) -> (x,y,[])) t

src/Dodge/Tree/Shift.hs

@@ -10,7 +10,7 @@ module Dodge.Tree.Shift
 --import Dodge.LevelGen.Data
 import Dodge.Data
 import Dodge.Room.Link
-import Dodge.Tree.Polymorphic
+import TreeHelp
 import Dodge.RoomLink
 import Geometry.ConvexPoly
 --import Geometry.Data
@@ -19,7 +19,6 @@ import LensHelp hiding (Empty, (<|) , (|>))
 --import Control.Lens hiding (Empty, (<|) , (|>))
 
 import qualified Data.Set as S
-import Data.Tree
 import qualified Data.Sequence as Seq
 import Data.List (delete)
 import Data.Bifunctor
@@ -100,7 +99,7 @@ posRms prs parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
                     , _rpLinkStatus = UsedInLink (_rlType il) (snd parenti)
                     , _rpPlacementUse = 0
                     }
-            shiftedt = applyToRoot
+            shiftedt = over root
                 (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) 
                 t
 

src/TreeHelp.hs

@@ -5,10 +5,11 @@ 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).
+the nodes in the trunk are [a,b].
  -}
-module Dodge.Tree.Polymorphic
+module TreeHelp
-    ( applyToRoot
+    ( module Data.Tree
+    , module Data.Tree.Lens
     , applyToSubtree
     , applyToSubforest
     , treeFromPost
@@ -17,7 +18,8 @@ module Dodge.Tree.Polymorphic
     , applyToRandomNode
     , addToTrunk
     , inorderNumberTree
-    , updateSingleNode
+    , updateSingleNodes
+    , updateRandNode
     , safeUpdateSingleNode
     ) where
 import Dodge.RandomHelp
@@ -32,8 +34,7 @@ import Control.Lens
 {- | Creates a linear tree.
 Safe.  -}
 treeFromPost :: [a] -> a -> Tree a
-treeFromPost []     y = Node y []
+treeFromPost xs = treeFromTrunk xs . pure
-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.  -}
@@ -41,12 +42,9 @@ treeFromTrunk
     :: [a]      -- ^ The trunk
     -> Tree a   -- ^ The end of the tree
     -> Tree a
-treeFromTrunk [] t     = t
+treeFromTrunk = flip $ foldr f
-treeFromTrunk (x:xs) t = Node x [treeFromTrunk xs t]
+  where
-
+    f x t = Node x [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
@@ -56,26 +54,22 @@ applyToRoot f (Node t ts) = Node (f t) ts
 {- | 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 is = applyToSubtree is . over root
-applyToNode (i:is) f (Node x xs) = Node x (ys ++ [applyToNode is f z] ++ zs)
-  where
-    (ys, z:zs) = splitAt i xs
 
 {- | Applies a function to a specific subtree determined by a list of indices.
 Unsafe (partial function).  -}
 applyToSubtree :: [Int] -> (Tree a -> Tree a) -> Tree a -> Tree a
 applyToSubtree [] f t = f t
-applyToSubtree (i:is) f (Node x xs) = Node x (ys ++ [applyToSubtree is f z] ++ zs)
+applyToSubtree (i:is) f (Node x xs) = Node x (xs & ix i %~ applyToSubtree is f)
-  where
-    (ys, z:zs) = splitAt i xs
 
 {- | Applies a function to a specific subforest determined by a list of indices.
 Unsafe (partial function).  -}
 applyToSubforest :: [Int] -> ([Tree a] -> [Tree a]) -> Tree a -> Tree a
-applyToSubforest [] f (Node p cs) = Node p (f cs)
+applyToSubforest is = applyToSubtree is . over branches
-applyToSubforest (i:is) f (Node x xs) = Node x (ys ++ [applyToSubforest is f z] ++ zs)
+--applyToSubforest [] f (Node p cs) = Node p (f cs)
-  where
+--applyToSubforest (i:is) f (Node x xs) = Node x (ys ++ [applyToSubforest is f z] ++ zs)
-    (ys, z:zs) = splitAt i xs
+--  where
+--    (ys, z:zs) = splitAt i xs
 
 -- do not delete: find use for
 --{- |
@@ -88,24 +82,25 @@ applyToSubforest (i:is) f (Node x xs) = Node x (ys ++ [applyToSubforest is f z]
 --applyToSubTrunkBy _ _ t = t
 
 -- gives the list of all updates to a single node
-updateSingleNode :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> [Tree a]
+-- there must be a better way of doing something like this
-updateSingleNode f update t@(Node x ts)
+updateSingleNodes :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> [Tree a]
+updateSingleNodes f update t@(Node x ts)
     | f x       = update t : updateChildren
     | otherwise = updateChildren
   where
-    updateChildren = map (Node x) (subMap (updateSingleNode f update) ts)
+    updateChildren = map (Node x) (subMap (updateSingleNodes f update) ts)
+
+updateRandNode :: RandomGen g => (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> State g (Tree a)
+updateRandNode t f = takeOne . updateSingleNodes t f
+
 
 safeUpdateSingleNode :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> Tree a
-safeUpdateSingleNode f g t = fromMaybe t $ listToMaybe $ updateSingleNode f g t
+safeUpdateSingleNode f g t = fromMaybe t $ listToMaybe $ updateSingleNodes f g t
 
 subMap :: (a -> [a]) -> [a] -> [[a]]
 subMap f (x:xs) = (f x <&> (: xs)) ++ ( (x :) <$> subMap f xs ) 
 subMap _ [] = []
 
---subMap' :: Monad m => (a -> m a) -> [a] -> m [a]
---subMap' f (x:xs) = (f x <&> (: xs)) ++ ( (x :) <$> (subMap f xs) )
---subMap' f [] = 
-
 -- 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