## rw-vector-quicksort.pkg
# Compiled by:
# src/lib/std/standard.lib# Package for in-place sorting of typeagnostic arrays.
# Uses an engineered version of quicksort due to
# Bentley and McIlroy.
# Compare to:
# src/lib/src/rw-vector-quicksort-g.pkg### "Believe me, my young friend, there is
### NOTHING -- absolute nothing -- half so
### much worth doing as simply messing about
### in boats."
###
### -- The Water Rat
package rw_vector_quicksort: (weak) Rw_Vector_Sort { # Rw_Vector_Sort is from src/lib/src/rw-vector-sort.api package a= rw_vector; # rw_vector is from src/lib/std/src/rw-vector.pkg Rw_Vector(X) = a::Rw_Vector(X);
get = unsafe::rw_vector::get;
set = unsafe::rw_vector::set;
fun isort (rw_vector, start, n, compare)
=
rw_vector
where
fun item i
=
get (rw_vector, i);
fun swap (i, j)
=
{ tmp = get (rw_vector, i);
set (rw_vector, i, get (rw_vector, j));
set (rw_vector, j, tmp);
};
fun vecswap (i, j, 0) => ();
vecswap (i, j, n) => { swap (i, j); vecswap (i+1, j+1, n - 1); };
end;
fun insert_sort (start, n)
=
{ limit = start+n;
fun outer i
=
if (i < limit)
#
fun inner j
=
if (j == start)
#
outer (i+1);
else
j' = j - 1;
if (compare (item j', item j) == GREATER)
#
swap (j, j'); inner j';
else
outer (i+1);
fi;
fi;
inner i;
fi;
outer (start+1);
};
insert_sort (start, n);
end;
fun sort_range (rw_vector, start, n, compare)
=
sort (start, n)
where
fun item i
=
get (rw_vector, i);
fun swap (i, j)
=
{ tmp = get (rw_vector, i);
set (rw_vector, i, get (rw_vector, j));
set (rw_vector, j, tmp);
};
fun vecswap (i, j, 0) => ();
vecswap (i, j, n) => { swap (i, j); vecswap (i+1, j+1, n - 1); };
end;
fun insert_sort (start, n)
=
{ limit = start+n;
fun outer i
=
if (i < limit)
fun inner j
=
if (j == start)
outer (i+1);
else
j' = j - 1;
if (compare (item j', item j) == GREATER)
swap (j, j');
inner j';
else
outer (i+1);
fi;
fi;
inner i;
fi;
outer (start+1);
};
fun med3 (a, b, c)
=
{ a' = item a;
b' = item b;
c' = item c;
case (compare (a', b'), compare (b', c'))
#
(LESS, LESS) => b;
(_, GREATER) => b;
#
(LESS, _)
=>
case (compare (a', c')) LESS => c;
_ => a;
esac;
_ =>
case (compare (a', c')) LESS => a;
_ => c;
esac;
esac;
};
fun get_pivot (a, n)
=
if (n <= 7)
#
a + n / 2;
else
p1 = a;
pm = a + n / 2;
pn = a + n - 1;
if (n <= 40)
#
med3 (p1, pm, pn);
else
d = n / 8;
p1 = med3 (p1, p1+d, p1+2*d);
pm = med3 (pm-d, pm, pm+d);
pn = med3 (pn - 2*d, pn-d, pn);
med3 (p1, pm, pn);
fi;
fi;
fun quick_sort (arg as (a, n))
=
{ fun bottom limit
=
loop
where
fun loop (arg as (pa, pb))
=
if (pb > limit)
#
arg;
else
case (compare (item pb, item a))
#
GREATER => arg;
LESS => loop (pa, pb+1);
_ => { swap arg; loop (pa+1, pb+1); };
esac;
fi;
end;
fun top limit
=
loop
where
fun loop (arg as (pc, pd))
=
if (limit > pc)
#
arg;
else
case (compare (item pc, item a))
#
LESS => arg;
GREATER => loop (pc - 1, pd);
_ => { swap arg; loop (pc - 1, pd - 1); };
esac;
fi;
end;
fun split (pa, pb, pc, pd)
=
{ my (pa, pb) = bottom pc (pa, pb);
my (pc, pd) = top pb (pc, pd);
if (pb > pc)
#
(pa, pb, pc, pd);
else
swap (pb, pc);
split (pa, pb+1, pc - 1, pd);
fi;
};
pm = get_pivot arg;
swap (a, pm);
pa = a + 1;
pc = a + (n - 1);
my (pa, pb, pc, pd)
=
split (pa, pa, pc, pc);
pn = a + n;
r = int::min (pa - a, pb - pa);
vecswap (a, pb-r, r);
r = int::min (pd - pc, pn - pd - 1);
vecswap (pb, pn-r, r);
n' = pb - pa;
if (n' > 1) sort (a, n'); fi;
n' = pd - pc;
if (n' > 1) sort (pn-n', n'); fi;
();
}
also
fun sort (arg as (_, n))
=
if (n < 7) insert_sort arg;
else quick_sort arg;
fi;
end;
fun sort compare rw_vector
=
sort_range (rw_vector, 0, a::length rw_vector, compare);
fun sorted compare rw_vector
=
{ len = a::length rw_vector;
fun s (v, i)
=
{ v' = get (rw_vector, i);
case (compare (v, v'))
#
GREATER => FALSE;
_ => if (i+1 == len) TRUE;
else s (v', i+1);
fi;
esac;
};
if (len == 0
or len == 1) TRUE;
else s (get (rw_vector, 0), 1);
fi;
};
}; # package rw_vector_quicksort