Кодирование и декодирование текстовой информации циклическим кодом с исправлением тройных одиночных ошибок

   ncodingClick(Sender); end;

procedure Tfmzikl.ncodingClick(Sender: TObject);

var k,y:LongInt;

  procedure DecodeTabl;

  var k:LongInt; begin CountErrorCorrect:=0;  CountErrorNoCorrect:=0;

    pllogo.Visible:=false; plInfo.Visible:=false; plstatic.Visible:=false; plmatrix.Visible:=false;

    plcoding.Visible:=false; plgoto.Visible:=false; plAllDecode.Visible:=true;

    ndecodsms.Enabled:=true; for k:=0 to MaxLineDecode-1 do TextDecode[k]:='';

    MaxLineDecode:=0; reDecode.Clear; DoDecodeCikl;

    reDecode.SelAttributes.Color:=clBlack; for k:=0 to MaxLineDecode-1 do

    reDecode.Lines.Add(TextDecode[k]); for k:=1 to length(reDecode.Text) do

   begin if reDecode.Text[k]='#' then begin With reDecode do begin SelStart:=k-1;

     SelLength:=1; SelAttributes.Color:=clBlue; end end

      else if reDecode.Text[k]<>reInfo.Text[k] then

     begin With reDecode do begin SelStart:=k-1; SelLength:=1;

        SelAttributes.Color:=clBlack; end end; reDecode.SelLength:=0; end;

lbErCor.Caption:='Число правильно исправленных ошибок: '+IntToStr(CountErrorCorrect);

lbErNocor.Caption:='Число неправильно исправленных ошибок: '+IntToStr(CountErrorNoCorrect); CodeButton:=true; end;

Begin

  if not CodeButton then begin DecodeTabl;exit; end; ClearCodeTabl; ClearTabl(sgSym);

    DoCodingTabl; With sgSym do begin colWidths[1]:=154;

      Cells[0,0]:='            Символ'; Cells[1,0]:='                     Код'; RowCount:=13;

 

      for k:=0 to LongCodeTabl-1 do begin if k>11 then RowCount:=RowCount+1;

        if CodeTabl[k].endline then Cells[0,k+1]:=' конец строки'

        else if CodeTabl[k].Sym=' ' then Cells[0,k+1]:='          пробел  '

        else Cells[0,k+1]:='                   '+CodeTabl[k].Sym; end; end;

  pllogo.Visible:=false; plInfo.Visible:=false; plstatic.Visible:=false; plmatrix.Visible:=false;

  plgoto.Visible:=false; plAllDecode.Visible:=false; plcoding.Visible:=true;

  ncanal.Enabled:=true; ndecoding.Enabled:=false;

  for y:=0 to LongCodeTabl-1 do {Проверка на наличие пустых ячеек}

   if sgSym.Cells[1,y+1]='' then ncanal.Enabled:=true; end;

procedure Tfmzikl.DoCodingTabl;

var i:LongInt; begin LongCodeTabl:=LongStaticTabl; for i:=0 to LongCodeTabl-1 do begin

     CodeTabl[i].Sym:=StaticTabl[i].Sym; CodeTabl[i].endline:=StaticTabl[i].endline;

     CodeTabl[i].Code:=''; end; end;

procedure Tfmzikl.sbAutoTablClick(Sender: TObject);

var k:integer; begin AutomaticCodingCikl;

for k:=0 to LongCodeTabl-1 do begin sgSym.Cells[1,k+1]:='                 ' + CodeTabl[k].Code;

end; ncanal.Enabled:=true; end;

procedure Tfmzikl.ntablcodClick(Sender: TObject);

begin pllogo.Visible:=false; plInfo.Visible:=false; plstatic.Visible:=false; plmatrix.Visible:=false;

  plgoto.Visible:=false; plAllDecode.Visible:=false; plcoding.Visible:=true; end;

procedure Tfmzikl.ncanalClick(Sender: TObject);{Передача через канал }

