標準ライブラリより高速なマージソートの実装

MergeSort.ml

let merge_sort ( <= ) =
  (* 非減少列をマージして減少列を得る *)
  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)
  (* 減少列をマージして非減少列を得る *)
  and rev_merge_rev 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_rev l1 t2 (h2 :: acc)
        else rev_merge_rev t1 l2 (h1 :: acc) in
  let rec push xs m xss =
    if m land 1 = 0
    then xs :: xss
    else push_rev (rev_merge (List.hd xss) xs []) (m lsr 1) (List.tl xss)
  and push_rev xs m xss =
    if m land 1 = 0
    then xs :: xss
    else push (rev_merge_rev (List.hd xss) xs []) (m lsr 1) (List.tl xss) in
  let rec extract xs m xss =
    if m = 0 then xs
    else
      match m land 3 with
      | 0 -> extract xs (m lsr 2) xss
      | 2 -> extract (rev_merge_rev (List.hd xss) (List.rev xs) []) (m lsr 2) (List.tl xss)
      | _ -> extract_rev (rev_merge (List.hd xss) xs []) (m lsr 1) (List.tl xss)
  and extract_rev xs m xss =
    if m = 0 then List.rev xs
    else
      match m land 3 with
      | 0 -> extract_rev xs (m lsr 2) xss
      | 2 -> extract_rev (rev_merge (List.hd xss) (List.rev xs) []) (m lsr 2) (List.tl xss)
      | _ -> extract (rev_merge_rev (List.hd xss) xs []) (m lsr 1) (List.tl xss) in
  let rec merge_sort m stack = function
    | [] -> extract_rev [] m stack
    | [x] -> extract_rev [x] m stack
    | x1 :: x2 :: xs ->
        let rec cut_non_decreasing acc y = function
          | [] -> extract_rev (y :: acc) m stack
          | (x :: xs) as l ->
              if y <= x
              then cut_non_decreasing (y :: acc) x xs
              else merge_sort (m + 1) (push_rev (y :: acc) m stack) l in
        let rec cut_decreasing acc y = function
          | [] -> extract_rev (List.rev_append acc [y]) m stack
          | (x :: xs) as l ->
              if y <= x
              then merge_sort (m + 1) (push_rev (List.rev_append acc [y]) m stack) l
              else cut_decreasing (y :: acc) x xs in
        if x1 <= x2
        then cut_non_decreasing [x1] x2 xs
        else cut_decreasing [x1] x2 xs in
  merge_sort 0 [];;

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 () -> List.sort compare l);;
measure (fun () -> (merge_sort ( <= ) l));;

(* ちゃんとソートされているか *)
let a = Array.of_list @@ merge_sort ( <= ) l
let b = List.for_all (fun i -> a.(i) <= a.(i + 1)) @@ Array.to_list @@ Array.init (Array.length a - 1) @@ fun i -> i

(* ソート済の入力 *)
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]);;