Паскаль, матрицы, текст

[anhil]

1 задача... Тема: «Методы сортировок»

Выполнить задание по обработке матриц с использованием указанных методов сорти-ровок.
Программу оформить с использованием подпрограмм с передачей параметров (под-программы реализуют: ввод, вывод, обработка матрицы, метод сортировки).
На печать выдавать всю исходную информацию, промежуточные результаты и преоб-разованную матрицу.

Дана действительная матрица A размерности (n x n) . Если минимальный элемент мат-рицы встречается более 3 раз, и один из них находится на главной диагонали, то упорядо-чить столбцы матрицы по возрастанию максимальных элементов столбцов методом линейной вставки. В противном случае матрицу оставить без изменения.
--------------------------------------------------------------------------------------
2 задача.. По строкам

Дан текст, слова которого отделяются друг от друга пробелами. Если первое слово является максимальным по длине, то все слова, которые заканчиваются той же буквой, что и первое слово, поместить в конец текста.
Распечатать исходный текст, первое слово, если оно является максимальным по длине, и полученный текст.
----------------------------------------------------------------------------------------
3 задача.. «Использование множеств»

Составить программу обработки текста (строки).
Написать 2 варианта программы:
1) без использования множеств;
2) с использованием данных типа множество.

Составить программу, которая во введенном тексте удаляет все буквы латинского алфавита, удваивает все гласные буквы русского алфавита и подсчитывает количество согласных.
На печать выдать исходный текст, количество согласных и преобразованный текст.
----------------------------------------------------------------------------------------

[Naeel Maqsudov]

1)
[syntax=Delphi]
uses
Crt;
const
n=5;
m=n;
type
TBaseType = real;
TArr = array[1..n,1..m] of TBaseType;
TIdx = array[1..m] of integer;
const
ZeroOfBaseType = 1E-39;
MaxOfBaseType = 1.7e38;
var
a,b:TArr; MaxIdx, MaxIdx2:TIdx;
Min:TBaseType; Cnt,Pos:integer; s:string;


