1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
{------------------------------------------------------------------------------
SORTING LISTS
This module provides properly parameterised insertion and merge sort functions,
complete with associated functions for inserting and merging. `isort' is the
standard lazy version and can be used to the minimum k elements of a list in
linear time. The merge sort is based on a Bob Buckley's (Bob Buckley
18-AUG-95) coding of Knuth's natural merge sort (see Vol. 2). It seems to be
fast in the average case; it makes use of natural runs in the data becomming
linear on ordered data; and it completes in worst time O(n.log(n)). It is
divinely elegant.
`nub'' is an n.log(n) version of `nub' and `group_sort' sorts a list into
strictly ascending order, using a combining function in its arguments to
amalgamate duplicates.
Chris Dornan, 14-Aug-93, 17-Nov-94, 29-Dec-95
------------------------------------------------------------------------------}
module Sort where
-- Hide (<=) so that we don't get name shadowing warnings for it
import Prelude hiding ((<=))
-- `isort' is an insertion sort and is here for historical reasons; msort is
-- better in almost every situation.
isort:: (a->a->Bool) -> [a] -> [a]
isort (<=) = foldr (insrt (<=)) []
insrt:: (a->a->Bool) -> a -> [a] -> [a]
insrt _ e [] = [e]
insrt (<=) e l@(h:t) = if e<=h then e:l else h:insrt (<=) e t
msort :: (a->a->Bool) -> [a] -> [a]
msort _ [] = [] -- (foldb f []) is undefined
msort (<=) xs = foldb (mrg (<=)) (runs (<=) xs)
runs :: (a->a->Bool) -> [a] -> [[a]]
runs (<=) xs0 = foldr op [] xs0
where
op z xss@(xs@(x:_):xss') | z<=x = (z:xs):xss'
| otherwise = [z]:xss
op z xss = [z]:xss
foldb :: (a->a->a) -> [a] -> a
foldb _ [x] = x
foldb f xs0 = foldb f (fold xs0)
where
fold (x1:x2:xs) = f x1 x2 : fold xs
fold xs = xs
mrg:: (a->a->Bool) -> [a] -> [a] -> [a]
mrg _ [] l = l
mrg _ l@(_:_) [] = l
mrg (<=) l1@(h1:t1) l2@(h2:t2) =
if h1<=h2
then h1:mrg (<=) t1 l2
else h2:mrg (<=) l1 t2
nub':: (a->a->Bool) -> [a] -> [a]
nub' (<=) l = group_sort (<=) const l
group_sort:: (a->a->Bool) -> (a->[a]->b) -> [a] -> [b]
group_sort le cmb l = s_m (msort le l)
where
s_m [] = []
s_m (h:t) = cmb h (takeWhile (`le` h) t):s_m (dropWhile (`le` h) t)
|