318 lines
8.1 KiB
ObjectPascal
318 lines
8.1 KiB
ObjectPascal
{$A+,B+,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
|
|
|
unit file13;
|
|
|
|
interface
|
|
|
|
uses
|
|
crt,dos,
|
|
|
|
{rcg11172000 no overlay under Linux.}
|
|
{overlay,}
|
|
|
|
myio,
|
|
file0, file1, file2,
|
|
common;
|
|
|
|
procedure sort;
|
|
|
|
implementation
|
|
|
|
var totfils,totbases:longint;
|
|
bubblesortend:integer;
|
|
sortt:char;
|
|
isascend:boolean;
|
|
|
|
procedure switch(a,b:integer);
|
|
var f1,f2:ulfrec;
|
|
begin
|
|
seek(ulff,a); read(ulff,f1);
|
|
seek(ulff,b); read(ulff,f2); seek(ulff,b); write(ulff,f1);
|
|
seek(ulff,a); write(ulff,f2);
|
|
end;
|
|
|
|
function greater(islesser,isequ:boolean; r1,r2:integer):boolean;
|
|
var f1,f2:ulfrec;
|
|
b,c:boolean;
|
|
|
|
procedure figure1;
|
|
begin
|
|
case sortt of
|
|
'B':if (isequ) then b:=(f1.description<=f2.description)
|
|
else b:=(f1.description<f2.description);
|
|
'D':if (isequ) then b:=(f1.daten<=f2.daten)
|
|
else b:=(f1.daten<f2.daten);
|
|
'E':if (isequ) then b:=(copy(f1.filename,10,3)<=copy(f2.filename,10,3))
|
|
else b:=(copy(f1.filename,10,3)<copy(f2.filename,10,3));
|
|
'F':if (isequ) then b:=(f1.filepoints<=f2.filepoints)
|
|
else b:=(f1.filepoints<f2.filepoints);
|
|
'N':if (isequ) then b:=(f1.filename<=f2.filename)
|
|
else b:=(f1.filename<f2.filename);
|
|
'O':if (isequ) then b:=(f1.owner<=f2.owner)
|
|
else b:=(f1.owner<f2.owner);
|
|
'S':if (isequ) then b:=(f1.blocks<=f2.blocks)
|
|
else b:=(f1.blocks<f2.blocks);
|
|
'T':if (isequ) then b:=(f1.nacc<=f2.nacc)
|
|
else b:=(f1.nacc<f2.nacc);
|
|
end;
|
|
end;
|
|
|
|
procedure figure2;
|
|
begin
|
|
case sortt of
|
|
'B':if (isequ) then b:=(f1.description>=f2.description)
|
|
else b:=(f1.description>f2.description);
|
|
'D':if (isequ) then b:=(f1.daten>=f2.daten)
|
|
else b:=(f1.daten>f2.daten);
|
|
'E':if (isequ) then b:=(copy(f1.filename,10,3)>=copy(f2.filename,10,3))
|
|
else b:=(copy(f1.filename,10,3)>copy(f2.filename,10,3));
|
|
'F':if (isequ) then b:=(f1.filepoints>=f2.filepoints)
|
|
else b:=(f1.filepoints>f2.filepoints);
|
|
'N':if (isequ) then b:=(f1.filename>=f2.filename)
|
|
else b:=(f1.filename>f2.filename);
|
|
'O':if (isequ) then b:=(f1.owner>=f2.owner)
|
|
else b:=(f1.owner>f2.owner);
|
|
'S':if (isequ) then b:=(f1.blocks>=f2.blocks)
|
|
else b:=(f1.blocks>f2.blocks);
|
|
'T':if (isequ) then b:=(f1.nacc>=f2.nacc)
|
|
else b:=(f1.nacc>f2.nacc);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if (r1<r2) then begin
|
|
seek(ulff,r1); read(ulff,f1);
|
|
seek(ulff,r2); read(ulff,f2);
|
|
end else begin
|
|
seek(ulff,r2); read(ulff,f2);
|
|
seek(ulff,r1); read(ulff,f1);
|
|
end;
|
|
|
|
if (isascend) then islesser:=not islesser;
|
|
if (islesser) then figure1 else figure2;
|
|
greater:=b;
|
|
end;
|
|
|
|
(* *
|
|
* While I personally think labels are stupid as *@#((#@!#$, and they look *
|
|
* like *#$@*, I kept them in for lack of a better idea! *
|
|
*)
|
|
procedure mainsort(pl:integer);
|
|
label 10,20,30,40,50,60,70,80;
|
|
const maxsortrec=2000; (* maximum size of directory which can be processed *)
|
|
var hold,pass:array[1..maxsortrec] of integer;
|
|
a,b,c,d,e,f,x:integer;
|
|
begin
|
|
a:=pl; b:=0; c:=0; d:=1; e:=1; f:=0;
|
|
10:
|
|
if (a-e<9) then goto 70;
|
|
b:=e; c:=a;
|
|
20:
|
|
if (greater(TRUE,FALSE,b,c)) then begin
|
|
switch(c,b);
|
|
goto 60;
|
|
end;
|
|
30:
|
|
dec(c);
|
|
if (c>b) then goto 20;
|
|
inc(c);
|
|
40:
|
|
inc(d);
|
|
if (b-e<a-c) then begin
|
|
hold[d]:=c; pass[d]:=a;
|
|
a:=b;
|
|
goto 10;
|
|
end;
|
|
hold[d]:=e; pass[d]:=b;
|
|
e:=c;
|
|
goto 10;
|
|
50:
|
|
if (greater(FALSE,FALSE,c,b)) then begin
|
|
switch(c,b);
|
|
goto 30;
|
|
end;
|
|
60:
|
|
inc(b);
|
|
if (c>b) then goto 50;
|
|
inc(c);
|
|
goto 40;
|
|
70:
|
|
if (a-e+1=1) then goto 80;
|
|
for b:=e+1 to a do
|
|
for c:=e to (b-1) do begin
|
|
f:=b-c+e-1;
|
|
if (greater(TRUE,FALSE,f,f+1)) then begin
|
|
x:=f+1;
|
|
switch(f,x);
|
|
end;
|
|
end;
|
|
80:
|
|
e:=hold[d]; a:=pass[d];
|
|
dec(d);
|
|
if (d=0) then exit;
|
|
goto 10;
|
|
end;
|
|
|
|
procedure flipit(pl:integer);
|
|
var i:integer;
|
|
begin
|
|
for i:=1 to pl div 2 do switch(i,(pl-i)+1);
|
|
end;
|
|
|
|
procedure bubblesort(pl:integer);
|
|
var f1,f2:ulfrec;
|
|
i,j,numdone:integer;
|
|
foundit:boolean;
|
|
begin
|
|
if (bubblesortend>pl) then bubblesortend:=pl; { should never happen, but...}
|
|
numdone:=0;
|
|
repeat
|
|
i:=(bubblesortend+1)-numdone;
|
|
foundit:=FALSE;
|
|
while ((i<=pl) and (not foundit)) do
|
|
if (greater(FALSE,TRUE,1,i)) then foundit:=TRUE else inc(i);
|
|
|
|
{ while ((i<=pl) and (not greater(FALSE,TRUE,1,i))) do inc(i);}
|
|
seek(ulff,1); read(ulff,f1);
|
|
|
|
{ (i-1) __(i) }
|
|
{ | / }
|
|
{ x O + + + + + + + x x x x x x x ..... }
|
|
{ x + + + + + + + x x x x x x x ..... }
|
|
for j:=1 to i-2 do begin
|
|
seek(ulff,j+1); read(ulff,f2);
|
|
seek(ulff,j); write(ulff,f2);
|
|
end;
|
|
|
|
{ x + + + + + + + O x x x x x x x ..... }
|
|
seek(ulff,i-1); write(ulff,f1);
|
|
inc(numdone);
|
|
until ((numdone>=bubblesortend));
|
|
|
|
end;
|
|
|
|
function analysis(pl:integer):integer;
|
|
var i,j:integer;
|
|
c1,c2:boolean;
|
|
begin
|
|
analysis:=1;
|
|
c1:=TRUE; c2:=TRUE;
|
|
for i:=1 to pl-1 do begin
|
|
if (not greater(TRUE,TRUE,i,i+1)) then c1:=FALSE; { a }
|
|
if (not greater(FALSE,TRUE,i,i+1)) then c2:=FALSE; { d }
|
|
end;
|
|
if (c1) then analysis:=2; { list is backwards, so flip it }
|
|
if (c2) then analysis:=0; { list is already sorted }
|
|
if ((not c1) and (not c2)) then begin
|
|
c1:=FALSE; j:=0;
|
|
i:=pl-1;
|
|
while ((i>=1) and (not c1)) do begin
|
|
if (not greater(FALSE,TRUE,i,i+1)) then begin c1:=TRUE; j:=i; end;
|
|
dec(i);
|
|
end;
|
|
if ((c1) and (j/pl<0.15)) then begin
|
|
analysis:=3;
|
|
bubblesortend:=j;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure sortfiles(b:integer; var abort,next:boolean);
|
|
var s:string;
|
|
oldboard,pl,sortt:integer;
|
|
begin
|
|
oldboard:=fileboard;
|
|
if (fileboard<>b) then changefileboard(b);
|
|
if (fileboard=b) then begin
|
|
fiscan(pl);
|
|
seek(ulff,pl+1); truncate(ulff);
|
|
sprompt('Sorting '+#3#5+memuboard.name+#3#5+' #'+cstr(fileboard)+#3#1+
|
|
' ('+cstr(pl)+' files)');
|
|
abort:=FALSE; next:=FALSE;
|
|
sortt:=analysis(pl);
|
|
case sortt of 0:s:='.'; 1:s:=#3#0+'*'; 2:s:=#3#9+'x'; 3:s:=#3#9+'*'; end;
|
|
sprint(s);
|
|
case sortt of
|
|
0:;
|
|
1:mainsort(pl);
|
|
2:flipit(pl);
|
|
3:bubblesort(pl);
|
|
end;
|
|
wkey(abort,next);
|
|
close(ulff);
|
|
inc(totbases); inc(totfils,pl);
|
|
end;
|
|
fileboard:=oldboard;
|
|
end;
|
|
|
|
procedure sort;
|
|
var f:ulfrec;
|
|
sortstart,sortend,tooktime:datetimerec;
|
|
i:integer;
|
|
c:char;
|
|
global,abort,next,savepause:boolean;
|
|
begin
|
|
savepause:=(pause in thisuser.ac);
|
|
if (savepause) then thisuser.ac:=thisuser.ac-[pause];
|
|
|
|
repeat
|
|
nl; prt('Sorting method? (?=help) [N] : ');
|
|
onek(sortt,'QBDEFNOST?'^M);
|
|
if (sortt='?') then begin
|
|
nl;
|
|
lcmds(7,3,'Date','Brief description');
|
|
lcmds(7,3,'Name','Extension');
|
|
lcmds(7,3,'Owner','File points');
|
|
lcmds(7,3,'Size','Times downloaded');
|
|
lcmds(7,3,'Quit','');
|
|
end;
|
|
until ((sortt<>'?') or (hangup));
|
|
|
|
if (sortt=^M) then sortt:='N';
|
|
case sortt of
|
|
'D','F','O','S','T':isascend:=FALSE;
|
|
'Q':exit;
|
|
else
|
|
isascend:=TRUE;
|
|
end;
|
|
if (isascend) then c:='A' else c:='D';
|
|
prt('Order: (^3A^4)scending (^3D^4)escending (^3Q^4)uit : ['+c+'] : ');
|
|
onek(c,'QADN'^M);
|
|
case c of
|
|
'A':isascend:=TRUE;
|
|
'D':isascend:=FALSE;
|
|
'Q':exit;
|
|
end;
|
|
|
|
nl;
|
|
global:=pynq('Sort all directories? ');
|
|
nl;
|
|
|
|
totfils:=0; totbases:=0;
|
|
|
|
getdatetime(sortstart);
|
|
abort:=FALSE; next:=FALSE;
|
|
if (not global) then
|
|
sortfiles(fileboard,abort,next)
|
|
else begin
|
|
i:=0;
|
|
while ((not abort) and (i<=maxulb) and (not hangup)) do begin
|
|
if (fbaseac(i)) then sortfiles(i,abort,next);
|
|
inc(i);
|
|
wkey(abort,next);
|
|
if (next) then abort:=FALSE;
|
|
end;
|
|
end;
|
|
getdatetime(sortend);
|
|
timediff(tooktime,sortstart,sortend);
|
|
|
|
nl;
|
|
print('Sorted '+cstrl(totfils)+' file'+aonoff(totfils<>1,'s','')+
|
|
' in '+cstrl(totbases)+' base'+aonoff(totbases<>1,'s','')+
|
|
' - Took '+longtim(tooktime));
|
|
|
|
if (savepause) then thisuser.ac:=thisuser.ac+[pause];
|
|
end;
|
|
|
|
end.
|