program MSVCRTsort;
//{$rangeChecks on} // OK tested already
{$macro on}
Uses
SysUtils,DateUtils,strutils ; {for timer and midstr only, not needed for quicksort}
{===== start sort ====}
// for Linux external libc.so (I think)
function qsort(T:pointer;size:longint;szdata:integer;p:pointer):integer ; cdecl external 'msvcrt.dll' name 'qsort';
type
direction =(up,down);
casetype=(CaseSensitive,CaseInsensitive);
asp=^ansistring;
var
u : Array[0..255] of byte; {look up table for speed}
ct:casetype=CaseInsensitive;
Function lessthan(const a:ansistring;const b:ansiString):integer;
Var
n,lim,lena,lenb:longint;
begin
lena:=length(a);
lenb:=length(b);
if (lena<lenb) then lim:=lena else lim:=lenb ;
For n :=1 To lim do
begin
If u[ord(a[n])] < u[ord(b[n])] Then exit (-1);
If u[ord(a[n])] > u[ord(b[n])] Then exit (0);
end ;
exit( 0 ) ;
End;
Function morethan(const a:ansistring;const b:ansiString):integer;
Var
n,lim,lena,lenb:longint;
begin
lena:=length(a);
lenb:=length(b);
if (lena<lenb) then lim:=lena else lim:=lenb ;
For n :=1 To lim do
begin
If u[ord(a[n])] > u[ord(b[n])] Then exit (-1);
If u[ord(a[n])] < u[ord(b[n])] Then exit (0);
end ;
exit( 0 ) ;
End;
function callbackU( const n1:asp; const n2:asp):integer;
begin
if (ct=CaseInsensitive) then
begin
if lessthan(n1^,n2^)=-1 then exit(-1);
if morethan(n1^,n2^)=-1 then exit(1) ;
end
else
begin
if n1^<n2^ then exit(-1);
if n1^>n2^ then exit(1);
end ;
exit(0);
end;
function callbackD(const n1:asp;const n2:asp):integer;
begin
if (ct=CaseInsensitive) then
begin
if lessthan(n1^,n2^)=-1 then exit(1);
if morethan(n1^,n2^)=-1 then exit(-1);
end
else
begin
if n1^<n2^ then exit(1);
if n1^>n2^ then exit(-1);
end;
exit(0);
end;
procedure csort(var a:array of ansistring;lower:longint;upper:longint;d:direction;ctype :casetype);
procedure setlookuparray(var u:array of byte); // must run
var x,r:integer;
begin
for x:=0 to 255 do
begin
r:=x;
if (r<91) and (r>64) then r:=r+32;
u[x]:=r;
end;
end;
const
done:integer=0;
begin
if done=0 then
begin
setlookuparray(u);done:=1;
end;
ct:=ctype;
If d=up Then qsort( @a[Lower],((Upper)-(Lower)+1),sizeof(ansistring),@callbackU);
If d=down Then qsort( @a[Lower],((Upper)-(Lower)+1),sizeof(ansistring),@callbackD);
end;
{===== end sort ====}
{ try it out}
function range(f:longint;l:longint):longint ;
begin
range:= random(1000000) mod (l-f+1) + f ;
end;
function mixcases:byte;
var i:integer;
begin
i:=range(97,122);
if random(10)<5 then i:=i-32;
exit(i)
end;
var
a:array of ansistring;
l,i,maxlen:longint;
StartTime: TTime;
Elapsed: Int64;
begin
maxlen:=1000000;
writeln('Creating a mixed case string array of ',maxlen,' elements');
setlength(a,maxlen);
{$define w:= char(mixcases)}
for l:=0 to maxlen-1 do
begin
for i:=1 to 50 do a[l]+=w;
a[l]:=midstr(a[l],1,range(10,49)); // make different lengths
end;
writeln('strings created, now sorting ');
writeln;
StartTime := Time;
csort(a,0,length(a),down,CaseInsensitive); //<< ------- method
Elapsed := MillisecondsBetween(Time, StartTime);
for l:=0 to 20 do writeln(a[l]);
writeln('. . .');
writeln('. . .');
for l:=length(a)-20 to length(a)-1 do writeln(a[l]);
writeln;
writeln('Time taken ',Elapsed,' milliseconds, ',ct);
readln;
end.