ソート済の入力にO(N)で動作し，ランダムな入力に対してもList.sortより高速なマージソート

MergeSort.ml

(* 非減少列をマージして減少列を得る *)
let rec rev_merge ( <= ) l1 l2 acc =
  match l1, l2 with
  | [], l2 -> List.rev_append l2 acc
  | l1, [] -> List.rev_append l1 acc
  | h1 :: t1, h2 :: t2 ->
      if h1 <= h2
      then rev_merge ( <= ) t1 l2 (h1 :: acc)
      else rev_merge ( <= ) l1 t2 (h2 :: acc)

(* リストの先頭から非減少列を切り出して反転して返す *)
let rec cut_sorted_section ( <= ) y = function
  | [] -> ([y], [])
  | x :: xs ->
      if y <= x
      then cut_non_decreasing ( <= ) [y] x xs
      else cut_decreasing ( <= ) [y] x xs
and cut_non_decreasing ( <= ) acc y = function
  | [] -> (y :: acc, [])
  | (x :: xs) as l ->
      if y <= x
      then cut_non_decreasing ( <= ) (y :: acc) x xs
      else (y :: acc, l)
and cut_decreasing ( <= ) acc y = function
  | [] -> (List.rev_append acc [y], [])
  | (x :: xs) as l ->
      if y <= x
      then (List.rev_append acc [y], l)
      else cut_decreasing ( <= ) (y :: acc) x xs

let rec push ( <= ) ( > ) m xs = function
  | [] -> [(m, xs)]
  | ((n, ys) :: rest) as stack ->
      if Pervasives.( < ) m n
      then (m, xs) :: stack
      else push ( > ) ( <= ) (m + 1) (rev_merge ( <= ) ys xs []) rest

let rec extract ( <= ) ( > ) m xs = function
  | [] -> (m, xs)
  | (n, ys) :: rest ->
      if m mod 2 = n mod 2 then
        extract ( > ) ( <= ) (n + 1) (rev_merge ( <= ) ys xs []) rest
      else
        extract ( <= ) ( > ) (n + 1) (rev_merge ( > ) ys (List.rev xs) []) rest

let merge_sort ( <= ) =
  let ( > ) x y = not (x <= y) in
  let rec merge_sort stack = function
    | [] -> extract ( > ) ( <= ) 0 [] stack
    | x :: xs ->
        let (ys, rest) = cut_sorted_section ( <= ) x xs in
        merge_sort (push ( > ) ( <= ) 0 ys stack) rest in
  fun xs ->
    let (n, xs) = merge_sort [] xs in
    if n mod 2 = 1
    then xs
    else List.rev xs

Random.self_init ();;
let measure f =
    let start = Sys.time () in
    f ();
    Sys.time () -. start;;

(* ランダムな入力 *)
let l = Array.to_list (Array.init 1919810 (fun _ -> Random.bits ()));;
(* 大体同じ速度 *)
measure (fun _ -> ignore (List.sort compare l));;
measure (fun _ -> ignore (merge_sort ( <= ) l));;

(* ソート済の入力 *)
let l' = List.sort compare l;;
measure (fun _ -> ignore (List.sort compare l'));;
(* とても速い *)
measure (fun _ -> ignore (merge_sort ( <= ) l'));;

(* 安定ソート *)
merge_sort (fun (x, _) (y, _) -> x <= y) (List.mapi (fun i x -> (x, i)) [1; 1; 2; 1; 3; 2]);;