## rw-vector-quicksort-g.pkg
# Compiled by:
# src/lib/std/standard.lib# generic for in-place sorting of abstract arrays.
# Uses an engineered version of quicksort due to
# Bentley and McIlroy.
# Compare to:
# src/lib/src/rw-vector-quicksort.pkg### "I don't know half of you
### half as well as I should like;
### and I like less than half of you
### half as well as you deserve."
###
### -- Bilbo
generic package rw_vector_quicksort_g (a: Typelocked_Rw_Vector ) # Typelocked_Rw_Vector is from src/lib/std/src/typelocked-rw-vector.api: (weak)
Typelocked_Rw_Vector_Sort # Typelocked_Rw_Vector_Sort is from src/lib/src/typelocked-rw-vector-sort.api{
package a = a;
fun isort (rw_vector, start, n, compare)
=
{ fun item i
=
a::get (rw_vector, i);
fun swap (i, j)
=
{ tmp = a::get (rw_vector, i);
a::set (rw_vector, i, a::get (rw_vector, j)); a::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);
rw_vector;
};
fun sort_range (rw_vector, start, n, compare)
=
{ fun item i = a::get (rw_vector, i);
fun swap (i, j)
=
{ tmp = a::get (rw_vector, i);
a::set (rw_vector, i, a::get (rw_vector, j));
a::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;
(LESS, _)
=>
case (compare (a', c'))
LESS => c;
_ => a;
esac;
(_, GREATER)
=>
b;
_ =>
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;
sort (start, n);
};
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' = a::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 (a::get (rw_vector, 0), 1);
fi;
};
}; # rw_vector_quicksort_g
## COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See SMLNJ-COPYRIGHT file for details.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.