[bolun]

1 курс не могу решить задачу для допуска на экзамен помогите плз!)

задача.
Уплотнить матрицу A(nxm)влево и вверх.Для выявления нулевых строк и столбцов используйте подпрограмму.

в задаче скобками обозначен мои попытки написать подпрограмму но не получается(
в общем нужна подпрограмма которая находит нулевую строку или столб и удаляет ее . помогите!)

Код:

program Project148;

{$APPTYPE CONSOLE}
 {$R+}
uses
  SysUtils,
  inout;

type
TMatrix=array of array of integer;
function TRX(A:TMatrix;i,j:integer):integer;
var
b:boolean;
k,rowcount:integer;
begin
{k:=0;
for i:=0 to high(A) do
begin
 b:=true;
            for j := 0 to high(A[i]) do begin
               if a[i,j]<>0 then b:=false;
               if not b then
          begin
          inc(k);
           for j := 0 to high(A[i]) do
           a[k,j]:=a[i,j];
          end;
            end;
            ROWcount:=k;
            writeln(' результат: ');
            for i:=0 to high(A) do
            begin
             for j := 0 to high(A[i]) do
             writeln( a[i,j]:3);
             writeln;
            end;
          end;
    end;}
var
A: TMatrix;
RowCount, ColCount:integer;
i,j:integer;
 key:Char;
 Fok:boolean;

begin
  SetConsoleTitleCyr ('Л.р.');
 SetConsoleCP_1251;
 repeat
 Randomize;
 {$I-}
    repeat
 write ('введите число строк матрицы ');
 readln(RowCount);
     FOK:=(ioresult=0) and (RowCount>0);
      if not(FOK) then
        writeln('ОШИБКА');
    until FOK ;
    repeat
  write ('введите число столбцов матрицы ');
 readln(ColCount);
  FOK:=(ioresult=0) and (ColCount>0);
      if not(FOK) then
        writeln('ОШИБКА');
    until FOK ;
    {$I+}
 SetLength (A,RowCount,ColCount);
 writeln ('матрица A:');
 for i := 0 to high(A)  do
  begin
  for j := 0 to high(A[i]) do
    begin
      A[i,j]:=-1+random(3);
    write (A[i,j]:3 );
    end;
    writeln;
  end;
 {$I-}
 begin
   TRX(A,i,j);
 end;
  Writeln (' для продолжения работы программы нажмите Y');
    Readln (key);
  until upcase(key) <>'Y' ;

end.

Админ: Пользуемся тегами для оформления кода!

[bolun]

кто поможет кину немного денег на телефон)

[ART]

Пиши в асю. Сделаю

[lmikle]

А чего тут делать?

Код:

function IsRowEmpty(A : Array [1..M,1..N] Of Integer; R : Integer) : Boolean;
var
  I : Integer;
begin
  Result := True;
  For I := 1 To N Do 
    Begin
       Result := A[I,R] = 0;
       If Not Result Then Break;
    End;
end;

function IsColEmpty(A : Array [1..M,1..N] Of Integer; C : Integer) : Boolean;
var
  I : Integer;
begin
  Result := True;
  For I := 1 To M Do 
    Begin
       Result := A[C,I] = 0;
       If Not Result Then Break;
    End;
end;

[ART]

Код:

type
 TMatrix = array of array of real;

procedure SwapCols(var M: TMatrix; i, j: Integer);
var
 k: integer;
 tmp: real;
begin
 for k := 0 to High(M[i]) do begin
  tmp := M[i][k];
  M[i][k] := M[j][k];
  M[j][k] := tmp;
 end;
end;

procedure SwapRows(var M: TMatrix; i, j: Integer);
var
 k: integer;
 tmp: real;
begin
 for k := 0 to High(M) do begin
  tmp := M[k][i];
  M[k][i] := M[k][j];
  M[k][j] := tmp;
 end;
end;

function IsZeroCol(M: TMatrix; n: Integer): Boolean;
var
 i: integer;
begin
 for i := 0 to High(M[n]) do
  if M[n][i] <> 0 then begin
   Result := false;
   Exit;
  end;
 Result := true;
end;

function IsZeroRow(M: TMatrix; n: Integer): Boolean;
var
 i: integer;
begin
 for i := 0 to High(M) do
  if M[i][n] <> 0 then begin
   Result := false;
   Exit;
  end;
 Result := true;
end;


procedure Compact(var M: TMatrix);
var
 r, c, w, h: integer;
 i, j: integer;
begin
 r := 0;
 for i := 0 to High(M) do
  if IsZeroRow(M, i) = True then r := r + 1;
 c := 0;
 for i := 0 to High(M[0]) do
  if IsZeroCol(M, i) = True then c := c + 1;

 h := r;
 w := c;

repeat
 for i := 0 to High(M) do
  if IsZeroRow(M, i) = True then
   for j := i to High(M) - 1 do SwapRows(M, j, j + 1);
 r := r - 1;
until r <= 0;

repeat
 for i := 0 to High(M[0]) do
  if IsZeroCol(M, i) = True then
   for j := i to High(M) - 1 do SwapCols(M, j, j + 1);
 c := c - 1;
until c <= 0;

 SetLength(M, Length(M[0]) - w, Length(M) - h);

end;

[AND_REY]

Ещё вариант:

Код:

Function TRX(M: TMatrix; var x,y: Integer): Boolean;//х,у-размер вых. М 
Var
 tempM: TMatrix;
 P: Boolean;
 i, j: Integer;
begin
 SetLength(tempM, Length(M), Length(M[0]));
 x:= -1; y:= -1;
 For i:= 0 To Length(M) - 1 Do
  begin
   P:= False;
   For j:= 0 To Length(M[0]) - 1 Do if M[i,j] <> 0 Then
    begin
     Inc(x);
     P:= True;
     Break;
    end;
   if P Then For j:= 0 To Length(M[0]) - 1 Do tempM[x,j]:= M[i,j];
  end;
 For j:= 0 To Length(tempM[0]) - 1 Do
  begin
   P:= False;
   For i:= 0 To Length(tempM) - 1 Do if tempM[i,j] <> 0 Then
    begin
     Inc(y);
     P:= True;
     Break;
    end;
   if P Then For i:= 0 To Length(M) - 1 Do M[i,y]:= tempM[i,j];
  end;
 SetLength(M, x, y);
end;