Well, for one, it's a bad sieve algorithm.
I think a neat algorithm to demonstrate laziness and Haskell clarity would be enumerating the Calkin-Wilf rationals. [0] It's quite a bit longer but demonstrates a number of neat ideas. I'll start first with a derivation which demonstrates all of the structure of the algorithm and then go through a series of mechanical transforms so that by the end I have a one-liner and a comparable Python implementation.
The first algorithm comes directly from the paper and uses an intermediary infinite tree to represent the rationals.
data BTree a = Node a (BTree a) (BTree a)
fold :: (a -> x -> x -> x) -> BTree a -> x
fold f (Node a l r) = f a (fold f l) (fold f r)
unfold :: (x -> (a, x, x)) -> x -> BTree a
unfold f x = let (a, l, r) = f x in Node a (unfold f l) (unfold f r)
breadthFirst :: BTree a -> [a]
breadthFirst = concat . fold glue where
glue a ls rs = [a] : zipWith (++) ls rs
allRationals :: Fractional a => [a]
allRationals = breadthFirst (unfold step (1, 1)) where
step (m, n) = ( m/n, (m, m+n)
, (n+m, n) )
In 16 lines I've got an infinite binary tree, its natural fold and unfold, a breadth first search, and a lazy algorithm for generating all of the rationals with no repeats. The whole thing is simple, natural, beautiful, and efficient! It demonstrates infinite recursive types, laziness, higher-order functions, and bounded polymorphism.
And also a neat algorithm!
The downside is that 16 lines is pretty long.
By inlining the fold and unfold I can get it down to 9 lines:
data BTree a = Node a (BTree a) (BTree a)
breadthFirst :: BTree a -> [a]
breadthFirst = concat . glue where
glue (Node a ls rs) = [a] : zipWith (++) (glue ls) (glue rs)
rats :: Fractional a => [a]
rats = breadthFirst (generate (1, 1)) where
generate (m, n) = Node (m/n) (generate (m, m+n)) (generate (n+m, n))
If I'm allowed imports we can use Data.Tree and make this a one-liner!
import Data.Tree
allRationals :: Fractional a => [a]
allRationals = flatten (unfoldTree step (1, 1)) where
step (m, n) = ( m/n, [ (m, m+n), (n+m, n) ] )
Finally, if I go another route and fuse the fold and unfold together into a hylomorphism
data Trip a x = Trip a x x deriving Functor
hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo phi psi = phi . fmap (hylo phi psi) . psi
allRationals :: Fractional a => [a]
allRationals = concat (hylo glue step (1, 1)) where
glue (Trip a ls rs) = [a] : zipWith (++) ls rs
step (m, n) = Trip (m/n) (m, m+n) (n+m, n)
we can hide the tree entirely and demonstrate `deriving`... at considerable cost to clarity! With a little more golfing (read: inlining) we arrive at this beauty:
allRationals :: Fractional a => [a]
allRationals = concat (go (1, 1)) where
go = glue . next . step
next (a, b, c) = (a, f b, f c)
glue (a, ls, rs) = [a] : zipWith (++) ls rs
step (m, n) = ( m/n, (m, m+n), (n+m, n) )
which at least has the bonus of demonstrating some nice co-recursion between go and next. Or even, ultimately:
allRationals :: Fractional a => [a]
allRationals = concat (go 1 1) where go m n = [m/n] : zipWith (++) (go m (m+n)) (go (n+m) n)
which is actually kind of nice again if almost all of the structure has vanished.
Note that if `interleave` were part of the Prelude then we could write
allRationals :: Fractional a => [a]
allRationals = go 1 1 where go m n = (m/n) : interleave (go m (m+n)) (go (n+m) n)
given
interleave :: [a] -> [a] -> [a]
interleave [] ys = ys
interleave xs [] = xs
interleave (x:xs) (y:ys) = x : y : interleave xs ys
which is a little prettier and directly comparable to something Pythonic like
from fractions import Fraction
from itertools import islice
def interleave(x, y):
while True:
yield x.next()
yield y.next()
def all_rationals():
def go(m, n):
yield (m/n)
for v in interleave(go(m, m+n), go(m+n, n)):
yield v
return go(Fraction(1,1), Fraction(1,1))
def rationals(n):
return list(islice(all_rationals(), n))
[0]
http://www.cs.ox.ac.uk/jeremy.gibbons/publications/rationals...