Polymorphise meta tree labels

src/Dodge/Annotation.hs

@@ -14,7 +14,7 @@ import LensHelp
 --import Control.Lens
 import Data.Maybe
 
-annoToRoomTree :: Annotation -> State (StdGen,Int) (MetaTree Room)
+annoToRoomTree :: Annotation -> State (StdGen,Int) MTRS
 annoToRoomTree an = case an of
     SpecificRoom r -> zoom _1 r 
     OnwardList ans -> do
@@ -31,6 +31,6 @@ annoToRoomTree an = case an of
         ii <- randomitemidentity
         keyroom <- fromJust $ lookup ii ks
         return $ MTree ("PassthroughLockKeyLists-"++show ii) 
-            (NodeMTree $ MTree "RassThroughLockKeyLists" (NodeMTree lr) [MBranch "" (toLabel i) keyroom])
+            (NodeMTree $ MTree "RassThroughLockKeyLists" (NodeMTree lr) [MBranch (toLabel i) keyroom])
             []
 

src/Dodge/Annotation/Data.hs

@@ -9,14 +9,17 @@ import Dodge.Tree.Compose.Data
 import Control.Monad.State
 import Control.Lens
 import System.Random
+
+type MTRS = MetaTree Room String
+
 data Annotation
-    = ModifyTree (MetaTree Room -> MetaTree Room) Annotation
+    = ModifyTree (MetaTree Room String -> MetaTree Room String) Annotation
     | OnwardList [Annotation]
     | IntAnno (Int -> Annotation)
-    | SpecificRoom (State StdGen (MetaTree Room))
+    | SpecificRoom (State StdGen (MetaTree Room String))
     | PassthroughLockKeyLists
-        [(Int -> State StdGen (MetaTree Room), State StdGen ItemBaseType)]
-        [(ItemBaseType, State StdGen (MetaTree Room))]
+        [(Int -> State StdGen (MetaTree Room String), State StdGen ItemBaseType)]
+        [(ItemBaseType, State StdGen (MetaTree Room String))]
          Int 
 
 makeLenses ''Annotation

src/Dodge/Floor.hs

@@ -38,7 +38,7 @@ import Data.List (intersperse)
 
 initialAnoTree :: Annotation
 initialAnoTree = OnwardList 
-        $ intersperse (SpecificRoom $ tToBTree . pure <$> shuffleLinks (cleatOnward corridor))
+        $ intersperse (SpecificRoom $ tToBTree "cori" . pure <$> shuffleLinks (cleatOnward corridor))
     [ IntAnno $ SpecificRoom . startRoom
 --     ,  (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
     , IntAnno $ PassthroughLockKeyLists
@@ -50,7 +50,7 @@ initialAnoTree = OnwardList
             [ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)
             , spNoID anyUnusedSpot (PutCrit armourChaseCrit)
             ]
-    , IntAnno $ SpecificRoom . fmap tToBTree . healthTest
+    , IntAnno $ SpecificRoom . fmap (tToBTree "healthTest") . healthTest
     , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward)
     , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms
     , SpecificRoom randomChallenges
@@ -100,5 +100,5 @@ initialAnoTree = OnwardList
     ]
 
 {- | A test level tree. -}
-initialRoomTree :: State (StdGen,Int) (MetaTree Room)
+initialRoomTree :: State (StdGen,Int) (MetaTree Room String)
 initialRoomTree = annoToRoomTree initialAnoTree

src/Dodge/LevelGen.hs

@@ -42,9 +42,6 @@ layoutLevelFromSeed i seed = do
     ----appendFile "log/TreeCluster" ("Seed: "++ show seed)
     ----mapM_ (appendFile "log/treeCluster" . ('\n':))  strs
     ----mapM_ putStrLn strs
-    --putStrLn "Room cluster layout:"
-    --putStrLn $ drawTreeSubLabelling $ fmap snd treecluster
-    --let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
     let rmtree = inorderNumberTree tc
     putStrLn "Room layout (compact): "
     putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