var k:integer; begin pllogo.Visible:=false; plInfo.Visible:=false; plstatic.Visible:=false;

  plmatrix.Visible:=false; plcoding.Visible:=false; plAllDecode.Visible:=false;

  plgoto.Visible:=true; meCountError.Text:='1';

  for k:=edE1.ComponentIndex to edE3.ComponentIndex do begin

    if k<>edE1.ComponentIndex then (Components[k] as TEdit).Enabled:=false

      else (Components[k] as TEdit).Enabled:=true;

             (Components[k] as TEdit).Text:='0.000'; end; reSource.Clear; reExit.Clear;

  ConvertEntry; reSource.Text:=TextSource; ndecoding.Enabled:=true;

  sbAutoFill.Enabled:=true; CodeButton:=true; end;

procedure Tfmzikl.sgSymDrawCell(Sender: TObject; ACol, ARow: Integer;

  Rect: TRect; State: TGridDrawState);

var k:integer; begin

  for k:=0 to LongCodeTabl-1 do    {Проверка на наличие пустых ячеек}

    if sgSym.Cells[1,k+1]='' then begin ncanal.Enabled:=false;Exit end;

  for k:=0 to LongCodeTabl-1 do    {Заполнение CodeTabl занчениями из таблицы}

   CodeTabl[k].Code:=sgSym.Cells[1,k+1]; MaxCodeSize:=0;

  for k:=0 to LongCodeTabl-1 do if length(CodeTabl[k].Code)>MaxCodeSize then

     MaxCodeSize:=length(CodeTabl[k].Code); ncanal.Enabled:=true; end;

procedure Tfmzikl.meCountErrorChange(Sender: TObject);

begin if meCountError.Text<>'' then begin if (StrToInt(meCountError.Text)>3) then

     meCountError.Text:='3'; if (StrToInt(meCountError.Text)=0) then meCountError.Text:='1';

  end; (Components[edE1.ComponentIndex+udCountError.Position-1]as TEdit).Enabled:=true;

if udCountError.Position<3 then

(Components[edE1.ComponentIndex+udCountError.Position]as TEdit).Enabled:=false; end;

procedure Tfmzikl.edE1Change(Sender: TObject);

begin With (Sender as TEdit) do begin if (length(Text)>1) and (Text[2]<>'.') then begin

      Text:=Copy(Text,1,Length(Text)-1); SelStart:=Length(Text);

    end else if length(Text)>=1 then if (Text[1]<>'0') and (Text[1]<>'1') then begin

        Text:=Copy(Text,1,Length(Text)-1); SelStart:=Length(Text); end; end; end;

procedure Tfmzikl.sgSymKeyPress(Sender: TObject; var Key: Char);

begin case Ord(Key) of 32..47,50..255:Key:=chr(0); end; end;

procedure Tfmzikl.edE1KeyPress(Sender: TObject; var Key: Char);

