Test of lock and key system

src/Dodge/Tree/Compose.hs

@@ -7,19 +7,29 @@ module Dodge.Tree.Compose
     , chainUses
     , useAllAtEnd
     , changeToPassDown
+    , overwriteLabel
     ) where
 import Dodge.Tree.Compose.Data
+import Dodge.Tree.Polymorphic
 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 . \i -> extChildren !! i) is)
-    Node (UseNone _)    _   -> fmap _unCompose root
+    Node (UseNone _) _   -> fmap _unCompose root
+    Node (UseLabel _ _) _   -> fmap _unCompose root
     Node (PassDown x)   xs  -> Node x $ map (expandTree . (`Node` extChildren)) xs
     Node (SplitDown x)  xs  -> Node x $ map expandTree $ zipWith Node xs 
             $ map (:[]) extChildren ++ repeat []
 
+overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
+overwriteLabel i f t ts = head $ updateSingleNode islabel update t
+  where
+    islabel (UseLabel j _) | i == j = True
+    islabel _ = False
+    update (Node cr _) = Node (f $ _unCompose cr) 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

src/Dodge/Tree/Compose/Data.hs

@@ -9,6 +9,7 @@ data ComposingNode a
     | UseAll    {_unCompose :: a}
     | UseSome   {_composeIndices :: [Int], _unCompose :: a}
     | UseNone   {_unCompose :: a}
+    | UseLabel  {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children
 type SubCompTree a = Tree (ComposingNode a)
 type CompTree a = Tree (Tree (ComposingNode a))
 makeLenses ''ComposingNode

src/Dodge/Tree/Polymorphic.hs

@@ -15,6 +15,7 @@ module Dodge.Tree.Polymorphic
     , applyToRandomNode
     , addToTrunk
     , inorderNumberTree
+    , updateSingleNode
     )
     where
 import Dodge.RandomHelp
@@ -22,6 +23,7 @@ import Dodge.RandomHelp
 import Data.Tree
 import Control.Monad.State
 import System.Random
+import Control.Lens
 
 {- |
 Creates a linear tree.
@@ -73,6 +75,22 @@ applyToNode (i:is) f (Node x xs) = Node x (ys ++ [applyToNode is f z] ++ zs)
 --    | otherwise = Node x (applyToSubTrunkBy cond f t : ts)
 --applyToSubTrunkBy _ _ t = t
 
+-- gives the list of all updates to a single node
+updateSingleNode :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> [Tree a]
+updateSingleNode f update t@(Node x ts)
+    | f x       = update t : updateChildren
+    | otherwise = updateChildren
+  where
+    updateChildren = map (Node x) (subMap (updateSingleNode f update) ts)
+
+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

src/Dodge/Tree/Shift.hs

@@ -48,7 +48,12 @@ posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do
             mayrs <- posRms (convexBounds ++ bounds) 
                 (first upr parenti) (numChild + 1) ts (tseq |> shiftedt)
             case mayrs of
-                Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
+                --Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
+                Nothing -> do
+                    putStr $ "Backtracking to " ++ (rpns 20 (_rmName cr ++ "-" ++ show i')) 
+                        ++ (rpns 9 (" child " ++ show numChild ))
+                        ++ (rpns 25 (" of " ++ _rmName pr ++ "-" ++ show i ))
+                    tryLinks (j+1) ls
                 Just rs -> return (Just rs)
       where
         convexBounds = map pointsToPoly $ _rmBound r'