@@ -66,13 +63,6 @@ layoutLevelFromSeed i seed = do
             let (seed',_) = random g
             layoutLevelFromSeed i' seed'
 
-drawTreeSubLabelling :: Tree TreeSubLabelling -> String
-drawTreeSubLabelling t = drawTree (fmap _topLabel t)
-    ++ concatMap f (flatten t)
-  where
-    f (TreeSubLabelling _ Nothing) = ""
-    f (TreeSubLabelling l (Just t')) = l ++ ":\n" ++ drawTreeSubLabelling t'
-
 reversePair :: (a,b) -> (b,a)
 reversePair (a,b) = (b,a)
 

src/Dodge/LockAndKey.hs

@@ -17,7 +17,7 @@ import Dodge.Item
 bossKeyItems :: RandomGen g => [ (State g (Tree Room), State g ItemBaseType) ]
 bossKeyItems = [(return . cleatOnward <$> bossRoom autoCrit, takeOne [PISTOL]) ]
 
-lockRoomMultiItems :: RandomGen g => [ ( State g (MetaTree Room) , State g [ItemBaseType] ) ]
+lockRoomMultiItems :: RandomGen g => [ ( State g (MetaTree Room String) , State g [ItemBaseType] ) ]
 lockRoomMultiItems = 
     [ (blinkAcrossChallenge, takeOne [[BLINKERUNSAFE,AUTODETECTOR WALLDETECTOR]
                                     ,[BLINKERUNSAFE,CLICKDETECTOR WALLDETECTOR]
@@ -25,7 +25,7 @@ lockRoomMultiItems =
         )
     ]
 
-lockRoomKeyItems :: RandomGen g => [ (Int -> State g (MetaTree Room) , State g ItemBaseType ) ]
+lockRoomKeyItems :: RandomGen g => [ (Int -> State g (MetaTree Room String) , State g ItemBaseType ) ]
 lockRoomKeyItems = 
     [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD,FORCEFIELDGUN] )
     ,(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )
@@ -37,10 +37,10 @@ lockRoomKeyItems =
     ,(const $ lasTunnelRunPast 400, takeOne [FLATSHIELD,FORCEFIELDGUN])
     ,(keyCardRoomRunPast 0, return (KEYCARD 0))
     ]
-keyCardRunPastRand :: RandomGen g => [ (Int -> State g (MetaTree Room) , State g ItemBaseType ) ]
+keyCardRunPastRand :: RandomGen g => [ (Int -> State g (MetaTree Room String) , State g ItemBaseType ) ]
 keyCardRunPastRand = [(keyCardRoomRunPast 0, return (KEYCARD 0)) ]
 
-itemRooms :: RandomGen g => [(ItemBaseType, State g (MetaTree Room))]
+itemRooms :: RandomGen g => [(ItemBaseType, State g (MetaTree Room String))]
 itemRooms = 
     [ (LAUNCHER , join $ takeOne 
         [corridorBoss launcherCrit
@@ -108,7 +108,7 @@ someCrits = do
 --    return $ roomsContaining crits its
 
 
-corridorBoss :: RandomGen g => Creature -> State g (MetaTree Room)
+corridorBoss :: RandomGen g => Creature -> State g (MetaTree Room String)
 corridorBoss cr = do
     endroom <- bossRoom cr
     rToOnward ("corridorBoss-"++_crName cr)

src/Dodge/Room/BlinkAcross.hs

@@ -34,7 +34,7 @@ import LensHelp
 import Control.Monad.State
 import System.Random
 
-blinkAcrossChallenge :: RandomGen g => State g (MetaTree Room)
+blinkAcrossChallenge :: RandomGen g => State g (MetaTree Room String)
 blinkAcrossChallenge = do
     teleFromRoom <- shuffleLinks $ roomRectAutoLinks 200 200
     teleToRoom  <- shuffleLinks $ roomRectAutoLinks 200 200

src/Dodge/Room/Containing.hs

@@ -15,7 +15,7 @@ import Geometry
 
 import Data.List
 
-roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room)
+roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room String)
 roomsContaining crs its = do
     endroom <- join $ takeOne
         [ randomFourCornerRoomCrsIts crs its 

src/Dodge/Room/GlassLesson.hs

@@ -1,6 +1,7 @@
 --{-# LANGUAGE TupleSections #-}
 module Dodge.Room.GlassLesson where
 import Dodge.UseAll
+import Dodge.Annotation.Data
 import Dodge.RoomLink
 import Dodge.Creature
 import Dodge.LevelGen.Data
@@ -53,7 +54,7 @@ glassLesson = do
             , mntLS vShape (V2 180 200) (V3 160 180 50)
             ]
         ]
-glassLessonRunPast :: RandomGen g => State g (MetaTree Room)
+glassLessonRunPast :: RandomGen g => State g MTRS
 glassLessonRunPast = glassLesson >>= rToOnward "glassLessonRunPast" . f
   where
     f (Node r rs) = Node r $ return (cleatLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs

src/Dodge/Room/LasTurret.hs

@@ -71,7 +71,7 @@ lightSensByDoor outplid rm = rm
     covershape = rectNSEW 10 (-10) 20 (-20)
     sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a)
 
-keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (MetaTree Room)
+keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (MetaTree Room String)
 keyCardRoomRunPast keyid rmid = do
     cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200
     let doorroom = triggerDoorRoom rmid
@@ -114,13 +114,13 @@ healthTest n = do
         , cleatOnward door
         ]
 
-lasSensorTurretTest :: RandomGen g => Int -> State g (MetaTree Room)
+lasSensorTurretTest :: RandomGen g => Int -> State g (MetaTree Room String)
 lasSensorTurretTest n = do
     cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur
     rToOnward "lasSensorTurretTest" $ treePost 
         [ door, cenroom, triggerDoorRoom n, cleatOnward door]
 
-lasCenSensEdge :: RandomGen g => Int -> State g (MetaTree Room)
+lasCenSensEdge :: RandomGen g => Int -> State g (MetaTree Room String)
 lasCenSensEdge n = do
     cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur
     let doorroom = triggerDoorRoom n
@@ -165,7 +165,7 @@ lasTunnel y = do
         ]
 
 -- a y value of 400 is probably "unrunnable"
-lasTunnelRunPast :: RandomGen g => Float -> State g (MetaTree Room)
+lasTunnelRunPast :: RandomGen g => Float -> State g (MetaTree Room String)
 lasTunnelRunPast y = do
     r <- lasTunnel y
     r1 <- takeOne [door,corridor]

src/Dodge/Room/LongDoor.hs

@@ -140,7 +140,7 @@ slowDoorRoom = do
     proom <- southPillarsRoom x y h
     addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels)))
 
