brauntolist.hs

import Test.QuickCheck
import Data.Tree.Binary.Preorder (Tree(..), drawTree)
import Control.Arrow (first)
import Data.List (unfoldr)

fromList :: [a] -> Tree a
fromList xs = head (l (foldr f b xs 1 2))
  where
    b _ _ ys zs = (repeat Leaf, (repeat Leaf, ys))
    
    l k = let (xs, ys) = uncurry k ys in xs
    
    f x k 0 j ys zs           = ([], (l (f x k j (j*2)), ys))
    f x k i j ~(y:ys) ~(z:zs) = first (Node x y z:) (k (i-1) j ys zs)

prop :: [Int] -> Property
prop xs = toList (fromList xs) === xs

newtype B a = B { unB :: (B a -> B a) -> (B a -> B a) -> [a] }

toList :: Tree a -> [a]
toList r = unB (f r b) id id
  where
    f (Node x l r) fw = B (\bwl bwr -> x : unB fw (bwl . f l) (bwr . f r))
    f Leaf         fw = B (\bwl bwr -> [])
  
    b = B (\qsl qsr -> unB (qsl (qsr b)) id id)