l4/pkg/ocaml/ocaml/contrib/stdlib/sort.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../LICENSE.     *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id: sort.ml 7164 2005-10-25 18:34:07Z doligez $ *)
  15
  16 (* Merging and sorting *)
  17
  18 open Array
  19
  20 let rec merge order l1 l2 =
  21   match l1 with
  22     [] -> l2
  23   | h1 :: t1 ->
  24       match l2 with
  25         [] -> l1
  26       | h2 :: t2 ->
  27           if order h1 h2
  28           then h1 :: merge order t1 l2
  29           else h2 :: merge order l1 t2
  30
  31 let list order l =
  32   let rec initlist = function
  33       [] -> []
  34     | [e] -> [[e]]
  35     | e1::e2::rest ->
  36         (if order e1 e2 then [e1;e2] else [e2;e1]) :: initlist rest in
  37   let rec merge2 = function
  38       l1::l2::rest -> merge order l1 l2 :: merge2 rest
  39     | x -> x in
  40   let rec mergeall = function
  41       [] -> []
  42     | [l] -> l
  43     | llist -> mergeall (merge2 llist) in
  44   mergeall(initlist l)
  45
  46 let swap arr i j =
  47   let tmp = unsafe_get arr i in
  48   unsafe_set arr i (unsafe_get arr j);
  49   unsafe_set arr j tmp
  50
  51 (* There is a known performance bug in the code below.  If you find
  52    it, don't bother reporting it.  You're not supposed to use this
  53    module anyway. *)
  54 let array cmp arr =
  55   let rec qsort lo hi =
  56     if hi - lo >= 6 then begin
  57       let mid = (lo + hi) lsr 1 in
  58       (* Select median value from among LO, MID, and HI. Rearrange
  59          LO and HI so the three values are sorted. This lowers the
  60          probability of picking a pathological pivot.  It also
  61          avoids extra comparisons on i and j in the two tight "while"
  62          loops below. *)
  63       if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo;
  64       if cmp (unsafe_get arr hi) (unsafe_get arr mid) then begin
  65         swap arr mid hi;
  66         if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo
  67       end;
  68       let pivot = unsafe_get arr mid in
  69       let i = ref (lo + 1) and j = ref (hi - 1) in
  70       if not (cmp pivot (unsafe_get arr hi))
  71          || not (cmp (unsafe_get arr lo) pivot)
  72       then raise (Invalid_argument "Sort.array");
  73       while !i < !j do
  74         while not (cmp pivot (unsafe_get arr !i)) do incr i done;
  75         while not (cmp (unsafe_get arr !j) pivot) do decr j done;
  76         if !i < !j then swap arr !i !j;
  77         incr i; decr j
  78       done;
  79       (* Recursion on smaller half, tail-call on larger half *)
  80       if !j - lo <= hi - !i then begin
  81         qsort lo !j; qsort !i hi
  82       end else begin
  83         qsort !i hi; qsort lo !j
  84       end
  85     end in
  86   qsort 0 (Array.length arr - 1);
  87   (* Finish sorting by insertion sort *)
  88   for i = 1 to Array.length arr - 1 do
  89     let val_i = (unsafe_get arr i) in
  90     if not (cmp (unsafe_get arr (i - 1)) val_i) then begin
  91       unsafe_set arr i (unsafe_get arr (i - 1));
  92       let j = ref (i - 1) in
  93       while !j >= 1 && not (cmp (unsafe_get arr (!j - 1)) val_i) do
  94         unsafe_set arr !j (unsafe_get arr (!j - 1));
  95         decr j
  96       done;
  97       unsafe_set arr !j val_i
  98     end
  99   done