begin if (Key<>#8) and (Key<>'.') and ((Key<'0') or (Key>'9')) then Key:=#0; end;

 

procedure Tfmzikl.sbAutoFillClick(Sender: TObject);

var MP:RASPRED; k:integer; function RealFloat(Str:String):real;

var k:integer; e,m:real; begin e:=Ord(Str[1])-48; m:=1;

for k:=2 to StrLen(PChar(Str)) do begin if (k=2) then if (Str[k]='.') then continue else begin RealFloat:=-1; exit end; m:=m*0.1; e:=e+(Ord(Str[k])-48)*m; end; RealFloat:=e; end;

begin for k:=1 to udCountError.Position do

    MP[k]:=RealFloat((Components[(edE1.ComponentIndex+k-1)] as TEdit).Text);

  ControlAnsamble(MP,udCountError.Position); if not KODVOZVR then begin

    Application.MessageBox(PChar(ErrorAnsamble),'Ошибка канала',idOk); Exit;

  end else begin DOTransf(TextSource,TextExit); end; reExit.Clear;

  reExit.SelAttributes.Color:=clBlack; reExit.Text:=TextExit; for k:=1 to length(TextExit) do

    if TextSource[k]<>TextExit[k] then With reExit do begin SelStart:=k-1; SelLength:=1;

      SelAttributes.Color:=clRed; end; reExit.SelLength:=0; sbAutoFill.Enabled:=false;

  ndecoding.Enabled:=true; end;

procedure Tfmzikl.ndecodingClick(Sender: TObject);

begin CodeButton:=false; ncodingClick(Sender); end;

procedure Tfmzikl.ndecodsmsClick(Sender: TObject);

begin pllogo.Visible:=false; plInfo.Visible:=false; plstatic.Visible:=false; plmatrix.Visible:=false;

  plcoding.Visible:=false; plgoto.Visible:=false; plAllDecode.Visible:=true; end;

procedure Tfmzikl.FormShow(Sender: TObject);

begin Form1.ShowModal; end;

procedure Tfmzikl.nhelp_avtorClick(Sender: TObject);

begin AboutBox.a1.Active:=true; AboutBox.a2.Active:=true; AboutBox.Visible:=true; end; end.

 

 

unit about;

interface

uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,

  Buttons, ExtCtrls, ComCtrls;

type

  TAboutBox = class(TForm)

    Panel1: TPanel;

    ProgramIcon: TImage;

    ProductName: TLabel;

    Copyright: TLabel;

    a1: TAnimate;

    a2: TAnimate;

    Panel2: TPanel;

    Label1: TLabel;

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

  end;

var

  AboutBox: TAboutBox;

Implementation uses main;

{$R *.dfm}

procedure TAboutBox.FormClose(Sender: TObject; var Action: TCloseAction);

begin

   AboutBox.a1.Active:=false; AboutBox.a2.Active:=false; end;

end.

 

 

unit logo;

interface

 

uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls;

type

  TForm1 = class(TForm)

    Panel1: TPanel;

    Panel2: TPanel;

    Image1: TImage;

    Panel3: TPanel;

    Label1: TLabel;

    Label2: TLabel;

    GroupBox1: TGroupBox;

    Label3: TLabel;

    Label4: TLabel;

    Timer1: TTimer;

    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;

      Shift: TShiftState; X, Y: Integer);

    procedure FormKeyDown(Sender: TObject; var Key: Word;

      Shift: TShiftState);

    procedure Timer1Timer(Sender: TObject);

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

  private

    { Private declarations }

  public

    { Public declarations }

  end;

var

  Form1: TForm1;

{$R *.dfm}

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);

Begin close; end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

  Shift: TShiftState);

Begin close; end;

procedure TForm1.Timer1Timer(Sender: TObject);

begin close; end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin Action:=caFree; end;

end.

 

 

unit Cikl;

interface

type TCodeMatrix=array[0..11] of String;

var

    ObrazMatrix:TCodeMatrix;                    {Образующая матрица}

    LongInfoSym,LongControlSym:integer;    {Размеры матриц}

    Dmin:integer;                                                {Минимальное кодовое расстояние}

    Polinom:String[20];                                     {Образующий полином}

    SError:integer;                                             {Число исправляемых ошибок}

    TError:integer;                                             {Число обнаруживаемых ошибок}

procedure AutomaticCodingCikl;

procedure DoDecodeCikl;

 

implementation uses obsh;

procedure AutomaticCodingCikl;

var i,j,k:integer; Str:String;

begin MaxCodeSize:=LongInfoSym+LongControlSym;

   for i:=1 to round(exp(LongInfoSym*ln(2)))-1 do begin if i>LongCodeTabl then break;

    Str:=''; for j:=1 to MaxCodeSize do Str:=Str+'0'; for j:=0 to LongInfoSym-1 do

      if (round(exp(j*ln(2))) and i)<>0 then for k:=1 to length(Str) do

          Str[k]:=chr(abs(ord(Str[k])-ord(ObrazMatrix[j][k]))+48); CodeTabl[i-1].Code:=Str;

  end; end;

procedure DoDecodeCikl;

var i,j,k:LongInt; St,Ost:string; Index:integer; b:integer;

function PXor(S1,S2:String):String;

var k:integer; PXorTemp:String; b:boolean; begin PXorTemp:=''; b:=false;

  for k:=1 to length(S1) do begin if S1[k]<>S2[k] then b:=true;

    if b then PXorTemp:=PXorTemp+chr(abs(ord(S1[k])-ord(S2[k]))+48); end;

  PXor:=PXorTemp; end;

function PXor2(S1,SM:String):String;

