Add simple smooth and tail-recursive mergesorts in OCaml

Author: pi8027

benchmark/ocaml/mergesort_ocaml.ml

@@ -104,9 +104,8 @@ let rec sort_rec (<=) n xs =
     let s2, xs2 = sort_rec (<=) n2 xs1 in
     (merge (<=) s1 s2, xs2)
 
-let sort (<=) = function
-  | [] -> []
-  | xs -> fst (sort_rec (<=) (length xs) xs)
+let sort (<=) xs =
+  if xs = [] then [] else fst (sort_rec (<=) (length xs) xs)
 
 end;;
 
@@ -131,6 +130,66 @@ let sort (<=) s = sort_rec (<=) 0 [] s
 
 end;;
 
+module Smooth = struct
+
+open NTRMerge
+
+let rec push (<=) xs k stack =
+  match k mod 2, stack with
+  | 0, _ -> xs :: stack
+  | 1, ys :: stack -> push (<=) (merge (<=) ys xs) (k / 2) stack
+
+let rec pop (<=) xs = function
+  | [] -> xs
+  | ys :: stack -> pop (<=) (merge (<=) ys xs) stack
+
+let rec sort_rec (<=) k stack s =
+  let rec sort_rec' mode accu x s =
+    let accu = x :: accu in
+    match s with
+    | y :: s when (x <= y) = mode -> sort_rec' mode accu y s
+    | _ -> sort_rec (<=) (k + 1)
+             (push (<=) (if mode then rev accu else accu) k stack) s
+  in
+  match s with
+  | x :: y :: s -> sort_rec' (x <= y) [x] y s
+  | _ -> pop (<=) s stack
+
+let sort (<=) s = sort_rec (<=) 0 [] s
+
+end;;
+
+module TailRec = struct
+
+open TRMerge
+
+let rec push (<=) mode xs k stack =
+  let (>=) x y = (<=) y x in
+  match k mod 2, stack with
+  | 0, _ -> xs :: stack
+  | 1, ys :: stack ->
+    push (<=) (not mode)
+      (if mode then rev_merge (>=) xs ys [] else rev_merge (<=) ys xs [])
+      (k / 2) stack
+
+let rec pop (<=) mode xs k stack =
+  match k mod 2, stack with
+  | _, [] -> if mode then rev xs else xs
+  | 0, _ -> pop (<=) (not mode) (rev xs) (k / 2) stack
+  | 1, ys :: stack ->
+    pop (<=) (not mode)
+      (if mode then rev_merge (>=) xs ys [] else rev_merge (<=) ys xs [])
+      (k / 2) stack
+
+let rec sort_rec (<=) k stack =
+  function
+  | x :: s -> sort_rec (<=) (k + 1) (push (<=) false [x] k stack) s
+  | [] -> pop (<=) false [] k stack
+
+let sort (<=) s = sort_rec (<=) 0 [] s
+
+end;;
+
 (* Stack-based bottom-up non-tail-recursive mergesorts *)
 module NTRStack = struct
 

benchmark/ocaml/mergesort_ocaml.mli

@@ -14,6 +14,14 @@ module BottomUp : sig
   val sort : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list
 end
 
+module Smooth : sig
+  val sort : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list
+end
+
+module TailRec : sig
+  val sort : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list
+end
+
 module NTRStack : sig
   val sort3 : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list
   val sortN : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list

benchmark/ocaml/test_stability.ml

@@ -12,6 +12,8 @@ QCheck.Test.check_exn (test_stability NaiveTopDown.sort);;
 QCheck.Test.check_exn (test_stability NaiveBottomUp.sort);;
 QCheck.Test.check_exn (test_stability TopDown.sort);;
 QCheck.Test.check_exn (test_stability BottomUp.sort);;
+QCheck.Test.check_exn (test_stability Smooth.sort);;
+QCheck.Test.check_exn (test_stability TailRec.sort);;
 QCheck.Test.check_exn (test_stability NTRStack.sort3);;
 QCheck.Test.check_exn (test_stability NTRStack.sortN);;
 QCheck.Test.check_exn (test_stability NTRStack.sort3N);;