unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, Vcl.StdCtrls, Vcl.Grids;

type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    Size: TLabel;
    MCol: TEdit;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Arr: TStringGrid;
    SetSize: TButton;
    FindMatrix: TButton;
    NCol: TEdit;
    LMCol: TLabel;
    LNCol: TLabel;
    procedure N2Click(Sender: TObject);
    procedure OpenDialog1CanClose(Sender: TObject; var CanClose: Boolean);
    procedure SaveDialog1CanClose(Sender: TObject; var CanClose: Boolean);
    procedure SetSizeClick(Sender: TObject);
    procedure MColChange(Sender: TObject);
    procedure MColKeyPress(Sender: TObject; var Key: Char);
    procedure FindMatrixClick(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure N4Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure ArrKeyPress(Sender: TObject; var Key: Char);
    procedure ArrDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect;
      State: TGridDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  SizeN, SizeM: Integer;
  IsValid: Boolean;
const
   MIN_SIZE = 2;
   MAX_SIZE = 8;

implementation

{$R *.dfm}

procedure TForm1.ArrDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect;
  State: TGridDrawState);
var
   CellColor : TColor;
begin
  with Arr.Canvas do
   begin
      CellColor := TColor(Arr.Rows[ACol].Objects[ARow]);
      Brush.Color := CellColor;
      FillRect(Rect);
      TextOut(Rect.Left + 3, Rect.Top + 2, Arr.Cells[ACol, ARow]);
   end;
end;

