On Thu, 24 Nov 2022 18:51:12 +0000
"J. Gareth Moreton via fpc-devel" <fpc-devel@lists.freepascal.org> wrote:
> Hi everyone,
>
> I just need to touch on the knowledge base. What tests exist that test
> the functionality of rtl/inc/sortbase.pp? As Olly suggested, I'm
> looking at creating Introsort for this unit as well, but I need to know
> if such a unit already exists or if I need to make my own.
Some times ago I wrote a couple of merge sort routines to use in BWT,
the project never goes further so they remain at level of numerical
values input only.
They should have a good worst case scenario.
In the merge.pas the parameter nrm has to be false when the dimension
of the array is not a power of two.
There also is a check head-tail of the blocks to move in a single pass
the smaller one.
The natural.pas is recursive in the initial division in blocks and allow
for adaptation for inputs already sorted.
If you find them useful, you are free to made anything you want.
Marco
--
Simplex sigillum veri
PROGRAM Sort;
CONST
len=20;
VAR
a:ARRAY[0..2*len-1] OF Byte;
i,j:Word;
src:Boolean;
PROCEDURE MergeSort(VAR src:Boolean;nrm:Boolean);
VAR
dbl,sub,i,j,k,l,m,n,dst,lim:Word;
x,y,z:Integer;
BEGIN
dbl:=len SHL 1;
sub:=1;
WHILE sub<len DO
BEGIN
i:=0;
j:=sub;
IF src THEN
BEGIN
Inc(i,len);
Inc(j,len);
k:=dbl;
dst:=0;
END
ELSE
BEGIN
k:=len;
dst:=len;
END;
n:=sub SHL 1;
WHILE i<k DO
BEGIN
l:=i+sub;
m:=j+sub;
lim:=dst+n;
IF nrm THEN
BEGIN
x:=sub;
y:=sub;
z:=n;
END
ELSE
BEGIN
IF src THEN
BEGIN
IF l>dbl THEN
l:=dbl;
IF m>dbl THEN
m:=dbl;
IF lim>len THEN
lim:=len;
END
ELSE
BEGIN
IF l>len THEN
l:=len;
IF m>len THEN
m:=len;
IF lim>dbl THEN
lim:=dbl;
END;
x:=l-i;
y:=m-j;
z:=m-i;
END;
IF a[l-1]<=a[j] THEN
BEGIN
IF z>0 THEN
Move(a[i],a[dst],z);
i:=l;
j:=m;
dst:=lim;
END
(* Solo < per avere un metodo stabile *)
ELSE IF a[m-1]<a[i] THEN
BEGIN
IF y>0 THEN
Move(a[j],a[dst],y)
ELSE
y:=0;
IF x>0 THEN
Move(a[i],a[dst+y],x);
i:=l;
j:=m;
dst:=lim;
END;
WHILE dst<lim DO
BEGIN
x:=a[i];
y:=a[j];
IF (j>=m) OR ((i<l) AND (x<=y)) THEN
BEGIN
a[dst]:=x;
Inc(i);
END
ELSE
BEGIN
a[dst]:=y;
Inc(j);
END;
Inc(dst);
END;
Inc(i,sub);
Inc(j,sub);
END;
sub:=n;
src:=NOT src;
END;
END;
BEGIN
Randomize;
FOR i:=0 TO len-1 DO
BEGIN
a[i]:=Random(256);
Write(' ',a[i]);
END;
WriteLn;
src:=False;
MergeSort(src,False);
IF NOT src THEN
j:=0
ELSE
j:=len;
FOR i:=j TO j+len-1 DO
Write(' ',a[i]);
END.
PROGRAM Sort;
CONST
len=20;
VAR
a,b:ARRAY[0..len-1] OF Byte;
h,t,idx:Word;
PROCEDURE NaturalSort(i,j,k:Word;run:Byte);
VAR
l,m:Word;
BEGIN
l:=i;
m:=j;
IF run<>2 THEN
BEGIN
t:=a[i];
Inc(i);
h:=a[i];
WHILE (i<=m) AND (h>=t) DO
BEGIN
t:=h;
Inc(i);
h:=a[i];
END;
Dec(i);
END
ELSE
i:=k;
IF i<m THEN
BEGIN
IF run<>1 THEN
BEGIN
h:=a[j];
Dec(j);
t:=a[j];
WHILE (j>=l) AND (h>=t) DO
BEGIN
h:=t;
Dec(j);
t:=a[j];
END;
Inc(j);
END
ELSE
j:=k;
IF i-l>=m-j THEN
BEGIN
k:=i+1;
NaturalSort(k,m,j,1);
j:=k;
END
ELSE
BEGIN
k:=j-1;
NaturalSort(l,k,i,2);
i:=k;
END;
END
ELSE
k:=len;
IF k<len THEN
BEGIN
h:=0;
t:=0;
WHILE l<=m DO
IF h=t THEN
IF (l>i) OR (a[l]<=a[j]) THEN
Inc(l)
ELSE
BEGIN
b[h]:=a[l];
Inc(h);
a[l]:=a[j];
Inc(l);
Inc(j);
END
ELSE
BEGIN
IF l<=i THEN
BEGIN
b[h]:=a[l];
Inc(h);
END;
IF (j>m) OR (b[t]<=a[j]) THEN
BEGIN
a[l]:=b[t];
Inc(l);
Inc(t);
END
ELSE
BEGIN
a[l]:=a[j];
Inc(l);
Inc(j);
END;
END;
END;
END;
BEGIN
Randomize;
FOR idx:=0 TO len-1 DO
BEGIN
a[idx]:=Random(256);
Write(' ',a[idx]);
END;
WriteLn;
NaturalSort(0,len-1,len,0);
FOR idx:=0 TO len-1 DO
Write(' ',a[idx]);
END.
_______________________________________________
fpc-devel maillist - fpc-devel@lists.freepascal.org
https://lists.freepascal.org/cgi-bin/mailman/listinfo/fpc-devel
