Добавил:
Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз: Предмет: Файл:

gas / UNITS / GNK2

.PAS
Скачиваний:
14
Добавлен:
15.06.2014
Размер:
15.58 Кб
Скачать
UNIT GNK2;
INTERFACE
  USES GNK;
  type IntArray = array [0..18] of integer;
       Binarray= array [1..16,1..10] of byte;
       Masarray = array [1..19,1..15] of byte;
       BinArray1 = array [1..15] of byte;
       BinArray2 = array [1..19] of byte;
  const
    flag : array [1..4,1..4] of byte = ((3,5,6,7),(6,8,10,11),(9,11,13,14),(12,14,17,19));
    flag1: array [1..4,1..4] of byte = ((2,3,3,3),(5,6,7,7),(8,9,10,10), (11,12,14,15));
  var jmax:integer;

  Procedure  OPD4(var mas:Masarray;var MOP:Intarray;var NRS,NPR:word;Param:byte;inf:word;Key1:Byte);
  Procedure  MTAB4(mas:masarray;inf:word;MOP:INTARRAY;var MAT:binarray;param,key2:byte);
  Procedure  ISP4(KP, KI:BinArray2;MAT:Binarray;MJ,KJ, NRS:integer;MOP:IntArray;var Kk:BinArray2; var KRIP, KRI:word);
  PROCEDURE  OPD(NRS,N1:word;var NPS:word;var MT1,MT2,MOP);
  PROCEDURE  MTAB(NRS,NPS,MJ,KJ:word;var MOP,MAT);
  PROCEDURE  RPT(T0,V,M,S:real;var PK,T1:real);
  PROCEDURE  DVK(NUK,INF:word;var MDV);
  PROCEDURE  KDR(var MAT,MDV,KP; MJ,KJ,NRS,INF:word);
  PROCEDURE  KAN(var KP,KI,MVO;NRS,MKO:word;T0,T1,PK,S,M:real;var IR:word);
  PROCEDURE  ISP(var MAT,MOP,OPZ,KI,TOP;MJ,KJ,NRS,NPR,NPS:word;var KC1:word);
  PROCEDURE  PVB(var MAT,KI,MVO,MDV;KJ:word; var KC1:word;nrs:word);
  PROCEDURE  BVUK(var MDV,YKout;INF,k:word;Q,Ymin:real);
  PROCEDURE  DEMO(N,KC1:word);

IMPLEMENTATION
  USES crt;
  TYPE
       VecB=array[1..65535] of byte;
       VecS=array[1..10922] of real;
       Ba= array [1..16,1..10] of byte;

Procedure OPD4;

var
    number,temp: byte;
    i,j,chislo : integer;

Function check_one(digit : integer; number : byte) : byte;
var i : byte;
begin
     check_one := 0;
     for i := 0 to number do
         if MOP[i] = digit then
         begin
              check_one := 1;
              exit;
         end;
end;

Function check_two(digit : integer; number : byte) : byte;
var i,j : byte;
begin
     check_two := 0;
     if Param = 1 then exit;
        for i := 0 to number - 2 do
            for j := i+1 to number - 1 do
                if (MOP[i] xor MOP[j]) = digit then
                begin
                     check_two := 1;
                     exit;
                end;
end;

Function check_three(digit : integer; number : byte) : byte;
var i,j,k : byte;
begin
     check_three := 0;
     if Param < 3 then exit;
        for i := 0 to number - 3 do
            for j := i+1 to number - 2 do
                for k := j+1 to number - 1 do
                    if (MOP[i] xor MOP[j] xor MOP[k]) = digit then
                    begin
                         check_three := 1;
                         exit;
                    end;
end;

Function check_four(digit : integer; number : byte) : byte;
var i,j,k,n : byte;
begin
   check_four := 0;
   if Param < 4 then exit;
      for i := 0 to number - 4 do
         for j := i+1 to number - 3 do
            for k := j+1 to number - 2 do
               for n := k+1 to number - 1 do
                  if (MOP[i] xor MOP[j] xor MOP[k] xor MOP[n]) = digit then
                  begin
                     check_four := 1;
                     exit;
                  end;
end;