procedure TForm1.ArrKeyPress(Sender: TObject; var Key: Char);
const
   Digit: set of Char = ['0', '1', #8];
var
   i, j, k: Integer;
   Flag: Boolean;
begin
   with (Sender as TStringGrid) do
   begin
      k := 1;
      if not(Key in Digit) then
         Key := #0;
      for i := 0 to Arr.RowCount - 1 do
         for j := 0 to Arr.ColCount - 1 do
            if Length(Arr.Cells[j, i]) = 1 then
            begin
               Arr.Cells[j, i] := Arr.Cells[j, i][1];
               Inc(k);
            end;
      for i := 0 to SizeM do
         for j := 0 to SizeN do
            Arr.Rows[j].Objects[i] := TObject(RGB(255, 255, 255));
      if (k = (SizeN) * (SizeM)) or (k - 1 = (SizeN) * (SizeM))  then
         Flag := True
      else
         Flag := False;
   if Key = #8 then
         Flag := False;
   FindMatrix.Enabled := Flag;
   N4.Enabled := False;
   end;
end;

procedure TForm1.SetSizeClick(Sender: TObject);
var
   ErrMsg: String;
   Err, i, j: Integer;
begin
   ErrMsg := 'Кол-во вершин должно лежать в промежутке ' + IntToStr(MIN_SIZE) + '..' + IntToStr(MAX_SIZE);
   val(MCol.Text, SizeM, Err);
   val(NCol.Text, SizeN, Err);
   if (SizeN < MIN_Size) or (SizeN > MAX_Size) or (SizeM < MIN_Size) or (SizeM > MAX_Size)then
      MessageDlg(ErrMsg, mtError, [mbOK], 0)
   else
   begin
      Arr.ColCount := SizeN;
      if (SizeM = 2) or (SizeN = 2) then
      begin
         Arr.DefaultColWidth := 50;
         Arr.Width := (Arr.DefaultColWidth + 6) * (SizeN);
         Arr.RowCount := SizeM;
         Arr.DefaultRowHeight := 20;
         Arr.Height := (Arr.DefaultRowHeight + 6) * SizeM;
      end
      else
      begin
         Arr.DefaultColWidth := 50;
         Arr.Width := (Arr.DefaultColWidth + 2) * (SizeN);
         Arr.RowCount := SizeM;
         Arr.DefaultRowHeight := 20;
         Arr.Height := (Arr.DefaultRowHeight + 2) * SizeM;
      end;
      for i := 0 to SizeM do
         for j := 0 to SizeN do
            Arr.Rows[j].Objects[i] := TObject(RGB(255, 255, 255));
      Arr.Repaint;
      Arr.Visible := True;
      FindMatrix.Visible := True;
      FindMatrix.Enabled := False;
   end;
end;

procedure TForm1.FindMatrixClick(Sender: TObject);
var
   i, j, k, Shir, Dlin, c, MaxId, MinShir: Integer;
   Matrix: array of array of Byte;
   a: array of Byte;
   x1, x2, y1, y2: array of Byte;
begin
   for i := 0 to SizeM do
         for j := 0 to SizeN do
            Arr.Rows[j].Objects[i] := TObject(RGB(255, 255, 255));
   SetLength(Matrix, SizeM, SizeN);
   for i := 0 to (SizeM - 1) do
      for j := 0 to SizeN - 1 do
         Matrix[i][j] := StrToInt(Arr.Cells[j, i]);

   SizeN := SizeN xor SizeM;
   SizeM := SizeN xor SizeM;
   SizeN := SizeN xor SizeM;

   for i := 0 to SizeN - 1 do
      for j := 0 to SizeM - 1 do
         if Matrix[i][j] = 1 then
         begin
            Dlin := 0;
            MinShir := 0;
            c := i;
            k := j;
            while Matrix[c][k] = 1 do
            begin
               Shir := 0;
               while Matrix[c][k] = 1 do
               begin
                  Inc(k);
                  inc(Shir);
                  if MinShir <> 0 then
                     if Shir > MinShir then
                     begin
                        Dec(Shir);
                        break;
                     end;
                  if k = SizeM then
                  begin
                     Dec(k);
                     break;
                  end;
               end;
               if (MinShir > Shir) or (MinShir = 0) then
                  MinShir := Shir;
               Inc(Dlin);
               SetLength(a, Length(a) + 1);
               SetLength(x1, Length(x1) + 1);
               SetLength(x2, Length(x2) + 1);
               SetLength(y1, Length(y1) + 1);
               SetLength(y2, Length(y2) + 1);
               a[High(a)] := Dlin * MinShir;
               x1[High(x1)] := i;
               x2[High(x2)] := c;
               y1[High(a)] := j;
               y2[High(a)] := y1[High(a)] + MinShir - 1;

               k := j;
               Inc(c);
               if c = SizeN then
               begin
                  Dec(c);
                  break;
               end;
            end;
         end;
   MaxId := 0;
   for i := 0 to High(a) do
      if a[i] > a[MaxId] then
         MaxId := i;
   for i := x1[MaxId] to x2[MaxId] do
      for j := y1[MaxId] to y2[MaxId] do
         Arr.Rows[j].Objects[i] := TObject(RGB(197, 244, 178));
   Arr.Repaint;
   N4.Enabled := True;
   FindMatrix.Enabled := False;
end;

procedure TForm1.MColChange(Sender: TObject);
var
   IsValid1, IsValid2: Boolean;
   i: Integer;
begin
   Arr.Visible := False;
   FindMatrix.Visible := False;
   with Arr do
      for i := 0 to SizeN do
         Cols[i].Clear;
   if MCol.Text <> '' then
      IsValid1 := True;
   if NCol.Text <> '' then
      IsValid2 := True;
   if (IsValid1) and (IsValid2) then
      SetSize.Enabled := True
   else
      SetSize.Enabled := False;
end;

procedure TForm1.MColKeyPress(Sender: TObject; var Key: Char);
const
   Digit: set of Char = ['1'..'9', '0', #8];
begin
   with (Sender as TEdit) do
   begin
      if not(Key in Digit) then
         Key := #0;
   end;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
   CanClose := MessageDlg('Вы уверены, что хотите выйти из программы?' +
      #10#13 + 'Все несохраненные данные будут утеряны.',
      mtConfirmation, [mbYes, mbNo], 0) = mrYes;
end;

procedure TForm1.N2Click(Sender: TObject);
var
   Task: String;
begin
   Task := 'Данная программа находит максимальную подматрицу из единиц' + #10#13;
   Task := Task + 'Автор - Пестунов Илья, гр. 051007';
   MessageDlg(Task, mtInformation, [mbOK], 0);
end;

procedure TForm1.N3Click(Sender: TObject);
var
   MyFile: TextFile;
   i, Value, j: Integer;
   s: String;
begin
   MCol.Text := '';
   NCol.Text := '';
   Arr.Visible := False;
   with Arr do
      for i := 0 to SizeN do
         Cols[i].Clear;
   if OpenDialog1.Execute then
   begin
      AssignFile(MyFile, OpenDialog1.FileName);
      Reset(MyFile);
      Read(MyFile, SizeM);
      Read(MyFile, SizeN);
      MCol.Text := IntToStr(SizeM);
      NCol.Text := IntToStr(SizeN);
      Arr.ColCount := SizeN;
      if (SizeM = 2) or (SizeN = 2) then
      begin
         Arr.DefaultColWidth := 50;
         Arr.Width := (Arr.DefaultColWidth + 6) * (SizeN);
         Arr.RowCount := SizeM;
         Arr.DefaultRowHeight := 20;
         Arr.Height := (Arr.DefaultRowHeight + 6) * SizeM;
      end
      else
      begin
         Arr.DefaultColWidth := 50;
         Arr.Width := (Arr.DefaultColWidth + 2) * (SizeN);
         Arr.RowCount := SizeM;
         Arr.DefaultRowHeight := 20;
         Arr.Height := (Arr.DefaultRowHeight + 2) * SizeM;
      end;
      for i := 0 to (SizeM - 1) do
         for j := 0 to SizeN - 1 do
         begin
            Read(MyFile, Value);
            str(Value, s);
            Arr.Cells[j, i] := s[1];
         end;
      CloseFile(MyFile);
      for i := 0 to SizeM do
         for j := 0 to SizeN do
            Arr.Rows[j].Objects[i] := TObject(RGB(255, 255, 255));
      Arr.Repaint;
      Arr.Visible := True;
      FindMatrix.Visible := True;
      FindMatrix.Click;
      //FindMatrix.Enabled := True;
   end;
end;

procedure TForm1.N4Click(Sender: TObject);
var
   MyFile: TextFile;
   i, j: Integer;
begin
   if SaveDialog1.Execute then
   begin
      AssignFile(MyFile, SaveDialog1.FileName);
      Rewrite(MyFile);
      Writeln(MyFile, 'Подматрица из 1 - найденная мамксимальная подматрица');
      for i := 0 to (SizeN - 1) do
      begin
         for j := 0 to (SizeM - 1) do
            if Arr.Rows[j].Objects[i] = TObject(RGB(197, 244, 178)) then
               Write(MyFile, Arr.Cells[j, i], ' ')
            else
               Write(MyFIle, '0 ');
         Writeln(MyFile);
      end;
      CloseFile(MyFile);
      MessageDlg('Результат успешно сохранён', mtCustom, [mbOK], 0);
   end;
end;

procedure TForm1.OpenDialog1CanClose(Sender: TObject; var CanClose: Boolean);
var
   IsValid: Boolean;
   N, i, Value, Err, j: Integer;
   MyFile: TextFile;
   Check: String;
const
   Digit: set of Char = ['1', '0', ' '];
begin
   IsValid := True;
   N := Length(OpenDialog1.FileName);
   if (OpenDialog1.FileName[N] = 't') and (OpenDialog1.FileName[N - 1] = 'x') and (OpenDialog1.FileName[N - 2] = 't') then
   begin
      AssignFile(MyFile, OpenDialog1.FileName);
      Reset(MyFile);
      Read(MyFile, Check);
      CloseFile(MyFile);
      if Length(Check) = 0 then
      begin
         MessageDlg('Файл пуст', mtWarning, [mbOK], 0);
         IsValid := False;
      end
      else
      begin
         AssignFile(MyFile, OpenDialog1.FileName);
         Reset(MyFile);
         try
            Read(MyFile, SizeN);
         except
            IsValid := False;
            MessageDlg('Порядок матрицы должен быть натуральным числом до 8', mtWarning, [mbOK], 0);
         end;
         if ((IsValid) and (SizeN < MIN_SIZE)) or ((IsValid) and (SizeN > MAX_SIZE)) then
         begin
            IsValid := False;
            MessageDlg('Порядок матрицы должна быть натуральным числом до 8', mtError, [mbOK], 0);
         end;
         try
            Readln(MyFile, SizeM);
         except
            IsValid := False;
            MessageDlg('Порядок матрицы должен быть натуральным числом до 8', mtWarning, [mbOK], 0);
         end;
         if ((IsValid) and (SizeM < MIN_SIZE)) or ((IsValid) and (SizeM > MAX_SIZE)) then
         begin
            IsValid := False;
            MessageDlg('Порядок матрицы должна быть натуральным числом до 8', mtError, [mbOK], 0);
         end;
         if IsValid then
         begin
            for j := 1 to SizeN do
            begin
               Readln(MyFile, Check);
               i := 1;
               while (IsValid) and (i <= Length(Check)) do
               begin
                  if not(Check[i] in Digit) then
                  begin
                     IsValid := False;
                     MessageDlg('Элементами матрицы должны быть числа 0 или 1', mtWarning, [mbOK], 0);
                  end;
                  Inc(i);
               end;
            end;
            Readln(MyFile, Check);
               i := 1;
               while (IsValid) and (i <= Length(Check)) do
               begin
                  if not(Check[i] in Digit) then
                  begin
                     IsValid := False;
                     MessageDlg('Элементами матрицы должны быть числа 0 или 1', mtWarning, [mbOK], 0);
                  end;
                  Inc(i);
               end;
         end;
         CloseFile(MyFile);
      end;
   end
   else
   begin
      MessageDlg('Файл должен иметь расширение .txt', mtError, [mbOK], 0);
      IsValid := False;
   end;
   if not(IsValid) then
      CanClose := False;
end;

procedure TForm1.SaveDialog1CanClose(Sender: TObject; var CanClose: Boolean);
var
   N: Integer;
begin
   N := Length(SaveDialog1.FileName);
   if (SaveDialog1.FileName[N] = 't') and (SaveDialog1.FileName[N - 1] = 'x') and (SaveDialog1.FileName[N - 2] = 't') then
      CanClose := True
   else
   begin
      CanClose := False;
      MessageDlg('Файл должен иметь расширение .txt', mtError, [mbOK], 0);
   end;
end;

end.