1. Заголовок темы должен быть информативным. В противном случае тема удаляется ... 2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения. 3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали! 4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора). 5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM! 6. Одна тема - один вопрос (задача) 7.Проверяйте программы перед тем, как разместить их на форуме!!! 8.Спрашивайте и отвечайте четко и по существу!!!
(************************************************* ************************* **************** Написать программу, которая, используя ес- *************** **************** тественное многопутевое слияние с 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);
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;
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);
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!');
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}
Вот что удалось по этой сортировке,подскажите как сделать её двухфазной?