procedure PressAnyKey;
begin
while KeyPressed do ReadKey;
Write('Press any key...'#13);
ReadKey;
ClrEOL;
end;

function eq(x,y:TBaseType):boolean;
begin
eq:=abs(x-y)<=ZeroOfBaseType;
end;


procedure input(var A:TArr);
var
i,j:integer;
begin
for i:=1 to n do for j:=1 to m do begin
write('A[',i,',',j,']=');
read(A[i,j]);
end;
end;

procedure output(var A:TArr; head:string; highlight:integer; HlightVal:TBaseType);
var
i,j:integer;
begin
writeln;
writeln('*** ',head,' ***');
for i:=1 to n do begin
for j:=1 to m do begin
case highlight of
0 :
if i=j then TextColor(Yellow) else TextColor(LightGray);
-1:
if eq(A[i,j],HLightVal) then TextColor(LightRed) else TextColor(LightGray);
-2:
if eq(A[i,j],HLightVal)
then TextColor(LightRed)
else if i=j
then TextColor(Yellow)
else
TextColor(LightGray);
else
if j=highlight then TextColor(Yellow) else TextColor(LightGray);
end;
write(A[i,j]:6:2,' ');
end;
TextColor(LightGray);
writeln;
end;
end;

function MinIsOnMainDiag(A:TArr; var Min:TBaseType; var Count:integer ):boolean;
var
i,j:integer; r:boolean;
begin
r:=false; Min:=MaxOfBaseType; Count:=0;
for i:=1 to n do for j:=1 to m do begin
if A[i,j]<Min then begin
Min:=A[i,j]; r:=i=j; Count:=1;
end else if eq(A[i,j],Min) then begin
inc(Count); r:=r or (i=j);
end;
end;
MinIsOnMainDiag:=r;
end;

procedure FindMaxForEachColumn(A:TArr; var Idx:TIdx);
var
i,j:integer;
begin
for j:=1 to m do begin
idx[j]:=1;
for i:= 2 to n do if A[i,j]>A[idx[j],j] then idx[j]:=i;
end;
end;

procedure InsertColumn(A:TArr; var B:TArr; ColFrom, ColTo:integer);
var
i,j:integer;
begin
for i:=1 to n do begin
for j:=M-1 downto ColTo do B[i,j+1]:=B[i,j];
B[i,ColTo]:=A[i,ColFrom];
end;
end;


function ProcessColumn(A:TArr; ColFrom:integer; var B:TArr; var Idx1,Idx2:TIdx):integer;
var
i,j,t, r,ColTo:integer;
begin
ColTo:=1;
if ColFrom=1 then begin
Idx2[1]:=Idx1[1];
end else begin
while
(ColTo<ColFrom) and
(A[idx1[ColFrom],ColFrom]>=B[idx2[ColTo],ColTo])
do inc(ColTo);
end;

for i:=ColFrom downto ColTo+1 do Idx2:=Idx2[i-1];

Idx2[ColTo]:=Idx1[ColFrom];


InsertColumn(A,B,ColFrom,ColTo);
ProcessColumn:=ColTo;
end;


begin
TextAttr:=$0007;
fillchar(b,0,SizeOf(b));
input(a);
output(a, 'Source Array',0,0);
if MinIsOnMainDiag(a,Min,Cnt) then begin
if Cnt>3 then begin
output(a, 'Minimum is present on the main diagonal',-1,Min);
writeln('Minimum value ',Min:6:2,' was found ',Cnt,' time(s).'#13#10+
'At least one of them is on the main diagonal.'#13#10+
'Sorting is needed!');
PressAnyKey;
FindMaxForEachColumn(a,MaxIdx);
for Cnt:=1 to m do begin
Pos:=ProcessColumn(a,Cnt,b,MaxIdx,MaxIdx2);
str(Cnt,s);
output(b,'Sorting. Step#'+s,Pos,0);
PressAnyKey;
end;

end else begin
output(a, 'Minimum is present on the main diagonal',-1,Min);
writeln('Minimum value ',Min:6:2,' was found ',Cnt,' time(s).'#13#10+
'At least one of them is on the main diagonal.'#13#10+
'Sorting is NOT needed!');
PressAnyKey;
end;
end else begin
output(a, 'Minimum isn''t present on the main diagonal',-2,Min);
writeln;
writeln('Minimum value ',Min:6:2,' was found ',Cnt,' time(s).'#13#10+
'But never on main diagonal.'#13#10+
'Sorting is NOT needed!');
PressAnyKey;
end;
end.

[/syntax]

[Naeel Maqsudov]

2)
[syntax=Delphi]
type
TWordDsc=record
Pos:integer;
Len:integer;
Last:char;
end;
var
si,so:string;
i:integer;
Words:array[1..128] of TWordDsc;
const
MaxLen:integer=0;
WCount:integer=0;

procedure SkipSpace(s:string; var p:integer);
begin
while (s[p]=' ') and (p<length(s)) do inc(p);
end;

function GetWord(s:string; var p:integer; var WDsc:TWordDsc):boolean;
begin
SkipSpace(s,p);
WDsc.Pos:=p;
while (s[p]<>' ') and (p<=length(s)) do inc(p);
WDsc.Len:=p-WDsc.Pos;
WDsc.Last:=s[p-1];
if WDsc.Len>MaxLen then MaxLen:=WDsc.Len;
GetWord:=WDsc.Len>0;
end;

begin
so:='';
write('Input some text:'); readln(si);
i:=1;
while GetWord(si,i,Words[WCount+1]) do begin
inc(WCount);
{writeln(Words[WCount].Pos,' ',Words[WCount].Len,' ',Words[WCount].Last);}
end;

if WCount > 0 then begin
writeln('Source text:');
writeln(si);
if Words[1].Len=MaxLen then begin
writeln('The first word of the text: ',copy(si,Words[1].Pos,Words[1].Len));
for i:=1 to WCount do
if Words.Last<>Words[1].Last then
so:=so + copy(si,Words.Pos,Words.Len) + ' ';
for i:=1 to WCount do
if Words.Last=Words[1].Last then
so:=so + copy(si,Words.Pos,Words.Len) + ' ';
writeln('Result text:');
writeln(so);
end else begin
writeln('The first word is not longest word in the text.');
end;
end else Writeln('Wrong input! No words was found.');
readln;
end.
[/syntax]