Specifically I'm searching for a function 'maximumWith',
maximumWith :: (Foldable f, Ord b) => (a -> b) -> f a -> a
Which behaves in the following way:
maximumWith length [[1, 2], [0, 1, 3]] == [0, 1, 3]
maximumWith null [[(+), (*)], []] == []
maximumWith (const True) x == head x
My use case is picking the longest word in a list.
For this I'd like something akin to maximumWith length.
I'd thought such a thing existed, since sortWith etc. exist.
Let me collect all the notes in the comments together...
Let's look at sort. There are 4 functions in the family:
sortBy is the actual implementation.
sort = sortBy compare uses Ord overloading.
sortWith = sortBy . comparing is the analogue of your desired maximumWith. However, this function has an issue. The ranking of an element is given by applying the given mapping function to it. However, the ranking is not memoized, so if an element needs to compared multiple times, the ranking will be recomputed. You can only use it guilt-free if the ranking function is very cheap. Such functions include selectors (e.g. fst), and newtype constructors. YMMV on simple arithmetic and data constructors. Between this inefficiency, the simplicity of the definition, and its location in GHC.Exts, it's easy to deduce that it's not used that often.
sortOn fixes the inefficiency by decorating each element with its image under the ranking function in a pair, sorting by the ranks, and then erasing them.
The first two have analogues in maximum: maximumBy and maximum. sortWith has no analogy; you may as well write out maximumBy (comparing _) every time. There is also no maximumOn, even though such a thing would be more efficient. The easiest way to define a maximumOn is probably just to copy sortOn:
maximumOn :: (Functor f, Foldable f, Ord r) => (a -> r) -> f a -> a
maximumOn rank = snd . maximumBy (comparing fst) . fmap annotate
where annotate e = let r = rank e in r `seq` (r, e)
There's a bit of interesting code in maximumBy that keeps this from optimizing properly on lists. It also works to use
maximumOn :: (Foldable f, Ord r) => (a -> r) -> f a -> a
maximumOn rank = snd . fromJust . foldl' max' Nothing
where max' Nothing x = let r = rank x in r `seq` Just (r, x)
max' old#(Just (ro, xo)) xn = let rn = rank xn
in case ro `compare` rn of
LT -> Just (rn, xo)
_ -> old
These pragmas may be useful:
{-# SPECIALIZE maximumOn :: Ord r => (a -> r) -> [a] -> a #-}
{-# SPECIALIZE maximumOn :: (a -> Int) -> [a] -> a #-}
HTNW has explained how to do what you asked, but I figured I should mention that for the specific application you mentioned, there's a way that's more efficient in certain cases (assuming the words are represented by Strings). Suppose you want
longest :: [[a]] -> [a]
If you ask for maximumOn length [replicate (10^9) (), []], then you'll end up calculating the length of a very long list unnecessarily. There are several ways to work around this problem, but here's how I'd do it:
data MS a = MS
{ _longest :: [a]
, _longest_suffix :: [a]
, _longest_bound :: !Int }
We will ensure that longest is the first of the longest strings seen thus far, and that longest_bound + length longest_suffix = length longest.
step :: MS a -> [a] -> MS a
step (MS longest longest_suffix longest_bound) xs =
go longest_bound longest_suffix xs'
where
-- the new list is not longer
go n suffo [] = MS longest suffo n
-- the new list is longer
go n [] suffn = MS xs suffn n
-- don't know yet
go !n (_ : suffo) (_ : suffn) =
go (n + 1) suffo suffn
xs' = drop longest_bound xs
longest :: [[a]] -> [a]
longest = _longest . foldl' step (MS [] [] 0)
Now if the second to longest list has q elements, we'll walk at most q conses into each list. This is the best possible complexity. Of course, it's only significantly better than the maximumOn solution when the longest list is much longer than the second to longest.
Related
I've been learning Haskell in my spare time working through LYAH. Would like to improve upon my Haskell (/ Functional programming) skills by solving some problems from the imperative world. One of the problems from EPI is to print an "almost sorted array", in a sorted fashion where it is guaranteed that no element in the array is more than k away from its correct position. The input is a stream of elements and the requirement is to do this in O(n log k) time complexity and O(k) space complexity.
I've attempted to re-implement the imperative solution in Haskell as follows:
import qualified Data.Heap as Heap
-- print the k-sorted list in a sorted fashion
ksorted :: (Ord a, Show a) => [a] -> Int -> IO ()
ksorted [] _ = return ()
ksorted xs k = do
heap <- ksorted' xs Heap.empty
mapM_ print $ (Heap.toAscList heap) -- print the remaining elements in the heap.
where
ksorted' :: (Ord a, Show a) => [a] -> Heap.MinHeap a -> IO (Heap.MinHeap a)
ksorted' [] h = return h
ksorted' (x:xs) h = do let (m, h') = getMinAndBuildHeap h x in
(printMin m >> ksorted' xs h')
printMin :: (Show a) => Maybe a -> IO ()
printMin m = case m of
Nothing -> return ()
(Just item) -> print item
getMinAndBuildHeap :: (Ord a, Show a) => Heap.MinHeap a -> a -> (Maybe a, Heap.MinHeap a)
getMinAndBuildHeap h item= if (Heap.size h) > k
then ((Heap.viewHead h), (Heap.insert item (Heap.drop 1 h)))
else (Nothing, (Heap.insert item h))
I would like to know a better way of solving this in Haskell. Any inputs would be appreciated.
[Edit 1]: The input is stream, but for now I assumed a list instead (with only a forward iterator/ input iterator in some sense.)
[Edit 2]: added Data.Heap import to the code.
Thanks.
I think the main improvement is to separate the production of the sorted list from the printing of the sorted list. So:
import Data.Heap (MinHeap)
import qualified Data.Heap as Heap
ksort :: Ord a => Int -> [a] -> [a]
ksort k xs = go (Heap.fromList b) e where
(b, e) = splitAt (k-1) xs
go :: Ord a => MinHeap a -> [a] -> [a]
go heap [] = Heap.toAscList heap
go heap (x:xs) = x' : go heap' xs where
Just (x', heap') = Heap.view (Heap.insert x heap)
printKSorted :: (Ord a, Show a) => Int -> [a] -> IO ()
printKSorted k xs = mapM_ print (ksort k xs)
If I were feeling extra-special-fancy, I might try to turn go into a foldr or perhaps a mapAccumR, but in this case I think the explicit recursion is relatively readable, too.
consider a function, which rates the level of 'visual similarity' between two numbers: 666666 and 666166 would be very similar, unlike 666666 and 111111
type N = Int
type Rate = Int
similar :: N -> N -> Rate
similar a b = length . filter id . zipWith (==) a' $ b'
where a' = show a
b' = show b
similar 666666 666166
--> 5
-- high rate : very similar
similar 666666 111111
--> 0
-- low rate : not similar
There will be more sophisticated implementations for this, however this serves the purpose.
The intention is to find a function that sorts a given list of N's, so that each item is the most similar one to it's preceding item. Since the first item does not have a predecessor, there must be a given first N.
similarSort :: N -> [N] -> [N]
Let's look at some sample data: They don't need to have the same arity but it makes it easier to reason about it.
sample :: [N]
sample = [2234, 8881, 1222, 8888, 8822, 2221, 5428]
one could be tempted to implement the function like so:
similarSortWrong x xs = reverse . sortWith (similar x) $ xs
but this would lead to a wrong result:
similarSortWrong 2222 sample
--> [2221,1222,8822,2234,5428,8888,8881]
In the beginning it looks correct, but it's obvious that 8822 should rather be followed by 8881, since it's more similar that 2234.
So here's the implementation I came up with:
similarSort _ [] = []
similarSort x xs = x : similarSort a as
where (a:as) = reverse . sortWith (similar x) $ xs
similarSort 2222 sample
--> [2222,2221,2234,1222,8822,8888,8881]
It seems to work. but it also seems to do lot more more work than necessary. Every step the whole rest is sorted again, just to pick up the first element. Usually lazyness should allow this, but reverse might break this again. I'd be keen to hear, if someone know if there's a common abstraction for this problem.
It's relatively straightforward to implement the greedy algorithm you ask for. Let's start with some boilerplate; we'll use the these package for a zip-like that hands us the "unused" tail ends of zipped-together lists:
import Data.Align
import Data.These
sampleStart = "2222"
sampleNeighbors = ["2234", "8881", "1222", "8888", "8822", "2221", "5428"]
Instead of using numbers, I'll use lists of digits -- just so we don't have to litter the code with conversions between the form that's convenient for the user and the form that's convenient for the algorithm. You've been a bit fuzzy about how to rate the similarity of two digit strings, so let's make it as concrete as possible: any digits that differ cost 1, and if the digit strings vary in length we have to pay 1 for each extension to the right. Thus:
distance :: Eq a => [a] -> [a] -> Int
distance l r = sum $ alignWith elemDistance l r where
elemDistance (These l r) | l == r = 0
elemDistance _ = 1
A handy helper function will pick the smallest element of some list (by a user-specified measure) and return the rest of the list in some implementation-defined order.
minRestOn :: Ord b => (a -> b) -> [a] -> Maybe (a, [a])
minRestOn f [] = Nothing
minRestOn f (x:xs) = Just (go x [] xs) where
go min rest [] = (min, rest)
go min rest (x:xs) = if f x < f min
then go x (min:rest) xs
else go min (x:rest) xs
Now the greedy algorithm almost writes itself:
greedy :: Eq a => [a] -> [[a]] -> [[a]]
greedy here neighbors = here : case minRestOn (distance here) neighbors of
Nothing -> []
Just (min, rest) -> greedy min rest
We can try it out on your sample:
> greedy sampleStart sampleNeighbors
["2222","1222","2221","2234","5428","8888","8881","8822"]
Just eyeballing it, that seems to do okay. However, as with many greedy algorithms, this one only minimizes the local cost of each edge in the path. If you want to minimize the total cost of the path found, you need to use another algorithm. For example, we can pull in the astar package. For simplicity, I'm going to do everything in a very inefficient way, but it's not too hard to do it "right". We'll need a fair chunk more imports:
import Data.Graph.AStar
import Data.Hashable
import Data.List
import Data.Maybe
import qualified Data.HashSet as HS
Unlike before, where we only wanted the nearest neighbor, we'll now want all the neighbors. (Actually, we could probably implement the previous use of minRestOn using the following function and minimumOn or something. Give it a try if you're interested!)
neighbors :: (a, [a]) -> [(a, [a])]
neighbors (_, xs) = go [] xs where
go ls [] = []
go ls (r:rs) = (r, ls ++ rs) : go (r:ls) rs
We can now call the aStar search method with appropriate parameters. We'll use ([a], [[a]]) -- representing the current list of digits and the remaining lists that we can choose from -- as our node type. The arguments to aStar are then, in order: the function for finding neighboring nodes, the function for computing distance between neighboring nodes, the heuristic for how far we have left to go (we'll just say 1 for each unique element in the list), whether we've reached a goal node, and the initial node to start the search from. We'll call fromJust, but it should be okay: all nodes have at least one path to a goal node, just by choosing the remaining lists of digits in order.
optimal :: (Eq a, Ord a, Hashable a) => [a] -> [[a]] -> [[a]]
optimal here elsewhere = (here:) . map fst . fromJust $ aStar
(HS.fromList . neighbors)
(\(x, _) (y, _) -> distance x y)
(\(x, xs) -> HS.size (HS.fromList (x:xs)) - 1)
(\(_, xs) -> null xs)
(here, elsewhere)
Let's see it run in ghci:
> optimal sampleStart sampleNeighbors
["2222","1222","8822","8881","8888","5428","2221","2234"]
We can see that it's done better this time by adding a pathLength function that computes all the distances between neighbors in a result.
pathLength :: Eq a => [[a]] -> Int
pathLength xs = sum [distance x y | x:y:_ <- tails xs]
In ghci:
> pathLength (greedy sampleStart sampleNeighbors)
15
> pathLength (optimal sampleStart sampleNeighbors)
14
In this particular example, I think the greedy algorithm could have found the optimal path if it had made the "right" choices whenever there were ties for minimal next step; but I expect it is not too hard to cook up an example where the greedy algorithm is forced into bad early choices.
I've been solving a few combinatoric problems on Haskell, so I wrote down those 2 functions:
permutations :: (Eq a) => [a] -> [[a]]
permutations [] = [[]]
permutations list = do
x <- list
xs <- permutations (filter (/= x) list)
return (x : xs)
combinations :: (Eq a, Ord a) => Int -> [a] -> [[a]]
combinations 0 _ = [[]]
combinations n list = do
x <- list
xs <- combinations (n-1) (filter (> x) list)
return (x : xs)
Which works as follows:
*Main> permutations [1,2,3]
[[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]
*Main> combinations 2 [1,2,3,4]
[[1,2],[1,3],[1,4],[2,3],[2,4],[3,4]]
Those were uncomfortably similar, so I had to abstract it. I wrote the following abstraction:
combinatoric next [] = [[]]
combinatoric next list = do
x <- list
xs <- combinatoric next (next x list)
return (x : xs)
Which receives a function that controls how to filter the elements of the list. It can be used to easily define permutations:
permutations :: (Eq a) => [a] -> [[a]]
permutations = combinatoric (\ x ls -> filter (/= x) ls)
But I couldn't define combinations this way since it carries an state (n). I could extend the combinatoric with an additional state argument, but that'd become too clunky and I remember such approach was not necessary in a somewhat similar situation. Thus, I wonder: is it possible to define combinations using combinatorics? If not, what is a better abstraction of combinatorics which successfully subsumes both functions?
This isn't a direct answer to your question (sorry), but I don't think your code is correct. The Eq and Ord constraints tipped me off - they shouldn't be necessary - so I wrote a couple of QuickCheck properties.
prop_numberOfPermutations xs = length (permutations xs) === factorial (length xs)
where _ = (xs :: [Int]) -- force xs to be instantiated to [Int]
prop_numberOfCombinations (Positive n) (NonEmpty xs) = n <= length xs ==>
length (combinations n xs) === choose (length xs) n
where _ = (xs :: [Int])
factorial :: Int -> Int
factorial x = foldr (*) 1 [1..x]
choose :: Int -> Int -> Int
choose n 0 = 1
choose 0 r = 0
choose n r = choose (n-1) (r-1) * n `div` r
The first property checks that the number of permutations of a list of length n is n!. The second checks that the number of r-combinations of a list of length n is C(n, r). Both of these properties fail when I run them against your definitions:
ghci> quickCheck prop_numberOfPermutations
*** Failed! Falsifiable (after 5 tests and 4 shrinks):
[0,0,0]
3 /= 6
ghci> quickCheck prop_numberOfCombinations
*** Failed! Falsifiable (after 4 tests and 1 shrink):
Positive {getPositive = 2}
NonEmpty {getNonEmpty = [3,3]}
0 /= 1
It looks like your functions fail when the input list contains duplicate elements. Writing an abstraction for an incorrect implementation isn't a good idea - don't try and run before you can walk! You might find it helpful to read the source code for the standard library's definition of permutations, which does not have an Eq constraint.
First let's improve the original functions. You assume that all elements are distinct wrt their equality for permutations, and that they're distinct and have an ordering for combinations. These constraints aren't necessary and as described in the other answer, the code can produce wrong results. Following the robustness principle, let's accept just unconstrained lists. For this we'll need a helper function that produces all possible splits of a list:
split :: [a] -> [([a], a, [a])]
split = loop []
where
loop _ [] = []
loop rs (x:xs) = (rs, x, xs) : loop (x:rs) xs
Note that the implementation causes prefixes returned by this function to be reversed, but it's nothing we require.
This allows us to write generic permutations and combinations.
permutations :: [a] -> [[a]]
permutations [] = [[]]
permutations list = do
(pre, x, post) <- split list
-- reversing 'pre' isn't really necessary, but makes the output
-- order natural
xs <- permutations (reverse pre ++ post)
return (x : xs)
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [[]]
combinations n list = do
(_, x, post) <- split list
xs <- combinations (n-1) post
return (x : xs)
Now what they have in common:
At each step they pick an element to output,
update the list of elements to pick from and
stop after some condition is met.
The last point is a bit problematic, as for permutations we end once the list to choose from is empty, while for combinations we have a counter. This is probably the reason why it was difficult to generalize. We can work around this by realizing that for permutations the number of steps is equal to the length of the input list, so we can express the condition in the number of repetitions.
For such problems it's often very convenient to express them using StateT s [] monad, where s is the state we're working with. In our case it'll be the list of elements to choose from. The core of our combinatorial functions can be then expressed with StateT [a] [] a: pick an element from the state and update the state for the next step. Since the stateful computations all happen in the [] monad, we automatically branch all possibilities. With that, we can define a generic function:
import Control.Monad.State
combinatoric :: Int -> StateT [a] [] b -> [a] -> [[b]]
combinatoric n k = evalStateT $ replicateM n k
And then define permutations and combinations by specifying the appropriate number of repetitions and what's the core StateT [a] [] a function:
permutations' :: [a] -> [[a]]
permutations' xs = combinatoric (length xs) f xs
where
f = StateT $ map (\(pre, x, post) -> (x, reverse pre ++ post)) . split
combinations' :: Int -> [a] -> [[a]]
combinations' n xs = combinatoric n f xs
where
f = StateT $ map (\(_, x, post) -> (x, post)) . split
Data.Tree includes unfoldTreeM_BF and unfoldForestM_BF functions to construct trees breadth-first using the results of monadic actions. The tree unfolder can be written easily using the forest unfolder, so I'll focus on the latter:
unfoldForestM_BF :: Monad m =>
(b -> m (a, [b])) -> [b] -> m [Tree a]
Starting with a list of seeds, it applies a function to each, generating actions that will produce the tree roots and the seeds for the next level of unfolding. The algorithm used is somewhat strict, so using unfoldForestM_BF with the Identity monad is not exactly the same as using the pure unfoldForest. I've been trying to figure out if there's a way to make it lazy without sacrificing its O(n) time bound. If (as Edward Kmett suggested to me) this is impossible, I wonder if it would be possible to do it with a more constrained type, specifically requiring MonadFix rather than Monad. The concept there would be to (somehow) set up the pointers to the results of future computations while adding those computations to the to-do list, so if they are lazy in the effects of earlier computations they will be available immediately.
I previously claimed that the third solution presented below has the same strictness as the depth-first unfoldForest, which is not correct.
Your intuition that trees can be lazily unfolded breadth first is at least partially correct, even if we don't require a MonadFix instance. Solutions exist for the special cases when the branching factor is known to be finite and when the branching factor is known to be "large". We will start with a solution that runs in O(n) time for trees with finite branching factors including degenerate trees with only one child per node. The solution for finite branching factors will fail to terminate on trees with infinite branching factors, which we will rectify with a solution that that runs in O(n) time for trees with "large" branching factors greater than one including trees with infinite branching factor. The solution for "large" branching factors will run in O(n^2) time on degenerate trees with only one child or no children per node. When we combine the methods from both steps in an attempt to make a hybrid solution that runs in O(n) time for any branching factor we will get a solution that is lazier than the first solution for finite branching factors but cannot accommodate trees that make a rapid transition from an infinite branching factor to having no branches.
Finite Branching Factor
The general idea is that we will first build all the labels for an entire level and the seeds for the forests for the next level. We will then descend into the next level, building all of it. We will collect together the results from the deeper level to build the forests for the outer level. We will put the labels together with the forests to build the trees.
unfoldForestM_BF is fairly simple. If there are no seeds for the level it returns. After building all the labels, it takes the seeds for each forest and collects them together into one list of all the seeds to build the next level and unfolds the entire deeper level. Finally it constructs the forest for each tree from the structure of the seeds.
import Data.Tree hiding (unfoldTreeM_BF, unfoldForestM_BF)
unfoldForestM_BF :: Monad m => (b->m (a, [b])) -> [b] -> m [Tree a]
unfoldForestM_BF f [] = return []
unfoldForestM_BF f seeds = do
level <- sequence . fmap f $ seeds
let (labels, bs) = unzip level
deeper <- unfoldForestM_BF f (concat bs)
let forests = trace bs deeper
return $ zipWith Node labels forests
trace reconstructs the structure of nested lists from a flattened list.It is assumed that there is an item in [b] for each of the items anywhere in [[a]]. The use of concat ... trace to flatten all the information about ancestor levels prevents this implementation from working on trees with infinite children for a node.
trace :: [[a]] -> [b] -> [[b]]
trace [] ys = []
trace (xs:xxs) ys =
let (ys', rem) = takeRemainder xs ys
in ys':trace xxs rem
where
takeRemainder [] ys = ([], ys)
takeRemainder (x:xs) (y:ys) =
let ( ys', rem) = takeRemainder xs ys
in (y:ys', rem)
Unfolding a tree is trivial to write in terms of unfolding a forest.
unfoldTreeM_BF :: MonadFix m => (b->m (a, [b])) -> b -> m (Tree a)
unfoldTreeM_BF f = (>>= return . head) . unfoldForestMFix_BF f . (:[])
Large Branching Factor
The solution for large branching factor proceeds in much the same way as the solution for finite branching factor, except it keeps the entire structure of the tree around instead of concatenating the branches in a level to a single list and traceing that list. In addition to the imports used in the previous section, we will be using Compose to compose the functors for multiple levels of a tree together and Traversable to sequence across multi-level structures.
import Data.Tree hiding (unfoldForestM_BF, unfoldTreeM_BF)
import Data.Foldable
import Data.Traversable
import Data.Functor.Compose
import Prelude hiding (sequence, foldr)
Instead of flattening all of the ancestor structures together with concat we will wrap with Compose the ancestors and the seeds for the next level and recurse on the entire structure.
unfoldForestM_BF :: (Traversable t, Traceable t, Monad m) =>
(b->m (a, [b])) -> t b -> m (t (Tree a))
unfoldForestM_BF f seeds
| isEmpty seeds = return (fmap (const undefined) seeds)
| otherwise = do
level <- sequence . fmap f $ seeds
deeper <- unfoldForestM_BF f (Compose (fmap snd level))
return $ zipWithIrrefutable Node (fmap fst level) (getCompose deeper)
zipWithIrrefutable is a lazier version of zipWith that relies on the assumption that there is an item in the second list for each item in the first list. The Traceable structures are the Functors that can provide a zipWithIrrefutable. The laws for Traceable are for every a, xs, and ys if fmap (const a) xs == fmap (const a) ys then zipWithIrrefutable (\x _ -> x) xs ys == xs and zipWithIrrefutable (\_ y -> y) xs ys == ys. Its strictness is given for every f and xs by zipWithIrrefutable f xs ⊥ == fmap (\x -> f x ⊥) xs.
class Functor f => Traceable f where
zipWithIrrefutable :: (a -> b -> c) -> f a -> f b -> f c
We can combine two lists lazily if we already know they have the same structure.
instance Traceable [] where
zipWithIrrefutable f [] ys = []
zipWithIrrefutable f (x:xs) ~(y:ys) = f x y : zipWithIrrefutable f xs ys
We can combine the composition of two functors if we know that we can combine each functor.
instance (Traceable f, Traceable g) => Traceable (Compose f g) where
zipWithIrrefutable f (Compose xs) (Compose ys) =
Compose (zipWithIrrefutable (zipWithIrrefutable f) xs ys)
isEmpty checks for an empty structure of nodes to expand like the pattern match on [] did in the solution for finite branching factors.
isEmpty :: Foldable f => f a -> Bool
isEmpty = foldr (\_ _ -> False) True
The astute reader may notice that zipWithIrrefutable from Traceable is very similar to liftA2 which is half of the definition of Applicative.
Hybrid Solution
The hybrid solution combines the approaches of the finite solution and the "large" solution. Like the finite solution, we will compress and decompress the tree representation at each step. Like the solution for "large" branching factors we will use a data structure that allows stepping over complete branches. The finite branching factor solution used a data type that is flattened everywhere, [b]. The "large" branching factor solution used a data type that was flattened nowhere: increasingly nested lists starting with [b] then [[b]] then [[[b]]] and so on. In between these structures would be nested lists that either stop nesting and just hold a b or keep nesting and hold [b]s. That pattern of recursion is described in general by the Free monad.
data Free f a = Pure a | Free (f (Free f a))
We will be working specifically with Free [] which looks like.
data Free [] a = Pure a | Free [Free [] a]
For the hybrid solution we will repeat all of its imports and components so that the code below here should be complete working code.
import Data.Tree hiding (unfoldTreeM_BF, unfoldForestM_BF)
import Data.Traversable
import Prelude hiding (sequence, foldr)
Since we will be working with Free [], we will provide it with a zipWithIrrefutable.
class Functor f => Traceable f where
zipWithIrrefutable :: (a -> b -> c) -> f a -> f b -> f c
instance Traceable [] where
zipWithIrrefutable f [] ys = []
zipWithIrrefutable f (x:xs) ~(y:ys) = f x y : zipWithIrrefutable f xs ys
instance (Traceable f) => Traceable (Free f) where
zipWithIrrefutable f (Pure x) ~(Pure y ) = Pure (f x y)
zipWithIrrefutable f (Free xs) ~(Free ys) =
Free (zipWithIrrefutable (zipWithIrrefutable f) xs ys)
The breadth first traversal will look very similar to the original version for the finitely branching tree. We build the current labels and seeds for the current level, compress the structure of the remainder of the tree, do all the work for the remaining depths, and decompress the structure of the results to get the forests to go with the labels.
unfoldFreeM_BF :: (Monad m) => (b->m (a, [b])) -> Free [] b -> m (Free [] (Tree a))
unfoldFreeM_BF f (Free []) = return (Free [])
unfoldFreeM_BF f seeds = do
level <- sequence . fmap f $ seeds
let (compressed, decompress) = compress (fmap snd level)
deeper <- unfoldFreeM_BF f compressed
let forests = decompress deeper
return $ zipWithIrrefutable Node (fmap fst level) forests
compress takes a Free [] holding the seeds for forests [b] and flattens the [b] into the Free to get a Free [] b. It also returns a decompress function that can be used to undo the flattening to get the original structure back. We compress away branches with no remaining seeds and branches that only branch one way.
compress :: Free [] [b] -> (Free [] b, Free [] a -> Free [] [a])
compress (Pure [x]) = (Pure x, \(Pure x) -> Pure [x])
compress (Pure xs ) = (Free (map Pure xs), \(Free ps) -> Pure (map getPure ps))
compress (Free xs) = wrapList . compressList . map compress $ xs
where
compressList [] = ([], const [])
compressList ((Free [],dx):xs) = let (xs', dxs) = compressList xs
in (xs', \xs -> dx (Free []):dxs xs)
compressList ( (x,dx):xs) = let (xs', dxs) = compressList xs
in (x:xs', \(x:xs) -> dx x:dxs xs)
wrapList ([x], dxs) = (x, \x -> Free (dxs [x]))
wrapList (xs , dxs) = (Free xs, \(Free xs) -> Free (dxs xs ))
Each compression step also returns a function that will undo it when applied to a Free [] tree with the same structure. All of these functions are partially defined; what they do to Free [] trees with a different structure is undefined. For simplicity we also define partial functions for the inverses of Pure and Free.
getPure (Pure x) = x
getFree (Free xs) = xs
Both unfoldForestM_BF and unfoldTreeM_BF are defined by packaging their argument up into a Free [] b and unpackaging the results assuming they are in the same structure.
unfoldTreeM_BF :: MonadFix m => (b->m (a, [b])) -> b -> m (Tree a)
unfoldTreeM_BF f = (>>= return . getPure) . unfoldFreeM_BF f . Pure
unfoldForestM_BF :: MonadFix m => (b->m (a, [b])) -> [b] -> m [Tree a]
unfoldForestM_BF f = (>>= return . map getPure . getFree) . unfoldFreeM_BF f . Free . map Pure
A more elegant version of this algorithm can probably be made by recognizing that >>= for a Monad is grafting on trees and both Free and FreeT provide monad instances. Both compress and compressList probably have more elegant presentations.
The algorithm presented above is not lazy enough to allow querying trees that branch an infinite number of ways and then terminate. A simple counter example is the following generating function unfolded from 0.
counterExample :: Int -> (Int, [Int])
counterExample 0 = (0, [1, 2])
counterExample 1 = (1, repeat 3)
counterExample 2 = (2, [3])
counterExample 3 = (3, [])
This tree would look like
0
|
+- 1
| |
| +- 3
| |
| `- 3
| |
| ...
|
`- 2
|
+- 3
Attempting to descend the second branch (to 2) and inspect the remaining finite sub-tree will fail to terminate.
Examples
The following examples demonstrate that all implementations of unfoldForestM_BF run actions in breadth first order and that runIdentity . unfoldTreeM_BF (Identity . f) has the same strictness as unfoldTree for trees with finite branching factor. For trees with inifinite branching factor, only the solution for "large" branching factors has the same strictness as unfoldTree. To demonstrate laziness we'll define three infinite trees - a unary tree with one branch, a binary tree with two branches, and an infinitary tree with an infinite number of branches for each node.
mkUnary :: Int -> (Int, [Int])
mkUnary x = (x, [x+1])
mkBinary :: Int -> (Int, [Int])
mkBinary x = (x, [x+1,x+2])
mkInfinitary :: Int -> (Int, [Int])
mkInfinitary x = (x, [x+1..])
Together with unfoldTree, we will define unfoldTreeDF in terms of unfoldTreeM to check that unfoldTreeM really is lazy like you claimed and unfoldTreeBF in terms of unfoldTreeMFix_BF to check that the new implementation is just as lazy.
import Data.Functor.Identity
unfoldTreeDF f = runIdentity . unfoldTreeM (Identity . f)
unfoldTreeBF f = runIdentity . unfoldTreeM_BF (Identity . f)
To get finite pieces of these infinite trees, even the infinitely branching one, we'll define a way to take from a tree as long as its labels match a predicate. This could be written more succinctly in terms of the ability to apply a function to every subForest.
takeWhileTree :: (a -> Bool) -> Tree a -> Tree a
takeWhileTree p (Node label branches) = Node label (takeWhileForest p branches)
takeWhileForest :: (a -> Bool) -> [Tree a] -> [Tree a]
takeWhileForest p = map (takeWhileTree p) . takeWhile (p . rootLabel)
This lets us define nine example trees.
unary = takeWhileTree (<= 3) (unfoldTree mkUnary 0)
unaryDF = takeWhileTree (<= 3) (unfoldTreeDF mkUnary 0)
unaryBF = takeWhileTree (<= 3) (unfoldTreeBF mkUnary 0)
binary = takeWhileTree (<= 3) (unfoldTree mkBinary 0)
binaryDF = takeWhileTree (<= 3) (unfoldTreeDF mkBinary 0)
binaryBF = takeWhileTree (<= 3) (unfoldTreeBF mkBinary 0)
infinitary = takeWhileTree (<= 3) (unfoldTree mkInfinitary 0)
infinitaryDF = takeWhileTree (<= 3) (unfoldTreeDF mkInfinitary 0)
infinitaryBF = takeWhileTree (<= 3) (unfoldTreeBF mkInfinitary 0)
All five methods have the same output for the unary and binary trees. The output comes from putStrLn . drawTree . fmap show
0
|
`- 1
|
`- 2
|
`- 3
0
|
+- 1
| |
| +- 2
| | |
| | `- 3
| |
| `- 3
|
`- 2
|
`- 3
However, the breadth first traversal from the finite branching factor solution is not sufficiently lazy for a tree with an infinite branching factor. The other four methods output the entire tree
0
|
+- 1
| |
| +- 2
| | |
| | `- 3
| |
| `- 3
|
+- 2
| |
| `- 3
|
`- 3
The tree generated with unfoldTreeBF for the finite branching factor solution can never be completely drawn past its first branches.
0
|
+- 1
| |
| +- 2
| | |
| | `- 3
| |
| `- 3
The construction is definitely breadth first.
mkDepths :: Int -> IO (Int, [Int])
mkDepths d = do
print d
return (d, [d+1, d+1])
mkFiltered :: (Monad m) => (b -> Bool) -> (b -> m (a, [b])) -> (b -> m (a, [b]))
mkFiltered p f x = do
(a, bs) <- f x
return (a, filter p bs)
binaryDepths = unfoldTreeM_BF (mkFiltered (<= 2) mkDepths) 0
Running binaryDepths outputs the outer levels before the inner ones
0
1
1
2
2
2
2
From Lazy to Downright Slothful
The hybrid solution from the earlier section is not lazy enough to have the same strictness semantics as Data.Tree's unfoldTree. It is the first in a series of algorithms, each slightly lazier than their predecessor, but none lazy enough to have the same strictness semantics as unfoldTree.
The hybrid solution does not provide a guarantee that exploring a portion of a tree doesn't demand exploring other portions of the same tree. Nor will the code presented below. In one particular yet common case identified by dfeuer exploring only a log(N) sized slice of a finite tree forces the entirety of the tree. This happens when exploring the last descendant of each branch of a tree with constant depth. When compressing the tree we throw out every trivial branch with no descendants, which is necessary to avoid O(n^2) running time. We can only lazily skip over this portion of compression if we can quickly show that a branch has at least one descendant and we can therefore reject the pattern Free []. At the greatest depth of the tree with constant depth, none of the branches have any remaining descendants, so we can never skip a step of the compression. This results in exploring the entire tree to be able to visit the very last node. When the entire tree to that depth is non-finite due to infinite branching factor, exploring a portion of the tree fails to terminate when it would terminate when generated by unfoldTree.
The compression step in the hybrid solution section compresses away branches with no descendants in the first generation that they can be discovered in, which is optimal for compression but not optimal for laziness. We can make the algorithm lazier by delaying when this compression occurs. If we delay it by a single generation (or even any constant number of generations) we will maintain the O(n) upper bound on time. If we delay it by a number of generations that somehow depends on N we would necessarily sacrifice the O(N) time bound. In this section we will delay the compression by a single generation.
To control how compression happens, we will separate stuffing the innermost [] into the Free [] structure from compressing away degenerate branches with 0 or 1 descendants.
Because part of this trick doesn't work without a lot of laziness in the compression, we will adopt a paranoid level of excessively slothful laziness everywhere. If anything about a result other than the tuple constructor (,) could be determined without forcing part of its input with a pattern match we will avoid forcing it until it is necessary. For tuples, anything pattern matching on them will do so lazily. Consequently, some of the code below will look like core or worse.
bindFreeInvertible replaces Pure [b,...] with Free [Pure b,...]
bindFreeInvertible :: Free [] ([] b) -> (Free [] b, Free [] a -> Free [] ([] a))
bindFreeInvertible = wrapFree . go
where
-- wrapFree adds the {- Free -} that would have been added in both branches
wrapFree ~(xs, dxs) = (Free xs, dxs)
go (Pure xs) = ({- Free -} (map Pure xs), Pure . map getPure . getFree)
go (Free xs) = wrapList . rebuildList . map bindFreeInvertible $ xs
rebuildList = foldr k ([], const [])
k ~(x,dx) ~(xs, dxs) = (x:xs, \(~(x:xs)) -> dx x:dxs xs)
wrapList ~(xs, dxs) = ({- Free -} xs, \(~(Free xs)) -> Free (dxs xs)))
compressFreeList removes occurrences of Free [] and replaces Free [xs] with xs.
compressFreeList :: Free [] b -> (Free [] b, Free [] a -> Free [] a)
compressFreeList (Pure x) = (Pure x, id)
compressFreeList (Free xs) = wrapList . compressList . map compressFreeList $ xs
where
compressList = foldr k ([], const [])
k ~(x,dx) ~(xs', dxs) = (x', dxs')
where
x' = case x of
Free [] -> xs'
otherwise -> x:xs'
dxs' cxs = dx x'':dxs xs''
where
x'' = case x of
Free [] -> Free []
otherwise -> head cxs
xs'' = case x of
Free [] -> cxs
otherwise -> tail cxs
wrapList ~(xs, dxs) = (xs', dxs')
where
xs' = case xs of
[x] -> x
otherwise -> Free xs
dxs' cxs = Free (dxs xs'')
where
xs'' = case xs of
[x] -> [cxs]
otherwise -> getFree cxs
The overall compression will not bind the Pure []s into Frees until after the degenerate Frees have been compressed away, delaying compression of degenerate Frees introduced in one generation to the next generation's compression.
compress :: Free [] [b] -> (Free [] b, Free [] a -> Free [] [a])
compress xs = let ~(xs' , dxs' ) = compressFreeList xs
~(xs'', dxs'') = bindFreeInvertible xs'
in (xs'', dxs' . dxs'')
Out of continued paranoia, the helpers getFree and getPure are also made irrefutably lazy.
getFree ~(Free xs) = xs
getPure ~(Pure x) = x
This very quickly solves the problematic example dfeuer discovered
print . until (null . subForest) (last . subForest) $
flip unfoldTreeBF 0 (\x -> (x, if x > 5 then [] else replicate 10 (x+1)))
But since we only delayed the compression by 1 generation, we can recreate exactly the same problem if the very last node of the very last branch is 1 level deeper than all of the other branches.
print . until (null . subForest) (last . subForest) $
flip unfoldTreeBF (0,0) (\(x,y) -> ((x,y),
if x==y
then if x>5 then [] else replicate 9 (x+1, y) ++ [(x+1, y+1)]
else if x>4 then [] else replicate 10 (x+1, y)))
I'm beginning to try and get my head round haskell performance, and what makes things fast and slow, and I'm a little confused by this.
I have two implementations of a function that generates a list of primes up to a certain value. The first is straight off the Haskell wiki:
primesTo :: (Ord a, Num a, Enum a) => a -> [a]
primesTo m = eratos [2..m] where
eratos [] = []
eratos (p:xs) = p : eratos (xs `minus` [p*p, p*p+p..m])
The second is the same, but using an infinite list internally:
primes2 :: (Ord a, Num a, Enum a) => a -> [a]
primes2 m = takeWhile (<= m) (eratos [2..]) where
eratos [] = []
eratos (p:xs) = p : eratos (xs `minus` [p*p, p*p+p..])
In both cases, the minus function is:
minus :: (Ord a) => [a] -> [a] -> [a]
minus (x:xs) (y:ys) = case (compare x y) of
LT -> x : minus xs (y:ys)
EQ -> minus xs ys
GT -> minus (x:xs) ys
minus xs _ = xs
The latter implementation is significantly (~100x) slower than the former, and I don't get why. I would have thought that haskell's lazy evalutation would make them fairly equivalent under the hood.
This is obviously a reduced test case for the purposes of the question - in real life the optimisation would be no problem (although I don't understand why it is needed), but to me a function that just generates an infinite list of primes is more generically useful than a finite list, but appears slower to work with.
Looks like to me that there's a big difference between
(xs `minus` [p*p, p*p+p..m]) -- primesTo
(xs `minus` [p*p, p*p+p..]) -- primes2
The function minus steps through lists pairwise and terminates when one list reaches the end. In the first minus expression above, this occurs in no more than (m-p*p)/p steps when the latter list is exhausted. In the second one, it will always take steps on the order of length xs.
So your infinite lists have disabled at least one meaningful optimization.
One difference is that in the second case you need to generate one extra prime. You need to generate the first prime greater than m before takeWhile knows its time to stop.
Additionally, the [..m] bounds on both the list to filter and the lists of multiples help reduce the number of calculations. Whenever one of these lists gets empty minus immediately returns via its secons clause while in the infinite case the minus gets stuck in the first case. You can explore this a bit better if you also test the cases where only one of the lists is infinite:
--this is also slow
primes3 :: (Ord a, Num a, Enum a) => a -> [a]
primes3 m = takeWhile (<= m) (eratos [2..m]) where
eratos [] = []
eratos (p:xs) = p : eratos (xs `minus` [p*p, p*p+p..])
--this fast
primes4 :: (Ord a, Num a, Enum a) => a -> [a]
primes4 m = takeWhile (<= m) (eratos [2..]) where
eratos [] = []
eratos (p:xs) = p : eratos (xs `minus` [p*p, p*p+p..m])