diff options
| -rw-r--r-- | test/Moretest/sorts.ml | 3835 |
1 files changed, 3835 insertions, 0 deletions
diff --git a/test/Moretest/sorts.ml b/test/Moretest/sorts.ml new file mode 100644 index 000000000..69c726b18 --- /dev/null +++ b/test/Moretest/sorts.ml @@ -0,0 +1,3835 @@ +(* + ocamlopt -noassert sorts.ml -cclib -lunix +*) + +open Printf;; + +(* + Criteres: + 0. overhead en pile: doit etre logn au maximum. + 1. stable ou non. + 2. overhead en espace. + 3. vitesse. +*) + +(* FIXME: faire des tests sur des longueurs non puissances de 2 *) + +(* FIXME: merge sort avec listes mutables *) +(* FIXME: merge sort avec listes initiales maximales *) + +(************************************************************************) +(* auxiliary functions *) + +let rec exp2 n = if n <= 0 then 1 else 2 * exp2 (n-1);; +let id x = x;; +let postl x y = Array.of_list y;; +let posta x y = x;; + +let mkconst n = Array.make n 0;; +let chkconst _ n a = (a = mkconst n);; + +let mksorted n = + let a = Array.make n 0 in + for i = 0 to n - 1 do + a.(i) <- i; + done; + a +;; +let chksorted _ n a = (a = mksorted n);; + +let mkrev n = + let a = Array.make n 0 in + for i = 0 to n - 1 do + a.(i) <- n - 1 - i; + done; + a +;; +let chkrev _ n a = (a = mksorted n);; + +let seed = ref 0;; +let random_reinit () = Random.init !seed;; + +let random_get_state () = + let a = Array.make 55 0 in + for i = 0 to 54 do a.(i) <- Random.bits (); done; + Random.full_init a; + a +;; +let random_set_state a = Random.full_init a;; + +let chkgen mke cmp rstate n a = + let marks = Array.make n (-1) in + let skipmarks l = + if marks.(l) = -1 then l else begin + let m = ref marks.(l) in + while marks.(!m) <> -1 do incr m; done; + marks.(l) <- !m; + !m + end + in + let linear e l = + let l = skipmarks l in + let rec loop l = + if cmp a.(l) e > 0 then raise Exit + else if e = a.(l) then marks.(l) <- l+1 + else loop (l+1) + in loop l + in + let rec dicho e l r = + if l = r then linear e l + else begin + assert (l < r); + let m = (l + r) / 2 in + if cmp a.(m) e >= 0 then dicho e l m else dicho e (m + 1) r + end + in + try + for i = 0 to n-2 do if cmp a.(i) a.(i+1) > 0 then raise Exit; done; + random_set_state rstate; + for i = 0 to n-1 do dicho (mke i) 0 (Array.length a - 1); done; + true + with Exit | Invalid_argument _ -> false; +;; + +let mkrand_dup n = + let a = Array.make n 0 in + for i = 0 to (n-1) do a.(i) <- Random.int n; done; + a +;; + +let chkrand_dup rstate n a = + chkgen (fun i -> Random.int n) compare rstate n a +;; + +let mkrand_nodup n = + let a = Array.make n 0 in + for i = 0 to (n-1) do a.(i) <- Random.bits (); done; + a +;; + +let chkrand_nodup rstate n a = + chkgen (fun i -> Random.bits ()) compare rstate n a +;; + +type record = { + s1 : string; + s2 : string; + i1 : int; + i2 : int; +};; + +let rand_string () = + let len = Random.int 10 in + let s = String.create len in + for i = 0 to len-1 do + s.[i] <- Char.chr (Random.int 256); + done; + s +;; + +let mkrec1 b i = { + s1 = rand_string (); + s2 = rand_string (); + i1 = Random.int b; + i2 = i; +};; + +let mkrecs b n = Array.init n (mkrec1 b);; + +let mkrec1_rev b i = { + s1 = rand_string (); + s2 = rand_string (); + i1 = - i; + i2 = i; +};; + +let mkrecs_rev n = Array.init n (mkrec1_rev 0);; + +let cmpstr r1 r2 = + let c1 = compare r1.s1 r2.s1 in + if c1 = 0 then compare r1.s2 r2.s2 else c1 +;; +let lestr r1 r2 = + let c1 = compare r1.s1 r2.s1 in + if c1 = 0 then r1.s2 <= r2.s2 else (c1 < 0) +;; +let chkstr b rstate n a = chkgen (mkrec1 b) cmpstr rstate n a;; + +let cmpint r1 r2 = compare r1.i1 r2.i1;; +let leint r1 r2 = r1.i1 <= r2.i1;; +let chkint b rstate n a = chkgen (mkrec1 b) cmpint rstate n a;; + +let cmplex r1 r2 = + let c1 = compare r1.i1 r2.i1 in + if c1 = 0 then compare r1.i2 r2.i2 else c1 +;; +let lelex r1 r2 = + let c1 = compare r1.i1 r2.i1 in + if c1 = 0 then r1.i2 <= r2.i2 else (c1 < 0) +;; +let chklex b rstate n a = chkgen (mkrec1 b) cmplex rstate n a;; + +(************************************************************************) + +let lens = [ + 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 28; + 100; 127; 128; 129; 191; 192; 193; 506; + 1000; 1023; 1024; 1025; 1535; 1536; 1537; 2323; + 4000; 4094; 4096; 4098; 5123; +];; + +type ('a, 'b, 'c, 'd) aux = { + prepf : ('a -> 'a -> int) -> ('a -> 'a -> bool) -> 'b; + prepd : 'a array -> 'c; + postd : 'a array -> 'd -> 'a array; +};; + +let ll = { prepf = (fun x y -> y); prepd = Array.to_list; postd = postl };; +let lc = { prepf = (fun x y -> x); prepd = Array.to_list; postd = postl };; +let al = { prepf = (fun x y -> y); prepd = id; postd = posta };; +let ac = { prepf = (fun x y -> x); prepd = id; postd = posta };; + +type 'a outcome = Value of 'a | Exception of exn;; + +let numfailed = ref 0;; + +let test1 name f prepdata postdata cmp desc mk chk = + random_reinit (); + printf " %s with %s" name desc; + let i = ref 0 in + List.iter (fun n -> + if !i = 0 then printf "\n "; incr i; if !i > 11 then i := 0; + printf "%5d" n; flush stdout; + let rstate = random_get_state () in + let a = mk n in + let input = prepdata a in + let output = try Value (f cmp input) with e -> Exception e in + printf "."; flush stdout; + begin match output with + | Value v -> + if not (chk rstate n (postdata a v)) + then (incr numfailed; printf "\n*** FAIL\n") + | Exception e -> + incr numfailed; printf "\n*** %s\n" (Printexc.to_string e) + end; + flush stdout; + ) lens; + printf "\n"; +;; + +let test name stable f1 f2 aux1 aux2 = + printf "Testing %s...\n" name; + let t a b c d = test1 name f1 aux1.prepd aux1.postd a b c d in + let cmp = aux1.prepf compare (<=) in + t cmp "constant ints" mkconst chkconst; + t cmp "sorted ints" mksorted chksorted; + t cmp "reverse-sorted ints" mkrev chkrev; + t cmp "random ints (many dups)" mkrand_dup chkrand_dup; + t cmp "random ints (few dups)" mkrand_nodup chkrand_nodup; + let t a b c d = test1 name f2 aux2.prepd aux2.postd a b c d in + let cmp = aux2.prepf cmpstr lestr in + t cmp "records (str)" (mkrecs 1) (chkstr 1); + let cmp = aux2.prepf cmpint leint in + List.iter (fun m -> t cmp (sprintf "records (int[%d])" m) (mkrecs m) + (chkint m) + ) [1; 10; 100; 1000]; + if stable then + List.iter (fun m -> t cmp (sprintf "records (int[%d]) [stable]" m) + (mkrecs m) (chklex m) + ) [1; 10; 100; 1000]; +;; + +(************************************************************************) + +(* bug: effet de bord sur l'argument: on ne peut pas repeter la fonction. *) +(* +let timer1 repeat f x = + Gc.full_major (); + ignore (f x); + let st = Unix.times().tms_utime in + for i = 1 to repeat do ignore (f x); done; + let en = Unix.times().tms_utime in + en -. st +;; + +let timer f x = + let repeat = ref 1 in + let t = ref (timer1 !repeat f x) in + while !t < 0.2 do + repeat := 10 * !repeat; + t := timer1 !repeat f x; + done; + if !t < 2.0 then begin + repeat := (int_of_float (10. *. (float !repeat) /. !t) + 1); + t := timer1 !repeat f x; + end; + !t /. (float !repeat) +;; +*) + +let timer f x = + let st = Sys.time () in + ignore (f x); + let en = Sys.time () in + (en -. st) +;; + +let table1 limit f mkarg = + printf " %10s %9s %9s %9s\n" "n" "t1" "t2" "t3"; + let sz = ref 49151 in + while !sz < int_of_float (2. ** float limit) do + begin try + printf " %10d " !sz; flush stdout; + for i = 0 to 2 do + let arg = mkarg !sz in + let t = timer f arg in + printf " %.2e " t; flush stdout; + done; + printf "\n"; + with e -> printf "*** %s\n" (Printexc.to_string e); + end; + flush stdout; + sz := (3 * !sz + 1) / 2 + done; +;; + +let table2 limit f mkarg = + printf " %10s %9s %9s %9s %9s %9s\n" + " n" "t" "t/n" "t/nlogn" "t/nlog^2n" "t/n^2"; + let sz = ref 49151 in + while !sz < int_of_float (2. ** float limit) do + begin try + printf " %10d " !sz; flush stdout; + Gc.compact (); + let arg = mkarg !sz in + let t = timer f arg in + let n = float !sz in + let logn = log (float !sz) /. log 2. in + printf "%.2e %.2e %.2e %.2e %.2e\n" + t (t/.n) (t/.n/.logn) (t/.n/.logn/.logn) (t/.n/.n); + with e -> printf "*** %s\n" (Printexc.to_string e); + end; + flush stdout; + sz := (3 * !sz + 1) / 2 + done; +;; + +(************************************************************************) + +(* benchmarks: + 1. random records, sorted with two keys + 2a. integers, constant + 2b. integers, already sorted + 2c. integers, reverse sorted +*) +let bench1 limit name f aux = + + (* Don't do benchmarks with assertions enabled. *) + assert (not true); + + printf "\n%s with random records [1000000000]:\n" name; + random_reinit (); + let cmp = aux.prepf cmpstr lestr in + table1 limit (f cmp) (fun n -> aux.prepd (mkrecs 1000000000 n)); +;; + +let bench2 limit name f aux = + + (* Don't do benchmarks with assertions enabled. *) + assert (not true); + + printf "\n%s with constant integers:\n" name; + let cmp = aux.prepf compare (<=) in + table2 limit (f cmp) (fun n -> aux.prepd (mkconst n)); + + printf "\n%s with sorted integers:\n" name; + let cmp = aux.prepf compare (<=) in + table2 limit (f cmp) (fun n -> aux.prepd (mksorted n)); + + printf "\n%s with reverse-sorted integers:\n" name; + let cmp = aux.prepf compare (<=) in + table2 limit (f cmp) (fun n -> aux.prepd (mkrev n)); +;; + +(************************************************************************) +(* merge sort on lists *) + +(* FIXME to do: cutoff + to do: cascader les pattern-matchings (enlever les paires) + to do: fermeture intermediaire pour merge +*) +let (@@) = List.rev_append;; + +let lmerge_1a cmp l = + let rec init accu = function + | [] -> accu + | e::rest -> init ([e] :: accu) rest + in + let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward; + accu,accu2 are rev *) + match l1, l2 with + | [] , _ -> mergepairs ((l2 @@ accu)::accu2) rest + | _ , [] -> mergepairs ((l1 @@ accu)::accu2) rest + | h1::t1, h2::t2 -> if cmp h1 h2 <= 0 + then merge rest accu2 (h1::accu) t1 l2 + else merge rest accu2 (h2::accu) l1 t2 + and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward; + l1,l2,rest are rev *) + match l1, l2 with + | [] , _ -> mergepairs_rev ((l2 @@ accu)::accu2) rest + | _ , [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest + | h1::t1, h2::t2 -> if cmp h2 h1 <= 0 + then merge_rev rest accu2 (h1::accu) t1 l2 + else merge_rev rest accu2 (h2::accu) l1 t2 + and mergepairs accu = function (* accu is rev, arg is forward *) + | [] -> mergeall_rev accu + | [l] -> mergeall_rev ((List.rev l)::accu) + | l1::l2::rest -> merge rest accu [] l1 l2 + and mergepairs_rev accu = function (* accu is forward, arg is rev *) + | [] -> mergeall accu + | [l] -> mergeall ((List.rev l)::accu) + | l1::l2::rest -> merge_rev rest accu [] l1 l2 + and mergeall = function (* arg is forward *) + | [] -> [] + | [l] -> l + | llist -> mergepairs [] llist + and mergeall_rev = function (* arg is rev *) + | [] -> [] + | [l] -> List.rev l + | llist -> mergepairs_rev [] llist + in + mergeall_rev (init [] l) +;; + +let lmerge_1b cmp l = + let rec init accu = function + | [] -> accu + | [e] -> [e] :: accu + | e1::e2::rest -> + init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest + in + let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward; + accu,accu2 are rev *) + match l1, l2 with + | [] , _ -> mergepairs ((l2 @@ accu)::accu2) rest + | _ , [] -> mergepairs ((l1 @@ accu)::accu2) rest + | h1::t1, h2::t2 -> if cmp h1 h2 <= 0 + then merge rest accu2 (h1::accu) t1 l2 + else merge rest accu2 (h2::accu) l1 t2 + and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward; + l1,l2,rest are rev *) + match l1, l2 with + | [] , _ -> mergepairs_rev ((l2 @@ accu)::accu2) rest + | _ , [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest + | h1::t1, h2::t2 -> if cmp h2 h1 <= 0 + then merge_rev rest accu2 (h1::accu) t1 l2 + else merge_rev rest accu2 (h2::accu) l1 t2 + and mergepairs accu = function (* accu is rev, arg is forward *) + | [] -> mergeall_rev accu + | [l] -> mergeall_rev ((List.rev l)::accu) + | l1::l2::rest -> merge rest accu [] l1 l2 + and mergepairs_rev accu = function (* accu is forward, arg is rev *) + | [] -> mergeall accu + | [l] -> mergeall ((List.rev l)::accu) + | l1::l2::rest -> merge_rev rest accu [] l1 l2 + and mergeall = function (* arg is forward *) + | [] -> [] + | [l] -> l + | llist -> mergepairs [] llist + and mergeall_rev = function (* arg is rev *) + | [] -> [] + | [l] -> List.rev l + | llist -> mergepairs_rev [] llist + in + mergeall_rev (init [] l) +;; + +let lmerge_1c cmp l = + let rec init accu = function + | [] -> accu + | [e] -> [e] :: accu + | e1::e2::rest -> + init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest + in + let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward; + accu,accu2 are rev *) + match l1 with + | [] -> mergepairs ((l2 @@ accu)::accu2) rest + | h1::t1 -> + match l2 with + | [] -> mergepairs ((l1 @@ accu)::accu2) rest + | h2::t2 -> if cmp h1 h2 <= 0 + then merge rest accu2 (h1::accu) t1 l2 + else merge rest accu2 (h2::accu) l1 t2 + and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward; + l1,l2,rest are rev *) + match l1 with + | [] -> mergepairs_rev ((l2 @@ accu)::accu2) rest + | h1::t1 -> + match l2 with + | [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest + | h2::t2 -> if cmp h2 h1 <= 0 + then merge_rev rest accu2 (h1::accu) t1 l2 + else merge_rev rest accu2 (h2::accu) l1 t2 + and mergepairs accu = function (* accu is rev, arg is forward *) + | [] -> mergeall_rev accu + | [l] -> mergeall_rev ((List.rev l)::accu) + | l1::l2::rest -> merge rest accu [] l1 l2 + and mergepairs_rev accu = function (* accu is forward, arg is rev *) + | [] -> mergeall accu + | [l] -> mergeall ((List.rev l)::accu) + | l1::l2::rest -> merge_rev rest accu [] l1 l2 + and mergeall = function (* arg is forward *) + | [] -> [] + | [l] -> l + | llist -> mergepairs [] llist + and mergeall_rev = function (* arg is rev *) + | [] -> [] + | [l] -> List.rev l + | llist -> mergepairs_rev [] llist + in + mergeall_rev (init [] l) +;; + +let lmerge_1d cmp l = + let rec init accu = function + | [] -> accu + | [e] -> [e] :: accu + | e1::e2::rest -> + init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest + in + let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward; + accu,accu2 are rev *) + let merge_rest_accu2 accu l1 l2 = + match l1 with + | [] -> mergepairs ((l2 @@ accu)::accu2) rest + | h1::t1 -> + match l2 with + | [] -> mergepairs ((l1 @@ accu)::accu2) rest + | h2::t2 -> if cmp h1 h2 <= 0 + then merge rest accu2 (h1::accu) t1 l2 + else merge rest accu2 (h2::accu) l1 t2 + in merge_rest_accu2 accu l1 l2 + and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward; + l1,l2,rest are rev *) + let merge_rev_rest_accu2 accu l1 l2 = + match l1 with + | [] -> mergepairs_rev ((l2 @@ accu)::accu2) rest + | h1::t1 -> + match l2 with + | [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest + | h2::t2 -> if cmp h2 h1 <= 0 + then merge_rev rest accu2 (h1::accu) t1 l2 + else merge_rev rest accu2 (h2::accu) l1 t2 + in merge_rev_rest_accu2 accu l1 l2 + and mergepairs accu = function (* accu is rev, arg is forward *) + | [] -> mergeall_rev accu + | [l] -> mergeall_rev ((List.rev l)::accu) + | l1::l2::rest -> merge rest accu [] l1 l2 + and mergepairs_rev accu = function (* accu is forward, arg is rev *) + | [] -> mergeall accu + | [l] -> mergeall ((List.rev l)::accu) + | l1::l2::rest -> merge_rev rest accu [] l1 l2 + and mergeall = function (* arg is forward *) + | [] -> [] + | [l] -> l + | llist -> mergepairs [] llist + and mergeall_rev = function (* arg is rev *) + | [] -> [] + | [l] -> List.rev l + | llist -> mergepairs_rev [] llist + in + mergeall_rev (init [] l) +;; + +(************************************************************************) +(* merge sort on lists, user-contributed (NOT STABLE) *) + +(* BEGIN code contributed by Yann Coscoy *) + + let rec rev_merge_append order l1 l2 acc = + match l1 with + [] -> List.rev_append l2 acc + | h1 :: t1 -> + match l2 with + [] -> List.rev_append l1 acc + | h2 :: t2 -> + if order h1 h2 + then rev_merge_append order t1 l2 (h1::acc) + else rev_merge_append order l1 t2 (h2::acc) + + let rev_merge order l1 l2 = rev_merge_append order l1 l2 [] + + let rec rev_merge_append' order l1 l2 acc = + match l1 with + | [] -> List.rev_append l2 acc + | h1 :: t1 -> + match l2 with + | [] -> List.rev_append l1 acc + | h2 :: t2 -> + if order h2 h1 + then rev_merge_append' order t1 l2 (h1::acc) + else rev_merge_append' order l1 t2 (h2::acc) + + let rev_merge' order l1 l2 = rev_merge_append' order l1 l2 [] + + let lmerge_3 order l = + let rec initlist l acc = match l with + | e1::e2::rest -> + initlist rest + ((if order e1 e2 then [e1;e2] else [e2;e1])::acc) + | [e] -> [e]::acc + | [] -> acc + in + let rec merge2 ll acc = match ll with + | [] -> acc + | [l] -> [List.rev l]@acc + | l1::l2::rest -> + merge2 rest (rev_merge order l1 l2::acc) + in + let rec merge2' ll acc = match ll with + | [] -> acc + | [l] -> [List.rev l]@acc + | l1::l2::rest -> + merge2' rest (rev_merge' order l1 l2::acc) + in + let rec mergeall rev = function + | [] -> [] + | [l] -> if rev then List.rev l else l + | llist -> + mergeall + (not rev) ((if rev then merge2' else merge2) llist []) + in + mergeall false (initlist l []) + +(* END code contributed by Yann Coscoy *) + +(************************************************************************) +(* merge sort on arrays, merge with tail-rec function *) + +let amerge_1a cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + dst.(d) <- s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 a.(i1) i2 s2 (d + 1) + else + Array.blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + dst.(d) <- s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 src2.(i2) (d + 1) + else + Array.blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; + in + let rec sortto srcofs dst dstofs len = + assert (len > 0); + if len = 1 then dst.(dstofs) <- a.(srcofs) + else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = Array.length a in + if l <= 1 then () + else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let amerge_1b cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + dst.(d) <- s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 a.(i1) i2 s2 (d + 1) + else + Array.blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + dst.(d) <- s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 src2.(i2) (d + 1) + else + Array.blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; + in + let rec sortto srcofs dst dstofs len = + assert (len > 0); + if len = 1 then dst.(dstofs) <- a.(srcofs) + else if len = 2 then begin + if cmp a.(srcofs) a.(srcofs+1) <= 0 then begin + dst.(dstofs) <- a.(srcofs); + dst.(dstofs+1) <- a.(srcofs+1); + end else begin + dst.(dstofs) <- a.(srcofs+1); + dst.(dstofs+1) <- a.(srcofs); + end; + end else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = Array.length a in + if l <= 1 then () + else if l = 2 then begin + if cmp a.(0) a.(1) > 0 then begin + let e = a.(0) in + a.(0) <- a.(1); + a.(1) <- e; + end; + end else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 3;; +let amerge_1c cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + dst.(d) <- s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 a.(i1) i2 s2 (d + 1) + else + Array.blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + dst.(d) <- s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 src2.(i2) (d + 1) + else + Array.blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; + in + let isortto srcofs dst dstofs len = + for i = 0 to len - 1 do + let e = a.(srcofs + i) in + let j = ref (dstofs + i - 1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 4;; +let amerge_1d cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + dst.(d) <- s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 a.(i1) i2 s2 (d + 1) + else + Array.blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + dst.(d) <- s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 src2.(i2) (d + 1) + else + Array.blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; + in + let isortto srcofs dst dstofs len = + for i = 0 to len - 1 do + let e = a.(srcofs + i) in + let j = ref (dstofs + i - 1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 5;; +let amerge_1e cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + dst.(d) <- s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 a.(i1) i2 s2 (d + 1) + else + Array.blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + dst.(d) <- s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 src2.(i2) (d + 1) + else + Array.blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; + in + let isortto srcofs dst dstofs len = + for i = 0 to len - 1 do + let e = a.(srcofs + i) in + let j = ref (dstofs + i - 1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 6;; +let amerge_1f cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + dst.(d) <- s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 a.(i1) i2 s2 (d + 1) + else + Array.blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + dst.(d) <- s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 src2.(i2) (d + 1) + else + Array.blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; + in + let isortto srcofs dst dstofs len = + for i = 0 to len - 1 do + let e = a.(srcofs + i) in + let j = ref (dstofs + i - 1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 7;; +let amerge_1g cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + dst.(d) <- s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 a.(i1) i2 s2 (d + 1) + else + Array.blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + dst.(d) <- s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 src2.(i2) (d + 1) + else + Array.blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; + in + let isortto srcofs dst dstofs len = + for i = 0 to len - 1 do + let e = a.(srcofs + i) in + let j = ref (dstofs + i - 1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 8;; +let amerge_1h cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + dst.(d) <- s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 a.(i1) i2 s2 (d + 1) + else + Array.blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + dst.(d) <- s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 src2.(i2) (d + 1) + else + Array.blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; + in + let isortto srcofs dst dstofs len = + for i = 0 to len - 1 do + let e = a.(srcofs + i) in + let j = ref (dstofs + i - 1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 9;; +let amerge_1i cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + dst.(d) <- s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 a.(i1) i2 s2 (d + 1) + else + Array.blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + dst.(d) <- s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 src2.(i2) (d + 1) + else + Array.blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; + in + let isortto srcofs dst dstofs len = + for i = 0 to len - 1 do + let e = a.(srcofs + i) in + let j = ref (dstofs + i - 1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 10;; +let amerge_1j cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + dst.(d) <- s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 a.(i1) i2 s2 (d + 1) + else + Array.blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + dst.(d) <- s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 src2.(i2) (d + 1) + else + Array.blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; + in + let isortto srcofs dst dstofs len = + for i = 0 to len - 1 do + let e = a.(srcofs + i) in + let j = ref (dstofs + i - 1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +(* FIXME: list->array->list direct and array->list->array direct *) +(* FIXME: overhead = 1/3, 1/4, etc. *) +(* FIXME: overhead = sqrt (n) *) +(* FIXME: overhead = n/3 jusqu'a 30k, 30k jusqu'a 900M, sqrt (n) au-dela *) + +(************************************************************************) +(* merge sort on arrays, merge with loop *) + +(* cutoff = 1 *) +let amerge_3a cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let i1 = ref src1ofs + and i2 = ref src2ofs + and d = ref dstofs + and src1r = src1ofs + src1len + and src2r = src2ofs + src2len + in + while !i1 < src1r && !i2 < src2r do + let s1 = a.(!i1) and s2 = src2.(!i2) in + if cmp s1 s2 <= 0 then begin + dst.(!d) <- s1; + incr i1; + end else begin + dst.(!d) <- s2; + incr i2; + end; + incr d; + done; + if !i1 < src1r then + Array.blit a !i1 dst !d (src1r - !i1) + else + Array.blit src2 !i2 dst !d (src2r - !i2) + in + let rec sortto srcofs dst dstofs len = + assert (len > 0); + if len = 1 then dst.(dstofs) <- a.(srcofs) else + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs+l1) dst (dstofs+l1) l2; + sortto srcofs a (srcofs+l2) l1; + merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; + in + let l = Array.length a in + if l <= 1 then () else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let amerge_3b cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let i1 = ref src1ofs + and i2 = ref src2ofs + and d = ref dstofs + and src1r = src1ofs + src1len + and src2r = src2ofs + src2len + in + while !i1 < src1r && !i2 < src2r do + let s1 = a.(!i1) and s2 = src2.(!i2) in + if cmp s1 s2 <= 0 then begin + dst.(!d) <- s1; + incr i1; + end else begin + dst.(!d) <- s2; + incr i2; + end; + incr d; + done; + if !i1 < src1r then + Array.blit a !i1 dst !d (src1r - !i1) + else + Array.blit src2 !i2 dst !d (src2r - !i2) + in + let rec sortto srcofs dst dstofs len = + assert (len > 0); + if len = 1 then dst.(dstofs) <- a.(srcofs) + else if len = 2 then begin + if cmp a.(srcofs) a.(srcofs+1) <= 0 then begin + dst.(dstofs) <- a.(srcofs); + dst.(dstofs+1) <- a.(srcofs+1); + end else begin + dst.(dstofs) <- a.(srcofs+1); + dst.(dstofs+1) <- a.(srcofs); + end + end else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs+l1) dst (dstofs+l1) l2; + sortto srcofs a (srcofs+l2) l1; + merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; + end + in + let l = Array.length a in + if l <= 1 then () + else if l = 2 then begin + if cmp a.(0) a.(1) > 0 then begin + let e = a.(0) in + a.(0) <- a.(1); + a.(1) <- e; + end; + end else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 3;; +let amerge_3c cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let i1 = ref src1ofs + and i2 = ref src2ofs + and d = ref dstofs + and src1r = src1ofs + src1len + and src2r = src2ofs + src2len + in + while !i1 < src1r && !i2 < src2r do + let s1 = a.(!i1) and s2 = src2.(!i2) in + if cmp s1 s2 <= 0 then begin + dst.(!d) <- s1; + incr i1; + end else begin + dst.(!d) <- s2; + incr i2; + end; + incr d; + done; + if !i1 < src1r then + Array.blit a !i1 dst !d (src1r - !i1) + else + Array.blit src2 !i2 dst !d (src2r - !i2) + in + let isortto srcofs dst dstofs len = + for i = 0 to len-1 do + let e = a.(srcofs+i) in + let j = ref (dstofs+i-1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs+l1) dst (dstofs+l1) l2; + sortto srcofs a (srcofs+l2) l1; + merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 4;; +let amerge_3d cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let i1 = ref src1ofs + and i2 = ref src2ofs + and d = ref dstofs + and src1r = src1ofs + src1len + and src2r = src2ofs + src2len + in + while !i1 < src1r && !i2 < src2r do + let s1 = a.(!i1) and s2 = src2.(!i2) in + if cmp s1 s2 <= 0 then begin + dst.(!d) <- s1; + incr i1; + end else begin + dst.(!d) <- s2; + incr i2; + end; + incr d; + done; + if !i1 < src1r then + Array.blit a !i1 dst !d (src1r - !i1) + else + Array.blit src2 !i2 dst !d (src2r - !i2) + in + let isortto srcofs dst dstofs len = + for i = 0 to len-1 do + let e = a.(srcofs+i) in + let j = ref (dstofs+i-1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs+l1) dst (dstofs+l1) l2; + sortto srcofs a (srcofs+l2) l1; + merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 5;; +let amerge_3e cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let i1 = ref src1ofs + and i2 = ref src2ofs + and d = ref dstofs + and src1r = src1ofs + src1len + and src2r = src2ofs + src2len + in + while !i1 < src1r && !i2 < src2r do + let s1 = a.(!i1) and s2 = src2.(!i2) in + if cmp s1 s2 <= 0 then begin + dst.(!d) <- s1; + incr i1; + end else begin + dst.(!d) <- s2; + incr i2; + end; + incr d; + done; + if !i1 < src1r then + Array.blit a !i1 dst !d (src1r - !i1) + else + Array.blit src2 !i2 dst !d (src2r - !i2) + in + let isortto srcofs dst dstofs len = + for i = 0 to len-1 do + let e = a.(srcofs+i) in + let j = ref (dstofs+i-1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs+l1) dst (dstofs+l1) l2; + sortto srcofs a (srcofs+l2) l1; + merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 6;; +let amerge_3f cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let i1 = ref src1ofs + and i2 = ref src2ofs + and d = ref dstofs + and src1r = src1ofs + src1len + and src2r = src2ofs + src2len + in + while !i1 < src1r && !i2 < src2r do + let s1 = a.(!i1) and s2 = src2.(!i2) in + if cmp s1 s2 <= 0 then begin + dst.(!d) <- s1; + incr i1; + end else begin + dst.(!d) <- s2; + incr i2; + end; + incr d; + done; + if !i1 < src1r then + Array.blit a !i1 dst !d (src1r - !i1) + else + Array.blit src2 !i2 dst !d (src2r - !i2) + in + let isortto srcofs dst dstofs len = + for i = 0 to len-1 do + let e = a.(srcofs+i) in + let j = ref (dstofs+i-1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs+l1) dst (dstofs+l1) l2; + sortto srcofs a (srcofs+l2) l1; + merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 7;; +let amerge_3g cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let i1 = ref src1ofs + and i2 = ref src2ofs + and d = ref dstofs + and src1r = src1ofs + src1len + and src2r = src2ofs + src2len + in + while !i1 < src1r && !i2 < src2r do + let s1 = a.(!i1) and s2 = src2.(!i2) in + if cmp s1 s2 <= 0 then begin + dst.(!d) <- s1; + incr i1; + end else begin + dst.(!d) <- s2; + incr i2; + end; + incr d; + done; + if !i1 < src1r then + Array.blit a !i1 dst !d (src1r - !i1) + else + Array.blit src2 !i2 dst !d (src2r - !i2) + in + let isortto srcofs dst dstofs len = + for i = 0 to len-1 do + let e = a.(srcofs+i) in + let j = ref (dstofs+i-1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs+l1) dst (dstofs+l1) l2; + sortto srcofs a (srcofs+l2) l1; + merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 8;; +let amerge_3h cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let i1 = ref src1ofs + and i2 = ref src2ofs + and d = ref dstofs + and src1r = src1ofs + src1len + and src2r = src2ofs + src2len + in + while !i1 < src1r && !i2 < src2r do + let s1 = a.(!i1) and s2 = src2.(!i2) in + if cmp s1 s2 <= 0 then begin + dst.(!d) <- s1; + incr i1; + end else begin + dst.(!d) <- s2; + incr i2; + end; + incr d; + done; + if !i1 < src1r then + Array.blit a !i1 dst !d (src1r - !i1) + else + Array.blit src2 !i2 dst !d (src2r - !i2) + in + let isortto srcofs dst dstofs len = + for i = 0 to len-1 do + let e = a.(srcofs+i) in + let j = ref (dstofs+i-1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs+l1) dst (dstofs+l1) l2; + sortto srcofs a (srcofs+l2) l1; + merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 9;; +let amerge_3i cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let i1 = ref src1ofs + and i2 = ref src2ofs + and d = ref dstofs + and src1r = src1ofs + src1len + and src2r = src2ofs + src2len + in + while !i1 < src1r && !i2 < src2r do + let s1 = a.(!i1) and s2 = src2.(!i2) in + if cmp s1 s2 <= 0 then begin + dst.(!d) <- s1; + incr i1; + end else begin + dst.(!d) <- s2; + incr i2; + end; + incr d; + done; + if !i1 < src1r then + Array.blit a !i1 dst !d (src1r - !i1) + else + Array.blit src2 !i2 dst !d (src2r - !i2) + in + let isortto srcofs dst dstofs len = + for i = 0 to len-1 do + let e = a.(srcofs+i) in + let j = ref (dstofs+i-1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs+l1) dst (dstofs+l1) l2; + sortto srcofs a (srcofs+l2) l1; + merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let cutoff = 10;; +let amerge_3j cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let i1 = ref src1ofs + and i2 = ref src2ofs + and d = ref dstofs + and src1r = src1ofs + src1len + and src2r = src2ofs + src2len + in + while !i1 < src1r && !i2 < src2r do + let s1 = a.(!i1) and s2 = src2.(!i2) in + if cmp s1 s2 <= 0 then begin + dst.(!d) <- s1; + incr i1; + end else begin + dst.(!d) <- s2; + incr i2; + end; + incr d; + done; + if !i1 < src1r then + Array.blit a !i1 dst !d (src1r - !i1) + else + Array.blit src2 !i2 dst !d (src2r - !i2) + in + let isortto srcofs dst dstofs len = + for i = 0 to len-1 do + let e = a.(srcofs+i) in + let j = ref (dstofs+i-1) in + while (!j >= dstofs && cmp dst.(!j) e > 0) do + dst.(!j + 1) <- dst.(!j); + decr j; + done; + dst.(!j + 1) <- e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs+l1) dst (dstofs+l1) l2; + sortto srcofs a (srcofs+l2) l1; + merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; + in + let l = Array.length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = Array.make l2 a.(0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +(* FIXME: bottom-up merge on arrays ? *) +(* FIXME: top-down merge on lists ? *) + +(************************************************************************) +(* Shell sort on arrays *) + +let ashell_1 cmp a = + let l = Array.length a in + let step = ref 1 in + while !step < l do step := !step * 3 + 1; done; + step := !step / 3; + while !step > 0 do + for j = !step to l-1 do + let e = a.(j) in + let k = ref (j - !step) in + let k1 = ref j in + while !k >= 0 && cmp a.(!k) e > 0 do + a.(!k1) <- a.(!k); + k1 := !k; + k := !k - !step; + done; + a.(!k1) <- e; + done; + step := !step / 3; + done; +;; + +let ashell_2 cmp a = + let l = Array.length a in + let step = ref 1 in + while !step < l do step := !step * 3 + 1; done; + step := !step / 3; + while !step > 0 do + for j = !step to l-1 do + let e = a.(j) in + let k = ref (j - !step) in + while !k >= 0 && cmp a.(!k) e > 0 do + a.(!k + !step) <- a.(!k); + k := !k - !step; + done; + a.(!k + !step) <- e; + done; + step := !step / 3; + done; +;; + +let ashell_3 cmp a = + let l = Array.length a in + let step = ref 1 in + while !step < l do step := !step * 3 + 1; done; + step := !step / 3; + while !step > 0 do + for i = 0 to !step - 1 do + let j = ref (i + !step) in + while !j < l do + let e = ref a.(!j) in + let k = ref (!j - !step) in + if cmp !e a.(i) < 0 then begin + let x = !e in e := a.(i); a.(i) <- x; + end; + while cmp a.(!k) !e > 0 do + a.(!k + !step) <- a.(!k); + k := !k - !step; + done; + a.(!k + !step) <- !e; + j := !j + !step; + done; + done; + step := !step / 3; + done; +;; + +let force = Lazy.force;; + +type iilist = Cons of int * iilist Lazy.t;; + +let rec mult n (Cons (x,l)) = Cons (n*x, lazy (mult n (force l))) + +let rec merge (Cons (x1, t1) as l1) (Cons (x2, t2) as l2) = + if x1 = x2 then Cons (x1, lazy (merge (force t1) (force t2))) + else if x1 < x2 then Cons (x1, lazy (merge (force t1) l2)) + else Cons (x2, lazy (merge l1 (force t2))) +;; + +let rec scale = Cons (1, lazy (merge (mult 2 scale) (mult 3 scale)));; + +let ashell_4 cmp a = + let l = Array.length a in + let rec loop1 accu (Cons (x, t)) = + if x > l then accu else loop1 (x::accu) (force t) + in + let sc = loop1 [] scale in + let rec loop2 = function + | [] -> () + | step::t -> + for i = 0 to step - 1 do + let j = ref (i + step) in + while !j < l do + let e = a.(!j) in + let k = ref (!j - step) in + while !k >= 0 && cmp a.(!k) e > 0 do + a.(!k + step) <- a.(!k); + k := !k - step; + done; + a.(!k + step) <- e; + j := !j + step; + done; + done; + loop2 t; + in + loop2 sc; +;; + +(************************************************************************) +(* Quicksort on arrays *) +let cutoff = 1;; +let aquick_1a cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in + while !p2 <= !p3 do + let e = a.(!p3) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + end else if c < 0 then begin + a.(!p3) <- a.(!p2); + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + a.(!p3) <- a.(!p2); + a.(!p2) <- e; + incr p2; + end; + done; + incr p3; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 1 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 2;; +let aquick_1b cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in + while !p2 <= !p3 do + let e = a.(!p3) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + end else if c < 0 then begin + a.(!p3) <- a.(!p2); + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + a.(!p3) <- a.(!p2); + a.(!p2) <- e; + incr p2; + end; + done; + incr p3; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 1 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 3;; +let aquick_1c cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in + while !p2 <= !p3 do + let e = a.(!p3) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + end else if c < 0 then begin + a.(!p3) <- a.(!p2); + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + a.(!p3) <- a.(!p2); + a.(!p2) <- e; + incr p2; + end; + done; + incr p3; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 1 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 4;; +let aquick_1d cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in + while !p2 <= !p3 do + let e = a.(!p3) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + end else if c < 0 then begin + a.(!p3) <- a.(!p2); + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + a.(!p3) <- a.(!p2); + a.(!p2) <- e; + incr p2; + end; + done; + incr p3; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 1 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 5;; +let aquick_1e cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in + while !p2 <= !p3 do + let e = a.(!p3) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + end else if c < 0 then begin + a.(!p3) <- a.(!p2); + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + a.(!p3) <- a.(!p2); + a.(!p2) <- e; + incr p2; + end; + done; + incr p3; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 1 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 6;; +let aquick_1f cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in + while !p2 <= !p3 do + let e = a.(!p3) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + end else if c < 0 then begin + a.(!p3) <- a.(!p2); + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + a.(!p3) <- a.(!p2); + a.(!p2) <- e; + incr p2; + end; + done; + incr p3; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 1 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 7;; +let aquick_1g cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in + while !p2 <= !p3 do + let e = a.(!p3) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + end else if c < 0 then begin + a.(!p3) <- a.(!p2); + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + a.(!p3) <- a.(!p2); + a.(!p2) <- e; + incr p2; + end; + done; + incr p3; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 1 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 1;; +let aquick_2a cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + incr p2; + end; + done; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 2;; +let aquick_2b cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + incr p2; + end; + done; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 3;; +let aquick_2c cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + incr p2; + end; + done; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 4;; +let aquick_2d cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + incr p2; + end; + done; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 5;; +let aquick_2e cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + incr p2; + end; + done; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 6;; +let aquick_2f cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + incr p2; + end; + done; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 7;; +let aquick_2g cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end else begin + incr p2; + end; + done; + let len1 = !p1 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p1; qsort !p3 r) + else (qsort !p3 r; qsort l !p1) + end else qsort l !p1 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 1;; +let aquick_3a cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + incr p2; + end else begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end + done; + while !p1 > l do + decr p1; + decr p2; + let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; + done; + let len1 = !p2 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p2; qsort !p3 r) + else (qsort !p3 r; qsort l !p2) + end else qsort l !p2 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 2;; +let aquick_3b cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + incr p2; + end else begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end + done; + while !p1 > l do + decr p1; + decr p2; + let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; + done; + let len1 = !p2 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p2; qsort !p3 r) + else (qsort !p3 r; qsort l !p2) + end else qsort l !p2 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 3;; +let aquick_3c cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + incr p2; + end else begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end + done; + while !p1 > l do + decr p1; + decr p2; + let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; + done; + let len1 = !p2 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p2; qsort !p3 r) + else (qsort !p3 r; qsort l !p2) + end else qsort l !p2 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 4;; +let aquick_3d cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + incr p2; + end else begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end + done; + while !p1 > l do + decr p1; + decr p2; + let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; + done; + let len1 = !p2 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p2; qsort !p3 r) + else (qsort !p3 r; qsort l !p2) + end else qsort l !p2 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 5;; +let aquick_3e cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + incr p2; + end else begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end + done; + while !p1 > l do + decr p1; + decr p2; + let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; + done; + let len1 = !p2 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p2; qsort !p3 r) + else (qsort !p3 r; qsort l !p2) + end else qsort l !p2 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 6;; +let aquick_3f cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + incr p2; + end else begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end + done; + while !p1 > l do + decr p1; + decr p2; + let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; + done; + let len1 = !p2 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p2; qsort !p3 r) + else (qsort !p3 r; qsort l !p2) + end else qsort l !p2 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 7;; +let aquick_3g cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + incr p2; + end else begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end + done; + while !p1 > l do + decr p1; + decr p2; + let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; + done; + let len1 = !p2 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p2; qsort !p3 r) + else (qsort !p3 r; qsort l !p2) + end else qsort l !p2 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 8;; +let aquick_3h cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + incr p2; + end else begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end + done; + while !p1 > l do + decr p1; + decr p2; + let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; + done; + let len1 = !p2 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p2; qsort !p3 r) + else (qsort !p3 r; qsort l !p2) + end else qsort l !p2 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 9;; +let aquick_3i cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + incr p2; + end else begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end + done; + while !p1 > l do + decr p1; + decr p2; + let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; + done; + let len1 = !p2 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p2; qsort !p3 r) + else (qsort !p3 r; qsort l !p2) + end else qsort l !p2 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +let cutoff = 10;; +let aquick_3j cmp a = + let rec qsort l r = (* ASSUMES r - l >= 2 *) + let m = (l + r) / 2 in + let al = a.(l) and am = a.(m) and ar = a.(r - 1) in + let pivot = if cmp al am <= 0 then + if cmp am ar <= 0 then am + else if cmp al ar <= 0 then ar + else al + else + if cmp al ar <= 0 then al + else if cmp am ar <= 0 then ar + else am + in + let p1 = ref l and p2 = ref l and p3 = ref r in + while !p2 < !p3 do + let e = a.(!p2) in + let c = cmp e pivot in + if c > 0 then begin + decr p3; + a.(!p2) <- a.(!p3); + a.(!p3) <- e; + end else if c < 0 then begin + incr p2; + end else begin + a.(!p2) <- a.(!p1); + a.(!p1) <- e; + incr p1; + incr p2; + end + done; + while !p1 > l do + decr p1; + decr p2; + let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; + done; + let len1 = !p2 - l and len2 = r - !p3 in + if len1 > cutoff then + if len2 > cutoff then begin + if len1 < len2 + then (qsort l !p2; qsort !p3 r) + else (qsort !p3 r; qsort l !p2) + end else qsort l !p2 + else if len2 > cutoff then qsort !p3 r; + in + let l = Array.length a in + if l > 1 then begin + qsort 0 l; + let mini = ref 0 in + for i = 0 to (min l cutoff) - 1 do + if cmp a.(i) a.(!mini) < 0 then mini := i; + done; + let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; + for i = 1 to l - 1 do + let e = a.(i) in + let j = ref (i - 1) in + while cmp a.(!j) e > 0 do + a.(!j + 1) <- a.(!j); + decr j; + done; + a.(!j + 1) <- e; + done; + end; +;; + +(************************************************************************) +(* Heap sort on arrays (top-down, ternary) *) + +let aheap_1 cmp a = + let l = ref (Array.length a) in + let l3 = ref ((!l + 1) / 3) in (* l3 is the first element without sons *) + let maxson i = (* ASSUMES i < !l3 *) + let i31 = i+i+i+1 in + let x = ref i31 in + if i31+2 < !l then begin + if cmp a.(i31) a.(i31+1) < 0 then x := i31+1; + if cmp a.(!x) a.(i31+2) < 0 then x := i31+2; + !x + end else begin + if i31+1 < !l && cmp a.(i31) a.(i31+1) < 0 + then i31+1 + else i31 + end + in + let rec trickledown i e = (* ASSUMES i < !l3 *) + let j = maxson i in + if cmp a.(j) e > 0 then begin + a.(i) <- a.(j); + if j < !l3 then trickledown j e else a.(j) <- e; + end else begin + a.(i) <- e; + end; + in + for i = !l3 - 1 downto 0 do trickledown i a.(i); done; + let m = ref (!l + 1 - 3 * !l3) in + while !l > 2 do + decr l; + if !m = 0 then (m := 2; decr l3) else decr m; + let e = a.(!l) in + a.(!l) <- a.(0); + trickledown 0 e; + done; + if !l > 1 then begin let e = a.(1) in a.(1) <- a.(0); a.(0) <- e; end; +;; + +(************************************************************************) +(* Heap sort on arrays (top-down, binary) *) + +(* FIXME to do: application partielle de trickledown (merge avec down) *) +(* FIXME to do: expanser maxson dans trickledown; supprimer l'exception. *) + +let aheap_2 cmp a = + let maxson l i e = + let i21 = i + i + 1 in + if i21 + 1 < l && cmp a.(i21) a.(i21+1) < 0 + then i21 + 1 + else if i21 < l then i21 else (a.(i) <- e; raise Exit) + in + let rec trickledown l i e = + let j = maxson l i e in + if cmp a.(j) e > 0 then begin + a.(i) <- a.(j); + trickledown l j e; + end else begin + a.(i) <- e; + end; + in + let down l i e = try trickledown l i e with Exit -> () in + let l = Array.length a in + for i = l / 2 -1 downto 0 do down l i a.(i); done; + for i = l - 1 downto 1 do + let e = a.(i) in + a.(i) <- a.(0); + down i 0 e; + done; +;; + +(************************************************************************) +(* Heap sort on arrays (bottom-up, ternary) *) + +exception Bottom of int;; + +let aheap_3 cmp a = + let maxson l i = + let i31 = i+i+i+1 in + let x = ref i31 in + if i31+2 < l then begin + if cmp a.(i31) a.(i31+1) < 0 then x := i31+1; + if cmp a.(!x) a.(i31+2) < 0 then x := i31+2; + !x + end else + if i31+1 < l && cmp a.(i31) a.(i31+1) < 0 + then i31+1 + else if i31 < l then i31 else raise (Bottom i) + in + let rec trickledown l i e = + let j = maxson l i in + if cmp a.(j) e > 0 then begin + a.(i) <- a.(j); + trickledown l j e; + end else begin + a.(i) <- e; + end; + in + let rec trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in + let rec bubbledown l i = + let j = maxson l i in + a.(i) <- a.(j); + bubbledown l j; + in + let bubble l i = try bubbledown l i with Bottom i -> i in + let rec trickleup i e = + let father = (i - 1) / 3 in + assert (i <> father); + if cmp a.(father) e < 0 then begin + a.(i) <- a.(father); + if father > 0 then trickleup father e else a.(0) <- e; + end else begin + a.(i) <- e; + end; + in + let l = Array.length a in + for i = (l + 1) / 3 - 1 downto 0 do trickle l i a.(i); done; + for i = l - 1 downto 2 do + let e = a.(i) in + a.(i) <- a.(0); + trickleup (bubble i 0) e; + done; + if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e); +;; + +(************************************************************************) +(* Heap sort on arrays (bottom-up, binary) *) + +let aheap_4 cmp a = + let maxson l i = + let i21 = i + i + 1 in + if i21 + 1 < l && cmp a.(i21) a.(i21 + 1) < 0 + then i21 + 1 + else if i21 < l then i21 else raise (Bottom i) + in + let rec trickledown l i e = + let j = maxson l i in + if cmp a.(j) e > 0 then begin + a.(i) <- a.(j); + trickledown l j e; + end else begin + a.(i) <- e; + end; + in + let trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in + let rec bubbledown l i = + let j = maxson l i in + a.(i) <- a.(j); + bubbledown l j; + in + let bubble l i = try bubbledown l i with Bottom i -> i in + let rec trickleup i e = + let father = (i - 1) / 2 in + assert (i <> father); + if cmp a.(father) e < 0 then begin + a.(i) <- a.(father); + if father > 0 then trickleup father e else a.(0) <- e; + end else begin + a.(i) <- e; + end; + in + let l = Array.length a in + for i = l / 2 - 1 downto 0 do trickle l i a.(i); done; + for i = l - 1 downto 2 do + let e = a.(i) in + a.(i) <- a.(0); + trickleup (bubble i 0) e; + done; + if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e); +;; + +(************************************************************************) +(* heap sort, top-down, ternary, recursive final loop *) + +let aheap_5 cmp a = + let maxson l i = (* ASSUMES i < (l+1)/3 *) + let i31 = i+i+i+1 in + let x = ref i31 in + if i31+2 < l then begin + if cmp a.(i31) a.(i31+1) < 0 then x := i31+1; + if cmp a.(!x) a.(i31+2) < 0 then x := i31+2; + !x + end else begin + if i31+1 < l && cmp a.(i31) a.(i31+1) < 0 + then i31+1 + else i31 + end + in + let rec trickledown l l3 i e = (* ASSUMES i < l3 *) + let j = maxson l i in + if cmp a.(j) e > 0 then begin + a.(i) <- a.(j); + if j < l3 then trickledown l l3 j e else a.(j) <- e; + end else begin + a.(i) <- e; + end; + in + let l = Array.length a in + let l3 = (l + 1) / 3 in + for i = l3 - 1 downto 0 do trickledown l l3 i a.(i); done; + let rec loop0 l l3 = + let e = a.(l) in + a.(l) <- a.(0); + trickledown l l3 0 e; + loop2 (l-1) (l3-1); + and loop1 l l3 = + let e = a.(l) in + a.(l) <- a.(0); + trickledown l l3 0 e; + loop0 (l-1) l3; + and loop2 l l3 = + if l > 1 then begin + let e = a.(l) in + a.(l) <- a.(0); + trickledown l l3 0 e; + loop1 (l-1) l3; + end else begin + let e = a.(1) in a.(1) <- a.(0); a.(0) <- e; + end; + in + if l > 1 then + match l + 1 - 3 * l3 with + | 0 -> loop2 (l-1) (l3-1); + | 1 -> loop0 (l-1) l3; + | 2 -> loop1 (l-1) l3; + | _ -> assert false; +;; + +(************************************************************************) +(* heap sort, top-down, ternary, with exception *) + +let aheap_6 cmp a = + let maxson e l i = + let i31 = i + i + i + 1 in + let x = ref i31 in + if i31+2 < l then begin + if cmp a.(i31) a.(i31+1) < 0 then x := i31+1; + if cmp a.(!x) a.(i31+2) < 0 then x := i31+2; + !x + end else begin + if i31+1 < l && cmp a.(i31) a.(i31+1) < 0 + then i31+1 + else if i31 < l then i31 else (a.(i) <- e; raise Exit) + end + in + let rec trickledown e l i = + let j = maxson e l i in + if cmp a.(j) e > 0 then begin + a.(i) <- a.(j); + trickledown e l j; + end else begin + a.(i) <- e; + end; + in + let down e l i = try trickledown e l i with Exit -> (); in + let l = Array.length a in + for i = (l + 1) / 3 - 1 downto 0 do down a.(i) l i; done; + for i = l - 1 downto 2 do + let e = a.(i) in + a.(i) <- a.(0); + down e i 0; + done; + if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e); +;; + +(* FIXME cutoff pour heapsort ? *) + +(************************************************************************) +(* Insertion sort with dichotomic search *) + +let ainsertion_1 cmp a = + let rec dicho l r e = + if l = r then l else begin + let m = (l + r) / 2 in + if cmp a.(m) e <= 0 + then dicho (m+1) r e + else dicho l m e + end + in + for i = 1 to Array.length a - 1 do + let e = a.(i) in + let j = dicho 0 i e in + Array.blit a j a (j + 1) (i - j); + a.(j) <- e; + done; +;; + +(************************************************************************) +(* merge sort on lists via arrays *) + +let array_to_list_in_place a = + let l = Array.length a in + let rec loop accu n p = + if p <= 0 then accu else begin + if p = n then begin + Obj.truncate (Obj.repr a) p; + loop (a.(p-1) :: accu) (n-1000) (p-1) + end else begin + loop (a.(p-1) :: accu) n (p-1) + end + end + in + loop [] l l +;; + +let lmerge_0 cmp l = + let a = Array.of_list l in + amerge_1e cmp a; + array_to_list_in_place a +;; + +let lshell_0 cmp l = + let a = Array.of_list l in + ashell_2 cmp a; + array_to_list_in_place a +;; + +let lquick_0 cmp l = + let a = Array.of_list l in + aquick_3f cmp a; + array_to_list_in_place a +;; + +(************************************************************************) +(* merge sort on arrays via lists *) + +let amerge_0 cmp a = (* cutoff is not yet used *) + let l = lmerge_1a cmp (Array.to_list a) in + let rec loop i = function + | [] -> () + | h::t -> a.(i) <- h; loop (i + 1) t + in + loop 0 l +;; + +(************************************************************************) + +let lnew = [ + "lmerge_0", lmerge_0, true; +(* + "lshell_0", lshell_0, false; + "lquick_0", lquick_0, false; + "lmerge_1a", lmerge_1a, true; + "lmerge_1b", lmerge_1b, true; + "lmerge_1c", lmerge_1c, true; + "lmerge_1d", lmerge_1d, true; +*) +];; +let anew = [ +(* + "amerge_0", amerge_0, true; + + "amerge_1a", amerge_1a, true; + "amerge_1b", amerge_1b, true; + "amerge_1c", amerge_1c, true; + "amerge_1d", amerge_1d, true; +*) + "amerge_1e", amerge_1e, true; +(* + "amerge_1f", amerge_1f, true; + "amerge_1g", amerge_1g, true; + "amerge_1h", amerge_1h, true; + "amerge_1i", amerge_1i, true; + "amerge_1j", amerge_1j, true; + + "amerge_3a", amerge_3a, true; + "amerge_3b", amerge_3b, true; + "amerge_3c", amerge_3c, true; + + "amerge_3d", amerge_3d, true; + "amerge_3e", amerge_3e, true; + "amerge_3f", amerge_3f, true; + "amerge_3g", amerge_3g, true; + "amerge_3h", amerge_3h, true; + "amerge_3i", amerge_3i, true; + "amerge_3j", amerge_3j, true; + + "ashell_1", ashell_1, false; + "ashell_2", ashell_2, false; + "ashell_3", ashell_3, false; + "ashell_4", ashell_4, false; + + "aquick_1a", aquick_1a, false; + "aquick_1b", aquick_1b, false; + "aquick_1c", aquick_1c, false; + "aquick_1d", aquick_1d, false; + "aquick_1e", aquick_1e, false; + "aquick_1f", aquick_1f, false; + "aquick_1g", aquick_1g, false; + + "aquick_2a", aquick_2a, false; + "aquick_2b", aquick_2b, false; + "aquick_2c", aquick_2c, false; + "aquick_2d", aquick_2d, false; + "aquick_2e", aquick_2e, false; + "aquick_2f", aquick_2f, false; + "aquick_2g", aquick_2g, false; + + "aquick_3a", aquick_3a, false; + "aquick_3b", aquick_3b, false; + "aquick_3c", aquick_3c, false; + "aquick_3d", aquick_3d, false; + "aquick_3e", aquick_3e, false; + "aquick_3f", aquick_3f, false; + "aquick_3g", aquick_3g, false; + "aquick_3h", aquick_3h, false; + "aquick_3i", aquick_3i, false; + "aquick_3j", aquick_3j, false; + + "aheap_1", aheap_1, false; + "aheap_2", aheap_2, false; +*) + "aheap_3", aheap_3, false; +(* + "aheap_4", aheap_4, false; + "aheap_5", aheap_5, false; + "aheap_6", aheap_6, false; + + "ainsertion_1", ainsertion_1, true; +*) +];; + +(************************************************************************) +(* main program *) + +type mode = Test_std | Test | Bench1 | Bench2;; + +let size = ref 22 +and mem = ref 0 +and mode = ref Test_std +;; + +let usage = "Usage: sorts [-size <table size>] [-mem <memory size>]\n\ + \032 [-seed <random seed>] [-test|-bench]" +;; + +let options = [ + "-size", Arg.Int ((:=) size), " Maximum size for benchmarks (default 22)"; + "-meg",Arg.Int ((:=) mem)," How many megabytes to preallocate (default 0)"; + "-seed", Arg.Int ((:=) seed), " PRNG seed (default 0)"; + "-teststd", Arg.Unit (fun () -> mode := Test_std), " Test stdlib (default)"; + "-test", Arg.Unit (fun () -> mode := Test), " Select test mode"; + "-bench1", Arg.Unit (fun () -> mode := Bench1), " Select bench mode 1"; + "-bench2", Arg.Unit (fun () -> mode := Bench2), " Select bench mode 2"; +];; +let anonymous x = raise (Arg.Bad ("unrecognised option "^x));; + +let main () = + Arg.parse options anonymous usage; + + Printf.printf "Command line is:"; + for i = 0 to Array.length Sys.argv - 1 do + Printf.printf " %s" Sys.argv.(i); + done; + Printf.printf "\n"; + + ignore (String.create (1048576 * !mem)); + Gc.full_major (); + let limit = !size in + let a2l = Array.to_list in + let l2ak x y = Array.of_list x in + let id = fun x -> x in + let fst x y = x in + let snd x y = y in + + match !mode with + | Test_std -> begin + test "List.sort" false List.sort List.sort lc lc; + test "List.stable_sort" true List.stable_sort List.stable_sort lc lc; + test "Array.sort" false Array.sort Array.sort ac ac; + test "Array.stable_sort" true Array.stable_sort Array.stable_sort ac ac; + printf "Number of tests failed: %d\n" !numfailed; + end; + | Test -> begin + test "Sort.list" true Sort.list Sort.list ll ll; + test "Sort.array" false Sort.array Sort.array al al; + test "lmerge_3" false lmerge_3 lmerge_3 ll ll; + for i = 0 to List.length lnew - 1 do + let (name, f1, stable) = List.nth lnew i in + let (_, f2, _) = List.nth lnew i in + test name stable f1 f2 lc lc; + done; + for i = 0 to List.length anew - 1 do + let (name, f1, stable) = List.nth anew i in + let (_, f2, _) = List.nth anew i in + test name stable f1 f2 ac ac; + done; + printf "Number of tests failed: %d\n" !numfailed; + end; + | Bench1 -> begin + let b = bench1 in + (* + b limit "Sort.list" Sort.list ll; + b limit "Sort.array" Sort.array al; + b limit "lmerge_3" lmerge_3 ll; + *) + for i = 0 to List.length lnew - 1 do + let (name, f, stable) = List.nth lnew i in + b limit name f lc; + done; + for i = 0 to List.length anew - 1 do + let (name, f, stable) = List.nth anew i in + b limit name f ac; + done; + end; + | Bench2 -> begin + let b = bench2 in + (* + b limit "Sort.list" Sort.list ll; + b limit "Sort.array" Sort.array al; + b limit "lmerge_3" lmerge_3 ll; + *) + for i = 0 to List.length lnew - 1 do + let (name, f, stable) = List.nth lnew i in + b limit name f lc; + done; + for i = 0 to List.length anew - 1 do + let (name, f, stable) = List.nth anew i in + b limit name f ac; + done; + end; +;; + +if not !Sys.interactive then Printexc.catch main ();; + +(* $Id$ *) |