(************************************************* *************************
**************** Написать программу, которая, используя ес- ***************
**************** тественное многопутевое слияние с 2*N-1 ***************
**************** вспомогательными файлами, сортирует после- ***************
**************** довательности без *явной* процедура слия- ***************
**************** ния распределенных файлов. Начальный файл ***************
**************** можно считать 2*N вспомогательным файлом. ***************
************************************************** ************************)
program Prog_Tree;
uses crt, sortrout, dos;
const n=7;
SortAmounts :array[1..3] of LongInt = (1000,5000,10000);

type TimeStruct=record
hour,min,sec,msec:WORD;
end;{TimeStruct}

var StartTime :TimeStruct;
CountSortAttempt :BYTE;

(************************************************* *************************
**************** Зарисывает текущее время в структуру &ts ***************
************************************************** ************************)
procedure GetCurrentTime(var ts:TimeStruct);
begin
GetTime(ts.hour,ts.min,ts.sec,ts.msec);
end;

(************************************************* *************************
*************** Выводит результат и время сортировки на экран *************
************************************************** ************************)
procedure CalculateTime;
var ResultTime :LongInt;
EndTime :TimeStruct;
begin
GetCurrentTime(EndTime);
gotoxy((CountSortAttempt-1)*26 +1, 19);
TextColor(LightGray);Write('--== ');
TextColor(White);Write(SortAmounts[CountSortAttempt],' elemes ');
TextColor(LightGray);Write('==--');
TextColor(White);
gotoxy((CountSortAttempt-1)*26 +1, 20);
writeln('Start at ',
StartTime.hour div 10,
StartTime.hour mod 10,':',
StartTime.min div 10,
StartTime.min mod 10,':',
StartTime.sec div 10,
StartTime.sec mod 10,'.',
StartTime.msec div 10,
StartTime.msec mod 10);
gotoxy((CountSortAttempt-1)*26 +1, 21);
writeln('Finish at ',
EndTime.hour div 10,
EndTime.hour mod 10,':',
EndTime.min div 10,
EndTime.min mod 10,':',
EndTime.sec div 10,
EndTime.sec mod 10,'.',
EndTime.msec div 10,
EndTime.msec mod 10);
ResultTime:=(EndTime.min-StartTime.min)*6000+
(EndTime.sec-StartTime.sec)*100+
(EndTime.msec-StartTime.msec);{in milisec}
gotoxy((CountSortAttempt-1)*26 +1, 22);
TextColor(White); Write(ResultTime); TextColor(LightGray); WriteLn(' hundredths seconds');
end;


(************************************************* *************************
**************** Разливает начальный файл в N+1..2*N файлы. ***************
************************************************** ************************)
procedure BreakBigFile;
var
count,i :longInt;
ValInLast :item;
ptr :FileRing;
size :byte;
buf :array[1..bufsize] of item;

begin
gotoxy(1,12);
TextColor(LightGray);
Write('Breaking the DataFile to ',n,' files:');clreol;
TextColor(LightGray);

RewriteArray(TRUE);
assign(FirstRingHead^.f,TemporaryDirectory+'\input .dat');
size:=sizeof(item);
reset(FirstRingHead^.f,size);
ptr:=SecondRingHead;

count:=0;
while count+bufsize <= SortAmounts[CountSortAttempt] do
begin
BlockRead(FirstRingHead^.f,buf,bufsize);
for i:=1 to bufsize do
begin
if ((count<>0) or (i>1)) and (ValInLast > buf[i]) then
begin
ptr:=ptr^.next;
ptr^.eof:=false;
if (ptr^.eor=true) then
begin
ptr^.eor:=false;
ptr^.Val:=buf[i];
end;
end;
ValInLast:=buf[i];
BlockWrite(ptr^.f,buf[i],1);
if (ptr=SecondRingHead) and (ptr^.eor=true) then
begin
ptr^.eof:=false;
ptr^.eor:=false;
ptr^.Val:=buf[i];
end;