-slowDoorRoomRunPast :: RandomGen g => State g (MetaTree Room)
+slowDoorRoomRunPast :: RandomGen g => State g (MetaTree Room String)
 slowDoorRoomRunPast = do
     r <- slowDoorRoom
     rToOnward "slowDoorRoomRunPast" $ treeFromTrunk [ door] $ Node r

src/Dodge/Room/LongRoom.hs

@@ -47,7 +47,7 @@ longRoom = do
                 | crx <- [12.5,37.5,62.5] ] ++
         [sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ]
 
-longRoomRunPast :: RandomGen g => State g (MetaTree Room)
+longRoomRunPast :: RandomGen g => State g (MetaTree Room String)
 longRoomRunPast = do
     r <- longRoom
     rToOnward "longRoomRunPast"

src/Dodge/Room/Room.hs

@@ -123,7 +123,7 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen)
 -- So, the idea is to attach outer children to the bottommost right nodes
 -- inside an inner tree
 -- no idea what was going on here...
-roomMiniIntro :: RandomGen g => State g (MetaTree Room)
+roomMiniIntro :: RandomGen g => State g (MetaTree Room String)
 roomMiniIntro = do
     midroom <- join $ takeOne [miniTree2] --,glassLesson]
     rToOnward "roomMiniIntro" midroom
@@ -191,7 +191,7 @@ weaponEmptyRoom = do
         $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
     return $ treeFromTrunk [ corridor] (pure $ cleatOnward rm )
      
-weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room)
+weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String)
 weaponUnderCrits i = do
     let plmnts = 
             [--sPS (V2 20 0)   0 $ RandPS randFirstWeapon
@@ -278,7 +278,7 @@ deadEndRoom = defaultRoom
   where 
     lnks = [(V2 0 30  ,0) ]
 {- A random Either tree with a weapon and melee monster challenge.  -}
-weaponRoom :: RandomGen g => Int -> State g (MetaTree Room)
+weaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
 weaponRoom i = join $ takeOne 
     [ weaponEmptyRoom       >>= rToOnward "weaponEmptyRoom"
     , weaponUnderCrits i
@@ -381,7 +381,7 @@ pistolerRoom = pillarGrid
         ]
             ++)
 
-shootingRange :: RandomGen g => State g (MetaTree Room)
+shootingRange :: RandomGen g => State g (MetaTree Room String)
 shootingRange = do
     rm1 <- shootersRoom1 >>= shuffleLinks . restrictInLinks (\(V2 _ y,_) -> y < 40)
             . restrictOutLinks  (\(V2 _ y,r) -> y > 200 && r /= 0)

src/Dodge/Room/SensorDoor.hs

