All possible binary trees storing a value

Question

I want to write a function, allTrees , to generate a list of all possible binary trees that store the number of leaves each tree has.

Here are my data types and my attempt at the allTrees function:

data BTree = L | B BTree BTree
    deriving (Eq, Ord, Show)

data SpecTree = S Integer BTree
    deriving (Eq, Ord, Show)

leafNode :: SpecTree
leafNode = S 1 L

branch :: SpecTree -> SpecTree -> SpecTree
branch (S size1 sub1) (S size2 sub2) = S (size1 + size2) (B sub1 sub2)

allTrees :: [SpecTree]
allTrees = leafNode : branch allTrees allTrees

Expected output:

take 9 allTrees = [S 1 L,S 2 (B L L),S 3 (B L (B L L)),S 3 (B (B L L) L),S 4 (B L (B L (B L L))),S 4 (B L (B (B L L) L)),S 4 (B (B L L) (B L L)),S 4 (B (B L (B L L)) L),S 4 (B (B (B L L) L) L)]

Actual output:

take 9 allTrees = [S 1 L,S 2 (B L L),S 3 (B L (B L L)),S 4 (B L (B L (B L L))),S 5 (B L (B L (B L (B L L)))),S 6 (B L (B L (B L (B L (B L L))))),S 7 (B L (B L (B L (B L (B L (B L L)))))),S 8 (B L (B L (B L (B L (B L (B L (B L L))))))),S 9 (B L (B L (B L (B L (B L (B L (B L (B L L))))))))]

My output is close but not quite it. I think foldM may be useful here, but not sure how I can use it.

Answer 1

The problem is as Carl describes in the comments. You're generating infinitely many different trees, but because of the order you generate them in, you don't get them all. It's like generating "all integers" by starting at 1 and doubling each time. Every integer is new, and you never run out, but you miss most integers. In your case, you generate just the degenerate right-child-only trees, because that's the direction you bias your exploration, and you never run out of room to explore that direction.

Instead, as Carl also suggested in the comments, if you want to ensure you hit every possible tree, generate them in an order that ensures you don't miss any: smallest first.

allTreesOfSize :: Integer -> [BTree]
allTreesOfSize 0 = [] -- Not used in the recursive case
allTreesOfSize 1 = [L]
allTreesOfSize n = do
  lSize <- [1..n-1]
  let rSize = n - lSize
  B <$> allTreesOfSize lSize <*> allTreesOfSize rSize

allTrees :: [SpecTree]
allTrees = do
  n <- [1..]
  S n <$> allTreesOfSize n

> take 5 allTrees
[ S 1 L
, S 2 (B L L)
, S 3 (B L (B L L))
, S 3 (B (B L L) L)
, S 4 (B L (B L (B L L)))
]

Answer 2

@amalloy's answer is elegant, but it does require you to think about a way to generate the data in your specific domain (namely, how to split the "size" between the subtrees).

In general, you might really want to apply a function to all pairs from two infinite lists. Here's a function that does it. I bet it can still be done more elegantly.

data BTree = L | B BTree BTree
    deriving (Eq, Ord, Show)

data SpecTree = S Integer BTree
    deriving (Eq, Ord, Show)

leafNode :: SpecTree
leafNode = S 1 L

branch :: SpecTree -> SpecTree -> SpecTree
branch (S size1 sub1) (S size2 sub2) = S (size1 + size2) (B sub1 sub2)

allTrees :: [SpecTree]
allTrees = leafNode : infApply branch allTrees allTrees

infApply :: (a -> b -> c) -> [a] -> [b] -> [c]
infApply f xs ys = map (uncurry f) (infProduct xs ys)

-- All possible pairs from two infinite lists.
infProduct xs ys = infterleave (infNested xs ys)

-- A nested (infinite) list of (infinite) lists of pairs from the two given (infinite) lists.
infNested xs ys = [[(x, y) | x <- xs] | y <- ys]

-- Interleave the elements of an infinite collection of infinite lists.
infterleave xss =
  infterleave' xss 0 0
  where
    infterleave' :: [[a]] -> Int -> Int -> [a]
    infterleave' xss n m =
      let (result, remainder) = snoc (xss !! n)
          newXss = take n xss ++ [remainder] ++ drop (n+1) xss
      in
        result : (infterleave' newXss (if n < m then n+1 else 0) (if n < m then m else m+1))

snoc (x:xs) = (x, xs)