end;
count:=count+bufsize;
gotoxy(35,12);
write((count*10) div (SortAmounts[CountSortAttempt] div 10),'% complete.');
end;
BlockRead(FirstRingHead^.f,buf,SortAmounts[CountSortAttempt]-count);
for i:=1 to SortAmounts[CountSortAttempt]-count do
begin
if ((count<>0) or (i>1)) and (ValInLast > buf[i]) then
begin
ptr:=ptr^.next;
ptr^.eof:=false;
if (ptr^.eor=true) then
begin
ptr^.eor:=false;
ptr^.Val:=buf[i];
end;
end;

ValInLast:=buf[i];
BlockWrite(ptr^.f,buf[i],1);
if (ptr=SecondRingHead) and (ptr^.eor=true) then
begin
ptr^.eof:=false;
ptr^.eor:=false;
ptr^.Val:=buf[i];
end;
end;
gotoxy(35,12);
write('100% complete. ');
TextColor(DarkGray);
WriteLn('File was breaked successfully.');
end;{// this breaks the main big file into N files}



(************************************************* *************************
************* Тетстирует результат, сравнивая соседние элементы ***********
************************************************** ************************)
procedure TestResultFile(var SrcFile:File);
var
count:LongInt;
i:WORD;
buf:array[1..BufSize] of item;
result:boolean;
LastVal:item;
begin
gotoxy(1,14);
reset(SrcFile,sizeof(item));
gotoxy((CountSortAttempt-1)*26 +1, 23);
TextColor(LightGray);Write('Test: ');
if FileSize(SrcFile)<>SortAmounts[CountSortAttempt] then
begin
TextColor(White);
Write('FAILED');
close(SrcFile);
exit;
end;

result:=true;
count:=0;
while count+bufsize<=SortAmounts[CountSortAttempt] do
begin
BlockRead(SrcFile,buf,bufsize);
for i:=1 to bufsize do
begin
if ((count<>0) or (i>1)) and result then
if (LastVal > buf[i]) then result:=FALSE;
LastVal:=buf[i];
end;
count:=count+bufsize;
end;
if result then
begin
BlockRead(SrcFile,buf,SortAmounts[CountSortAttempt]-count);
for i:=1 to SortAmounts[CountSortAttempt]-count do
if ((count<>0) or (i>1)) and (LastVal > buf[i]) then result:=FALSE
else LastVal:=buf[i];
end;

TextColor(White);
if result then Write('PASSED')
else Write('FAILED');
close(SrcFile);
end;


(************************************************* *************************
************* Возвращает указатель на структуру с минимальным *************
************* элементом, который следует записать в файл. *************
************************************************** ************************)
function FindMin(var StartFrom:FileRing):FileRing;
var ptr,MinPtr:FileRing;
i: byte;

procedure FindMatch(var p:FileRing);
begin
repeat
p:=p^.next;
until not(p^.eor);
end;{findMatch}

begin
MinPtr:=StartFrom;
FindMatch(MinPtr);
ptr:=MinPtr;
for i:=1 to n do
begin
FindMatch(ptr);
if (ptr^.val<MinPtr^.Val) then MinPtr:=ptr;
end;
FindMin:=MinPtr;
end;{FindMin}


(************************************************* *************************
************ Получает колличество файлов, всё ещё содержащих **************
************ элементы текущей серии. То есть используемые на **************
************ данном этапе сортировки. **************
************************************************** ************************)
procedure GetUsedFilesAndRuns(var Files:byte;
var Runs:byte;
var InRing:FileRing);
var TmpPtr:FileRing;
begin
TmpPtr:=InRing;
Files:=0;
Runs:=0;
repeat
if not(TmpPtr^.eof) then
begin
TmpPtr^.eof:=FALSE;
inc(Files);
end;
TmpPtr:=TmpPtr^.next;
until (TmpPtr=InRing);
Runs:=Files;
end;


(************************************************* *************************
**************** Основное звено - слияние с одновременным ***************
**************** разлиянием без непосредственной записи на ***************
**************** диск результата слияния, как один файл. ***************
************************************************** ************************)
procedure MergeFrom(Second:boolean);
var
FromPtr :FileRing;
MinPtr :FileRing;
CurrentVal :Item;
CurrentPtr :FileRing;
NumOfUsedFiles,
NumOfUsedRuns :BYTE;
buf :array[0..bufsize-1] of item;
bufcount :integer;

begin
if (Second) then
begin
FromPtr:=SecondRingHead;
CurrentPtr:=FirstRingHead;
CurrentPtr^.eor:=true;
end
else
begin
FromPtr:=FirstRingHead;
CurrentPtr:=SecondRingHead;
CurrentPtr^.eor:=true;
end;
CurrentVal:=FromPtr^.Val;
GetUsedFilesAndRuns(NumOfUsedFiles,NumOfUsedRuns,F romPtr);

bufcount:=0;

while (NumOfUsedFiles<>0) do
begin
while (NumOfUsedRuns<>0) do
begin
{Selecting of the minimal key}
MinPtr:=FindMin(FromPtr);

if (CurrentPtr^.eor)
or (MinPtr^.Val>=CurrentVal) then
begin
CurrentPtr^.eor:=false;
CurrentVal:=MinPtr^.Val;
if not EnableWriteBuffer then
BlockWrite(CurrentPtr^.f,MinPtr^.Val,1)
else (*Bufferization of writing*)
begin
if BufCount=bufSize-1 then
begin
{***** OverFilling of the buffer ******}
BlockWrite(CurrentPtr^.f,buf,bufsize-1);
bufcount:=0;
end;
buf[bufCount]:=MinPtr^.Val;
Inc(bufCount);
end;
if not eof(MinPtr^.f) then
begin
BlockRead(MinPtr^.f,MinPtr^.Val,1);
if (MinPtr^.Val < CurrentVal) then
begin
dec(NumOfUsedRuns);
MinPtr^.eor:=true;
end;
end
else
begin
Dec(NumOfUsedFiles);
Dec(NumOfUsedRuns);
MinPtr^.eor:=true;
MinPtr^.eof:=true;
{ writeln;}
end;
end
else
begin
if EnableWriteBuffer then
begin
{****** Flushing of write buffer ******}
BlockWrite(CurrentPtr^.f,buf,bufcount);
bufcount:=0;
end;
CurrentPtr:=CurrentPtr^.next;
CurrentVal:=MinPtr^.Val;
end;
end;
MinPtr:=FromPtr;
repeat
if not(MinPtr^.eof) then
begin
MinPtr^.eor:=false;
Inc(NumOfUsedRuns);
end;
MinPtr:=MinPtr^.next;
until MinPtr=FromPtr;
end;
{****** Flushing of write buffer ******}
BlockWrite(CurrentPtr^.f,buf,bufcount);
{END while there are files to sort}
Write('.');
end;


(************************************************* *************************
*************** Пороцедура вызывающая "разливание-слияние" ***************
*************** циклически до получения единственного файла ***************
*************** как признак конца процесса сортировки. ***************
************************************************** ************************)
procedure ProcessAdvancedMerge;
var Direction:boolean;
size:LongInt;
begin
TextColor(LightGray);
Write('Sorting');clreol;
TextColor(White);

Direction:=True;
GetCurrentTime(StartTime);
repeat
ResetArray(Direction,TRUE);
RewriteArray(not(Direction));
MergeFrom(Direction);
if Direction then
begin
Direction:=FALSE;
Size:=FileSize(FirstRingHead^.f);
end
else
begin
Direction:=TRUE;
Size:=FileSize(SecondRingHead^.f);
end;
CloseFiles(TRUE);
CloseFiles(FALSE);
until (Size=SortAmounts[CountSortAttempt]);
Writeln('Sorting accompleshed.');

CalculateTime;

if Direction then TestResultFile(SecondRingHead^.f)
else TestResultFile(FirstRingHead^.f)
end;


(************************************************* *************************
*********** Основная программа - три повтора по 1k, 5k и 10k. *************
************************************************** ************************)
BEGIN
InitInstance(n,EnableWriteBuffer);
for CountSortAttempt:=1 to 3 do
begin
CreateInFile(SortAmounts[CountSortAttempt]);
BreakBigFile;
ProcessAdvancedMerge;
end;
OnDestroy;
END.
----------------------

Oleg M. добавил [date]1077131924[/date]:
это типа "shared stuff" шло по курсу...
---------
unit sortrout;
interface
const
BufSize =16384;


type
item=BYTE;
FileRing=^RingItem;
RingItem=record
f :File;
Val :item;
eof :boolean;
eor :boolean;
Next:FileRing;
end;{RingItem}
var
FirstRingHead :FileRing;
SecondRingHead :FileRing;
EnableWriteBuffer :boolean;
EnableReadBuffer :boolean;
TemporaryDirectory :string;

procedure InitInstance(N:BYTE; var WriteBuf: boolean);
procedure printfiles(Second:boolean);
procedure PrintInputFile;
procedure CloseFiles(second:boolean);
procedure RewriteArray(Second:boolean);
procedure ResetArray(Second:boolean;AssignRingVals:boolean);
procedure OnDestroy;
procedure CreateInFile(Amount:LongInt);

implementation
uses crt;
const variety =32767;


function Int2String(num:integer):string;
var
result:string;
c:char;
begin
result:='';
repeat
c:=chr(ord('0')+num-(num div 10)*10);
result:=c+result;
num:=num div 10;
until (num=0);
Int2String:=result;
end;{int2string}



procedure DestroyRing(var RingHead:FileRing);
var ptr1,ptr2:FileRing;
begin
ptr1:=RingHead;
ptr2:=nil;
while (ptr2 <> RingHead) and
(ptr1 <> nil) do
begin
ptr2:=ptr1^.next;
dispose(ptr1);
ptr1:=ptr2;
end;
end;


procedure CreateInFile(amount:LongInt);
var
count:LongInt;
i:WORD;
buf:array[1..BufSize] of item;
begin
TextColor(LightGray);
{$I-}
MkDir(TemporaryDirectory);
{$I+}
gotoxy(1,10);
if (IOResult=0) then
Writeln('Temporary directory '+TemporaryDirectory+' was created. ')
else
Writeln('Using exiting '+TemporaryDirectory+' direcotory. ');
Write('Creating the file...');
assign(FirstRingHead^.f,TemporaryDirectory+'\input .dat');
rewrite(FirstRingHead^.f,sizeof(item));
count:=0;
while count+bufsize<=amount do
begin
for i:=1 to bufsize do buf[i]:=random(variety);
BlockWrite(FirstRingHead^.f,buf,bufsize);
count:=count+bufsize;
end;
for i:=1 to amount-count do buf[i]:=random(variety);
BlockWrite(FirstRingHead^.f,buf,amount-count);
Close(FirstRingHead^.f);
TextColor(DarkGray);
WriteLn(' File was created successfully.');

end;


procedure InitFileRing(var RingHead:FileRing; Index:WORD; n:byte);
var
ptr:FileRing;
count:integer;
begin
new(ptr);
Assign(ptr^.f,TemporaryDirectory+'\file'+Int2strin g(Index)+'.dat');
RingHead:=ptr;
for count:=Index+1 to Index+n-1 do
begin
new(ptr^.next);
ptr:=ptr^.next;
ptr^.eof:=true;
ptr^.eor:=true;
ptr^.Val:=0;
assign(ptr^.f,TemporaryDirectory+'\file'+Int2Strin g(count)+'.dat');
end;
ptr^.next:=RingHead;
ptr^.next^.eof:=true;
ptr^.next^.eor:=true;
ptr^.next^.Val:=0;

end;


procedure ShowWellcomeTips;
begin
ClrScr;
TextColor(White);
WriteLn('.........-------========= Advanced Merge Algorithm ==========--------.........');

TextColor(LightGray);WriteLn(#13#10'You are wellcomed by the fourth program of Oleg M.');
TextColor(white);Write(' '#9);
TextColor(LightGray);WriteLn(' This is a HighEnd algorithm of sorting the files.');
TextColor(white);Write(' '#9);
TextColor(LightGray);WriteLn(' Using of Read/Write bufferization');
TextColor(white);Write(' '#9);
TextColor(LightGray);WriteLn(' Optimizated File/Create method.');
end;


procedure InitInstance(N:BYTE; var WriteBuf: boolean);
var result:char;
begin
ShowWellcomeTips;
TextColor(LightGray);
Write('Do You want to use the');
TextColor(White);
Write(' WRITE BUFFER');
TextColor(LightGray);
Write(' for acceleration? [Enter=Yes / Esc=No] ');
repeat
result:=ReadKey;
until result in [#13,#27];
TextColor(White);
if (result=#13) then
begin
Writeln('YES');
WriteBuf:=TRUE;
end
else
begin
Writeln('NO');
WriteBuf:=FALSE;
end;
TextColor(LightGray);
Writeln('Define the temporary directory name:');
TextColor(white);
readln(TemporaryDirectory);

Randomize;
InitFileRing(FirstRingHead,1,N);
InitFileRing(SecondRingHead,N+1,N);
end;


procedure OnDestroy;
var ptr:FileRing;

procedure EraseTempFiles;
begin
ptr:=FirstRingHead;
{$I-}
while(ptr^.next<>FirstRingHead) do
begin
Erase(ptr^.f);
ptr:=ptr^.next;
end;
Erase(ptr^.f);
ptr:=SecondRingHead;
while(ptr^.next<>SecondRingHead) do
begin
Erase(ptr^.f);
ptr:=ptr^.next;
end;
Erase(ptr^.f);
{$I+}
end;{erase}

begin
TextColor(White);
gotoxy(1,25);
Write('End of program work. See You later, when You''ll run me again. Bay!');

EraseTempFiles;

DestroyRing(FirstRingHead);
DestroyRing(SecondRingHead);

delay(2000);
end;


procedure ResetArray(Second:boolean; AssignRingVals :boolean);
var
count:integer;
var ptr, head:FileRing;
begin
if (Second) then head:=SecondRingHead else head:=FirstRingHead;
ptr:=head;
repeat
reset(ptr^.f,sizeof(item));
ptr^.eof:=true;
if eof(ptr^.f) then ptr^.eof:=true
else if AssignRingVals then
begin
BlockRead(ptr^.f,ptr^.Val,1);
ptr^.eof:=false;
end;
ptr^.eor:=ptr^.eof;
ptr:=ptr^.next;
until ptr=head;
end;



procedure RewriteArray(Second:boolean);
var
count:integer;
var ptr, head:FileRing;
begin
if (Second) then head:=SecondRingHead else head:=FirstRingHead;
ptr:=head;
repeat
rewrite(ptr^.f,sizeof(item));
ptr:=ptr^.next;
until ptr=head;
end;


procedure CloseFiles(second:boolean);
var ptr,head:FileRing;
begin
if Second then head:=SecondRingHead
else head:=FirstRingHead;
ptr:=head;
repeat
close(ptr^.f);
ptr:=ptr^.next;
until ptr=head;
end;{close}


procedure PrintInputFile;
var
val:item;

begin
assign(FirstRingHead^.f,TemporaryDirectory+'\input .dat');
reset(FirstRingHead^.f,sizeof(item));
TextColor(WHITE);
while not eof(FirstRingHead^.f) do
begin
BlockRead(FirstRingHead^.f,val,1);
write(' ',Val);
end;
writeln;
end;


procedure printfiles(Second:boolean);
var
ptr1,ptr2 :FileRing;
Val :Item;

begin
if (Second) then ptr2:=SecondRingHead
else ptr2:=FirstRingHead;

TextColor(White);
ptr1:=ptr2;
repeat
while not eof(ptr1^.f) do
begin
BlockRead(ptr1^.f,Val,1);
write(' ',Val);
end;
writeln;
ptr1:=ptr1^.next;
until ptr1=ptr2;
end;


END.{UNIT}