module Math.Combinat.Trees.Nary
(
derivTrees
, addUniqueLabelsTree
, addUniqueLabelsForest
, addUniqueLabelsTree_
, addUniqueLabelsForest_
, labelDepthTree
, labelDepthForest
, labelDepthTree_
, labelDepthForest_
) where
import Data.Tree
import Control.Applicative
import Control.Monad.State
import Data.Traversable (traverse)
import Math.Combinat.Sets (listTensor)
import Math.Combinat.Partitions (partitionMultiset)
addUniqueLabelsTree :: Tree a -> Tree (a,Int)
addUniqueLabelsTree tree = head (addUniqueLabelsForest [tree])
addUniqueLabelsForest :: Forest a -> Forest (a,Int)
addUniqueLabelsForest forest = evalState (mapM globalAction forest) 1 where
globalAction tree =
unwrapMonad $ traverse localAction tree
localAction x = WrapMonad $ do
i <- get
put (i+1)
return (x,i)
addUniqueLabelsTree_ :: Tree a -> Tree Int
addUniqueLabelsTree_ = fmap snd . addUniqueLabelsTree
addUniqueLabelsForest_ :: Forest a -> Forest Int
addUniqueLabelsForest_ = map (fmap snd) . addUniqueLabelsForest
labelDepthTree :: Tree a -> Tree (a,Int)
labelDepthTree tree = worker 0 tree where
worker depth (Node label subtrees) = Node (label,depth) (map (worker (depth+1)) subtrees)
labelDepthForest :: Forest a -> Forest (a,Int)
labelDepthForest forest = map labelDepthTree forest
labelDepthTree_ :: Tree a -> Tree Int
labelDepthTree_ = fmap snd . labelDepthTree
labelDepthForest_ :: Forest a -> Forest Int
labelDepthForest_ = map (fmap snd) . labelDepthForest
derivTrees :: [Int] -> [Tree ()]
derivTrees xs = derivTrees' (map (+1) xs)
derivTrees' :: [Int] -> [Tree ()]
derivTrees' [] = []
derivTrees' [n] =
if n>=1
then [unfoldTree f 1]
else []
where
f k = if k<n then ((),[k+1]) else ((),[])
derivTrees' ks =
if and (map (>0) ks)
then
[ Node () sub
| part <- parts
, let subtrees = map g part
, sub <- listTensor subtrees
]
else []
where
parts = partitionMultiset ks
g xs = derivTrees' (map (\x->x1) xs)