-
-
Save treeowl/b7d5daee549eb9bc6e6f2d9f851aab8c to your computer and use it in GitHub Desktop.
-- | This module defines a function that produces a complete binary tree | |
-- from a breadth-first list of its (internal) node labels. It is an | |
-- optimized version of an implementation by Will Ness that avoids | |
-- any "impossible" cases. See | |
-- | |
-- https://stackoverflow.com/a/60561480/1477667 | |
module Bftr (Tree (..), bft, list, deftest) where | |
import Data.Function (fix) | |
import Data.Monoid (Endo (..)) | |
-- | A binary tree. | |
data Tree a | |
= Empty | |
| Node a (Tree a) (Tree a) | |
deriving Show | |
-- An infinite stream. Why don't we just use a list? First, I think it's | |
-- easier to see what's going on this way. Second, the garbage collector | |
-- can clean up more garbage with this representation. The `bft` function | |
-- includes several lazy patterns. These cause the runtime system to | |
-- produce thunks to actually perform the pattern matches. Unlike a list | |
-- cons, a stream cons is a *record*, so the runtime system will produce | |
-- *selector thunks* for these pattern matches. That means that as soon | |
-- as one field of a particular cons is forced, all the selector thunks | |
-- matching on *either* field become available for GC simplification. | |
data SS a = a :< SS a | |
infixr 5 :< | |
bft' :: [a] -> Tree a | |
bft' xs = tree | |
where | |
-- `subtrees` is a stream of all proper subtrees of the result tree, | |
-- in breadth-first order, followed by infinitely many empty trees. | |
-- We form each tree in the result by combining a label from the input | |
-- list with consecutive subtrees. | |
tree :< subtrees = go xs subtrees | |
go :: [a] -> SS (Tree a) -> SS (Tree a) | |
go (a : as) ~(b1 :< ~(b2 :< bs)) = Node a b1 b2 :< go as bs | |
go [] _ = fix (Empty :<) | |
-- Ugh. The above definition, while beautiful, can leak space, thanks | |
-- to limitations of GHC's selector thunk mechanism. To avoid this, | |
-- at the cost of efficiency in some cases, we write this instead. | |
-- | Build a complete binary tree from a list of its breadth-first | |
-- traversal. | |
bft :: [a] -> Tree a | |
bft xs = tree | |
where | |
-- `subtrees` is a stream of all proper subtrees of the result tree, | |
-- in breadth-first order, followed by infinitely many empty trees. | |
-- We form each tree in the result by combining a label from the input | |
-- list with consecutive subtrees. | |
tree :< subtrees = go xs subtrees | |
go :: [a] -> SS (Tree a) -> SS (Tree a) | |
go (a : as) ys = Node a b1 b2 :< go as bs | |
where | |
{-# NOINLINE b2bs #-} | |
b1 :< b2bs = ys | |
b2 :< bs = b2bs | |
go [] _ = fix (Empty :<) | |
-- | Perform a simple laziness test; takes a non-negative integer. | |
-- This should not throw an exception. | |
deftest :: Int -> Int | |
deftest n = sum . take n . list . bft $ [1..n] ++ undefined | |
-- | Convert a tree to a list in breadth-first order (useful for testing). | |
-- | |
-- @list . bft = id@ | |
-- | |
-- When @t@ is a complete tree, | |
-- | |
-- @bft . list $ t = t@ | |
list :: Tree a -> [a] | |
-- there's probably a better way to do this. | |
list t = appEndo (foldMap id (levels t)) [] | |
levels :: Tree a -> [Endo [a]] | |
levels Empty = [] | |
levels (Node a l r) = Endo (a:) : combine (levels l) (levels r) | |
where | |
combine [] ys = ys | |
combine (x : xs) ys = (x <> hd) : combine xs tl | |
where | |
(hd, tl) = case ys of | |
[] -> (mempty, []) | |
y:ys' -> (y, ys') |
Sorry, I deleted the comment I think you just responded to, because I realized it was bogus. Anyway, Here's one based on a similar function for Data.Tree
by @oisdk:
breadthFirst :: forall a. [Tree a] -> [a]
breadthFirst ts = foldr f b ts []
where
f (Node x l r) fw bw = x : fw (r : l : bw)
f Empty fw bw = fw bw
b :: [Tree a] -> [a]
b [] = []
b ts = foldl (flip f) b ts []
I don't really like this, TBH, because it's not remotely obvious that the foldl
here actually represents a queue rotation. But here's a partially deobfuscated version of the same idea:
breadthFirst :: forall a. [Tree a] -> [a]
breadthFirst ts = foldr f b ts []
where
-- The forest we fold over represents the front of a banker's queue. bw
-- represents its back. Once the front is empty (we've finished a level)
-- we rotate the queue.
f (Node x l r) fw bw = x : fw (r : l : bw)
f Empty fw bw = fw bw
b :: [Tree a] -> [a]
b [] = []
b ts = breadthFirst (reverse ts)
no, I replied to the comment directly above mine. I tried to summarize the workings of your go
function there.
is "rotate the queue" common terminology for the switching it describes? for my mind, rotate (x:xs) == xs++[x]
.
also, I'd name b
's argument bw
, for uniformity and clarity. I can already see it's [Tree a]
, so calling it ts
doesn't add any new clues; but seeing that it's the same bw
as in f
clarifies f
's definition for me. Or, we could get rid of b
altogether with
breadthFirst :: forall a. [Tree a] -> [a]
breadthFirst [] = []
breadthFirst ts = foldr f (breadthFirst . reverse) ts []
where
f (Node x l r) fw bw = x : fw (r : l : bw)
f Empty fw bw = fw bw
my bflist
can be made to skip over the Empty's ahead of time, at the cost of putting more clauses into its definition:
bflist2 :: Tree a -> [a]
bflist2 Empty = []
bflist2 t = map (\ ~(Node x _ _) -> x) q
where
q = t : go 1 q
go 0 _ = []
go i (Node _ Empty Empty : ns) = go (i-1) ns
go i (Node _ l Empty : ns) = l : go (i) ns
go i (Node _ Empty r : ns) = r : go (i) ns
go i (Node _ l r : ns) = l : r : go (i+1) ns
Might perform better than the shorter version.
I haven't followed the whole conversation here, but for breadth-first traversals I think the optimal function is the following:
levels :: Tree a -> [[a]]
levels t = takeWhile (not . null) (f t (repeat []))
where
f Empty qs = qs
f (Node x ls rs) ~(q : qs) = (x:q) : f ls (f rs qs)
It would probably benefit from some optimisation, like using streams instead of lists:
data Stream a = a :< Stream a
toListWhile p (x :< xs)
| p x = x : toListWhile p xs
| otherwise = []
levels :: Tree a -> [[a]]
levels t = toListWhile (not . null) (f t (fix ([] :<)))
where
f Empty qs = qs
f (Node x ls rs) ~(q :< qs) = (x:q) :< f ls (f rs qs)
It also looks the most like the "inverse" of the unfold.
interesting. it blazes the trail first i.e. creates more entries in the spine (than just the one as before), filled with completely uninstantiated variables at first - driven by the strict pattern match of
zs
. so by the timeys
hits the[]
the spine is built in full.