var k,i:integer; PXorTemp:String; begin PXorTemp:='';

  for k:=1 to length(S1)-length(SM) do PXorTemp:=PXorTemp+S1[k];

  for i:=k to length(S1) do PXorTemp:=PXorTemp+chr(abs(ord(S1[i])-ord(SM[i-k+1]))+48);

  PXor2:=PXorTemp; end;

function OstFromDelenie(St,Polinom:String):String;

var k:integer; O:String;

begin O:=''; for k:=1 to length(St) do begin

    if (O='') and (St[k]='0') then continue; O:=O+St[k]; if length(O)=length(Polinom) then

      O:=PXor(Polinom,O); end; OstFromDelenie:=O; end;

procedure CiklSdvigRight(var St:String);

var c:char; k:integer; begin c:=St[length(St)]; for k:=length(St) downto 2 do

    St[k]:=St[k-1]; St[1]:=c; end;

procedure CiklSdvigLeft(var St:String);

var c:char; k:integer; begin c:=St[1]; for k:=1 to Length(St)-1 do St[k]:=St[k+1];

  St[length(St)]:=c; end;

function Ves(Ost:String):integer; var k:integer; V:integer; begin V:=0;

  for k:=1 to length(Ost) do if Ost[k]='1' then inc(V); Ves:=V; end;

begin

  St:='';Index:=0; MaxLineDecode:=1; i:=1; b:=0;

while i<=length(TextExit) do begin

    St:=St+TextExit[i]; if TextExit[i]<>TextSource[i] then inc(b); inc(Index);

    if Index=MaxCodeSize then begin k:=0;

         while k<Length(St) do begin

               Ost:=OstFromDelenie(St,Polinom);

                  if Ves(Ost)<=SError then break;

               CiklSdvigLeft(St); inc(k); end; if k<length(St) then begin St:=PXor2(St,Ost);

        for j:=1 to k do CiklSdvigRight(St); end; if (b>0) and (b<=SError) then

          inc(CountErrorCorrect); if (b>SError) then inc(CountErrorNoCorrect);

      for j:=0 to LongCodeTabl-1 do if St=CodeTabl[j].Code then

          if CodeTabl[j].endline then begin inc(MaxLineDecode);break; end else begin

          TextDecode[MaxLineDecode-1]:=TextDecode[MaxLineDecode-]+CodeTabl[j].Sym;break;

       end; if j=LongCodeTabl then begin TextDecode[MaxLineDecode-

                    1]:=TextDecode[MaxLineDecode-]+'#';

      if (b>SError) then dec(CountErrorNoCorrect); end; St:=''; Index:=0; b:=0; end; inc(i); end; end;

end.

 

 

unit Kanal;

interface

Type RASPRED  =array[1..NP] of real;  { Вероятности пачек ошибок }

Var P:RASPRED;n_p:integer; { Длина пачки }

 

s:real;{ Контрольная сумма }

mistake:integer; { Число искажаемых разрядов }

razrjad:char; { Разряд собственной персоною }

x:real; { Для работы генератора СВ}

Function GEN(var x:real)  : real;

Function Sboy(var x:real) : integer;

procedure ControlAnsamble(PE:RASPRED;count:integer);

Procedure DOTransf(Str:String;var NewStr:String);

Implementation uses SysUtils;

Function GEN(var x:real): real;

const Pi=3.14159265; { Равномерно распределенная СВ [0,1]

  Mx=0.5, Dx=1/12, Sigma_x=0.2893  } var y : real;

Begin y:=exp(x+pi); x:=y-TRUNC(y); GEN:=x end;

Function Sboy(var x:real)   :integer;

{ Получение дискретной СВ, равной  длине пачки ошибки }

var sv :real; { непрерывная СВ } i:integer; Begin sv:=GEN(x); i:=1;

   while (i<=n_p)and(sv>P[i]) do i:=i+1; if i>n_p then Sboy:=0   { отсутствие ошибки }

      else Sboy:=i   { число пораженных разрядов } end;

procedure ControlAnsamble(PE:RASPRED;count:integer);

begin P:=PE; if count<=5 then n_p:=count else n_p:=5; s:=P[1]; x:=Random;