Function verify( digit : integer;number : byte) : byte;
var tmp,i,j,k : integer;
begin
     verify := 0;
     if Param =1 then exit;
     for i := 0 to number-1 do
     begin
        tmp := MOP[i] xor digit;
        if (check_one(tmp, number)=1) or (check_two(tmp,number)=1) or
            (check_three(tmp,number)=1) or (check_four(tmp,number)=1) then
             begin
                  verify := 1;
                  exit;
             end;
     end;

     if Param < 3 then exit;
     for i := 0  to number - 2 do
       for j := i + 1 to number-1 do
       begin
          tmp := MOP[i] xor MOP[j] xor digit;
          if (check_one(tmp, number)=1) or (check_two(tmp,number)=1) or
             (check_three(tmp,number)=1) or (check_four(tmp,number)=1) then
             begin
                  verify := 1;
                  exit;
             end;
       end;

     if Param < 4 then exit;

     for i := 0 to number - 3 do
       for j := i + 1 to number - 2 do
         for k := j + 1 to number-1 do
         begin
            tmp := MOP[i] xor MOP[j] xor MOP[k] xor digit;
            if(check_one(tmp, number)=1) or (check_two(tmp,number)=1) or
              (check_three(tmp,number)=1) or (check_four(tmp,number)=1) then
              begin
                verify := 1;
                exit;
              end;
         end;
end;

begin
{  KJ:=5;
   MJ:=flag1[Param]+1;
}
   NRS:=flag1[Param,inf]+inf; { зЁб«® а §а冷ў Ї®¬Ґе®гбв®©зЁў®Ј® Є®¤®ў®Ј® б«®ў }
   NPR:=flag1[Param,inf];   { зЁб«® Ё§Ўлв®з­ле а §а冷ў}

   {
   N1 - Є®«ЁзҐбвў® ®Ї®§­ ў вҐ«Ґ© ¤ўгЄа в­ле ®иЁЎ®Є;
   MJ - Є®«ЁзҐбвў® бва®Є ў Є®¤Ёаго饩 в Ў«ЁжҐ;
   KJ - Є®«ЁзҐбвў® бв®«Ўж®ў ў Є®¤Ёаго饩 в Ў«ЁжҐ;
   }

   number := 2;
   for i:=0 to 18 do MOP[i] :=0;

   MOP[0] := 1;
   MOP[1] := 2;

   if Param >2 then
   begin
        MOP[2] := 4;
        number:=3;
   end;

   if Param >3 then
   begin
        MOP[3] := 8;
        number:=4;
   end;

   if Param=4 then
   begin
        MOP[4]:=16;
        MOP[5]:=32;
        MOP[6]:=64;
        MOP[7]:=128;
        MOP[8]:=255;
        MOP[9]:=256;
        MOP[10]:=512;
        MOP[11]:=1024;
        MOP[12]:=2048;
        MOP[13]:=3855;
        MOP[14]:=4096;
        MOP[15]:=8192;
        MOP[16]:=13107;
        MOP[17]:=16384;
        MOP[18]:=21845;
   end
   else
   begin
       for i := 3 to 32767 do
       begin
         if not ((check_one(i,number)=1) or (check_two(i,number)=1) or
                (check_three(i,number)=1) or (check_four(i,number)=1)) then
          if not (verify(i,number)=1) then
          begin
              MOP[number] := i;
              inc(number);
              if key1=1 then write('*');
          end;
          if number = nrs then break;
       end;
   end;
   writeln;

   for i:=1 to flag[Param,inf] do
       for j:=1 to inf+1 do mas[i,j]:=0;
jmax:=0;
   for i:=1 to flag[Param,inf] do
   begin
       j:=1;
       chislo:=MOP[i-1];

       if chislo > 1 then
       repeat
             mas[i,j]:=chislo mod 2;
             chislo:=chislo div 2;
             j:=j+1;
             if j>jmax then jmax:=j;
       until (chislo < 2);

       mas[i,j]:=1;
   end;

   for i:=1 to flag[Param,inf] do
   begin
     if key1=1 then begin
        for j:=jmax downto 1 do write(mas[i,j]);
        writeln;
     end;
   end;
end;

Function Divm(m:integer):boolean;
var i:integer;
begin
Divm:=false;
 for i:=0 to 16 do
  if m-round(exp(ln(2)*i))=0 then begin Divm:=true;break;end;
end;

PROCEDURE MTAB4;
var i,j,j2 : integer;
tmp, x, y : byte;
begin
   for i:=1 to flag[param,inf] do for j:=1 to 5 do MAT[i,j]:=0;

   j:=2;j2:=2;
   for i:=1 to flag[param,inf] do
       if divm(mop[i-1]) then begin MAT[j,1]:=i;inc(j);end else
       begin mat[1,j2]:=i;inc(j2);end;

   for i:=2 to flag1[param,inf]+1 do
    for j:=2 to inf+1 do
      if mas[mat[1,j],i-1]=1 then mat[i,j]:=1;

   x:=40; y:=4;
   if key2=1 then begin
     gotoxy(42,2);write('Љ®¤Ёагой п в Ў«Ёж ');
     for i:=1 to flag1[param,inf]+1 do
       begin
         for j:=1 to inf+1 do begin
           gotoxy(x,y);write(MAT[i,j]:4);x:=x+4;end;
           x:=40;inc(y);
       end;
     gotoxy(1, flag[Param,inf]+3);
   end;
