6.4 Модуль Kur

Unit kur;

interface

Uses Crt,LLisTT,Info;

procedure Task1; {Выполняет задание 1}

procedure Task2; {Выполняет задание 2}

implementation

procedure PrintWord(var F:Text;I:Integer;P:tpWord); {вывод слова в файл}

var

X,Y:Integer;

begin

Write(F,I:5);

Write(F,' "');

For Y:=1 to P^^.Word.Col do

write(F,P^^.Word.S[Y]);

write(F,'"');

For Y:=P^^.Word.Col+1 to cStrSize+1 do

write(F,' ');

write(F,P^^.Num:5);

end;

function Letter(C:Char):Boolean; {проверка на букву}

begin

Letter:=

( (C >= 'a') and (C <= 'z') ) or

( (C >= 'A') and (C <= 'Z') ) or

( (C >= '0') and (C <= '9') );

end;

function Vowel(C:char):Boolean; {проверка на гласную}

begin

Vowel:=

(C = 'a') or (C = 'e') or (C = 'i') or

(C = 'o') or (C = 'u') or (C = 'y') or

(C = 'A') or (C = 'E') or (C = 'I') or

(C = 'O') or (C = 'U') or (C = 'Y')

end;

function GetWord(var F:Text; var S:tStr):boolean; {выделение очередного слова}

var

C:Char;

Exit:Boolean;

Y:integer;

begin

S.Col:=0;

Exit:=false;

while not Eof(F) and not (Exit) do

begin

Read(F,C);

If Letter(C) then

Exit:=true

end;

if not Exit then

GetWord := false

else

begin

S.S[1]:=C;

S.Col:=1;

Exit:=false;

while (not(Eof(F))) and (not(Exit)) do

begin

read(F,C);

If not(Letter(C)) then

Exit:=true

else

begin

S.Col:=S.Col+1;

if S.Col > cStrSize then

begin

clrscr;

WriteLn;

write('The word "');

For Y:=1 to S.Col do

write(S.S[Y]);

WriteLn('" is too long...');

WriteLn('The File has not been analysed...');

readkey;

halt(1)

end;

S.S[S.Col]:=C

end

end;

GetWord:=true

end

end;

function Compare(A,B: tpStr):Integer; {сравнение строк}

var

I,MinLen:Integer;

Exit:Boolean;

begin

I:=1;

If A^.Col<B^.Col then

MinLen:=A^.Col

else

MinLen:=B^.Col;

exit:=false;

while (I<=MinLen) and (not(Exit)) do

If A^.S[I]=B^.S[I] then

I:=I+1

else

exit:=true;

If exit then

If A^.S[I]<B^.S[I] then

Compare:=-1

else

Compare:=1

else

If A^.Col<B^.Col then

Compare:=-1

else

If A^.Col>B^.Col then

Compare:=1

else

Compare:=0

end;

procedure PutWord(var WordList:PUList; var Str:tpStr);{внесение данных о слове в список}

var

Ans:Boolean;

El:pList;

begin

GoBol(WordList);

Ans:=false;

while not(Eolist(WordList))and(not(Ans)) do

begin

If Compare(@(WordList^.Cur^.Date^.word), Str) = 0 then

begin

inc(WordList^.Cur^.Date^.Num);

ans:=true

end;

GoNext(WordList);

end;

If not(ans) and (WordList^.Cur <> nil) then

if (Compare(@(WordList^.Cur^.Date^.word), Str)) = 0 then

begin

inc(WordList^.Cur^.Date^.Num);

ans:=true

end;

If not(Ans) then

begin

New(El);

New(El^.Date);

El^.Date^.word:=Str^;

El^.Date^.Num:=1;

El^.Next:=wordList^.L;

WordList^.L:=El;

El:=El;

end

end;

procedure PrintRes(var F:Text;var WordList:pulist); {вывод результата в задании 1}

var

Rec,Num:Integer;

LocLink,LocLink2,L : pList;

begin

Num:=0;

while WordList^.L<>Nil do

begin

Rec:=0;

LocLink:=Nil;

GoBol(WordList);

Num:=Num+1;

while not(Eolist(WordList)) do

begin

If WordList^.Cur^.Date^.Num>Rec then

begin

LocLink:=WordList^.Cur;

LocLink2:=WordList^.Pred;

Rec:=WordList^.Cur^.Date^.Num

end;

GoNext(WordList)

end;

If WordList^.Cur^.Date^.Num>Rec then

begin

LocLink:=WordList^.Cur;

LocLink2:=WordList^.Pred;

Rec:=WordList^.Cur^.Date^.Num

end;

PrintWord(F,Num,@(LocLink^.Date));

writeLn(F);

If LocLink2=Nil then

WordList^.L := LocLink^.Next

else

LocLink2^.Next := LocLink^.Next;

Dispose(LocLink^.Date);

Dispose(LocLink);

end;

end;

Procedure SortWord(var S:tStr); {сортировка букв в слове}

var

I,J,X:Integer;

C:Char;

begin

For I:=1 to S.Col do

begin

X:=I;

For J:=I to S.Col do

If S.S[X]>S.S[J] then

X:=J;

C:=S.S[X];

S.S[X]:=S.S[I];

S.S[I]:=C

end

end;

procedure Task2;

var

F,Fout:Text;

W:tpStr;

M,M2:puList;

I,J,K:Integer;

locStr:tpStr;

begin

assign(F,'aaa.txt');

Assign(Fout,'Res2.txt');

Reset(F);

Rewrite(Fout);

New(M);

Create(M);

New(W);

While not (Eof(F)) do

if GetWord(F,W^) then

PutWord(M,W);

GoBoL(M);

While not(Eolist(M)) do

begin

If ((M^.Cur^.Date^.word.Col mod 2) = 1) and Vowel(M^.Cur^.Date^.word.S[(M^.Cur^.Date^.word.Col div 2)+1]) then

SortWord(M^.Cur^.Date^.word);

GoNext(M)

end;

If ((M^.Cur^.Date^.word.Col mod 2) = 1) and Vowel(M^.Cur^.Date^.word.S[(M^.Cur^.Date^.word.Col div 2)+1]) then

SortWord(M^.Cur^.Date^.word);

New(M2);

Create(M2);

New(LocStr);

GoBol(M);

while not(Eolist(M)) do

begin

LocStr:=@(M^.Cur^.Date^.Word);

putword(M2, LocStr);

GoNext(M)

end;

LocStr:=@(M^.Cur^.Date^.Word);

putword(M2, LocStr);

GoBol(M2);

while not(Eolist(M2)) do

begin

For K:=1 to M2^.Cur^.Date^.Word.Col do

write(Fout,M2^.Cur^.Date^.Word.S[K]);

writeLn(Fout,'');

GoNext(M2)

end;

If M2^.Cur<>Nil then

For K:=1 to M2^.Cur^.Date^.Word.Col do

write(Fout,M2^.Cur^.Date^.Word.S[K]);

clrscr;

writeLn('The text has been analysed...');

writeLn;

writeLn('...Press any key to exit...');

readkey;

Close(Fout);

end;

procedure Task1;

var

F,Fout:Text;

W:tpStr;

M:puList;

I,J:Integer;

begin

assign(F,'aaa.txt');

Assign(Fout,'Res.txt');

Reset(F);

Rewrite(Fout);

New(M);

Create(M);

New(W);

While not (Eof(F)) do

if GetWord(F,W^) then

PutWord(M,W);

PrintRes(Fout,M);

clrscr;

writeLn('The text has been analysed...');

writeLn;

writeLn('...Press any key to exit...');

readkey;

Close(Fout);

end;

begin

end.