Правила форума
Прочтите прежде чем задавать вопрос!
как это делается хотя есть пример
помогите пожалуйста
| 2 | 3 |
1 | | | 4
---------------------------
8 | | |5
| 7 | 6 |
" (Показать/Скрыть)
program sort;
uses Crt,Graph;
const
raz=8;
type
TMatr=array[1..raz,1..raz] of integer;
var
n,k,i,j,rows,cols:integer;
a:TMatr;
b:TMatr;
z,rowNo:integer;
Procedure sort1V (var a1:TMatr);
begin
for j:=cols+2 to 2*cols
do For k:=j-cols-1 downto 1
do for i:=2*rows-j+1 to rows-1
do if b[i,j]>b[i+1,j]
then begin
z:=b[i,j];
b[i,j]:=b[i+1,j];
b[i+1,j]:=z
end;
end;
{Процедура рисования окна диалога}
procedure okno(xv,yv,xn,yn,colfona,colbukv:byte;zag:string);
var
i:integer;
begin
TextBackGround(8);
Window(xv,yv,xn,yn);
TextColor(colbukv);
write(#201);
for i:=1 to xn-xv-1
do write(#205);
write(#187);
for i:=1 to yn-yv-2
do begin
GoToXY(1,i+1); write(#186);
GoToXY(xn-xv+1,i+1); write(#186);
end;
write(#200);
for i:=1 to xn-xv-1
do write(#205);
write(#188);
window(xv+1,yv+1,xn-1,yn-2);
TextBackGround(colfona);
ClrScr;
GoToXY((xn-xv) div 2 - Length(zag) div 2,1);
write(zag);
window(xv+1,yv+2,xn-1,yn-2);
end;
procedure vvod_dannblx(var a,b:TMatr);
var
beg,fin,ii,jj,x:integer;
error,pr:boolean;
begin
repeat
write('Введите размер матрицы:');
readln(rows,cols);
write('Введите начало и конец диопозона:');
{$I-}
{$R-}
read(beg,fin);
{$I+}
{$R+}
error:=((fin-beg)<SQR(2*cols))or (IOResult<>0);
if (rows>raz/2)or(cols>raz/2)or (rows<>cols)
then error:=true;
if error
then writeln('Ошибка ввода!!!');
until not error;
for i:=1 to 2*rows
do for j:=1 to 2*cols
do begin
repeat
x:=round(random*(fin-beg)+beg);
pr:=false;
for ii:=1 to i-1
do for jj:=1 to 2*cols
do if a[ii,jj]=x
then pr:=true;
for jj:=1 to j-1
do if a[i,jj]=x
then pr:=true
until not pr;
a[i,j]:=x;
b[i,j]:=0;
end;
sort1V(a);
end;
procedure vblvod_isx_dannblx;
var count:integer;
begin
writeln;
count:=-1;
for i:=1 to 2*rows
do begin
count:=count+1;
for j:=1 to 2*cols
do begin
if (i>=1) and (i<=rows)
then begin
if (j>=2*cols-count) and (j<=2*cols)
then begin
b[i,j]:=a[i,j];
TextColor(0)
end
else textcolor(15);
end
else
textcolor(15);
write(a[i,j]:4);
end;
writeln('');
end;
sort1V(b);
readln;
end;
procedure vblvod_rezyltata;
begin
writeln;
for i:=1 to 2*rows
do begin
for j:=1 to 2*cols
do write(b[i,j]:4);
writeln('');
end;
readln;
end;
procedure prosmotr;
label go;
var
otv:char;
begin
TextBackGround(8);
ClrScr;
Okno(12,2,64,9,8,14,'Основное меню');
writeln('Выбор операции:1-ввод исходных данных');
writeln(' 2-исходная матрица');
writeln(' 3-отсортированная матрица');
write (' 4-выход');
repeat
go:
otv:=readkey;
case otv of
'1':begin
Okno(2,9,54,20,8,14,'');
vvod_dannblx(a,b);
end;
'2':begin
Okno(2,9,40,25,4,14,'Исходная матрица:');
vblvod_isx_dannblx;
goto go;
end;
'3':begin
Okno(41,9,78,25,9,14,'Отсортированная матрица:');
vblvod_rezyltata;
end;
end;
window (1,1,80,25);
TextBackGround(8);
ClrScr;
Okno(12,2,64,9,8,14,'Основное меню');
writeln('Выбор операции:1-ввод исходных данных');
writeln(' 2-исходная матрица');
writeln(' 3-отсортированная матрица');
write (' 4-выход');
until otv='4';
end;
begin
clrscr;
prosmotr;
end.