end;

PROCEDURE ISP4;
var
   i,j,k,n : integer;
   temp : word;
   tmp : byte;
   opz:binarray1;

begin
     krip:=0;kri:=0;
      for i:=1 to nrs do
       if ki[i]<>kp[i] then inc(krip);

     for i:=1 to (nrs div 2) do begin
      k:=ki[i];ki[i]:=ki[nrs-i+1];ki[nrs-i+1]:=k;
     end;


     for i := 2 to MJ do
     begin
          tmp:=0;
          for j := 2 to KJ do
            if MAT[i,j]=1 then tmp:=tmp xor KI[MAT[1,j]];

         OPZ[i-1]:=tmp xor KI[MAT[i,1]];
     end;

     temp:=0;
     for i := MJ-1 downto 1 do
         if OPZ[i]=1 then temp:=temp + trunc( exp((i-1)*ln(2)) );

     tmp:=0;

     for i := 0 to NRS-1 do
     begin
        if MOP[i] = temp then
        begin
             KI[i+1]:=1-KI[i+1];
             tmp:=1;
        end;
     end;

     if MJ>5 then
     for i := 0 to MJ+KJ-4 do
      for j := i+1 to MJ+KJ-3 do
        if (MOP[i] xor MOP[j]) = temp then
        begin
             tmp:=1;
             KI[i+1]:=1-KI[i+1];
             KI[j+1]:=1-KI[j+1];
        end;

     if MJ > 8 then
     for i := 0 to MJ+KJ-5 do
      for j := i+1 to MJ+KJ-4 do
        for k := j+1 to MJ+KJ-3 do
          if (MOP[i] xor MOP[j] xor MOP[k]) = temp then
          begin
               tmp:=1;
               KI[i+1]:=1-KI[i+1];
               KI[j+1]:=1-KI[j+1];
               KI[k+1]:=1-KI[k+1];
          end;

     if MJ > 11 then
     for i := 0 to MJ+KJ-6 do
      for j := i+1 to MJ+KJ-5 do
        for k := j+1 to MJ+KJ-4 do
          for n := k+1 to MJ+KJ-3 do
            if (MOP[i] xor MOP[j] xor MOP[k] xor MOP[n]) = temp then
            begin
                 tmp:=1;
                 KI[i+1]:=1-KI[i+1];
                 KI[j+1]:=1-KI[j+1];
                 KI[k+1]:=1-KI[k+1];
                 KI[n+1]:=1-KI[n+1];
            end;
     for i:=1 to (nrs div 2) do begin
      k:=ki[i];ki[i]:=ki[nrs-i+1];ki[nrs-i+1]:=k;
     end;

     for i:=1 to nrs do kk[i]:=ki[i];
     for i:=1 to nrs do
       if kp[i]<>kk[i] then inc(kri);
