-- Sieve of Eratosthenes
-- Melissa O'Neill "The Genuine Sieve of Eratosthenes"
-- http://www.cs.hmc.edu/~oneill/papers/Sieve-JFP.pdf
-- priority queue from http://hpaste.org/report/1447
module PriorityQueue ( ) where
data PriorityQ k v = Lf
| Br !k v !(PriorityQ k v) !(PriorityQ k v)
deriving (Eq, Ord, Read, Show)
empty :: PriorityQ k v
empty = Lf
isEmpty :: PriorityQ k v -> Bool
isEmpty Lf = True
isEmpty _ = False
minKeyValue :: PriorityQ k v -> (k, v)
minKeyValue (Br k v _ _) = (k,v)
minKeyValue _ = error "Empty heap!"
minKey :: PriorityQ k v -> k
minKey (Br k v _ _) = k
minKey _ = error "Empty heap!"
minValue :: PriorityQ k v -> v
minValue (Br k v _ _) = v
minValue _ = error "Empty heap!"
insert :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v
insert wk wv (Br vk vv t1 t2)
| wk <= vk = Br wk wv (PriorityQ.insert vk vv t2) t1
| otherwise = Br vk vv (PriorityQ.insert wk wv t2) t1
insert wk wv Lf = Br wk wv Lf Lf
siftdown :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v -> PriorityQ k v
siftdown wk wv Lf _ = Br wk wv Lf Lf
siftdown wk wv (t @ (Br vk vv _ _)) Lf
| wk <= vk = Br wk wv t Lf
| otherwise = Br vk vv (Br wk wv Lf Lf) Lf
siftdown wk wv (t1 @ (Br vk1 vv1 p1 q1)) (t2 @ (Br vk2 vv2 p2 q2))
| wk <= vk1 && wk <= vk2 = Br wk wv t1 t2
| vk1 <= vk2 = Br vk1 vv1 (siftdown wk wv p1 q1) t2
| otherwise = Br vk2 vv2 t1 (siftdown wk wv p2 q2)
deleteMinAndInsert :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v
deleteMinAndInsert wk wv Lf = error "Empty PriorityQ"
deleteMinAndInsert wk wv (Br _ _ t1 t2) = siftdown wk wv t1 t2
leftrem :: PriorityQ k v -> (k, v, PriorityQ k v)
leftrem (Br vk vv Lf Lf) = (vk, vv, Lf)
leftrem (Br vk vv t1 t2) = (wk, wv, Br vk vv t t2) where
(wk, wv, t) = leftrem t1
leftrem _ = error "Empty heap!"
deleteMin :: Ord k => PriorityQ k v -> PriorityQ k v
deleteMin (Br vk vv Lf _) = Lf
deleteMin (Br vk vv t1 t2) = siftdown wk wv t2 t where
(wk,wv,t) = leftrem t1
deleteMin _ = error "Empty heap!"
module Main ( ) where
import qualified PQ (PriorityQueue)
sieve [] = []
sieve (x:xs) = x : sieve' xs (insertprime x xs PQ.empty)
where
insertprime p xs table = PQ.insert (p*p) (map (* p) xs) table
sieve' [] table = []
sieve' (x:xs) table
| nextComposite <= x = sieve' xs (adjust table)
| otherwise = x : sieve' xs (insertprime x xs table)
where
nextComposite = PQ.minKey table
adjust table
| n <= x = adjust (PQ.deleteMinAndInsert n' ns table)
| otherwise = table
where
(n, n':ns) = PQ.minKeyValue table
primes = 2 : sieve [3,5..]
main = print $ takewhile (< 100) primes