@@ -1,5 +1,6 @@
 --{-# LANGUAGE TupleSections #-}
 module Dodge.Room.SensorDoor where
+import Dodge.Annotation.Data
 import Dodge.UseAll
 import Dodge.LevelGen.Data
 import Dodge.PlacementSpot
@@ -56,7 +57,7 @@ sensorRoom senseType n = do
         p' = p +.+ rotateV d (V2 0 (negate 100))
         isclose = dist (_rlPos rl) p' < 30
 
-sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (MetaTree Room)
+sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g MTRS
 sensorRoomRunPast dt n = do
     t <- sensorRoom dt n
     rToOnward "sensorRoomRunPast" $ t & applyToSubforest [0] 

src/Dodge/Room/Start.hs

@@ -48,7 +48,7 @@ powerFakeout = do
                 , keyholeCorridor, corridor])
         `treeFromPost` cleatOnward door
 
-startRoom :: RandomGen g => Int -> State g (MetaTree Room)
+startRoom :: RandomGen g => Int -> State g (MetaTree Room String)
 startRoom i = join (takeOne
     [-- (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i]) 
      --       <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing))
@@ -60,7 +60,7 @@ startRoom i = join (takeOne
 --    , startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms
 --        >>= rToOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"
     ])
-randomChallenges :: RandomGen g => State g (MetaTree Room)
+randomChallenges :: RandomGen g => State g (MetaTree Room String)
 randomChallenges = shootingRange
 --        join (takeOne
 --    [fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
@@ -80,17 +80,17 @@ rezBoxStart = do
     ls <- rezColor
     return $ treePost [ rezBox ls, cleatOnward door ]
 
-rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room)
+rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
 rezBoxesThenWeaponRoom i = do
     rboxes <- rezBoxes
     wroom  <- weaponRoom i
-    return $ tToBTree rboxes `attachOnward` wroom
+    return $ tToBTree "rboxes" rboxes `attachOnward` wroom
 
-rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room)
+rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
 rezBoxThenWeaponRoom i = do
     rcol <- rezColor
     wroom <- weaponRoom i
-    return $ tToBTree (treePost [rezBox rcol, cleatOnward door]) `attachOnward` wroom
+    return $ tToBTree "rezbox" (treePost [rezBox rcol, cleatOnward door]) `attachOnward` wroom
 
 rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room)
 rezBoxThenRoom r = do

src/Dodge/Room/Warning.hs

@@ -37,7 +37,7 @@ import qualified Data.Map.Strict as M
 --import qualified Data.Text as T
 
 
-warningRooms :: RandomGen g => Int -> State g (MetaTree Room)
+warningRooms :: RandomGen g => Int -> State g (MetaTree Room String)
 warningRooms n = do
     rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200]
     cenroom <- shuffleLinks $ addWarningTerminal n rm

src/Dodge/Tree/Compose.hs

@@ -22,25 +22,12 @@ import TreeHelp
 --import Dodge.Base
 import LensHelp
 
-import Data.Bifunctor
-import Control.Monad.State
-import Data.Foldable
-import System.Random
+--import Data.Bifunctor
+--import Control.Monad.State
+--import Data.Foldable
+--import System.Random
 import Data.Maybe
 
---expandTree :: CompTree a -> Tree a
---expandTree (Node rt extChildren) = case rt 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 rt
---    Node (useLabel _ _) _   -> fmap _unCompose rt
---    Node ( x)   xs  -> Node x $ map (expandTree . (`Node` extChildren)) xs
---    Node (SplitDown x)  xs  -> Node x $ map expandTree $ zipWith Node xs 
---            $ map (:[]) extChildren ++ repeat []
-
---applyToCompRoot :: (a -> a) -> Tree a -> Tree a
---applyToCompRoot f = over root (unCompose %~ f)
-
 overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room
 overwriteLabel i t ts = safeUpdateSingleNode 
     (\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks))
@@ -186,17 +173,17 @@ shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
 --        brs <- mapM (composeAndSubLog is dolog) $ _btBranches mt
 --        return $ Node (_btValue mt) brs
 
-composeTree :: MetaTree a -> Tree a
+composeTree :: MetaTree a b -> Tree a
 composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt)
 
-composeNode :: MetaNode a -> Tree a
+composeNode :: MetaNode a b -> Tree a
 composeNode (NodeTree t) = t
 composeNode (NodeMTree mt) = composeTree mt
 
-attachList' :: Tree a -> [MetaBranch a] -> Tree a
+attachList' :: Tree a -> [MetaBranch a b] -> Tree a
 attachList' t xs = shiftChildren $ foldr attachBranch (fmap ([],) t) xs
 
