(************************************************* *************************
**************** Написать программу, которая, используя ес- ***************
**************** тественное многопутевое слияние с 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}