for i:=2 to n_p do Begin{ Контроль ансамбля и разметка интервала } s:=s+P[i]; P[i]:=s; end;

  if s>=1.0 then KODVOZVR:=false; end;

procedure DOTransf(Str:String; var NewStr:String);

var c:integer; bc:boolean; begin NewStr:=''; bc:=true; c:=1;{счетчик символов}

  repeat  { цикл по символам до конца строки }

  mistake:=Sboy(x); { далее используется как счетчик по вычитaнию }

   if (mistake>0) and (bc) then repeat razrjad:=Str[c]; Case razrjad of    { искажения }

        '1': Begin razrjad:='0'; mistake:=mistake-1 End;

        '0': Begin razrjad:='1'; mistake:=mistake-1 End End; NewStr:=NewStr+razrjad;

             c:=c+1; bc:=true; until (mistake<=0) or (c>StrLen(PChar(Str))) else

        Begin { без искажений } NewStr:=NewStr+Str[c];  c:=c+1; bc:=true; End

  until c>StrLen(PChar(Str)); end;

Begin Randomize; end.

 

 

unit obsh;

interface

uses Grids;

const MaxCountStr=11; MaxCodeType=8;

type TSP=record Sym:char; P:integer; endline:boolean; end;

       TStartInfo=array[0..100] of String; TCodeTabl=array[0..255] of record

     Sym:char; Code:String; endline:boolean; end;

    TStaticTabl=array[0..255] of TSP;

    TCodeMatrix=array[0..7] of String;

var Transf:TStartInfo;       {Исходное сообщение}

    MaxTransf:integer;       {Количество строк в исходном сообщении}

    StaticTabl:TStaticTabl; LongStaticTabl:integer;

    CodeTabl:TCodeTabl;      {Кодовая табица}

    LongCodeTabl:integer;     {Длина кодовой таблицы}

    MaxCodeSize:integer;       {Длина кодовой комбинации}

    AllSymbols:integer;           {Общее число символов}

    TextSource:string;       {Cообщение из 0 и 1 в виде одной строки, поступающее на вход канала}

TextExit:string;         {Cообщение из 0 и 1 в виде одной строки образующееся на выходе

 

канала}

    TextDecode:TStartInfo;   {Декодированное сообщение}

    MaxLineDecode:integer;

    CountErrorCorrect:integer; {Число исправленных ошибок}

    CountErrorNoCorrect:integer; {Исправленных неправильно}

procedure ClearCodeTabl;                     {Отчистка кодовой таблицы}

procedure ClearTabl(var Sender:TStringGrid); {Отчистка таблицы  TStringGrid}

function ReadCodeLine:String;                {Возвращает код конца строки}

function ReadCode(Sym:Char):String;  {Ищет в кодовой таблице Sym и возвращает его код}

procedure ConvertEntry;                      {Преобразует исходное собщение в набор 0 и 1}

implementation uses SysUtils;

procedure ClearCodeTabl;

var k:integer; begin for k:=0 to 255 do With CodeTabl[k] do

  begin Sym:=' '; Code:=''; end; LongCodeTabl:=0; end;

procedure ClearTabl(var Sender:TStringGrid);

var i,j:integer; begin With Sender as TStringGrid do for i:=0 to RowCount-1 do

    for j:=0 to ColCount-1 do Cells[j,i]:=''; end;

function ReadCode(Sym:Char):String;

var k:integer; begin ReadCode:=''; for k:=0 to LongCodeTabl-1 do

    if (CodeTabl[k].Sym=Sym) and not (CodeTabl[k].endline) then ReadCode:=CodeTabl[k].Code;

end;

function ReadCodeLine:String;

var k:integer; begin ReadCodeLine:=''; for k:=0 to LongCodeTabl-1 do

    if CodeTabl[k].endline then ReadCodeLine:=CodeTabl[k].Code; end;

procedure ConvertEntry;

var k,i:integer;

begin TextSource:='';

  for k:=0 to MaxTransf-1 do begin for i:=1 to StrLen(PChar(Transf[k])) do

      TextSource:=TextSource+ReadCode(Transf[k][i]);

      TextSource:=TextSource+ReadCodeLine; end;end;

  end.

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

ПРИЛОЖЕНИЕ  Б