blob: 66546b12b184623990ee9714b8956b195135b864 (
plain)
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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License, with *)
(* the special exception on linking described in file ../LICENSE. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Merging and sorting *)
open Array
let rec merge order l1 l2 =
match l1 with
[] -> l2
| h1 :: t1 ->
match l2 with
[] -> l1
| h2 :: t2 ->
if order h1 h2
then h1 :: merge order t1 l2
else h2 :: merge order l1 t2
let list order l =
let rec initlist = function
[] -> []
| [e] -> [[e]]
| e1::e2::rest ->
(if order e1 e2 then [e1;e2] else [e2;e1]) :: initlist rest in
let rec merge2 = function
l1::l2::rest -> merge order l1 l2 :: merge2 rest
| x -> x in
let rec mergeall = function
[] -> []
| [l] -> l
| llist -> mergeall (merge2 llist) in
mergeall(initlist l)
let swap arr i j =
let tmp = unsafe_get arr i in
unsafe_set arr i (unsafe_get arr j);
unsafe_set arr j tmp
(* There is a known performance bug in the code below. If you find
it, don't bother reporting it. You're not supposed to use this
module anyway. *)
let array cmp arr =
let rec qsort lo hi =
if hi - lo >= 6 then begin
let mid = (lo + hi) lsr 1 in
(* Select median value from among LO, MID, and HI. Rearrange
LO and HI so the three values are sorted. This lowers the
probability of picking a pathological pivot. It also
avoids extra comparisons on i and j in the two tight "while"
loops below. *)
if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo;
if cmp (unsafe_get arr hi) (unsafe_get arr mid) then begin
swap arr mid hi;
if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo
end;
let pivot = unsafe_get arr mid in
let i = ref (lo + 1) and j = ref (hi - 1) in
if not (cmp pivot (unsafe_get arr hi))
|| not (cmp (unsafe_get arr lo) pivot)
then raise (Invalid_argument "Sort.array");
while !i < !j do
while not (cmp pivot (unsafe_get arr !i)) do incr i done;
while not (cmp (unsafe_get arr !j) pivot) do decr j done;
if !i < !j then swap arr !i !j;
incr i; decr j
done;
(* Recursion on smaller half, tail-call on larger half *)
if !j - lo <= hi - !i then begin
qsort lo !j; qsort !i hi
end else begin
qsort !i hi; qsort lo !j
end
end in
qsort 0 (Array.length arr - 1);
(* Finish sorting by insertion sort *)
for i = 1 to Array.length arr - 1 do
let val_i = (unsafe_get arr i) in
if not (cmp (unsafe_get arr (i - 1)) val_i) then begin
unsafe_set arr i (unsafe_get arr (i - 1));
let j = ref (i - 1) in
while !j >= 1 && not (cmp (unsafe_get arr (!j - 1)) val_i) do
unsafe_set arr !j (unsafe_get arr (!j - 1));
decr j
done;
unsafe_set arr !j val_i
end
done
|
