1
(* Test bench for sorting algorithms. *)
5
ocamlopt -noassert sorts.ml -cclib -lunix
12
0. overhead en pile: doit etre logn au maximum.
14
2. overhead en espace.
18
(************************************************************************)
19
(* auxiliary functions *)
21
let rec exp2 n = if n <= 0 then 1 else 2 * exp2 (n-1);;
23
let postl x y = Array.of_list y;;
26
let mkconst n = Array.make n 0;;
27
let chkconst _ n a = (a = mkconst n);;
30
let a = Array.make n 0 in
36
let chksorted _ n a = (a = mksorted n);;
39
let a = Array.make n 0 in
45
let chkrev _ n a = (a = mksorted n);;
48
let random_reinit () = Random.init !seed;;
50
let random_get_state () =
51
let a = Array.make 55 0 in
52
for i = 0 to 54 do a.(i) <- Random.bits (); done;
56
let random_set_state a = Random.full_init a;;
58
let chkgen mke cmp rstate n a =
59
let marks = Array.make n (-1) in
61
if marks.(l) = -1 then l else begin
62
let m = ref marks.(l) in
63
while marks.(!m) <> -1 do incr m; done;
69
let l = skipmarks l in
71
if cmp a.(l) e > 0 then raise Exit
72
else if e = a.(l) then marks.(l) <- l+1
77
if l = r then linear e l
80
let m = (l + r) / 2 in
81
if cmp a.(m) e >= 0 then dicho e l m else dicho e (m + 1) r
85
for i = 0 to n-2 do if cmp a.(i) a.(i+1) > 0 then raise Exit; done;
86
random_set_state rstate;
87
for i = 0 to n-1 do dicho (mke i) 0 (Array.length a - 1); done;
89
with Exit | Invalid_argument _ -> false;
93
let a = Array.make n 0 in
94
for i = 0 to (n-1) do a.(i) <- Random.int n; done;
98
let chkrand_dup rstate n a =
99
chkgen (fun i -> Random.int n) compare rstate n a
103
let a = Array.make n 0 in
104
for i = 0 to (n-1) do a.(i) <- Random.bits (); done;
108
let chkrand_nodup rstate n a =
109
chkgen (fun i -> Random.bits ()) compare rstate n a
113
let a = Array.make n 0.0 in
114
for i = 0 to (n-1) do a.(i) <- Random.float 1.0; done;
118
let chkfloats rstate n a =
119
chkgen (fun i -> Random.float 1.0) compare rstate n a
130
let len = Random.int 10 in
131
let s = String.create len in
132
for i = 0 to len-1 do
133
s.[i] <- Char.chr (Random.int 256);
145
let mkrecs b n = Array.init n (mkrec1 b);;
147
let mkrec1_rev b i = {
154
let mkrecs_rev n = Array.init n (mkrec1_rev 0);;
157
let c1 = compare r1.s1 r2.s1 in
158
if c1 = 0 then compare r1.s2 r2.s2 else c1
161
let c1 = compare r1.s1 r2.s1 in
162
if c1 = 0 then r1.s2 <= r2.s2 else (c1 < 0)
164
let chkstr b rstate n a = chkgen (mkrec1 b) cmpstr rstate n a;;
166
let cmpint r1 r2 = compare r1.i1 r2.i1;;
167
let leint r1 r2 = r1.i1 <= r2.i1;;
168
let chkint b rstate n a = chkgen (mkrec1 b) cmpint rstate n a;;
171
let c1 = compare r1.i1 r2.i1 in
172
if c1 = 0 then compare r1.i2 r2.i2 else c1
175
let c1 = compare r1.i1 r2.i1 in
176
if c1 = 0 then r1.i2 <= r2.i2 else (c1 < 0)
178
let chklex b rstate n a = chkgen (mkrec1 b) cmplex rstate n a;;
180
(************************************************************************)
183
0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 28;
184
100; 127; 128; 129; 191; 192; 193; 506;
185
1000; 1023; 1024; 1025; 1535; 1536; 1537; 2323;
186
4000; 4094; 4096; 4098; 5123;
189
type ('a, 'b, 'c, 'd) aux = {
190
prepf : ('a -> 'a -> int) -> ('a -> 'a -> bool) -> 'b;
191
prepd : 'a array -> 'c;
192
postd : 'a array -> 'd -> 'a array;
195
let ll = { prepf = (fun x y -> y); prepd = Array.to_list; postd = postl };;
196
let lc = { prepf = (fun x y -> x); prepd = Array.to_list; postd = postl };;
197
let al = { prepf = (fun x y -> y); prepd = id; postd = posta };;
198
let ac = { prepf = (fun x y -> x); prepd = id; postd = posta };;
200
type 'a outcome = Value of 'a | Exception of exn;;
202
let numfailed = ref 0;;
204
let test1 name f prepdata postdata cmp desc mk chk =
206
printf " %s with %s" name desc;
209
if !i = 0 then printf "\n "; incr i; if !i > 11 then i := 0;
210
printf "%5d" n; flush stdout;
211
let rstate = random_get_state () in
213
let input = prepdata a in
214
let output = try Value (f cmp input) with e -> Exception e in
215
printf "."; flush stdout;
216
begin match output with
218
if not (chk rstate n (postdata a v))
219
then (incr numfailed; printf "\n*** FAIL\n")
221
incr numfailed; printf "\n*** %s\n" (Printexc.to_string e)
228
let test name stable f1 f2 aux1 aux2 =
229
printf "Testing %s...\n" name;
230
let t a b c d = test1 name f1 aux1.prepd aux1.postd a b c d in
231
let cmp = aux1.prepf compare (<=) in
232
t cmp "constant ints" mkconst chkconst;
233
t cmp "sorted ints" mksorted chksorted;
234
t cmp "reverse-sorted ints" mkrev chkrev;
235
t cmp "random ints (many dups)" mkrand_dup chkrand_dup;
236
t cmp "random ints (few dups)" mkrand_nodup chkrand_nodup;
238
let t a b c d = test1 name f3 aux3.prepd aux3.postd a b c d in
239
t cmp "random floats" mkfloats chkfloats;
241
let t a b c d = test1 name f2 aux2.prepd aux2.postd a b c d in
242
let cmp = aux2.prepf cmpstr lestr in
243
t cmp "records (str)" (mkrecs 1) (chkstr 1);
244
let cmp = aux2.prepf cmpint leint in
245
List.iter (fun m -> t cmp (sprintf "records (int[%d])" m) (mkrecs m)
247
) [1; 10; 100; 1000];
249
List.iter (fun m -> t cmp (sprintf "records (int[%d]) [stable]" m)
250
(mkrecs m) (chklex m)
251
) [1; 10; 100; 1000];
254
(************************************************************************)
256
(* Warning: rpt_timer cannot be used for the array sorts because
257
the sorting functions have effects.
260
let rpt_timer1 repeat f x =
263
let st = Sys.time () in
264
for i = 1 to repeat do ignore (f x); done;
265
let en = Sys.time () in
270
let repeat = ref 1 in
271
let t = ref (rpt_timer1 !repeat f x) in
273
repeat := 10 * !repeat;
274
t := rpt_timer1 !repeat f x;
276
if !t < 2.0 then begin
277
repeat := (int_of_float (10. *. (float !repeat) /. !t) + 1);
278
t := rpt_timer1 !repeat f x;
280
!t /. (float !repeat)
284
let st = Sys.time () in
286
let en = Sys.time () in
290
let table1 limit f mkarg =
291
printf " %10s %9s %9s %9s %9s %9s\n" "n" "t1" "t2" "t3" "t4" "t5";
292
let sz = ref 49151 in
293
while !sz < int_of_float (2. ** float limit) do
295
printf " %10d " !sz; flush stdout;
297
let arg = mkarg !sz in
298
let t = timer f arg in
299
printf " %.2e " t; flush stdout;
302
with e -> printf "*** %s\n" (Printexc.to_string e);
309
let table2 limit f mkarg =
310
printf " %10s %9s %9s %9s %9s %9s\n"
311
" n" "t" "t/n" "t/nlogn" "t/nlog^2n" "t/n^2";
312
let sz = ref 49151 in
313
while float !sz < 2. ** float limit do
315
printf " %10d " !sz; flush stdout;
317
let arg = mkarg !sz in
318
let t = timer f arg in
320
let logn = log (float !sz) /. log 2. in
321
printf "%.2e %.2e %.2e %.2e %.2e\n"
322
t (t/.n) (t/.n/.logn) (t/.n/.logn/.logn) (t/.n/.n);
323
with e -> printf "*** %s\n" (Printexc.to_string e);
330
let table3 limit f mkarg =
331
printf " %10s %9s %9s %9s %9s %9s\n" "n" "t1" "t2" "t3" "t4" "t5";
333
while float !sz < 2. ** float limit do
335
printf " %10d " !sz; flush stdout;
337
let arg = mkarg !sz in
338
let t = rpt_timer f arg in
339
printf " %.2e " t; flush stdout;
342
with e -> printf "*** %s\n" (Printexc.to_string e);
349
(************************************************************************)
352
1a. random records, sorted with two keys
356
2a. integers, constant
357
2b. integers, already sorted
358
2c. integers, reverse sorted
360
only for short lists:
361
3a. random records, sorted with two keys
365
let bench1a limit name f aux =
367
(* Don't do benchmarks with assertions enabled. *)
372
printf "\n%s with random records [10]:\n" name;
373
let cmp = aux.prepf cmplex lelex in
374
table1 limit (f cmp) (fun n -> aux.prepd (mkrecs 10 n));
377
let bench1b limit name f aux =
379
(* Don't do benchmarks with assertions enabled. *)
384
printf "\n%s with random integers:\n" name;
385
let cmp = aux.prepf (-) (<=) in
386
table1 limit (f cmp) (fun n -> aux.prepd (mkrand_nodup n));
389
let bench1c limit name f aux =
391
(* Don't do benchmarks with assertions enabled. *)
396
printf "\n%s with random floats:\n" name;
397
let cmp = aux.prepf compare (<=) in
398
table1 limit (f cmp) (fun n -> aux.prepd (mkfloats n));
401
let bench2 limit name f aux =
403
(* Don't do benchmarks with assertions enabled. *)
406
printf "\n%s with constant integers:\n" name;
407
let cmp = aux.prepf compare (<=) in
408
table2 limit (f cmp) (fun n -> aux.prepd (mkconst n));
410
printf "\n%s with sorted integers:\n" name;
411
let cmp = aux.prepf compare (<=) in
412
table2 limit (f cmp) (fun n -> aux.prepd (mksorted n));
414
printf "\n%s with reverse-sorted integers:\n" name;
415
let cmp = aux.prepf compare (<=) in
416
table2 limit (f cmp) (fun n -> aux.prepd (mkrev n));
419
let bench3a limit name f aux =
421
(* Don't do benchmarks with assertions enabled. *)
426
printf "\n%s with random records [10]:\n" name;
427
let cmp = aux.prepf cmplex lelex in
428
table3 limit (f cmp) (fun n -> aux.prepd (mkrecs 10 n));
431
let bench3b limit name f aux =
433
(* Don't do benchmarks with assertions enabled. *)
438
printf "\n%s with random integers:\n" name;
439
let cmp = aux.prepf (-) (<=) in
440
table3 limit (f cmp) (fun n -> aux.prepd (mkrand_nodup n));
443
let bench3c limit name f aux =
445
(* Don't do benchmarks with assertions enabled. *)
450
printf "\n%s with random floats:\n" name;
451
let cmp = aux.prepf compare (<=) in
452
table3 limit (f cmp) (fun n -> aux.prepd (mkfloats n));
455
(************************************************************************)
456
(* merge sort on lists *)
458
(* FIXME to do: cutoff
459
to do: cascader les pattern-matchings (enlever les paires)
460
to do: fermeture intermediaire pour merge
462
let (@@) = List.rev_append;;
464
let lmerge_1a cmp l =
465
let rec init accu = function
467
| e::rest -> init ([e] :: accu) rest
469
let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
470
accu,accu2 are rev *)
472
| [] , _ -> mergepairs ((l2 @@ accu)::accu2) rest
473
| _ , [] -> mergepairs ((l1 @@ accu)::accu2) rest
474
| h1::t1, h2::t2 -> if cmp h1 h2 <= 0
475
then merge rest accu2 (h1::accu) t1 l2
476
else merge rest accu2 (h2::accu) l1 t2
477
and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
478
l1,l2,rest are rev *)
480
| [] , _ -> mergepairs_rev ((l2 @@ accu)::accu2) rest
481
| _ , [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest
482
| h1::t1, h2::t2 -> if cmp h2 h1 <= 0
483
then merge_rev rest accu2 (h1::accu) t1 l2
484
else merge_rev rest accu2 (h2::accu) l1 t2
485
and mergepairs accu = function (* accu is rev, arg is forward *)
486
| [] -> mergeall_rev accu
487
| [l] -> mergeall_rev ((List.rev l)::accu)
488
| l1::l2::rest -> merge rest accu [] l1 l2
489
and mergepairs_rev accu = function (* accu is forward, arg is rev *)
490
| [] -> mergeall accu
491
| [l] -> mergeall ((List.rev l)::accu)
492
| l1::l2::rest -> merge_rev rest accu [] l1 l2
493
and mergeall = function (* arg is forward *)
496
| llist -> mergepairs [] llist
497
and mergeall_rev = function (* arg is rev *)
500
| llist -> mergepairs_rev [] llist
502
mergeall_rev (init [] l)
505
let lmerge_1b cmp l =
506
let rec init accu = function
510
init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest
512
let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
513
accu,accu2 are rev *)
515
| [] , _ -> mergepairs ((l2 @@ accu)::accu2) rest
516
| _ , [] -> mergepairs ((l1 @@ accu)::accu2) rest
517
| h1::t1, h2::t2 -> if cmp h1 h2 <= 0
518
then merge rest accu2 (h1::accu) t1 l2
519
else merge rest accu2 (h2::accu) l1 t2
520
and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
521
l1,l2,rest are rev *)
523
| [] , _ -> mergepairs_rev ((l2 @@ accu)::accu2) rest
524
| _ , [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest
525
| h1::t1, h2::t2 -> if cmp h2 h1 <= 0
526
then merge_rev rest accu2 (h1::accu) t1 l2
527
else merge_rev rest accu2 (h2::accu) l1 t2
528
and mergepairs accu = function (* accu is rev, arg is forward *)
529
| [] -> mergeall_rev accu
530
| [l] -> mergeall_rev ((List.rev l)::accu)
531
| l1::l2::rest -> merge rest accu [] l1 l2
532
and mergepairs_rev accu = function (* accu is forward, arg is rev *)
533
| [] -> mergeall accu
534
| [l] -> mergeall ((List.rev l)::accu)
535
| l1::l2::rest -> merge_rev rest accu [] l1 l2
536
and mergeall = function (* arg is forward *)
539
| llist -> mergepairs [] llist
540
and mergeall_rev = function (* arg is rev *)
543
| llist -> mergepairs_rev [] llist
545
mergeall_rev (init [] l)
548
let lmerge_1c cmp l =
549
let rec init accu = function
553
init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest
555
let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
556
accu,accu2 are rev *)
558
| [] -> mergepairs ((l2 @@ accu)::accu2) rest
561
| [] -> mergepairs ((l1 @@ accu)::accu2) rest
562
| h2::t2 -> if cmp h1 h2 <= 0
563
then merge rest accu2 (h1::accu) t1 l2
564
else merge rest accu2 (h2::accu) l1 t2
565
and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
566
l1,l2,rest are rev *)
568
| [] -> mergepairs_rev ((l2 @@ accu)::accu2) rest
571
| [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest
572
| h2::t2 -> if cmp h2 h1 <= 0
573
then merge_rev rest accu2 (h1::accu) t1 l2
574
else merge_rev rest accu2 (h2::accu) l1 t2
575
and mergepairs accu = function (* accu is rev, arg is forward *)
576
| [] -> mergeall_rev accu
577
| [l] -> mergeall_rev ((List.rev l)::accu)
578
| l1::l2::rest -> merge rest accu [] l1 l2
579
and mergepairs_rev accu = function (* accu is forward, arg is rev *)
580
| [] -> mergeall accu
581
| [l] -> mergeall ((List.rev l)::accu)
582
| l1::l2::rest -> merge_rev rest accu [] l1 l2
583
and mergeall = function (* arg is forward *)
586
| llist -> mergepairs [] llist
587
and mergeall_rev = function (* arg is rev *)
590
| llist -> mergepairs_rev [] llist
592
mergeall_rev (init [] l)
595
let lmerge_1d cmp l =
596
let rec init accu = function
600
init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest
602
let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
603
accu,accu2 are rev *)
604
let merge_rest_accu2 accu l1 l2 =
606
| [] -> mergepairs ((l2 @@ accu)::accu2) rest
609
| [] -> mergepairs ((l1 @@ accu)::accu2) rest
610
| h2::t2 -> if cmp h1 h2 <= 0
611
then merge rest accu2 (h1::accu) t1 l2
612
else merge rest accu2 (h2::accu) l1 t2
613
in merge_rest_accu2 accu l1 l2
614
and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
615
l1,l2,rest are rev *)
616
let merge_rev_rest_accu2 accu l1 l2 =
618
| [] -> mergepairs_rev ((l2 @@ accu)::accu2) rest
621
| [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest
622
| h2::t2 -> if cmp h2 h1 <= 0
623
then merge_rev rest accu2 (h1::accu) t1 l2
624
else merge_rev rest accu2 (h2::accu) l1 t2
625
in merge_rev_rest_accu2 accu l1 l2
626
and mergepairs accu = function (* accu is rev, arg is forward *)
627
| [] -> mergeall_rev accu
628
| [l] -> mergeall_rev ((List.rev l)::accu)
629
| l1::l2::rest -> merge rest accu [] l1 l2
630
and mergepairs_rev accu = function (* accu is forward, arg is rev *)
631
| [] -> mergeall accu
632
| [l] -> mergeall ((List.rev l)::accu)
633
| l1::l2::rest -> merge_rev rest accu [] l1 l2
634
and mergeall = function (* arg is forward *)
637
| llist -> mergepairs [] llist
638
and mergeall_rev = function (* arg is rev *)
641
| llist -> mergepairs_rev [] llist
643
mergeall_rev (init [] l)
646
(************************************************************************)
647
(* merge sort on lists, user-contributed (NOT STABLE) *)
649
(* BEGIN code contributed by Yann Coscoy *)
651
let rec rev_merge_append order l1 l2 acc =
653
[] -> List.rev_append l2 acc
656
[] -> List.rev_append l1 acc
659
then rev_merge_append order t1 l2 (h1::acc)
660
else rev_merge_append order l1 t2 (h2::acc)
662
let rev_merge order l1 l2 = rev_merge_append order l1 l2 []
664
let rec rev_merge_append' order l1 l2 acc =
666
| [] -> List.rev_append l2 acc
669
| [] -> List.rev_append l1 acc
672
then rev_merge_append' order t1 l2 (h1::acc)
673
else rev_merge_append' order l1 t2 (h2::acc)
675
let rev_merge' order l1 l2 = rev_merge_append' order l1 l2 []
677
let lmerge_3 order l =
678
let rec initlist l acc = match l with
681
((if order e1 e2 then [e1;e2] else [e2;e1])::acc)
685
let rec merge2 ll acc = match ll with
687
| [l] -> [List.rev l]@acc
689
merge2 rest (rev_merge order l1 l2::acc)
691
let rec merge2' ll acc = match ll with
693
| [l] -> [List.rev l]@acc
695
merge2' rest (rev_merge' order l1 l2::acc)
697
let rec mergeall rev = function
699
| [l] -> if rev then List.rev l else l
702
(not rev) ((if rev then merge2' else merge2) llist [])
704
mergeall false (initlist l [])
706
(* END code contributed by Yann Coscoy *)
708
(************************************************************************)
709
(* merge sort on short lists, Francois Pottier *)
711
(* BEGIN code contributed by Francois Pottier *)
713
(* [chop k l] returns the list [l] deprived of its [k] first
714
elements. The length of the list [l] must be [k] at least. *)
719
| _, x :: l -> chop (k-1) l
720
| _, _ -> assert false
723
let rec merge order l1 l2 =
731
then h1 :: merge order t1 l2
732
else h2 :: merge order l1 t2
735
let rec lmerge_4a order l =
740
let rec sort k l = (* k > 1 *)
742
| 2, x1 :: x2 :: _ ->
743
if order x1 x2 then [ x1; x2 ] else [ x2; x1 ]
744
| 3, x1 :: x2 :: x3 :: _ ->
749
if order x1 x3 then [ x1 ; x3 ; x2 ] else [ x3; x1; x2 ]
754
if order x2 x3 then [ x2; x3; x1 ] else [ x3; x2; x1 ]
758
merge order (sort k1 l) (sort k2 (chop k1 l))
760
sort (List.length l) l
762
(* END code contributed by Francois Pottier *)
764
(************************************************************************)
765
(* merge sort on short lists, Francois Pottier,
766
adapted to new-style interface *)
768
(* BEGIN code contributed by Francois Pottier *)
770
(* [chop k l] returns the list [l] deprived of its [k] first
771
elements. The length of the list [l] must be [k] at least. *)
776
| _, x :: l -> chop (k-1) l
777
| _, _ -> assert false
780
let rec merge order l1 l2 =
788
then h1 :: merge order t1 l2
789
else h2 :: merge order l1 t2
792
let rec lmerge_4b order l =
797
let rec sort k l = (* k > 1 *)
799
| 2, x1 :: x2 :: _ ->
800
if order x1 x2 <= 0 then [ x1; x2 ] else [ x2; x1 ]
801
| 3, x1 :: x2 :: x3 :: _ ->
802
if order x1 x2 <= 0 then
803
if order x2 x3 <= 0 then
806
if order x1 x3 <= 0 then [ x1 ; x3 ; x2 ] else [ x3; x1; x2 ]
808
if order x1 x3 <= 0 then
811
if order x2 x3 <= 0 then [ x2; x3; x1 ] else [ x3; x2; x1 ]
815
merge order (sort k1 l) (sort k2 (chop k1 l))
817
sort (List.length l) l
819
(* END code contributed by Francois Pottier *)
821
(************************************************************************)
822
(* merge sort on short lists a la Pottier, modified merge *)
825
if k = 0 then l else begin
827
| x::t -> chop (k-1) t
832
let lmerge_4c cmp l =
833
let rec merge1 h1 t1 l2 =
838
then h1 :: (merge2 t1 h2 t2)
839
else h2 :: (merge1 h1 t1 t2)
840
and merge2 l1 h2 t2 =
845
then h1 :: (merge2 t1 h2 t2)
846
else h2 :: (merge1 h1 t1 t2)
848
let merge l1 = function
850
| h2 :: t2 -> merge2 l1 h2 t2
854
| 2, x1 :: x2 :: _ ->
855
if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1]
856
| 3, x1 :: x2 :: x3 :: _ ->
857
if cmp x1 x2 <= 0 then begin
858
if cmp x2 x3 <= 0 then [x1; x2; x3]
859
else if cmp x1 x3 <= 0 then [x1; x3; x2]
862
if cmp x1 x3 <= 0 then [x2; x1; x3]
863
else if cmp x2 x3 <= 0 then [x2; x3; x1]
869
merge (sort n1 l) (sort n2 (chop n1 l))
871
let len = List.length l in
872
if len < 2 then l else sort len l
875
(************************************************************************)
876
(* merge sort on short lists a la Pottier, logarithmic stack space *)
879
if k = 0 then l else begin
881
| x::t -> chop (k-1) t
886
let lmerge_4d cmp l =
887
let rec rev_merge l1 l2 accu =
889
| [], l2 -> l2 @@ accu
890
| l1, [] -> l1 @@ accu
893
then rev_merge t1 l2 (h1::accu)
894
else rev_merge l1 t2 (h2::accu)
896
let rec rev_merge_rev l1 l2 accu =
898
| [], l2 -> l2 @@ accu
899
| l1, [] -> l1 @@ accu
902
then rev_merge_rev t1 l2 (h1::accu)
903
else rev_merge_rev l1 t2 (h2::accu)
907
| 2, x1 :: x2 :: _ ->
908
if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1]
909
| 3, x1 :: x2 :: x3 :: _ ->
910
if cmp x1 x2 <= 0 then begin
911
if cmp x2 x3 <= 0 then [x1; x2; x3]
912
else if cmp x1 x3 <= 0 then [x1; x3; x2]
915
if cmp x1 x3 <= 0 then [x2; x1; x3]
916
else if cmp x2 x3 <= 0 then [x2; x3; x1]
922
rev_merge_rev (rev_sort n1 l) (rev_sort n2 (chop n1 l)) []
925
| 2, x1 :: x2 :: _ ->
926
if cmp x1 x2 > 0 then [x1; x2] else [x2; x1]
927
| 3, x1 :: x2 :: x3 :: _ ->
928
if cmp x1 x2 > 0 then begin
929
if cmp x2 x3 > 0 then [x1; x2; x3]
930
else if cmp x1 x3 > 0 then [x1; x3; x2]
933
if cmp x1 x3 > 0 then [x2; x1; x3]
934
else if cmp x2 x3 > 0 then [x2; x3; x1]
940
rev_merge (sort n1 l) (sort n2 (chop n1 l)) []
942
let len = List.length l in
943
if len < 2 then l else sort len l
947
(************************************************************************)
948
(* merge sort on short lists a la Pottier, logarithmic stack space,
949
in place: input list is freed as the output is being computed. *)
952
if k = 0 then l else begin
954
| x::t -> chop (k-1) t
959
let lmerge_4e cmp l =
960
let rec rev_merge l1 l2 accu =
962
| [], l2 -> l2 @@ accu
963
| l1, [] -> l1 @@ accu
966
then rev_merge t1 l2 (h1::accu)
967
else rev_merge l1 t2 (h2::accu)
969
let rec rev_merge_rev l1 l2 accu =
971
| [], l2 -> l2 @@ accu
972
| l1, [] -> l1 @@ accu
975
then rev_merge_rev t1 l2 (h1::accu)
976
else rev_merge_rev l1 t2 (h2::accu)
980
| 2, x1 :: x2 :: _ ->
981
if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1]
982
| 3, x1 :: x2 :: x3 :: _ ->
983
if cmp x1 x2 <= 0 then begin
984
if cmp x2 x3 <= 0 then [x1; x2; x3]
985
else if cmp x1 x3 <= 0 then [x1; x3; x2]
988
if cmp x1 x3 <= 0 then [x2; x1; x3]
989
else if cmp x2 x3 <= 0 then [x2; x3; x1]
995
let l2 = chop n1 l in
996
let s1 = rev_sort n1 l in
997
let s2 = rev_sort n2 l2 in
998
rev_merge_rev s1 s2 []
1001
| 2, x1 :: x2 :: _ ->
1002
if cmp x1 x2 > 0 then [x1; x2] else [x2; x1]
1003
| 3, x1 :: x2 :: x3 :: _ ->
1004
if cmp x1 x2 > 0 then begin
1005
if cmp x2 x3 > 0 then [x1; x2; x3]
1006
else if cmp x1 x3 > 0 then [x1; x3; x2]
1009
if cmp x1 x3 > 0 then [x2; x1; x3]
1010
else if cmp x2 x3 > 0 then [x2; x3; x1]
1016
let l2 = chop n1 l in
1017
let s1 = sort n1 l in
1018
let s2 = sort n2 l2 in
1021
let len = List.length l in
1022
if len < 2 then l else sort len l
1025
(************************************************************************)
1026
(* chop-free version of Pottier's code, binary version *)
1028
let rec merge cmp l1 l2 =
1032
| h1 :: t1, h2 :: t2 ->
1034
then h1 :: merge cmp t1 l2
1035
else h2 :: merge cmp l1 t2
1038
let lmerge_5a cmp l =
1040
let rec sort_prefix n =
1041
if n <= 1 then begin
1044
| [x] as l -> rem := []; l
1045
| x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x]
1046
end else if !rem = [] then []
1048
let l1 = sort_prefix (n-1) in
1049
let l2 = sort_prefix (n-1) in
1053
let len = ref (List.length l) in
1055
while !len > 0 do incr i; len := !len lsr 1; done;
1059
(************************************************************************)
1060
(* chop-free version of Pottier's code, dichotomic version,
1061
ground cases 1 & 2 *)
1063
let rec merge cmp l1 l2 =
1067
| h1 :: t1, h2 :: t2 ->
1069
then h1 :: merge cmp t1 l2
1070
else h2 :: merge cmp l1 t2
1073
let lmerge_5b cmp l =
1075
let rec sort_prefix n =
1077
| 1, x::t -> rem := t; [x]
1078
| 2, x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x]
1082
let l1 = sort_prefix n1 in
1083
let l2 = sort_prefix n2 in
1086
let len = List.length l in
1087
if len <= 1 then l else sort_prefix len
1090
(************************************************************************)
1091
(* chop-free version of Pottier's code, dichotomic version,
1092
ground cases 2 & 3 *)
1094
let rec merge cmp l1 l2 =
1098
| h1 :: t1, h2 :: t2 ->
1100
then h1 :: merge cmp t1 l2
1101
else h2 :: merge cmp l1 t2
1104
let lmerge_5c cmp l =
1106
let rec sort_prefix n =
1108
| 2, x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x]
1111
if cmp x y <= 0 then
1112
if cmp y z <= 0 then [x; y; z]
1113
else if cmp x z <= 0 then [x; z; y]
1116
if cmp x z <= 0 then [y; x; z]
1117
else if cmp y z <= 0 then [y; z; x]
1122
let l1 = sort_prefix n1 in
1123
let l2 = sort_prefix n2 in
1126
let len = List.length l in
1127
if len <= 1 then l else sort_prefix len
1130
(************************************************************************)
1131
(* chop-free, ref-free version of Pottier's code, dichotomic version,
1132
ground cases 2 & 3, modified merge *)
1134
let lmerge_5d cmp l =
1135
let rec merge1 h1 t1 l2 =
1140
then h1 :: merge2 t1 h2 t2
1141
else h2 :: merge1 h1 t1 t2
1142
and merge2 l1 h2 t2 =
1147
then h1 :: merge2 t1 h2 t2
1148
else h2 :: merge1 h1 t1 t2
1150
let rec sort_prefix n l =
1152
| 2, x::y::t -> ((if cmp x y <= 0 then [x;y] else [y;x]), t)
1154
((if cmp x y <= 0 then
1155
if cmp y z <= 0 then [x; y; z]
1156
else if cmp x z <= 0 then [x; z; y]
1159
if cmp x z <= 0 then [y; x; z]
1160
else if cmp y z <= 0 then [y; z; x]
1166
let (l1, rest1) = sort_prefix n1 l in
1167
match sort_prefix n2 rest1 with
1168
| (h2::t2, rest2) -> ((merge2 l1 h2 t2), rest2)
1171
let len = List.length l in
1172
if len <= 1 then l else fst (sort_prefix len l)
1175
(************************************************************************)
1176
(* merge sort on arrays, merge with tail-rec function *)
1178
let amerge_1a cmp a =
1179
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1180
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
1181
let rec loop i1 s1 i2 s2 d =
1182
if cmp s1 s2 <= 0 then begin
1186
loop i1 a.(i1) i2 s2 (d + 1)
1188
Array.blit src2 i2 dst (d + 1) (src2r - i2)
1193
loop i1 s1 i2 src2.(i2) (d + 1)
1195
Array.blit a i1 dst (d + 1) (src1r - i1)
1197
in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
1199
let rec sortto srcofs dst dstofs len =
1201
if len = 1 then dst.(dstofs) <- a.(srcofs)
1204
let l2 = len - l1 in
1205
sortto (srcofs + l1) dst (dstofs + l1) l2;
1206
sortto srcofs a (srcofs + l2) l1;
1207
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
1210
let l = Array.length a in
1215
let t = Array.make l2 a.(0) in
1218
merge l2 l1 t 0 l2 a 0;
1222
let amerge_1b cmp a =
1223
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1224
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
1225
let rec loop i1 s1 i2 s2 d =
1226
if cmp s1 s2 <= 0 then begin
1230
loop i1 a.(i1) i2 s2 (d + 1)
1232
Array.blit src2 i2 dst (d + 1) (src2r - i2)
1237
loop i1 s1 i2 src2.(i2) (d + 1)
1239
Array.blit a i1 dst (d + 1) (src1r - i1)
1241
in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
1243
let rec sortto srcofs dst dstofs len =
1245
if len = 1 then dst.(dstofs) <- a.(srcofs)
1246
else if len = 2 then begin
1247
if cmp a.(srcofs) a.(srcofs+1) <= 0 then begin
1248
dst.(dstofs) <- a.(srcofs);
1249
dst.(dstofs+1) <- a.(srcofs+1);
1251
dst.(dstofs) <- a.(srcofs+1);
1252
dst.(dstofs+1) <- a.(srcofs);
1256
let l2 = len - l1 in
1257
sortto (srcofs + l1) dst (dstofs + l1) l2;
1258
sortto srcofs a (srcofs + l2) l1;
1259
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
1262
let l = Array.length a in
1264
else if l = 2 then begin
1265
if cmp a.(0) a.(1) > 0 then begin
1273
let t = Array.make l2 a.(0) in
1276
merge l2 l1 t 0 l2 a 0;
1281
let amerge_1c cmp a =
1282
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1283
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
1284
let rec loop i1 s1 i2 s2 d =
1285
if cmp s1 s2 <= 0 then begin
1289
loop i1 a.(i1) i2 s2 (d + 1)
1291
Array.blit src2 i2 dst (d + 1) (src2r - i2)
1296
loop i1 s1 i2 src2.(i2) (d + 1)
1298
Array.blit a i1 dst (d + 1) (src1r - i1)
1300
in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
1302
let isortto srcofs dst dstofs len =
1303
for i = 0 to len - 1 do
1304
let e = a.(srcofs + i) in
1305
let j = ref (dstofs + i - 1) in
1306
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1307
dst.(!j + 1) <- dst.(!j);
1313
let rec sortto srcofs dst dstofs len =
1314
if len <= cutoff then isortto srcofs dst dstofs len else begin
1316
let l2 = len - l1 in
1317
sortto (srcofs + l1) dst (dstofs + l1) l2;
1318
sortto srcofs a (srcofs + l2) l1;
1319
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
1322
let l = Array.length a in
1323
if l <= cutoff then isortto 0 a 0 l else begin
1326
let t = Array.make l2 a.(0) in
1329
merge l2 l1 t 0 l2 a 0;
1334
let amerge_1d cmp a =
1335
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1336
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
1337
let rec loop i1 s1 i2 s2 d =
1338
if cmp s1 s2 <= 0 then begin
1342
loop i1 a.(i1) i2 s2 (d + 1)
1344
Array.blit src2 i2 dst (d + 1) (src2r - i2)
1349
loop i1 s1 i2 src2.(i2) (d + 1)
1351
Array.blit a i1 dst (d + 1) (src1r - i1)
1353
in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
1355
let isortto srcofs dst dstofs len =
1356
for i = 0 to len - 1 do
1357
let e = a.(srcofs + i) in
1358
let j = ref (dstofs + i - 1) in
1359
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1360
dst.(!j + 1) <- dst.(!j);
1366
let rec sortto srcofs dst dstofs len =
1367
if len <= cutoff then isortto srcofs dst dstofs len else begin
1369
let l2 = len - l1 in
1370
sortto (srcofs + l1) dst (dstofs + l1) l2;
1371
sortto srcofs a (srcofs + l2) l1;
1372
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
1375
let l = Array.length a in
1376
if l <= cutoff then isortto 0 a 0 l else begin
1379
let t = Array.make l2 a.(0) in
1382
merge l2 l1 t 0 l2 a 0;
1387
let amerge_1e cmp a =
1388
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1389
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
1390
let rec loop i1 s1 i2 s2 d =
1391
if cmp s1 s2 <= 0 then begin
1395
loop i1 a.(i1) i2 s2 (d + 1)
1397
Array.blit src2 i2 dst (d + 1) (src2r - i2)
1402
loop i1 s1 i2 src2.(i2) (d + 1)
1404
Array.blit a i1 dst (d + 1) (src1r - i1)
1406
in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
1408
let isortto srcofs dst dstofs len =
1409
for i = 0 to len - 1 do
1410
let e = a.(srcofs + i) in
1411
let j = ref (dstofs + i - 1) in
1412
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1413
dst.(!j + 1) <- dst.(!j);
1419
let rec sortto srcofs dst dstofs len =
1420
if len <= cutoff then isortto srcofs dst dstofs len else begin
1422
let l2 = len - l1 in
1423
sortto (srcofs + l1) dst (dstofs + l1) l2;
1424
sortto srcofs a (srcofs + l2) l1;
1425
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
1428
let l = Array.length a in
1429
if l <= cutoff then isortto 0 a 0 l else begin
1432
let t = Array.make l2 a.(0) in
1435
merge l2 l1 t 0 l2 a 0;
1440
let amerge_1f cmp a =
1441
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1442
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
1443
let rec loop i1 s1 i2 s2 d =
1444
if cmp s1 s2 <= 0 then begin
1448
loop i1 a.(i1) i2 s2 (d + 1)
1450
Array.blit src2 i2 dst (d + 1) (src2r - i2)
1455
loop i1 s1 i2 src2.(i2) (d + 1)
1457
Array.blit a i1 dst (d + 1) (src1r - i1)
1459
in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
1461
let isortto srcofs dst dstofs len =
1462
for i = 0 to len - 1 do
1463
let e = a.(srcofs + i) in
1464
let j = ref (dstofs + i - 1) in
1465
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1466
dst.(!j + 1) <- dst.(!j);
1472
let rec sortto srcofs dst dstofs len =
1473
if len <= cutoff then isortto srcofs dst dstofs len else begin
1475
let l2 = len - l1 in
1476
sortto (srcofs + l1) dst (dstofs + l1) l2;
1477
sortto srcofs a (srcofs + l2) l1;
1478
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
1481
let l = Array.length a in
1482
if l <= cutoff then isortto 0 a 0 l else begin
1485
let t = Array.make l2 a.(0) in
1488
merge l2 l1 t 0 l2 a 0;
1493
let amerge_1g cmp a =
1494
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1495
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
1496
let rec loop i1 s1 i2 s2 d =
1497
if cmp s1 s2 <= 0 then begin
1501
loop i1 a.(i1) i2 s2 (d + 1)
1503
Array.blit src2 i2 dst (d + 1) (src2r - i2)
1508
loop i1 s1 i2 src2.(i2) (d + 1)
1510
Array.blit a i1 dst (d + 1) (src1r - i1)
1512
in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
1514
let isortto srcofs dst dstofs len =
1515
for i = 0 to len - 1 do
1516
let e = a.(srcofs + i) in
1517
let j = ref (dstofs + i - 1) in
1518
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1519
dst.(!j + 1) <- dst.(!j);
1525
let rec sortto srcofs dst dstofs len =
1526
if len <= cutoff then isortto srcofs dst dstofs len else begin
1528
let l2 = len - l1 in
1529
sortto (srcofs + l1) dst (dstofs + l1) l2;
1530
sortto srcofs a (srcofs + l2) l1;
1531
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
1534
let l = Array.length a in
1535
if l <= cutoff then isortto 0 a 0 l else begin
1538
let t = Array.make l2 a.(0) in
1541
merge l2 l1 t 0 l2 a 0;
1546
let amerge_1h cmp a =
1547
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1548
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
1549
let rec loop i1 s1 i2 s2 d =
1550
if cmp s1 s2 <= 0 then begin
1554
loop i1 a.(i1) i2 s2 (d + 1)
1556
Array.blit src2 i2 dst (d + 1) (src2r - i2)
1561
loop i1 s1 i2 src2.(i2) (d + 1)
1563
Array.blit a i1 dst (d + 1) (src1r - i1)
1565
in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
1567
let isortto srcofs dst dstofs len =
1568
for i = 0 to len - 1 do
1569
let e = a.(srcofs + i) in
1570
let j = ref (dstofs + i - 1) in
1571
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1572
dst.(!j + 1) <- dst.(!j);
1578
let rec sortto srcofs dst dstofs len =
1579
if len <= cutoff then isortto srcofs dst dstofs len else begin
1581
let l2 = len - l1 in
1582
sortto (srcofs + l1) dst (dstofs + l1) l2;
1583
sortto srcofs a (srcofs + l2) l1;
1584
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
1587
let l = Array.length a in
1588
if l <= cutoff then isortto 0 a 0 l else begin
1591
let t = Array.make l2 a.(0) in
1594
merge l2 l1 t 0 l2 a 0;
1599
let amerge_1i cmp a =
1600
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1601
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
1602
let rec loop i1 s1 i2 s2 d =
1603
if cmp s1 s2 <= 0 then begin
1607
loop i1 a.(i1) i2 s2 (d + 1)
1609
Array.blit src2 i2 dst (d + 1) (src2r - i2)
1614
loop i1 s1 i2 src2.(i2) (d + 1)
1616
Array.blit a i1 dst (d + 1) (src1r - i1)
1618
in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
1620
let isortto srcofs dst dstofs len =
1621
for i = 0 to len - 1 do
1622
let e = a.(srcofs + i) in
1623
let j = ref (dstofs + i - 1) in
1624
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1625
dst.(!j + 1) <- dst.(!j);
1631
let rec sortto srcofs dst dstofs len =
1632
if len <= cutoff then isortto srcofs dst dstofs len else begin
1634
let l2 = len - l1 in
1635
sortto (srcofs + l1) dst (dstofs + l1) l2;
1636
sortto srcofs a (srcofs + l2) l1;
1637
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
1640
let l = Array.length a in
1641
if l <= cutoff then isortto 0 a 0 l else begin
1644
let t = Array.make l2 a.(0) in
1647
merge l2 l1 t 0 l2 a 0;
1652
let amerge_1j cmp a =
1653
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1654
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
1655
let rec loop i1 s1 i2 s2 d =
1656
if cmp s1 s2 <= 0 then begin
1660
loop i1 a.(i1) i2 s2 (d + 1)
1662
Array.blit src2 i2 dst (d + 1) (src2r - i2)
1667
loop i1 s1 i2 src2.(i2) (d + 1)
1669
Array.blit a i1 dst (d + 1) (src1r - i1)
1671
in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
1673
let isortto srcofs dst dstofs len =
1674
for i = 0 to len - 1 do
1675
let e = a.(srcofs + i) in
1676
let j = ref (dstofs + i - 1) in
1677
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1678
dst.(!j + 1) <- dst.(!j);
1684
let rec sortto srcofs dst dstofs len =
1685
if len <= cutoff then isortto srcofs dst dstofs len else begin
1687
let l2 = len - l1 in
1688
sortto (srcofs + l1) dst (dstofs + l1) l2;
1689
sortto srcofs a (srcofs + l2) l1;
1690
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
1693
let l = Array.length a in
1694
if l <= cutoff then isortto 0 a 0 l else begin
1697
let t = Array.make l2 a.(0) in
1700
merge l2 l1 t 0 l2 a 0;
1704
(* FIXME a essayer: *)
1705
(* list->array->list direct et array->list->array direct *)
1706
(* overhead = 1/3, 1/4, etc. *)
1707
(* overhead = sqrt (n) *)
1708
(* overhead = n/3 jusqu'a 30k, 30k jusqu'a 900M, sqrt (n) au-dela *)
1710
(************************************************************************)
1711
(* merge sort on arrays, merge with loop *)
1714
let amerge_3a cmp a =
1715
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1716
let i1 = ref src1ofs
1717
and i2 = ref src2ofs
1719
and src1r = src1ofs + src1len
1720
and src2r = src2ofs + src2len
1722
while !i1 < src1r && !i2 < src2r do
1723
let s1 = a.(!i1) and s2 = src2.(!i2) in
1724
if cmp s1 s2 <= 0 then begin
1734
Array.blit a !i1 dst !d (src1r - !i1)
1736
Array.blit src2 !i2 dst !d (src2r - !i2)
1738
let rec sortto srcofs dst dstofs len =
1740
if len = 1 then dst.(dstofs) <- a.(srcofs) else
1742
let l2 = len - l1 in
1743
sortto (srcofs+l1) dst (dstofs+l1) l2;
1744
sortto srcofs a (srcofs+l2) l1;
1745
merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
1747
let l = Array.length a in
1748
if l <= 1 then () else begin
1751
let t = Array.make l2 a.(0) in
1754
merge l2 l1 t 0 l2 a 0;
1758
let amerge_3b cmp a =
1759
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1760
let i1 = ref src1ofs
1761
and i2 = ref src2ofs
1763
and src1r = src1ofs + src1len
1764
and src2r = src2ofs + src2len
1766
while !i1 < src1r && !i2 < src2r do
1767
let s1 = a.(!i1) and s2 = src2.(!i2) in
1768
if cmp s1 s2 <= 0 then begin
1778
Array.blit a !i1 dst !d (src1r - !i1)
1780
Array.blit src2 !i2 dst !d (src2r - !i2)
1782
let rec sortto srcofs dst dstofs len =
1784
if len = 1 then dst.(dstofs) <- a.(srcofs)
1785
else if len = 2 then begin
1786
if cmp a.(srcofs) a.(srcofs+1) <= 0 then begin
1787
dst.(dstofs) <- a.(srcofs);
1788
dst.(dstofs+1) <- a.(srcofs+1);
1790
dst.(dstofs) <- a.(srcofs+1);
1791
dst.(dstofs+1) <- a.(srcofs);
1795
let l2 = len - l1 in
1796
sortto (srcofs+l1) dst (dstofs+l1) l2;
1797
sortto srcofs a (srcofs+l2) l1;
1798
merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
1801
let l = Array.length a in
1803
else if l = 2 then begin
1804
if cmp a.(0) a.(1) > 0 then begin
1812
let t = Array.make l2 a.(0) in
1815
merge l2 l1 t 0 l2 a 0;
1820
let amerge_3c cmp a =
1821
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1822
let i1 = ref src1ofs
1823
and i2 = ref src2ofs
1825
and src1r = src1ofs + src1len
1826
and src2r = src2ofs + src2len
1828
while !i1 < src1r && !i2 < src2r do
1829
let s1 = a.(!i1) and s2 = src2.(!i2) in
1830
if cmp s1 s2 <= 0 then begin
1840
Array.blit a !i1 dst !d (src1r - !i1)
1842
Array.blit src2 !i2 dst !d (src2r - !i2)
1844
let isortto srcofs dst dstofs len =
1845
for i = 0 to len-1 do
1846
let e = a.(srcofs+i) in
1847
let j = ref (dstofs+i-1) in
1848
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1849
dst.(!j + 1) <- dst.(!j);
1855
let rec sortto srcofs dst dstofs len =
1856
if len <= cutoff then isortto srcofs dst dstofs len else
1858
let l2 = len - l1 in
1859
sortto (srcofs+l1) dst (dstofs+l1) l2;
1860
sortto srcofs a (srcofs+l2) l1;
1861
merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
1863
let l = Array.length a in
1864
if l <= cutoff then isortto 0 a 0 l else begin
1867
let t = Array.make l2 a.(0) in
1870
merge l2 l1 t 0 l2 a 0;
1875
let amerge_3d cmp a =
1876
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1877
let i1 = ref src1ofs
1878
and i2 = ref src2ofs
1880
and src1r = src1ofs + src1len
1881
and src2r = src2ofs + src2len
1883
while !i1 < src1r && !i2 < src2r do
1884
let s1 = a.(!i1) and s2 = src2.(!i2) in
1885
if cmp s1 s2 <= 0 then begin
1895
Array.blit a !i1 dst !d (src1r - !i1)
1897
Array.blit src2 !i2 dst !d (src2r - !i2)
1899
let isortto srcofs dst dstofs len =
1900
for i = 0 to len-1 do
1901
let e = a.(srcofs+i) in
1902
let j = ref (dstofs+i-1) in
1903
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1904
dst.(!j + 1) <- dst.(!j);
1910
let rec sortto srcofs dst dstofs len =
1911
if len <= cutoff then isortto srcofs dst dstofs len else
1913
let l2 = len - l1 in
1914
sortto (srcofs+l1) dst (dstofs+l1) l2;
1915
sortto srcofs a (srcofs+l2) l1;
1916
merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
1918
let l = Array.length a in
1919
if l <= cutoff then isortto 0 a 0 l else begin
1922
let t = Array.make l2 a.(0) in
1925
merge l2 l1 t 0 l2 a 0;
1930
let amerge_3e cmp a =
1931
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1932
let i1 = ref src1ofs
1933
and i2 = ref src2ofs
1935
and src1r = src1ofs + src1len
1936
and src2r = src2ofs + src2len
1938
while !i1 < src1r && !i2 < src2r do
1939
let s1 = a.(!i1) and s2 = src2.(!i2) in
1940
if cmp s1 s2 <= 0 then begin
1950
Array.blit a !i1 dst !d (src1r - !i1)
1952
Array.blit src2 !i2 dst !d (src2r - !i2)
1954
let isortto srcofs dst dstofs len =
1955
for i = 0 to len-1 do
1956
let e = a.(srcofs+i) in
1957
let j = ref (dstofs+i-1) in
1958
while (!j >= dstofs && cmp dst.(!j) e > 0) do
1959
dst.(!j + 1) <- dst.(!j);
1965
let rec sortto srcofs dst dstofs len =
1966
if len <= cutoff then isortto srcofs dst dstofs len else
1968
let l2 = len - l1 in
1969
sortto (srcofs+l1) dst (dstofs+l1) l2;
1970
sortto srcofs a (srcofs+l2) l1;
1971
merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
1973
let l = Array.length a in
1974
if l <= cutoff then isortto 0 a 0 l else begin
1977
let t = Array.make l2 a.(0) in
1980
merge l2 l1 t 0 l2 a 0;
1985
let amerge_3f cmp a =
1986
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
1987
let i1 = ref src1ofs
1988
and i2 = ref src2ofs
1990
and src1r = src1ofs + src1len
1991
and src2r = src2ofs + src2len
1993
while !i1 < src1r && !i2 < src2r do
1994
let s1 = a.(!i1) and s2 = src2.(!i2) in
1995
if cmp s1 s2 <= 0 then begin
2005
Array.blit a !i1 dst !d (src1r - !i1)
2007
Array.blit src2 !i2 dst !d (src2r - !i2)
2009
let isortto srcofs dst dstofs len =
2010
for i = 0 to len-1 do
2011
let e = a.(srcofs+i) in
2012
let j = ref (dstofs+i-1) in
2013
while (!j >= dstofs && cmp dst.(!j) e > 0) do
2014
dst.(!j + 1) <- dst.(!j);
2020
let rec sortto srcofs dst dstofs len =
2021
if len <= cutoff then isortto srcofs dst dstofs len else
2023
let l2 = len - l1 in
2024
sortto (srcofs+l1) dst (dstofs+l1) l2;
2025
sortto srcofs a (srcofs+l2) l1;
2026
merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
2028
let l = Array.length a in
2029
if l <= cutoff then isortto 0 a 0 l else begin
2032
let t = Array.make l2 a.(0) in
2035
merge l2 l1 t 0 l2 a 0;
2040
let amerge_3g cmp a =
2041
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
2042
let i1 = ref src1ofs
2043
and i2 = ref src2ofs
2045
and src1r = src1ofs + src1len
2046
and src2r = src2ofs + src2len
2048
while !i1 < src1r && !i2 < src2r do
2049
let s1 = a.(!i1) and s2 = src2.(!i2) in
2050
if cmp s1 s2 <= 0 then begin
2060
Array.blit a !i1 dst !d (src1r - !i1)
2062
Array.blit src2 !i2 dst !d (src2r - !i2)
2064
let isortto srcofs dst dstofs len =
2065
for i = 0 to len-1 do
2066
let e = a.(srcofs+i) in
2067
let j = ref (dstofs+i-1) in
2068
while (!j >= dstofs && cmp dst.(!j) e > 0) do
2069
dst.(!j + 1) <- dst.(!j);
2075
let rec sortto srcofs dst dstofs len =
2076
if len <= cutoff then isortto srcofs dst dstofs len else
2078
let l2 = len - l1 in
2079
sortto (srcofs+l1) dst (dstofs+l1) l2;
2080
sortto srcofs a (srcofs+l2) l1;
2081
merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
2083
let l = Array.length a in
2084
if l <= cutoff then isortto 0 a 0 l else begin
2087
let t = Array.make l2 a.(0) in
2090
merge l2 l1 t 0 l2 a 0;
2095
let amerge_3h cmp a =
2096
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
2097
let i1 = ref src1ofs
2098
and i2 = ref src2ofs
2100
and src1r = src1ofs + src1len
2101
and src2r = src2ofs + src2len
2103
while !i1 < src1r && !i2 < src2r do
2104
let s1 = a.(!i1) and s2 = src2.(!i2) in
2105
if cmp s1 s2 <= 0 then begin
2115
Array.blit a !i1 dst !d (src1r - !i1)
2117
Array.blit src2 !i2 dst !d (src2r - !i2)
2119
let isortto srcofs dst dstofs len =
2120
for i = 0 to len-1 do
2121
let e = a.(srcofs+i) in
2122
let j = ref (dstofs+i-1) in
2123
while (!j >= dstofs && cmp dst.(!j) e > 0) do
2124
dst.(!j + 1) <- dst.(!j);
2130
let rec sortto srcofs dst dstofs len =
2131
if len <= cutoff then isortto srcofs dst dstofs len else
2133
let l2 = len - l1 in
2134
sortto (srcofs+l1) dst (dstofs+l1) l2;
2135
sortto srcofs a (srcofs+l2) l1;
2136
merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
2138
let l = Array.length a in
2139
if l <= cutoff then isortto 0 a 0 l else begin
2142
let t = Array.make l2 a.(0) in
2145
merge l2 l1 t 0 l2 a 0;
2150
let amerge_3i cmp a =
2151
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
2152
let i1 = ref src1ofs
2153
and i2 = ref src2ofs
2155
and src1r = src1ofs + src1len
2156
and src2r = src2ofs + src2len
2158
while !i1 < src1r && !i2 < src2r do
2159
let s1 = a.(!i1) and s2 = src2.(!i2) in
2160
if cmp s1 s2 <= 0 then begin
2170
Array.blit a !i1 dst !d (src1r - !i1)
2172
Array.blit src2 !i2 dst !d (src2r - !i2)
2174
let isortto srcofs dst dstofs len =
2175
for i = 0 to len-1 do
2176
let e = a.(srcofs+i) in
2177
let j = ref (dstofs+i-1) in
2178
while (!j >= dstofs && cmp dst.(!j) e > 0) do
2179
dst.(!j + 1) <- dst.(!j);
2185
let rec sortto srcofs dst dstofs len =
2186
if len <= cutoff then isortto srcofs dst dstofs len else
2188
let l2 = len - l1 in
2189
sortto (srcofs+l1) dst (dstofs+l1) l2;
2190
sortto srcofs a (srcofs+l2) l1;
2191
merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
2193
let l = Array.length a in
2194
if l <= cutoff then isortto 0 a 0 l else begin
2197
let t = Array.make l2 a.(0) in
2200
merge l2 l1 t 0 l2 a 0;
2205
let amerge_3j cmp a =
2206
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
2207
let i1 = ref src1ofs
2208
and i2 = ref src2ofs
2210
and src1r = src1ofs + src1len
2211
and src2r = src2ofs + src2len
2213
while !i1 < src1r && !i2 < src2r do
2214
let s1 = a.(!i1) and s2 = src2.(!i2) in
2215
if cmp s1 s2 <= 0 then begin
2225
Array.blit a !i1 dst !d (src1r - !i1)
2227
Array.blit src2 !i2 dst !d (src2r - !i2)
2229
let isortto srcofs dst dstofs len =
2230
for i = 0 to len-1 do
2231
let e = a.(srcofs+i) in
2232
let j = ref (dstofs+i-1) in
2233
while (!j >= dstofs && cmp dst.(!j) e > 0) do
2234
dst.(!j + 1) <- dst.(!j);
2240
let rec sortto srcofs dst dstofs len =
2241
if len <= cutoff then isortto srcofs dst dstofs len else
2243
let l2 = len - l1 in
2244
sortto (srcofs+l1) dst (dstofs+l1) l2;
2245
sortto srcofs a (srcofs+l2) l1;
2246
merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
2248
let l = Array.length a in
2249
if l <= cutoff then isortto 0 a 0 l else begin
2252
let t = Array.make l2 a.(0) in
2255
merge l2 l1 t 0 l2 a 0;
2259
(* FIXME essayer bottom-up merge on arrays ? *)
2261
(************************************************************************)
2262
(* Shell sort on arrays *)
2264
let ashell_1 cmp a =
2265
let l = Array.length a in
2267
while !step < l do step := !step * 3 + 1; done;
2270
for j = !step to l-1 do
2272
let k = ref (j - !step) in
2274
while !k >= 0 && cmp a.(!k) e > 0 do
2285
let ashell_2 cmp a =
2286
let l = Array.length a in
2288
while !step < l do step := !step * 3 + 1; done;
2291
for j = !step to l-1 do
2293
let k = ref (j - !step) in
2294
while !k >= 0 && cmp a.(!k) e > 0 do
2295
a.(!k + !step) <- a.(!k);
2298
a.(!k + !step) <- e;
2304
let ashell_3 cmp a =
2305
let l = Array.length a in
2307
while !step < l do step := !step * 3 + 1; done;
2310
for i = 0 to !step - 1 do
2311
let j = ref (i + !step) in
2313
let e = ref a.(!j) in
2314
let k = ref (!j - !step) in
2315
if cmp !e a.(i) < 0 then begin
2316
let x = !e in e := a.(i); a.(i) <- x;
2318
while cmp a.(!k) !e > 0 do
2319
a.(!k + !step) <- a.(!k);
2322
a.(!k + !step) <- !e;
2330
let force = Lazy.force;;
2332
type iilist = Cons of int * iilist Lazy.t;;
2334
let rec mult n (Cons (x,l)) = Cons (n*x, lazy (mult n (force l)))
2336
let rec merge (Cons (x1, t1) as l1) (Cons (x2, t2) as l2) =
2337
if x1 = x2 then Cons (x1, lazy (merge (force t1) (force t2)))
2338
else if x1 < x2 then Cons (x1, lazy (merge (force t1) l2))
2339
else Cons (x2, lazy (merge l1 (force t2)))
2342
let rec scale = Cons (1, lazy (merge (mult 2 scale) (mult 3 scale)));;
2344
let ashell_4 cmp a =
2345
let l = Array.length a in
2346
let rec loop1 accu (Cons (x, t)) =
2347
if x > l then accu else loop1 (x::accu) (force t)
2349
let sc = loop1 [] scale in
2350
let rec loop2 = function
2353
for i = 0 to step - 1 do
2354
let j = ref (i + step) in
2357
let k = ref (!j - step) in
2358
while !k >= 0 && cmp a.(!k) e > 0 do
2359
a.(!k + step) <- a.(!k);
2371
(************************************************************************)
2372
(* Quicksort on arrays *)
2374
let aquick_1a cmp a =
2375
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2376
let m = (l + r) / 2 in
2377
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2378
let pivot = if cmp al am <= 0 then
2379
if cmp am ar <= 0 then am
2380
else if cmp al ar <= 0 then ar
2383
if cmp al ar <= 0 then al
2384
else if cmp am ar <= 0 then ar
2387
let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
2390
let c = cmp e pivot in
2393
end else if c < 0 then begin
2406
let len1 = !p1 - l and len2 = r - !p3 in
2407
if len1 > cutoff then
2408
if len2 > cutoff then begin
2410
then (qsort l !p1; qsort !p3 r)
2411
else (qsort !p3 r; qsort l !p1)
2412
end else qsort l !p1
2413
else if len2 > cutoff then qsort !p3 r;
2415
let l = Array.length a in
2419
for i = 1 to (min l cutoff) - 1 do
2420
if cmp a.(i) a.(!mini) < 0 then mini := i;
2422
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
2423
for i = 1 to l - 1 do
2425
let j = ref (i - 1) in
2426
while cmp a.(!j) e > 0 do
2427
a.(!j + 1) <- a.(!j);
2436
let aquick_1b cmp a =
2437
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2438
let m = (l + r) / 2 in
2439
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2440
let pivot = if cmp al am <= 0 then
2441
if cmp am ar <= 0 then am
2442
else if cmp al ar <= 0 then ar
2445
if cmp al ar <= 0 then al
2446
else if cmp am ar <= 0 then ar
2449
let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
2452
let c = cmp e pivot in
2455
end else if c < 0 then begin
2468
let len1 = !p1 - l and len2 = r - !p3 in
2469
if len1 > cutoff then
2470
if len2 > cutoff then begin
2472
then (qsort l !p1; qsort !p3 r)
2473
else (qsort !p3 r; qsort l !p1)
2474
end else qsort l !p1
2475
else if len2 > cutoff then qsort !p3 r;
2477
let l = Array.length a in
2481
for i = 1 to (min l cutoff) - 1 do
2482
if cmp a.(i) a.(!mini) < 0 then mini := i;
2484
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
2485
for i = 1 to l - 1 do
2487
let j = ref (i - 1) in
2488
while cmp a.(!j) e > 0 do
2489
a.(!j + 1) <- a.(!j);
2498
let aquick_1c cmp a =
2499
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2500
let m = (l + r) / 2 in
2501
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2502
let pivot = if cmp al am <= 0 then
2503
if cmp am ar <= 0 then am
2504
else if cmp al ar <= 0 then ar
2507
if cmp al ar <= 0 then al
2508
else if cmp am ar <= 0 then ar
2511
let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
2514
let c = cmp e pivot in
2517
end else if c < 0 then begin
2530
let len1 = !p1 - l and len2 = r - !p3 in
2531
if len1 > cutoff then
2532
if len2 > cutoff then begin
2534
then (qsort l !p1; qsort !p3 r)
2535
else (qsort !p3 r; qsort l !p1)
2536
end else qsort l !p1
2537
else if len2 > cutoff then qsort !p3 r;
2539
let l = Array.length a in
2543
for i = 1 to (min l cutoff) - 1 do
2544
if cmp a.(i) a.(!mini) < 0 then mini := i;
2546
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
2547
for i = 1 to l - 1 do
2549
let j = ref (i - 1) in
2550
while cmp a.(!j) e > 0 do
2551
a.(!j + 1) <- a.(!j);
2560
let aquick_1d cmp a =
2561
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2562
let m = (l + r) / 2 in
2563
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2564
let pivot = if cmp al am <= 0 then
2565
if cmp am ar <= 0 then am
2566
else if cmp al ar <= 0 then ar
2569
if cmp al ar <= 0 then al
2570
else if cmp am ar <= 0 then ar
2573
let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
2576
let c = cmp e pivot in
2579
end else if c < 0 then begin
2592
let len1 = !p1 - l and len2 = r - !p3 in
2593
if len1 > cutoff then
2594
if len2 > cutoff then begin
2596
then (qsort l !p1; qsort !p3 r)
2597
else (qsort !p3 r; qsort l !p1)
2598
end else qsort l !p1
2599
else if len2 > cutoff then qsort !p3 r;
2601
let l = Array.length a in
2605
for i = 1 to (min l cutoff) - 1 do
2606
if cmp a.(i) a.(!mini) < 0 then mini := i;
2608
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
2609
for i = 1 to l - 1 do
2611
let j = ref (i - 1) in
2612
while cmp a.(!j) e > 0 do
2613
a.(!j + 1) <- a.(!j);
2622
let aquick_1e cmp a =
2623
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2624
let m = (l + r) / 2 in
2625
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2626
let pivot = if cmp al am <= 0 then
2627
if cmp am ar <= 0 then am
2628
else if cmp al ar <= 0 then ar
2631
if cmp al ar <= 0 then al
2632
else if cmp am ar <= 0 then ar
2635
let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
2638
let c = cmp e pivot in
2641
end else if c < 0 then begin
2654
let len1 = !p1 - l and len2 = r - !p3 in
2655
if len1 > cutoff then
2656
if len2 > cutoff then begin
2658
then (qsort l !p1; qsort !p3 r)
2659
else (qsort !p3 r; qsort l !p1)
2660
end else qsort l !p1
2661
else if len2 > cutoff then qsort !p3 r;
2663
let l = Array.length a in
2667
for i = 1 to (min l cutoff) - 1 do
2668
if cmp a.(i) a.(!mini) < 0 then mini := i;
2670
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
2671
for i = 1 to l - 1 do
2673
let j = ref (i - 1) in
2674
while cmp a.(!j) e > 0 do
2675
a.(!j + 1) <- a.(!j);
2684
let aquick_1f cmp a =
2685
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2686
let m = (l + r) / 2 in
2687
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2688
let pivot = if cmp al am <= 0 then
2689
if cmp am ar <= 0 then am
2690
else if cmp al ar <= 0 then ar
2693
if cmp al ar <= 0 then al
2694
else if cmp am ar <= 0 then ar
2697
let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
2700
let c = cmp e pivot in
2703
end else if c < 0 then begin
2716
let len1 = !p1 - l and len2 = r - !p3 in
2717
if len1 > cutoff then
2718
if len2 > cutoff then begin
2720
then (qsort l !p1; qsort !p3 r)
2721
else (qsort !p3 r; qsort l !p1)
2722
end else qsort l !p1
2723
else if len2 > cutoff then qsort !p3 r;
2725
let l = Array.length a in
2729
for i = 1 to (min l cutoff) - 1 do
2730
if cmp a.(i) a.(!mini) < 0 then mini := i;
2732
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
2733
for i = 1 to l - 1 do
2735
let j = ref (i - 1) in
2736
while cmp a.(!j) e > 0 do
2737
a.(!j + 1) <- a.(!j);
2746
let aquick_1g cmp a =
2747
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2748
let m = (l + r) / 2 in
2749
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2750
let pivot = if cmp al am <= 0 then
2751
if cmp am ar <= 0 then am
2752
else if cmp al ar <= 0 then ar
2755
if cmp al ar <= 0 then al
2756
else if cmp am ar <= 0 then ar
2759
let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
2762
let c = cmp e pivot in
2765
end else if c < 0 then begin
2778
let len1 = !p1 - l and len2 = r - !p3 in
2779
if len1 > cutoff then
2780
if len2 > cutoff then begin
2782
then (qsort l !p1; qsort !p3 r)
2783
else (qsort !p3 r; qsort l !p1)
2784
end else qsort l !p1
2785
else if len2 > cutoff then qsort !p3 r;
2787
let l = Array.length a in
2791
for i = 1 to (min l cutoff) - 1 do
2792
if cmp a.(i) a.(!mini) < 0 then mini := i;
2794
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
2795
for i = 1 to l - 1 do
2797
let j = ref (i - 1) in
2798
while cmp a.(!j) e > 0 do
2799
a.(!j + 1) <- a.(!j);
2808
let aquick_2a cmp a =
2809
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2810
let m = (l + r) / 2 in
2811
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2812
let pivot = if cmp al am <= 0 then
2813
if cmp am ar <= 0 then am
2814
else if cmp al ar <= 0 then ar
2817
if cmp al ar <= 0 then al
2818
else if cmp am ar <= 0 then ar
2821
let p1 = ref l and p2 = ref l and p3 = ref r in
2824
let c = cmp e pivot in
2829
end else if c < 0 then begin
2838
let len1 = !p1 - l and len2 = r - !p3 in
2839
if len1 > cutoff then
2840
if len2 > cutoff then begin
2842
then (qsort l !p1; qsort !p3 r)
2843
else (qsort !p3 r; qsort l !p1)
2844
end else qsort l !p1
2845
else if len2 > cutoff then qsort !p3 r;
2847
let l = Array.length a in
2851
for i = 0 to (min l cutoff) - 1 do
2852
if cmp a.(i) a.(!mini) < 0 then mini := i;
2854
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
2855
for i = 1 to l - 1 do
2857
let j = ref (i - 1) in
2858
while cmp a.(!j) e > 0 do
2859
a.(!j + 1) <- a.(!j);
2868
let aquick_2b cmp a =
2869
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2870
let m = (l + r) / 2 in
2871
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2872
let pivot = if cmp al am <= 0 then
2873
if cmp am ar <= 0 then am
2874
else if cmp al ar <= 0 then ar
2877
if cmp al ar <= 0 then al
2878
else if cmp am ar <= 0 then ar
2881
let p1 = ref l and p2 = ref l and p3 = ref r in
2884
let c = cmp e pivot in
2889
end else if c < 0 then begin
2898
let len1 = !p1 - l and len2 = r - !p3 in
2899
if len1 > cutoff then
2900
if len2 > cutoff then begin
2902
then (qsort l !p1; qsort !p3 r)
2903
else (qsort !p3 r; qsort l !p1)
2904
end else qsort l !p1
2905
else if len2 > cutoff then qsort !p3 r;
2907
let l = Array.length a in
2911
for i = 0 to (min l cutoff) - 1 do
2912
if cmp a.(i) a.(!mini) < 0 then mini := i;
2914
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
2915
for i = 1 to l - 1 do
2917
let j = ref (i - 1) in
2918
while cmp a.(!j) e > 0 do
2919
a.(!j + 1) <- a.(!j);
2928
let aquick_2c cmp a =
2929
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2930
let m = (l + r) / 2 in
2931
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2932
let pivot = if cmp al am <= 0 then
2933
if cmp am ar <= 0 then am
2934
else if cmp al ar <= 0 then ar
2937
if cmp al ar <= 0 then al
2938
else if cmp am ar <= 0 then ar
2941
let p1 = ref l and p2 = ref l and p3 = ref r in
2944
let c = cmp e pivot in
2949
end else if c < 0 then begin
2958
let len1 = !p1 - l and len2 = r - !p3 in
2959
if len1 > cutoff then
2960
if len2 > cutoff then begin
2962
then (qsort l !p1; qsort !p3 r)
2963
else (qsort !p3 r; qsort l !p1)
2964
end else qsort l !p1
2965
else if len2 > cutoff then qsort !p3 r;
2967
let l = Array.length a in
2971
for i = 0 to (min l cutoff) - 1 do
2972
if cmp a.(i) a.(!mini) < 0 then mini := i;
2974
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
2975
for i = 1 to l - 1 do
2977
let j = ref (i - 1) in
2978
while cmp a.(!j) e > 0 do
2979
a.(!j + 1) <- a.(!j);
2988
let aquick_2d cmp a =
2989
let rec qsort l r = (* ASSUMES r - l >= 2 *)
2990
let m = (l + r) / 2 in
2991
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
2992
let pivot = if cmp al am <= 0 then
2993
if cmp am ar <= 0 then am
2994
else if cmp al ar <= 0 then ar
2997
if cmp al ar <= 0 then al
2998
else if cmp am ar <= 0 then ar
3001
let p1 = ref l and p2 = ref l and p3 = ref r in
3004
let c = cmp e pivot in
3009
end else if c < 0 then begin
3018
let len1 = !p1 - l and len2 = r - !p3 in
3019
if len1 > cutoff then
3020
if len2 > cutoff then begin
3022
then (qsort l !p1; qsort !p3 r)
3023
else (qsort !p3 r; qsort l !p1)
3024
end else qsort l !p1
3025
else if len2 > cutoff then qsort !p3 r;
3027
let l = Array.length a in
3031
for i = 0 to (min l cutoff) - 1 do
3032
if cmp a.(i) a.(!mini) < 0 then mini := i;
3034
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3035
for i = 1 to l - 1 do
3037
let j = ref (i - 1) in
3038
while cmp a.(!j) e > 0 do
3039
a.(!j + 1) <- a.(!j);
3048
let aquick_2e cmp a =
3049
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3050
let m = (l + r) / 2 in
3051
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3052
let pivot = if cmp al am <= 0 then
3053
if cmp am ar <= 0 then am
3054
else if cmp al ar <= 0 then ar
3057
if cmp al ar <= 0 then al
3058
else if cmp am ar <= 0 then ar
3061
let p1 = ref l and p2 = ref l and p3 = ref r in
3064
let c = cmp e pivot in
3069
end else if c < 0 then begin
3078
let len1 = !p1 - l and len2 = r - !p3 in
3079
if len1 > cutoff then
3080
if len2 > cutoff then begin
3082
then (qsort l !p1; qsort !p3 r)
3083
else (qsort !p3 r; qsort l !p1)
3084
end else qsort l !p1
3085
else if len2 > cutoff then qsort !p3 r;
3087
let l = Array.length a in
3091
for i = 0 to (min l cutoff) - 1 do
3092
if cmp a.(i) a.(!mini) < 0 then mini := i;
3094
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3095
for i = 1 to l - 1 do
3097
let j = ref (i - 1) in
3098
while cmp a.(!j) e > 0 do
3099
a.(!j + 1) <- a.(!j);
3108
let aquick_2f cmp a =
3109
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3110
let m = (l + r) / 2 in
3111
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3112
let pivot = if cmp al am <= 0 then
3113
if cmp am ar <= 0 then am
3114
else if cmp al ar <= 0 then ar
3117
if cmp al ar <= 0 then al
3118
else if cmp am ar <= 0 then ar
3121
let p1 = ref l and p2 = ref l and p3 = ref r in
3124
let c = cmp e pivot in
3129
end else if c < 0 then begin
3138
let len1 = !p1 - l and len2 = r - !p3 in
3139
if len1 > cutoff then
3140
if len2 > cutoff then begin
3142
then (qsort l !p1; qsort !p3 r)
3143
else (qsort !p3 r; qsort l !p1)
3144
end else qsort l !p1
3145
else if len2 > cutoff then qsort !p3 r;
3147
let l = Array.length a in
3151
for i = 0 to (min l cutoff) - 1 do
3152
if cmp a.(i) a.(!mini) < 0 then mini := i;
3154
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3155
for i = 1 to l - 1 do
3157
let j = ref (i - 1) in
3158
while cmp a.(!j) e > 0 do
3159
a.(!j + 1) <- a.(!j);
3168
let aquick_2g cmp a =
3169
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3170
let m = (l + r) / 2 in
3171
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3172
let pivot = if cmp al am <= 0 then
3173
if cmp am ar <= 0 then am
3174
else if cmp al ar <= 0 then ar
3177
if cmp al ar <= 0 then al
3178
else if cmp am ar <= 0 then ar
3181
let p1 = ref l and p2 = ref l and p3 = ref r in
3184
let c = cmp e pivot in
3189
end else if c < 0 then begin
3198
let len1 = !p1 - l and len2 = r - !p3 in
3199
if len1 > cutoff then
3200
if len2 > cutoff then begin
3202
then (qsort l !p1; qsort !p3 r)
3203
else (qsort !p3 r; qsort l !p1)
3204
end else qsort l !p1
3205
else if len2 > cutoff then qsort !p3 r;
3207
let l = Array.length a in
3211
for i = 0 to (min l cutoff) - 1 do
3212
if cmp a.(i) a.(!mini) < 0 then mini := i;
3214
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3215
for i = 1 to l - 1 do
3217
let j = ref (i - 1) in
3218
while cmp a.(!j) e > 0 do
3219
a.(!j + 1) <- a.(!j);
3228
let aquick_3a cmp a =
3229
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3230
let m = (l + r) / 2 in
3231
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3232
let pivot = if cmp al am <= 0 then
3233
if cmp am ar <= 0 then am
3234
else if cmp al ar <= 0 then ar
3237
if cmp al ar <= 0 then al
3238
else if cmp am ar <= 0 then ar
3241
let p1 = ref l and p2 = ref l and p3 = ref r in
3244
let c = cmp e pivot in
3249
end else if c < 0 then begin
3261
let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
3263
let len1 = !p2 - l and len2 = r - !p3 in
3264
if len1 > cutoff then
3265
if len2 > cutoff then begin
3267
then (qsort l !p2; qsort !p3 r)
3268
else (qsort !p3 r; qsort l !p2)
3269
end else qsort l !p2
3270
else if len2 > cutoff then qsort !p3 r;
3272
let l = Array.length a in
3276
for i = 0 to (min l cutoff) - 1 do
3277
if cmp a.(i) a.(!mini) < 0 then mini := i;
3279
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3280
for i = 1 to l - 1 do
3282
let j = ref (i - 1) in
3283
while cmp a.(!j) e > 0 do
3284
a.(!j + 1) <- a.(!j);
3293
let aquick_3b cmp a =
3294
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3295
let m = (l + r) / 2 in
3296
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3297
let pivot = if cmp al am <= 0 then
3298
if cmp am ar <= 0 then am
3299
else if cmp al ar <= 0 then ar
3302
if cmp al ar <= 0 then al
3303
else if cmp am ar <= 0 then ar
3306
let p1 = ref l and p2 = ref l and p3 = ref r in
3309
let c = cmp e pivot in
3314
end else if c < 0 then begin
3326
let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
3328
let len1 = !p2 - l and len2 = r - !p3 in
3329
if len1 > cutoff then
3330
if len2 > cutoff then begin
3332
then (qsort l !p2; qsort !p3 r)
3333
else (qsort !p3 r; qsort l !p2)
3334
end else qsort l !p2
3335
else if len2 > cutoff then qsort !p3 r;
3337
let l = Array.length a in
3341
for i = 0 to (min l cutoff) - 1 do
3342
if cmp a.(i) a.(!mini) < 0 then mini := i;
3344
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3345
for i = 1 to l - 1 do
3347
let j = ref (i - 1) in
3348
while cmp a.(!j) e > 0 do
3349
a.(!j + 1) <- a.(!j);
3358
let aquick_3c cmp a =
3359
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3360
let m = (l + r) / 2 in
3361
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3362
let pivot = if cmp al am <= 0 then
3363
if cmp am ar <= 0 then am
3364
else if cmp al ar <= 0 then ar
3367
if cmp al ar <= 0 then al
3368
else if cmp am ar <= 0 then ar
3371
let p1 = ref l and p2 = ref l and p3 = ref r in
3374
let c = cmp e pivot in
3379
end else if c < 0 then begin
3391
let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
3393
let len1 = !p2 - l and len2 = r - !p3 in
3394
if len1 > cutoff then
3395
if len2 > cutoff then begin
3397
then (qsort l !p2; qsort !p3 r)
3398
else (qsort !p3 r; qsort l !p2)
3399
end else qsort l !p2
3400
else if len2 > cutoff then qsort !p3 r;
3402
let l = Array.length a in
3406
for i = 0 to (min l cutoff) - 1 do
3407
if cmp a.(i) a.(!mini) < 0 then mini := i;
3409
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3410
for i = 1 to l - 1 do
3412
let j = ref (i - 1) in
3413
while cmp a.(!j) e > 0 do
3414
a.(!j + 1) <- a.(!j);
3423
let aquick_3d cmp a =
3424
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3425
let m = (l + r) / 2 in
3426
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3427
let pivot = if cmp al am <= 0 then
3428
if cmp am ar <= 0 then am
3429
else if cmp al ar <= 0 then ar
3432
if cmp al ar <= 0 then al
3433
else if cmp am ar <= 0 then ar
3436
let p1 = ref l and p2 = ref l and p3 = ref r in
3439
let c = cmp e pivot in
3444
end else if c < 0 then begin
3456
let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
3458
let len1 = !p2 - l and len2 = r - !p3 in
3459
if len1 > cutoff then
3460
if len2 > cutoff then begin
3462
then (qsort l !p2; qsort !p3 r)
3463
else (qsort !p3 r; qsort l !p2)
3464
end else qsort l !p2
3465
else if len2 > cutoff then qsort !p3 r;
3467
let l = Array.length a in
3471
for i = 0 to (min l cutoff) - 1 do
3472
if cmp a.(i) a.(!mini) < 0 then mini := i;
3474
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3475
for i = 1 to l - 1 do
3477
let j = ref (i - 1) in
3478
while cmp a.(!j) e > 0 do
3479
a.(!j + 1) <- a.(!j);
3488
let aquick_3e cmp a =
3489
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3490
let m = (l + r) / 2 in
3491
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3492
let pivot = if cmp al am <= 0 then
3493
if cmp am ar <= 0 then am
3494
else if cmp al ar <= 0 then ar
3497
if cmp al ar <= 0 then al
3498
else if cmp am ar <= 0 then ar
3501
let p1 = ref l and p2 = ref l and p3 = ref r in
3504
let c = cmp e pivot in
3509
end else if c < 0 then begin
3521
let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
3523
let len1 = !p2 - l and len2 = r - !p3 in
3524
if len1 > cutoff then
3525
if len2 > cutoff then begin
3527
then (qsort l !p2; qsort !p3 r)
3528
else (qsort !p3 r; qsort l !p2)
3529
end else qsort l !p2
3530
else if len2 > cutoff then qsort !p3 r;
3532
let l = Array.length a in
3536
for i = 0 to (min l cutoff) - 1 do
3537
if cmp a.(i) a.(!mini) < 0 then mini := i;
3539
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3540
for i = 1 to l - 1 do
3542
let j = ref (i - 1) in
3543
while cmp a.(!j) e > 0 do
3544
a.(!j + 1) <- a.(!j);
3553
let aquick_3f cmp a =
3554
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3555
let m = (l + r) / 2 in
3556
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3557
let pivot = if cmp al am <= 0 then
3558
if cmp am ar <= 0 then am
3559
else if cmp al ar <= 0 then ar
3562
if cmp al ar <= 0 then al
3563
else if cmp am ar <= 0 then ar
3566
let p1 = ref l and p2 = ref l and p3 = ref r in
3569
let c = cmp e pivot in
3574
end else if c < 0 then begin
3586
let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
3588
let len1 = !p2 - l and len2 = r - !p3 in
3589
if len1 > cutoff then
3590
if len2 > cutoff then begin
3592
then (qsort l !p2; qsort !p3 r)
3593
else (qsort !p3 r; qsort l !p2)
3594
end else qsort l !p2
3595
else if len2 > cutoff then qsort !p3 r;
3597
let l = Array.length a in
3601
for i = 0 to (min l cutoff) - 1 do
3602
if cmp a.(i) a.(!mini) < 0 then mini := i;
3604
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3605
for i = 1 to l - 1 do
3607
let j = ref (i - 1) in
3608
while cmp a.(!j) e > 0 do
3609
a.(!j + 1) <- a.(!j);
3618
let aquick_3g cmp a =
3619
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3620
let m = (l + r) / 2 in
3621
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3622
let pivot = if cmp al am <= 0 then
3623
if cmp am ar <= 0 then am
3624
else if cmp al ar <= 0 then ar
3627
if cmp al ar <= 0 then al
3628
else if cmp am ar <= 0 then ar
3631
let p1 = ref l and p2 = ref l and p3 = ref r in
3634
let c = cmp e pivot in
3639
end else if c < 0 then begin
3651
let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
3653
let len1 = !p2 - l and len2 = r - !p3 in
3654
if len1 > cutoff then
3655
if len2 > cutoff then begin
3657
then (qsort l !p2; qsort !p3 r)
3658
else (qsort !p3 r; qsort l !p2)
3659
end else qsort l !p2
3660
else if len2 > cutoff then qsort !p3 r;
3662
let l = Array.length a in
3666
for i = 0 to (min l cutoff) - 1 do
3667
if cmp a.(i) a.(!mini) < 0 then mini := i;
3669
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3670
for i = 1 to l - 1 do
3672
let j = ref (i - 1) in
3673
while cmp a.(!j) e > 0 do
3674
a.(!j + 1) <- a.(!j);
3683
let aquick_3h cmp a =
3684
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3685
let m = (l + r) / 2 in
3686
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3687
let pivot = if cmp al am <= 0 then
3688
if cmp am ar <= 0 then am
3689
else if cmp al ar <= 0 then ar
3692
if cmp al ar <= 0 then al
3693
else if cmp am ar <= 0 then ar
3696
let p1 = ref l and p2 = ref l and p3 = ref r in
3699
let c = cmp e pivot in
3704
end else if c < 0 then begin
3716
let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
3718
let len1 = !p2 - l and len2 = r - !p3 in
3719
if len1 > cutoff then
3720
if len2 > cutoff then begin
3722
then (qsort l !p2; qsort !p3 r)
3723
else (qsort !p3 r; qsort l !p2)
3724
end else qsort l !p2
3725
else if len2 > cutoff then qsort !p3 r;
3727
let l = Array.length a in
3731
for i = 0 to (min l cutoff) - 1 do
3732
if cmp a.(i) a.(!mini) < 0 then mini := i;
3734
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3735
for i = 1 to l - 1 do
3737
let j = ref (i - 1) in
3738
while cmp a.(!j) e > 0 do
3739
a.(!j + 1) <- a.(!j);
3748
let aquick_3i cmp a =
3749
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3750
let m = (l + r) / 2 in
3751
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3752
let pivot = if cmp al am <= 0 then
3753
if cmp am ar <= 0 then am
3754
else if cmp al ar <= 0 then ar
3757
if cmp al ar <= 0 then al
3758
else if cmp am ar <= 0 then ar
3761
let p1 = ref l and p2 = ref l and p3 = ref r in
3764
let c = cmp e pivot in
3769
end else if c < 0 then begin
3781
let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
3783
let len1 = !p2 - l and len2 = r - !p3 in
3784
if len1 > cutoff then
3785
if len2 > cutoff then begin
3787
then (qsort l !p2; qsort !p3 r)
3788
else (qsort !p3 r; qsort l !p2)
3789
end else qsort l !p2
3790
else if len2 > cutoff then qsort !p3 r;
3792
let l = Array.length a in
3796
for i = 0 to (min l cutoff) - 1 do
3797
if cmp a.(i) a.(!mini) < 0 then mini := i;
3799
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3800
for i = 1 to l - 1 do
3802
let j = ref (i - 1) in
3803
while cmp a.(!j) e > 0 do
3804
a.(!j + 1) <- a.(!j);
3813
let aquick_3j cmp a =
3814
let rec qsort l r = (* ASSUMES r - l >= 2 *)
3815
let m = (l + r) / 2 in
3816
let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
3817
let pivot = if cmp al am <= 0 then
3818
if cmp am ar <= 0 then am
3819
else if cmp al ar <= 0 then ar
3822
if cmp al ar <= 0 then al
3823
else if cmp am ar <= 0 then ar
3826
let p1 = ref l and p2 = ref l and p3 = ref r in
3829
let c = cmp e pivot in
3834
end else if c < 0 then begin
3846
let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
3848
let len1 = !p2 - l and len2 = r - !p3 in
3849
if len1 > cutoff then
3850
if len2 > cutoff then begin
3852
then (qsort l !p2; qsort !p3 r)
3853
else (qsort !p3 r; qsort l !p2)
3854
end else qsort l !p2
3855
else if len2 > cutoff then qsort !p3 r;
3857
let l = Array.length a in
3861
for i = 0 to (min l cutoff) - 1 do
3862
if cmp a.(i) a.(!mini) < 0 then mini := i;
3864
let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
3865
for i = 1 to l - 1 do
3867
let j = ref (i - 1) in
3868
while cmp a.(!j) e > 0 do
3869
a.(!j + 1) <- a.(!j);
3877
(************************************************************************)
3878
(* Heap sort on arrays (top-down, ternary) *)
3881
let l = ref (Array.length a) in
3882
let l3 = ref ((!l + 1) / 3) in (* l3 is the first element without sons *)
3883
let maxson i = (* ASSUMES i < !l3 *)
3884
let i31 = i+i+i+1 in
3886
if i31+2 < !l then begin
3887
if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
3888
if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
3891
if i31+1 < !l && cmp a.(i31) a.(i31+1) < 0
3896
let rec trickledown i e = (* ASSUMES i < !l3 *)
3898
if cmp a.(j) e > 0 then begin
3900
if j < !l3 then trickledown j e else a.(j) <- e;
3905
for i = !l3 - 1 downto 0 do trickledown i a.(i); done;
3906
let m = ref (!l + 1 - 3 * !l3) in
3909
if !m = 0 then (m := 2; decr l3) else decr m;
3914
if !l > 1 then begin let e = a.(1) in a.(1) <- a.(0); a.(0) <- e; end;
3917
(************************************************************************)
3918
(* Heap sort on arrays (top-down, binary) *)
3920
(* FIXME essayer application partielle de trickledown (merge avec down) *)
3921
(* FIXME essayer expanser maxson dans trickledown; supprimer l'exception. *)
3925
let i21 = i + i + 1 in
3926
if i21 + 1 < l && cmp a.(i21) a.(i21+1) < 0
3928
else if i21 < l then i21 else (a.(i) <- e; raise Exit)
3930
let rec trickledown l i e =
3931
let j = maxson l i e in
3932
if cmp a.(j) e > 0 then begin
3939
let down l i e = try trickledown l i e with Exit -> () in
3940
let l = Array.length a in
3941
for i = l / 2 -1 downto 0 do down l i a.(i); done;
3942
for i = l - 1 downto 1 do
3949
(************************************************************************)
3950
(* Heap sort on arrays (bottom-up, ternary) *)
3952
exception Bottom of int;;
3956
let i31 = i+i+i+1 in
3958
if i31+2 < l then begin
3959
if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
3960
if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
3963
if i31+1 < l && cmp a.(i31) a.(i31+1) < 0
3965
else if i31 < l then i31 else raise (Bottom i)
3967
let rec trickledown l i e =
3968
let j = maxson l i in
3969
if cmp a.(j) e > 0 then begin
3976
let rec trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in
3977
let rec bubbledown l i =
3978
let j = maxson l i in
3982
let bubble l i = try bubbledown l i with Bottom i -> i in
3983
let rec trickleup i e =
3984
let father = (i - 1) / 3 in
3985
assert (i <> father);
3986
if cmp a.(father) e < 0 then begin
3987
a.(i) <- a.(father);
3988
if father > 0 then trickleup father e else a.(0) <- e;
3993
let l = Array.length a in
3994
for i = (l + 1) / 3 - 1 downto 0 do trickle l i a.(i); done;
3995
for i = l - 1 downto 2 do
3998
trickleup (bubble i 0) e;
4000
if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
4003
(************************************************************************)
4004
(* Heap sort on arrays (bottom-up, binary) *)
4008
let i21 = i + i + 1 in
4009
if i21 + 1 < l && cmp a.(i21) a.(i21 + 1) < 0
4011
else if i21 < l then i21 else raise (Bottom i)
4013
let rec trickledown l i e =
4014
let j = maxson l i in
4015
if cmp a.(j) e > 0 then begin
4022
let trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in
4023
let rec bubbledown l i =
4024
let j = maxson l i in
4028
let bubble l i = try bubbledown l i with Bottom i -> i in
4029
let rec trickleup i e =
4030
let father = (i - 1) / 2 in
4031
assert (i <> father);
4032
if cmp a.(father) e < 0 then begin
4033
a.(i) <- a.(father);
4034
if father > 0 then trickleup father e else a.(0) <- e;
4039
let l = Array.length a in
4040
for i = l / 2 - 1 downto 0 do trickle l i a.(i); done;
4041
for i = l - 1 downto 2 do
4044
trickleup (bubble i 0) e;
4046
if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
4049
(************************************************************************)
4050
(* heap sort, top-down, ternary, recursive final loop *)
4053
let maxson l i = (* ASSUMES i < (l+1)/3 *)
4054
let i31 = i+i+i+1 in
4056
if i31+2 < l then begin
4057
if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
4058
if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
4061
if i31+1 < l && cmp a.(i31) a.(i31+1) < 0
4066
let rec trickledown l l3 i e = (* ASSUMES i < l3 *)
4067
let j = maxson l i in
4068
if cmp a.(j) e > 0 then begin
4070
if j < l3 then trickledown l l3 j e else a.(j) <- e;
4075
let l = Array.length a in
4076
let l3 = (l + 1) / 3 in
4077
for i = l3 - 1 downto 0 do trickledown l l3 i a.(i); done;
4078
let rec loop0 l l3 =
4081
trickledown l l3 0 e;
4086
trickledown l l3 0 e;
4092
trickledown l l3 0 e;
4095
let e = a.(1) in a.(1) <- a.(0); a.(0) <- e;
4099
match l + 1 - 3 * l3 with
4100
| 0 -> loop2 (l-1) (l3-1);
4101
| 1 -> loop0 (l-1) l3;
4102
| 2 -> loop1 (l-1) l3;
4103
| _ -> assert false;
4106
(************************************************************************)
4107
(* heap sort, top-down, ternary, with exception *)
4111
let i31 = i + i + i + 1 in
4113
if i31+2 < l then begin
4114
if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
4115
if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
4118
if i31+1 < l && cmp a.(i31) a.(i31+1) < 0
4120
else if i31 < l then i31 else (a.(i) <- e; raise Exit)
4123
let rec trickledown e l i =
4124
let j = maxson e l i in
4125
if cmp a.(j) e > 0 then begin
4132
let down e l i = try trickledown e l i with Exit -> (); in
4133
let l = Array.length a in
4134
for i = (l + 1) / 3 - 1 downto 0 do down a.(i) l i; done;
4135
for i = l - 1 downto 2 do
4140
if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
4143
(* FIXME essayer cutoff pour heapsort *)
4145
(************************************************************************)
4146
(* Insertion sort with dichotomic search *)
4148
let ainsertion_1 cmp a =
4149
let rec dicho l r e =
4150
if l = r then l else begin
4151
let m = (l + r) / 2 in
4153
then dicho (m+1) r e
4157
for i = 1 to Array.length a - 1 do
4159
let j = dicho 0 i e in
4160
Array.blit a j a (j + 1) (i - j);
4165
(************************************************************************)
4166
(* merge sort on lists via arrays *)
4168
let array_to_list_in_place a =
4169
let l = Array.length a in
4170
let rec loop accu n p =
4171
if p <= 0 then accu else begin
4173
Obj.truncate (Obj.repr a) p;
4174
loop (a.(p-1) :: accu) (n-1000) (p-1)
4176
loop (a.(p-1) :: accu) n (p-1)
4183
let array_of_list l len =
4187
let a = Array.make len h in
4191
| h::t -> a.(i) <- h; loop (i+1) t
4197
let lmerge_0a cmp l =
4198
let a = Array.of_list l in
4200
array_to_list_in_place a
4203
let lmerge_0b cmp l =
4204
let len = List.length l in
4205
if len > 256 then Gc.minor ();
4206
let a = array_of_list l len in
4208
array_to_list_in_place a
4211
let lshell_0 cmp l =
4212
let a = Array.of_list l in
4214
array_to_list_in_place a
4217
let lquick_0 cmp l =
4218
let a = Array.of_list l in
4220
array_to_list_in_place a
4223
(************************************************************************)
4224
(* merge sort on arrays via lists *)
4226
let amerge_0 cmp a = (* cutoff is not yet used *)
4227
let l = lmerge_4e cmp (Array.to_list a) in
4228
let rec loop i = function
4230
| h::t -> a.(i) <- h; loop (i + 1) t
4235
(************************************************************************)
4238
"Sort.list", Sort.list, true;
4239
"lmerge_3", lmerge_3, false;
4240
"lmerge_4a", lmerge_4a, true;
4244
"List.stable_sort", List.stable_sort, true;
4246
"lmerge_0a", lmerge_0a, true;
4247
"lmerge_0b", lmerge_0b, true;
4248
"lshell_0", lshell_0, false;
4249
"lquick_0", lquick_0, false;
4251
"lmerge_1a", lmerge_1a, true;
4252
"lmerge_1b", lmerge_1b, true;
4253
"lmerge_1c", lmerge_1c, true;
4254
"lmerge_1d", lmerge_1d, true;
4256
"lmerge_4b", lmerge_4b, true;
4257
"lmerge_4c", lmerge_4c, true;
4258
"lmerge_4d", lmerge_4d, true;
4259
"lmerge_4e", lmerge_4e, true;
4261
"lmerge_5a", lmerge_5a, true;
4262
"lmerge_5b", lmerge_5b, true;
4263
"lmerge_5c", lmerge_5c, true;
4264
"lmerge_5d", lmerge_5d, true;
4267
"Array.stable_sort", Array.stable_sort, true;
4268
"Array.sort", Array.sort, false;
4270
"amerge_0", amerge_0, true;
4272
"amerge_1a", amerge_1a, true;
4273
"amerge_1b", amerge_1b, true;
4274
"amerge_1c", amerge_1c, true;
4275
"amerge_1d", amerge_1d, true;
4276
"amerge_1e", amerge_1e, true;
4277
"amerge_1f", amerge_1f, true;
4278
"amerge_1g", amerge_1g, true;
4279
"amerge_1h", amerge_1h, true;
4280
"amerge_1i", amerge_1i, true;
4281
"amerge_1j", amerge_1j, true;
4283
"amerge_3a", amerge_3a, true;
4284
"amerge_3b", amerge_3b, true;
4285
"amerge_3c", amerge_3c, true;
4286
"amerge_3d", amerge_3d, true;
4287
"amerge_3e", amerge_3e, true;
4288
"amerge_3f", amerge_3f, true;
4289
"amerge_3g", amerge_3g, true;
4290
"amerge_3h", amerge_3h, true;
4291
"amerge_3i", amerge_3i, true;
4292
"amerge_3j", amerge_3j, true;
4294
"ashell_1", ashell_1, false;
4295
"ashell_2", ashell_2, false;
4296
"ashell_3", ashell_3, false;
4297
"ashell_4", ashell_4, false;
4299
"aquick_1a", aquick_1a, false;
4300
"aquick_1b", aquick_1b, false;
4301
"aquick_1c", aquick_1c, false;
4302
"aquick_1d", aquick_1d, false;
4303
"aquick_1e", aquick_1e, false;
4304
"aquick_1f", aquick_1f, false;
4305
"aquick_1g", aquick_1g, false;
4307
"aquick_2a", aquick_2a, false;
4308
"aquick_2b", aquick_2b, false;
4309
"aquick_2c", aquick_2c, false;
4310
"aquick_2d", aquick_2d, false;
4311
"aquick_2e", aquick_2e, false;
4312
"aquick_2f", aquick_2f, false;
4313
"aquick_2g", aquick_2g, false;
4315
"aquick_3a", aquick_3a, false;
4316
"aquick_3b", aquick_3b, false;
4317
"aquick_3c", aquick_3c, false;
4318
"aquick_3d", aquick_3d, false;
4319
"aquick_3e", aquick_3e, false;
4320
"aquick_3f", aquick_3f, false;
4321
"aquick_3g", aquick_3g, false;
4322
"aquick_3h", aquick_3h, false;
4323
"aquick_3i", aquick_3i, false;
4324
"aquick_3j", aquick_3j, false;
4326
"aheap_1", aheap_1, false;
4327
"aheap_2", aheap_2, false;
4328
"aheap_3", aheap_3, false;
4329
"aheap_4", aheap_4, false;
4330
"aheap_5", aheap_5, false;
4331
"aheap_6", aheap_6, false;
4333
"ainsertion_1", ainsertion_1, true;
4336
(************************************************************************)
4339
type mode = Test_std | Test | Bench1 | Bench2 | Bench3;;
4343
and mode = ref Test_std
4347
let usage = "Usage: sorts [-size <table size>] [-mem <memory size>]\n\
4348
\032 [-seed <random seed>] [-test|-bench]"
4352
"-size", Arg.Int ((:=) size), " Maximum size for benchmarks (default 22)";
4353
"-meg",Arg.Int ((:=) mem)," How many megabytes to preallocate (default 0)";
4354
"-seed", Arg.Int ((:=) seed), " PRNG seed (default 0)";
4355
"-teststd", Arg.Unit (fun () -> mode := Test_std), " Test stdlib (default)";
4356
"-test", Arg.Unit (fun () -> mode := Test), " Select test mode";
4357
"-bench1", Arg.Unit (fun () -> mode := Bench1), " Select bench mode 1";
4358
"-bench2", Arg.Unit (fun () -> mode := Bench2), " Select bench mode 2";
4359
"-bench3", Arg.Unit (fun () -> mode := Bench3), " Select bench mode 3";
4360
"-fn", Arg.String (fun x -> only := x :: !only),
4361
" <function> Test/Bench this function (default all)";
4363
let anonymous x = raise (Arg.Bad ("unrecognised option "^x));;
4366
Arg.parse options anonymous usage;
4368
Printf.printf "Command line arguments are:";
4369
for i = 1 to Array.length Sys.argv - 1 do
4370
Printf.printf " %s" Sys.argv.(i);
4374
ignore (String.create (1048576 * !mem));
4377
let a2l = Array.to_list in
4378
let l2ak x y = Array.of_list x in
4379
let id = fun x -> x in
4383
let benchonly f x y z t =
4386
| l -> if List.mem y l then f x y z t
4388
let testonly x1 x2 x3 x4 x5 x6 =
4390
| [] -> test x1 x2 x3 x4 x5 x6
4391
| l -> if List.mem x1 l then test x1 x2 x3 x4 x5 x6
4396
testonly "List.sort" false List.sort List.sort lc lc;
4397
testonly "List.stable_sort" true List.stable_sort List.stable_sort lc lc;
4398
testonly "Array.sort" false Array.sort Array.sort ac ac;
4399
testonly "Array.stable_sort" true Array.stable_sort Array.stable_sort
4401
printf "Number of tests failed: %d\n" !numfailed;
4404
for i = 0 to List.length lold - 1 do
4405
let (name, f1, stable) = List.nth lold i in
4406
let (_, f2, _) = List.nth lold i in
4407
testonly name stable f1 f2 ll ll;
4409
testonly "Sort.array" false Sort.array Sort.array al al;
4410
for i = 0 to List.length lnew - 1 do
4411
let (name, f1, stable) = List.nth lnew i in
4412
let (_, f2, _) = List.nth lnew i in
4413
testonly name stable f1 f2 lc lc;
4415
for i = 0 to List.length anew - 1 do
4416
let (name, f1, stable) = List.nth anew i in
4417
let (_, f2, _) = List.nth anew i in
4418
testonly name stable f1 f2 ac ac;
4420
printf "Number of tests failed: %d\n" !numfailed;
4423
let ba = fun x y z -> benchonly bench1a !size x y z
4424
and bb = fun x y z -> benchonly bench1b !size x y z
4425
and bc = fun x y z -> benchonly bench1c !size x y z
4427
for i = 0 to List.length lold - 1 do
4428
let (name, f, stable) = List.nth lold i in ba name f ll;
4429
let (name, f, stable) = List.nth lold i in bb name f ll;
4430
let (name, f, stable) = List.nth lold i in bc name f ll;
4432
ba "Sort.array" Sort.array al;
4433
bb "Sort.array" Sort.array al;
4434
bc "Sort.array" Sort.array al;
4435
for i = 0 to List.length lnew - 1 do
4436
let (name, f, stable) = List.nth lnew i in ba name f lc;
4437
let (name, f, stable) = List.nth lnew i in bb name f lc;
4438
let (name, f, stable) = List.nth lnew i in bc name f lc;
4440
for i = 0 to List.length anew - 1 do
4441
let (name, f, stable) = List.nth anew i in ba name f ac;
4442
let (name, f, stable) = List.nth anew i in bb name f ac;
4443
let (name, f, stable) = List.nth anew i in bc name f ac;
4447
let b = fun x y z -> benchonly bench2 !size x y z in
4448
for i = 0 to List.length lold - 1 do
4449
let (name, f, stable) = List.nth lold i in b name f ll;
4451
b "Sort.array" Sort.array al;
4452
for i = 0 to List.length lnew - 1 do
4453
let (name, f, stable) = List.nth lnew i in b name f lc;
4455
for i = 0 to List.length anew - 1 do
4456
let (name, f, stable) = List.nth anew i in b name f ac;
4460
let ba = fun x y z -> benchonly bench3a !size x y z
4461
and bb = fun x y z -> benchonly bench3b !size x y z
4462
and bc = fun x y z -> benchonly bench3c !size x y z
4464
for i = 0 to List.length lold - 1 do
4465
let (name, f, stable) = List.nth lold i in ba name f ll;
4466
let (name, f, stable) = List.nth lold i in bb name f ll;
4467
let (name, f, stable) = List.nth lold i in bc name f ll;
4469
for i = 0 to List.length lnew - 1 do
4470
let (name, f, stable) = List.nth lnew i in ba name f lc;
4471
let (name, f, stable) = List.nth lnew i in bb name f lc;
4472
let (name, f, stable) = List.nth lnew i in bc name f lc;
4477
if not !Sys.interactive then Printexc.catch main ();;
4479
(* $Id: sorts.ml 4955 2002-06-26 14:55:37Z doligez $ *)
added
removed
testsuite/tests/misc/sorts.ml