end;


 PROCEDURE OPD;
 LABEL 0,1,2;
 VAR
    I,J,K,M,NB:word;
    P,Z:byte;
 BEGIN
   FOR k:=1 TO NRS-1 DO VecB(MT1)[k]:=0;
   VecB(MT1)[NRS]:=1;
   NB:=0;
   FOR i:=2 TO NRS DO
     BEGIN
       FOR k:=1 TO NRS DO VecB(MT1)[NRS*(i-1)+k]:=VecB(MT1)[NRS*(i-2)+k];
    0: P:=0;
       FOR k:=NRS DOWNTO 1 DO
         BEGIN
           Z:=VecB(MT1)[NRS*(i-1)+k]+P;
           IF k=NRS THEN Z:=Z+1;
           VecB(MT1)[NRS*(i-1)+k]:=Z mod 2;
           P:=Z div 2
         END;
       FOR j:=1 TO NB DO
         BEGIN
           FOR k:=1 TO NRS DO
             IF VecB(MT2)[NRS*(j-1)+k]<>VecB(MT1)[NRS*(i-1)+k] THEN goto 1;
           goto 0;
          1: ;
         END;
       FOR j:=1 TO NB DO FOR m:=1 TO i-1 DO
         BEGIN
           FOR k:=1 TO NRS DO
             IF VecB(MT2)[NRS*(j-1)+k]<>
             byte(VecB(MT1)[NRS*(m-1)+k]<>VecB(MT1)[NRS*(i-1)+k])
             THEN goto 2;
           goto 0;
          2: ;
         END;
       FOR m:=1 TO i-1 DO
         BEGIN
           NB:=NB+1;
           FOR k:=1 TO NRS DO
             VecB(MT2)[NRS*(nb-1)+k]:=
             byte(VecB(MT1)[NRS*(m-1)+k]<>VecB(MT1)[NRS*(i-1)+k])
         END;
     END;
   k:=1;
   WHILE (k<NRS) and (VecB(MT1)[NRS*(NRS-1)+k]=0) DO k:=k+1;
   NPS:=NRS-k+2;
   FOR i:=1 TO NRS*NRS DO VecB(MOP)[i]:=0;
   FOR i:=1 TO NRS DO
     BEGIN
       VecB(MOP)[NRS*(i-1)+1]:=i;
       j:=NPS;
       FOR m:=k TO NRS DO
         BEGIN
           VecB(MOP)[NRS*(i-1)+j]:=VecB(MT1)[NRS*(i-1)+m];
           j:=j-1
         END
     END
 END;

 PROCEDURE MTAB;
 VAR
   I,J,K,M,N1:word;
 BEGIN
   FOR i:=1 TO MJ*KJ DO VecB(MAT)[i]:=0;
   m:=2;k:=KJ;
   FOR i:=1 TO NRS DO
   BEGIN
     n1:=0;
     FOR j:=2 TO NPS DO IF VecB(MOP)[NRS*(i-1)+j]=1 THEN inc(n1);
     IF n1=1
     THEN
       BEGIN VecB(MAT)[KJ*(m-1)+1]:=VecB(MOP)[NRS*(i-1)+1];
             inc(m)
       END
     ELSE
       BEGIN
          VecB(MAT)[k]:=VecB(MOP)[NRS*(i-1)+1];
          FOR j:=2 TO NPS DO VecB(MAT)[KJ*(j-1)+k]:=VecB(MOP)[NRS*(i-1)+j];
          dec(k)
       END
   END
 END;

  PROCEDURE RPT;
  BEGIN
       PK:=AVER(V,M,S);
       T1:=2*PK+T0;
       PK:=PK+T0
  END;

  PROCEDURE DVK;
  VAR
     I:word;
  BEGIN
    FOR i:=1 TO INF DO VecB(MDV)[i]:=0;
    i:=INF;
    WHILE (NUK>1) and (i>1) DO
      BEGIN
        VecB(MDV)[i]:=NUK mod 2;
        NUK:=NUK div 2;
        i:=i-1
      END;
    VecB(MDV)[i]:=NUK
  END;

 procedure KDR;
 var I,J:word;
 begin
  for i:=1 to NRS do VecB(KP)[i]:=0;
  for i:=1 to inf do VecB(KP)[Nrs-Ba(mat)[1,i+1]+1]:=VecB(mdv)[inf-i+1];
  for i:=2 to mj do
   for j:=2 to kj do
    if Ba(mat)[i,j]=1 then Vecb(KP)[nrs-Ba(mat)[i,1]+1]:=Vecb(KP)[nrs-Ba(mat)[i,1]+1] xor Vecb(KP)[nrs-Ba(mat)[1,j]+1];
 end;

 PROCEDURE KAN;
 VAR
    R,US:real;
    J:word;
 BEGIN
      IR:=0;
      FOR j:=1 TO NRS DO
        BEGIN
          R:=GAUSS(M,S);
          IF VecB(KP)[j]=1 THEN US:=T1 ELSE US:=T0;
          US:=US+R;
          {-----------}
          IF US>PK THEN VecB(KI)[j]:=1;
          {----------}
          IF US<PK THEN VecB(KI)[j]:=0;
          {----------}
          IF VecB(KI)[j]=VecB(KP)[j] THEN VecB(MVO)[j]:=0
          ELSE
            IF IR<MKO THEN
              BEGIN
                IR:=IR+1;
                VecB(MVO)[j]:=1
              END
            ELSE VecB(KI)[j]:=VecB(KP)[j]
        END
 END;

 PROCEDURE ISP;
 VAR N1,N2,S,I,J,K:word;
 BEGIN
      FOR i:=1 TO MJ DO
        BEGIN
          S:=0;
          FOR j:=2 TO KJ DO
            IF VecB(MAT)[KJ*(i-1)+j]=1
            THEN BEGIN  N1:=VecB(MAT)[j]; S:=S xor VecB(KI)[N1]  END;
          N2:=VecB(MAT)[KJ*(i-1)+1];
          VecB(OPZ)[i-1]:=S xor VecB(KI)[N2]
        END;
{------------- €бЇа ў«Ґ­ЁҐ ®¤­®Єа в­ле ®иЁЎ®Є ----------------------}
      FOR i:=1 TO NRS DO
        BEGIN
          S:=0;
          FOR j:=2 TO NPS DO
            IF VecB(OPZ)[j-1]=VecB(MOP)[NRS*(i-1)+j] THEN S:=S+1;
          IF S=NPR THEN
            BEGIN
                 VecB(KI)[i]:=1-VecB(KI)[i];
                 EXIT
            END
        END;
{------------- €бЇа ў«Ґ­ЁҐ ¤ўгеЄа в­ле ®иЁЎ®Є ----------------------}
     N1:=1; N2:=0;
     WHILE N1<=NRS DO
       BEGIN
          IF N2<NRS THEN N2:=N2+1
          ELSE
              BEGIN N1:=N1+1; N2:=N1+1 END;
         {-----------}
          FOR j:=2 TO NPS DO VecB(TOP)[j-1]:=VecB(MOP)[NRS*(N1-1)+j];
          FOR j:=2 TO NPS
          DO VecB(TOP)[j-1]:=VecB(TOP)[j-1] xor VecB(MOP)[NRS*(N2-1)+j];
         {-----------}
          k:=1;
          WHILE (VecB(OPZ)[k]=VecB(TOP)[k]) and (k<NPR) DO k:=k+1;
          IF VecB(OPZ)[k]=VecB(TOP)[k] THEN
            BEGIN
                 VecB(KI)[N1]:=1-VecB(KI)[N1];
                 VecB(KI)[N2]:=1-VecB(KI)[N2];
                 EXIT
            END
         {-----------}
       END;
{--------------- €­ЄаҐ¬Ґ­в бзҐвзЁЄ  Ї®вҐап­­ле б®®ЎйҐ­Ё© -----------}
      KC1:=KC1+1
 END;

 PROCEDURE PVB;
 VAR J,IL:word;
 BEGIN
      FOR j:=2 TO KJ DO
        BEGIN
          IL:=VecB(MAT)[j];
          VecB(MVO)[kj-j+1]:=VecB(KI)[nrs-IL+1]
        END;
      FOR j:=1 to kj-1 do
       if VecB(MVO)[j]<>VecB(MdV)[j] then begin KC1:=KC1+1;exit;end;
 END;

 PROCEDURE BVUK;
 VAR I,J,NUKV:word;
 BEGIN
      NUKV:=0;
      j:=INF;
      FOR i:=1 TO INF DO
        BEGIN
          NUKV:=NUKV+VecB(MDV)[j]*TRUNC(EXP((i-1)*LN(2)));
          j:=j-1
        END;
      VecS(YKout)[k]:=Ymin+Q+2*Q*NUKV;
 END;

 PROCEDURE DEMO;
 VAR tx:char;
 BEGIN
      WRITELN('‚ᥣ® в®зҐЄ :',N,'  €бЄ ¦Ґ­® :',KC1);
      WRITELN('— бв®в  Ї®вҐаЁ б®®ЎйҐ­Ё© :',KC1/N:5:3);
      WRITELN('— бв®в  Їа ўЁ«м­®© ЇҐаҐ¤ зЁ б®®ЎйҐ­Ё© :',1-KC1/N:5:3);
      WRITELN;
      WRITELN;
      WRITELN('„«п Їа®¤®«¦Ґ­Ёп а Ў®вл ­ ¦¬ЁвҐ «оЎго Є« ўЁиг');
      while keypressed do tx:=readkey;tx:=readkey
 END;

 BEGIN
      CLRSCR
 END.
Соседние файлы в папке UNITS
  • #
    15.06.201418.77 Кб15FKT.PAS
  • #
    15.06.201416.58 Кб15FKT.TPU
  • #
    15.06.201411.42 Кб14GNK.BAK
  • #
    15.06.201411.41 Кб14GNK.PAS
  • #
    15.06.201419.92 Кб14GNK.TPU
  • #
    15.06.201415.58 Кб14GNK2.PAS
  • #
    15.06.201412.11 Кб14GNK2.TPU
  • #
    15.06.201412.64 Кб14GNK4.TPU
  • #
    15.06.20140 б15TP0FD422.$$$
  • #
    15.06.20141.04 Кб15tt.pas