-attachBranch :: MetaBranch a -> Tree ([Tree a],a) -> Tree ([Tree a],a)
+attachBranch :: MetaBranch a b -> Tree ([Tree a],a) -> Tree ([Tree a],a)
 attachBranch mb = safeUpdateSingleNode (isJust . upf . snd) 
     ( (root . _2 %~ g) . (root ._1 .:~ composeTree (_mbTree mb)) )
   where
@@ -204,14 +191,15 @@ attachBranch mb = safeUpdateSingleNode (isJust . upf . snd)
     g x = fromMaybe x (upf x)
 
 
-tToBTree :: Tree Room -> MetaTree Room
-tToBTree t = MTree "" (NodeTree t) []
+tToBTree :: String -> Tree Room -> MetaTree Room String
+tToBTree str t = MTree str (NodeTree t) []
 
-attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room
-attachOnward t1 t2 = t1 & mtBranches .:~ MBranch "Onward" toOnward t2
+attachOnward :: MetaTree Room b -> MetaTree Room b -> MetaTree Room b
+attachOnward t1 t2 = t1 & mtBranches .:~ MBranch toOnward t2
 
 toOnward :: Room -> Maybe Room
 toOnward rm
     | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks 
         = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
     | otherwise = Nothing
+

src/Dodge/Tree/Compose/Data.hs

@@ -4,23 +4,12 @@ module Dodge.Tree.Compose.Data where
 import Data.Tree
 import Control.Lens
 
-data MetaBranch a 
-    = MBranch {_mbLabel :: String, _mbAttach :: a -> Maybe a, _mbTree :: MetaTree a}
 
-data MetaTree a
-    = MTree {_mtLabel :: String , _mtTree :: MetaNode a , _mtBranches :: [MetaBranch a] }
---    | BTree {_btLabel :: String , _btValue :: a ,         _btBranches :: [MetaTree a] }
-data MetaNode a = NodeTree {_nodeTree :: Tree a} | NodeMTree {_nodeMetaTree :: MetaTree a}
+--data MetaTree a = MTree {_mtLabel :: String , _mtTree :: MetaNode a , _mtBranches :: [MetaBranch a] }
+data MetaTree a b = MTree {_mtLabel :: b , _mtTree :: MetaNode a b, _mtBranches :: [MetaBranch a b] }
+data MetaNode a b = NodeTree {_nodeTree :: Tree a} | NodeMTree {_nodeMetaTree :: MetaTree a b}
+data MetaBranch a b = MBranch {_mbAttach :: a -> Maybe a, _mbTree :: MetaTree a b}
 
---type CompTree a = Tree (Tree a)
-type LabTree a = (a -> Maybe ([String],a),Tree a)
-type LabCompTree a = Tree (LabTree a)
-data TreeSubLabelling = TreeSubLabelling
-    { _topLabel :: String
-    , _subLabels :: Maybe (Tree TreeSubLabelling)
-    }
-makeLenses ''TreeSubLabelling
 makeLenses ''MetaTree
 makeLenses ''MetaBranch
 makeLenses ''MetaNode
-

src/Dodge/UseAll.hs

@@ -18,8 +18,8 @@ toLabel i rm
     | LabelCluster i `elem` rm ^?! rmClusterStatus . csLinks = Just rm
     | otherwise = Nothing
 
-rToOnward :: Monad m => String -> Tree Room -> m (MetaTree Room)
-rToOnward s t = return $ tToBTree t & mtLabel .~ s
+rToOnward :: Monad m => String -> Tree Room -> m (MetaTree Room String)
+rToOnward s t = return $ tToBTree s t
 
 cleatOnward :: Room -> Room
 cleatOnward = rmClusterStatus . csLinks .~ S.singleton OnwardCluster

src/TreeHelp.hs

@@ -24,9 +24,11 @@ module TreeHelp
     , updateRandNode
     , safeUpdateSingleNode
     , msafeUpdateSingleNode
+    , numTraversable
     ) where
 import RandomHelp
 
+import Data.Traversable
 import Data.Maybe
 import Data.Tree.Lens
 import Data.Tree
@@ -183,15 +185,11 @@ splitTrunk t = do
     i <- state $ randomR (0, trunkDepth t)
     return $ splitTrunkAt i t
 
+numTraversable :: Traversable t => t a -> t (a,Int)
+numTraversable = snd . mapAccumL f 0
+  where
+    f i x = (i+1,(x,i))
+
 -- 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)
+inorderNumberTree = numTraversable