BUG FOUND
I found a compiler bug in 'ghc', it came up as follows: forgetting a
definition, e.g. 'atMost', in a signature, but still keeping a default method
for 'atMost' should produce something like
TestADT.lhs:56: Value not in scope: `atMost'
But with the appended source ('TestADT.lhs') ghc gave the message
panic! (the `impossible' happened):
classOpTagByOccName PriorityQueue{-r3O,x-} atMost
Please report it as a compiler bug to [EMAIL PROTECTED]
I used the command line
ghc -O - o testadt testADT.lhs -H16M
-Joerg
Joerg Prante
[EMAIL PROTECTED]
-------TestADT.lhs-----------------------------------------------------
> data SeqView t a = Null
> | Cons a (t a)
Priority Queue.
> class PriorityQueue q where
> empty :: (Ord a) => q a
> single :: (Ord a) => a -> q a
> insert :: (Ord a) => a -> q a -> q a
> meld :: (Ord a) => q a -> q a -> q a
> deleteMin :: (Ord a) => q a -> q a
> replaceMin :: (Ord a) => a -> q a -> q a
> isEmpty :: (Ord a) => q a -> Bool
> isSingle :: (Ord a) => q a -> Bool
> fold :: (Ord a) => (a -> b -> b) -> b -> q a -> b
> splitMin :: (Ord a) => q a -> SeqView q a
> findMin :: (Ord a) => q a -> a
atMost :: (Ord a) => a -> q a -> [a]
> size :: (Ord a) => q a -> Int
> fromList :: (Ord a) => [a] -> q a
> fromOrderedList :: (Ord a) => [a] -> q a
> toList :: (Ord a) => q a -> [a]
> toOrderedList :: (Ord a) => q a -> [a]
Defaultmethoden
> single a = insert a empty
> insert a q = single a `meld` q
> meld p q = insertMany (toList p) q
> deleteMin q = case splitMin q of
> Null -> error "deleteMin: empty priority queue"
> Cons _ q -> q
> replaceMin a q = deleteMin (insert a q)
> isEmpty s = case splitMin s of
> Null -> True
> _ -> False
> isSingle s = case splitMin s of
> Null -> False
> Cons _ s -> isEmpty s
> fold (*) e s = case splitMin s of
> Null -> e
> Cons a s -> a * fold (*) e s
> splitMin q
> | isEmpty q = Null
> | otherwise = Cons (findMin q) (deleteMin q)
> findMin q = case splitMin q of
> Null -> error "findMin: empty priority queue"
> Cons a _ -> a
> atMost a q = takeWhile (<= a) (toOrderedList q)
> size = fold (\_ n -> n + 1) 0
> fromList = foldm meld empty . map single
> toList = fold (:) []
> fromOrderedList = fromList
> toOrderedList q = case splitMin q of
> Null -> []
> Cons a q -> a : toOrderedList q
Abgeleitete Funktionen.
> insertMany :: (PriorityQueue q, Ord a) => [a] -> q a -> q a
> insertMany x q = foldr insert q x
> foldm :: (a -> a -> a) -> a -> [a] -> a
> foldm (*) e [] = e
> foldm (*) e x = fst (rec (length x) x)
> where rec 1 (a:x) = (a, x)
> rec n x = (a * b, z)
> where m = n `div` 2
> (a, y) = rec (n - m) x
> (b, z) = rec m y
Binary Heaps.
> data BinTree a = Empty
> | Bin (BinTree a) a (BinTree a)
> instance PriorityQueue BinTree where
> empty = Empty
> single a = Bin Empty a Empty
> isEmpty Empty = True
> isEmpty _ = False
> insert b Empty = Bin Empty b Empty
> insert b (Bin l a r)
> | a <= b = Bin (insert b r) a l
> | otherwise = Bin (insert a r) b l
> meld Empty u = u
> meld t@(Bin _ _ _) Empty = t
> meld t@(Bin l a r) u@(Bin l' b r')
> | a <= b = Bin (meld l r) a u
> | otherwise = Bin t b (meld l' r')
> splitMin Empty = Null
> splitMin (Bin l a r) = Cons a (meld l r)
> fromList = foldr insert empty
toOrderedList Empty = []
toOrderedList (Bin l a r) = a : toOrderedList (meld l r)
> isBinTree Empty = True
> isBinTree (Bin l a r) = True
> isBinTree _ = False
Sortieren.
> pqSort q x = toOrderedList (insertMany x q)
> main = do
> let n = 10000
> putStr "*** sorting\n"
> out (pqSort q0 [1 .. n])
> out (pqSort q0 [n, n-1 .. 1])
> out (pqSort q0 (take n $ random2Ints 82437 24376))
> out :: (Num a) => [a] -> IO ()
> out x | sum x == 0 = putStr "ok\n"
> | otherwise = putStr "ok\n"
> q0 :: (Ord a) => BinTree a
> q0 = empty
The random-number generator which is stolen from the `hbc'-library.
> random2Ints :: Int -> Int -> [Int]
> random2Ints s1 s2
> | s1 < 1 || s1 > 2147483562 = error "random2Ints: Bad first seed."
> | s2 < 1 || s2 > 2147483398 = error "random2Ints: Bad second seed."
> | otherwise = rands s1 s2
> rands :: Int -> Int -> [Int]
> rands s1 s2
> | z < 1 = z + 2147483562 : rands s1'' s2''
> | otherwise = z : rands s1'' s2''
> where k = s1 `div` 53668
> s1' = 40014 * (s1 - k * 53668) - k * 12211
> s1'' | s1' < 0 = s1' + 2147483563
> | otherwise = s1'
> k' = s2 `div` 52774
> s2' = 40692 * (s2 - k' * 52774) - k' * 3791
> s2'' | s2' < 0 = s2' + 2147483399
> | otherwise = s2'
> z = s1'' - s2''
