Ask Question

Name:
Title:
Your Question:

Answer Question

Name:
Your Answer:
User Submitted Source Code!


Description:
  2
Language: PASCAL
Code:
Program K_Maklassski;
 uses
  crt;
 Const Length_8=8;
       Length_4=4;
        Length_20=20;
 type
  Matrica=array[1..Length_8,1..Length_4] of integer;
  Matrica2=array[1..Length_20,1..Length_4] of integer;
 
 var
  Razmer_1,Razmer_2,Razmer_3,Razmer_4,DSNF_Matrica:Matrica;
  Razmer_20,Otvet:Matrica2;
  Schetchik:integer;
  i,j:integer;
 
  {Процедура чтения чтения ДСНФ из файла и запись в матрицу }
  Procedure VVOD_Matrica(imya:string; var X:Matrica);
  var
   Fil:TEXT;
   i,j:byte;
  begin
   Assign(Fil,imya);
   Reset(Fil);
    For i:= 1 to Length_8 do
     For j:= 1 to Length_4 do
       Read(Fil,X[i,j]);
   Close(fil);
  end;
 
  {Первый этап Расфасовка по матрицам (опорная точка количество единиц в строке)}
 Procedure Rasfasovka_First_Stage(R:integer; DSNF:Matrica; var OutR:Matrica);
  var
   i,j,Summa,k,t:integer;
  begin
    k:=1;
     For i:=1 to Length_8 do
      For j:=1 to Length_4 do
        OutR[i,j]:=2;
   For i:=1 to Length_8 do
    begin
       Summa:=0;
     For j:=1 to Length_4 do
       if DSNF[i,j]=1 then
        Summa:=Summa+1;
       If Summa=R then
        begin
         For t:=1 to 4 do
           OutR[k,t]:=DSNF[i,t];
          k:=k+1;
        end;
     end;
  end;
 
  {Второй этап склеивание строк с 1 различием}
  Procedure Skleivanie_Second_Stage(X,Y:Matrica; Sc:integer; var Z:Matrica2; var Sc2:integer);
   var
    i,j,k,l,ad:integer;
   begin
     k:=0;
    For l:=1 to Length_8 do
     For i:=1 to Length_8 do
       begin
        For j:=1 to Length_4 do
         if X[l,j]<>Y[i,j] then
           begin
           inc(k);
            ad:=j;
           end;
          if k=1 then
           begin
            For j:=1 to Length_4 do
             Z[Sc,j]:=Y[i,j];
            Z[Sc,ad]:=3;
            inc(Sc);
           end;
          k:=0;
          ad:=0;
        end;
       Sc2:=Sc;
   end;
 
   {Этап третий Упорядочивание по месту положения метки}
  Procedure Sorted_Sage_Third(k:integer; X:Matrica2; var Y:Matrica);
   var
    i,j,n:integer;
   begin
     n:=1;
       For i:=1 to Length_8 do
        For j:=1 to Length_4 do
         Y[i,j]:=2;
    For i:=1 to Length_20 do
      For j:=1 to Length_4 do
        If (X[i,j]<>2) and (X[i,k]=3) then
         begin
          Y[n,j]:=X[i,j];
           if j=4 then
            inc(n);
          end;
   end;
 
   {Четвертый этап. Склеивание строк с 1 отличием}
   Procedure Skleivanie_Stage_Fourth(X:Matrica; Sch:integer; var Y:Matrica2; Var Sch2:integer);
    var
      i,k,l,j,ad,kesh:integer;
     begin
       k:=0;
       kesh:=Sch;
      For l:=1 to Length_8-1 do
       For i:=l+1 to Length_8 do
        begin
         For j:=1 to Length_4 do
          If X[l,j]<>X[i,j] then
            begin
             inc(k);
             ad:=j;
            end;
           If k=1 then
            begin
             For j:=1 to Length_4 do
              Y[Sch,j]:=X[i,j];
             Y[Sch,ad]:=3;
             inc(Sch);
            end;
           ad:=0;
           k:=0;
        end;
        IF Kesh=Sch then
         begin
          For j:=1 to Length_4 do
            Y[Sch,j]:=X[1,j];
           Inc(Sch);
          end;
       Sch2:=Sch;
     end;
 
     {Пятый этап удаление дубликатов}
     Procedure Delete_Dublicats_Stage_Fifth(X:Matrica2; var Y:Matrica2);
      var
       i,l,j,Sh,k:integer;
          Proverka:boolean;
      begin
         Proverka:=false;
       k:=0; Sh:=2;
        For j:=1 to Length_4 do
         Y[1,j]:=X[1,j];
        For l:=1 to Length_8 do
            begin
          For i:=1 to Length_8 do
             begin
              For j:= 1 to Length_4 DO
                if (X[l,j]=Y[i,j]) and (X[l,j]<>2) then
                   inc(k);
                If (k=4)  then
                 Proverka:=true;
                  k:=0;
             end;
             If Not(Proverka) then
             begin
              For j:=1 to Length_4 DO
                   Y[Sh,j]:=X[l,j];
                   Inc(Sh);
 
              end;
              Proverka:=false;
           end;
 
         end;
 
 
 
   {Процедура ввывода матрицы на экран}
  Procedure PrintMatrica(X:Matrica);
   var
    i,j:integer;
   begin
    For i:=1 to Length_8 do
      begin
       For j:=1 to Length_4 do
        if X[i,j]<>2 then
         Write(X[i,j]);
       Writeln;
      end;
     Writeln(#13#10);
   end;
 
  begin
   ClrScr;
    Schetchik:=1;
    VVOD_Matrica('D:\TPascal.71\BIN\1.txt',DSNF_Matrica);
 
     Rasfasovka_First_Stage(1,DSNF_Matrica,Razmer_1);
     Rasfasovka_First_Stage(2,DSNF_Matrica,Razmer_2);
     Rasfasovka_First_Stage(3,DSNF_Matrica,Razmer_3);
     Rasfasovka_First_Stage(4,DSNF_Matrica,Razmer_4);
 
 
 
     For i:=1 to Length_20 do
      For j:=1 to Length_4 do
       Razmer_20[i,j]:=2;
 
     Skleivanie_Second_Stage(Razmer_1,Razmer_2,Schetchik,Razmer_20,Schetchik);
     Skleivanie_Second_Stage(Razmer_2,Razmer_3,Schetchik,Razmer_20,Schetchik);
     Skleivanie_Second_Stage(Razmer_3,Razmer_4,Schetchik,Razmer_20,Schetchik);
 
 
 
    Sorted_Sage_Third(1,Razmer_20,Razmer_1);
    Sorted_Sage_Third(2,Razmer_20,Razmer_2);
     Sorted_Sage_Third(3,Razmer_20,Razmer_3);
     Sorted_Sage_Third(4,Razmer_20,Razmer_4);
 
     {PrintMatrica(Razmer_1);
     PrintMatrica(Razmer_2);
     PrintMatrica(Razmer_3);
     PrintMatrica(Razmer_4);}
 
     For i:=1 to Length_20 do
      For j:=1 to Length_4 do
          begin
        Razmer_20[i,j]:=2;
           Otvet[i,j]:=2;
          end;
 
      Schetchik:=1;
     Skleivanie_Stage_Fourth(Razmer_1,Schetchik,Razmer_20,Schetchik);
     Skleivanie_Stage_Fourth(Razmer_2,Schetchik,Razmer_20,Schetchik);
     Skleivanie_Stage_Fourth(Razmer_3,Schetchik,Razmer_20,Schetchik);
     Skleivanie_Stage_Fourth(Razmer_4,Schetchik,Razmer_20,Schetchik);
 
     Delete_Dublicats_Stage_Fifth(Razmer_20,Otvet);
            Writeln('--------Otvet-------',#13#10);
      For i:=1 to Length_20 do
      begin
        For j:=1 to Length_4 do
           begin
           if Otvet[i,j]=3 then
            Write('* ')
           else
           If Otvet[i,j]<>2 then
         Write(Otvet[i,j],' ');
           end;
       Writeln;
     end;
 
   Readln;
  end.
Comments: