Криптосистема Des Delphi

Этот код я написал еще в колледже за неделю.. Вот вид самой программы:

Здесь используется 8ми байтное шифруемое сообщение и 8ми байтный ключ.. Но конечно при незначительной доработке можно сделать полное шифрование любого текстового документа.. Исходные коды программы:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Button2: TButton;
    Edit5: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Button3: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
     //
    { Private declarations }
  public
    { Public declarations }
  end;
  b1=array[1..28] of boolean;
  b2=array[1..48] of boolean;
  b3=array[1..32] of boolean;
  procedure slijanieCD(cw:b1;dw:b1);
  procedure kluchyk;
  procedure rasher(rl:b3);
  procedure shifr(rr:b3;kr:b2);
  procedure modul2(gl:b3;gf:b3);
  procedure glawnaja;
  var
  Form1: TForm1;
  SOOBSHENYE,KLUCH:ARRAY[1..8] OF BYTE;
  nach,p1,kl,kon1,kon2:array[1..64] of boolean;
  l0,r0,got,modl2:b3;
  I,j,chislo1,chislo2,increm,mmm:INTEGER;
  b,cd,prom4:array[1..56] of boolean;
  c1,d1,c0,d0,prom1,prom2,prom7:b1;
  kprom,erprom,rkprom,kprom2,kprom3:b2;
  shifrowka:string;
  flag:boolean;
  kluc,kluc2:array [1..16] of b2;
  procedure sdwig1(x:integer;prom6:b1);

  implementation

{$R *.dfm}


procedure TForm1.Button1Click(Sender: TObject);
begin
if (length(edit1.Text)=8) and (length(edit2.Text)=8) then begin

flag:=false;
shifrowka:='';
increm:=1;
FOR I:=1 TO 8 DO
BEGIN
SOOBSHENYE[I]:=ORD(EDIT1.TEXT[I]);
KLUCH[I]:= ORD(EDIT2.TEXT[I]);
END;
glawnaja;
form1.edit3.Text:=shifrowka;
end
else
showmessage('WWedyte rowno 8 BAyt  !!!!!');

 end;



 //!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 procedure glawnaja;
 begin
  {Преобразовани в двоичную последовательность}
FOR I:=1 TO 8 DO
  begin
    chislo1:=SOOBSHENYE[I];
    chislo2:= KLUCH[I];
        for j:=8*i downto increm do
          BEGIN
            kl[j]:=bool(chislo2 mod 2);  //двоичная последовательность ключа
            nach[j]:= bool(chislo1 mod 2); //двоичная последовательность открытого текста
            chislo1:=chislo1 div 2;
            chislo2:=chislo2 div 2;
            increm:=increm+1;
          end;
  end;
{********************************************}

{Начальная перестановка}
for i:=1 to 64 do
 begin
 p1[i]:=nach[n1[i]];
 end;
{*********************}
 //1111111111111111111111111111111111111111
{Получение двух последовательностей L(0) и R(0)}
if flag=false then
begin
for j:=1 to 32 do
  begin
   l0[j]:=p1[j];
   r0[j]:=p1[32+j];
  end;
end;
if flag=true then
begin
for j:=1 to 32 do
  begin
   r0[j]:=p1[j];
   l0[j]:=p1[32+j];
  end;
end;
{**********************************}

{Матрица B первоначальной подготовки ключа (56 разрядов)}
 for i:=1 to 56 do
  begin
   b[i]:=kl[n2[i]];
  end;
{******************************************************}

 {Получение последовательностей C0 и D0}
 for i:=1 to 28 do
  begin
   c0[i]:=b[i];
   d0[i]:=b[i+28];
  end;
 {*************************************}

 {Получение последовательностей D(i) и C(i) посредством}
 {циклически сдвигающей процедуры sdwig1}


//получение c(i)
for j:=1 to 16 do
begin

sdwig1(sdv[j],c0);
c0:=prom7;
sdwig1(sdv[j],d0);
d0:=prom7;
slijanieCD(c0,d0);
 kluchyk;  //
kluc[j]:=kprom;
{Получение последовательностей K(i)}


end;

if flag=true then
begin
for i:=1 to 16 do
begin
kluc2[i]:=kluc[17-i];
end;
kluc:=kluc2;

end;
for mmm:=1 to 16 do
begin
{Основная часть}
shifr(r0,kluc[mmm]);
modul2(l0,got);
l0:=r0;
r0:= modl2;
end;

if flag=false then begin
for i:=1 to 32 do
begin
kon1[i]:=l0[i];
end;
for i:=33 to 64 do
begin
kon1[i]:=r0[i-32];
end;
end;

if flag=true then begin
for i:=1 to 32 do
begin
kon1[i]:=r0[i];
end;
for i:=33 to 64 do
begin
kon1[i]:=l0[i-32];
end;
end;
for i:=1 to 64 do
begin
kon2[i]:=kon1[n6[i]];
end;

//процедура перевода в ASCII

for i:=0 to 7 do
begin
chislo1:=0;
for j:=0 to 7 do
begin
chislo1:=chislo1+(ord(kon2[(j+1)+8*i]))*trunc((intpower(2,7-j)));
SOOBSHENYE[I+1]:=chislo1;
end;
end;
for i:=1 to 8 do
begin
shifrowka:=shifrowka+char(SOOBSHENYE[i]);
end;

 end;
//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!



 procedure modul2(gl:b3;gf:b3);
 begin
 for i:=1 to 32 do
 begin
 modl2[i]:=gl[i] xor gf[i];
 end;
 end;

 procedure shifr(rr:b3;kr:b2);
 var
 stroka:array[1..2] of boolean;
 stolbec:array[1..4] of boolean;
 chis1,chis2:integer;
 strocy,stolbcy:array[0..7] of integer;
bch:array[1..8] of integer;
 s:array[1..32] of boolean;
 begin
 increm:=1;
 rasher(rr);
 for i:=1 to 48 do
 begin
 rkprom[i]:=erprom[i] xor kr[i];
 end;
 for i:=0 to 7 do
 begin
 stroka[1]:=rkprom[1+i*6];stroka[2]:=rkprom[6+i*6];stolbec[1]:=rkprom[2+i*6];
 stolbec[2]:=rkprom[3+i*6];stolbec[3]:=rkprom[4+i*6];stolbec[4]:=rkprom[5+i*6];
 chis1:=ord(stroka[1])*2+ord(stroka[2]);
 chis2:=ord(stolbec[1])*8+ord(stolbec[2])*4+ord(stolbec[3])*2+ord(stolbec[4]);
 strocy[i]:=chis1;stolbcy[i]:=chis2;
 end;
bch[1]:=s1[ strocy[0],stolbcy[0]];bch[2]:=s2[ strocy[1],stolbcy[1]];
bch[3]:=s3[ strocy[2],stolbcy[2]];bch[4]:=s4[ strocy[3],stolbcy[3]];
bch[5]:=s5[ strocy[4],stolbcy[4]];bch[6]:=s6[ strocy[5],stolbcy[5]];
bch[7]:=s7[ strocy[6],stolbcy[6]];bch[8]:=s8[ strocy[7],stolbcy[7]];

for i:=1 to 32 do
begin
s[i]:=false;
end;
FOR I:=1 TO 8 DO
  begin
    chislo1:=bch[i];

        for j:=4*i downto increm do
          BEGIN

          s[j]:= bool(chislo1 mod 2); //двоичная последовательность открытого текста
            chislo1:=chislo1 div 2;

            increm:=increm+1;
          end;
  end;
  for i:=1 to 32 do
  begin
   got[i]:=s[n5[i]];
  end;
  end;

 {Процедура раширения с 32 до 48 бит}
 procedure rasher(rl:b3);
 begin
 for i:=1 to 48 do
 begin
 erprom[i]:=rl[n4[i]];
 end;
 end;
 {***********************************}

 {Процедура завершающей обработки ключа}
 procedure kluchyk;
 begin
  for i:=1 to 48 do
  begin
  kprom[i]:=cd[n3[i]];
  end;
 end;
{**************************************}

{Функция конкатенации последовательностей C(i)D(i)}
procedure slijanieCD( cw:b1;dw:b1);
begin
 for i:=1 to 28 do
   begin
      cd[i]:=cw[i];
   end;

 for i:=29 to 56 do
   begin
      cd[i]:=dw[i-28];
   end;

   end;
{******************************************}

 {Функция циклического сдвига}
 procedure  sdwig1(x:integer;prom6:b1);
var
 prom3:b1;

 begin
   for i:=1+x to 28 do
     begin
      prom3[i-x]:=prom6[i];
     end;
   for i:=x downto 1 do
     begin
      prom3[29-i]:=prom6[x-i+1];
     end;
   for i:=1 to 28 do
     begin
      prom7[i]:=prom3[i];
     end;
 end;
 {********************************}
 procedure TForm1.Button2Click(Sender: TObject);
begin
   if (length(edit3.Text)=8) and (length(edit4.Text)=8) then begin;

   flag:=true;shifrowka:='';increm:=1;chislo1:=0;chislo2:=0;
 FOR I:=1 TO 8 DO
BEGIN
SOOBSHENYE[I]:=ORD(edit3.text[i]);
KLUCH[I]:= ORD(edit4.text[i]);
END;
  glawnaja;
{Преобразовани в двоичную последовательность}

{********************************************}


 form1.edit5.Text:=shifrowka;
 end
else
showmessage('WWedyte 8 BAYT!!!!!');
 end;

procedure TForm1.Button3Click(Sender: TObject);
var
 T:array[0..7] of integer;
begin
edit2.Clear;
edit4.Clear;
randomize;
T[0]:=RandomRange(65,256);

for i:=1 to 7 do
begin
j:=random(14);
t[i]:=(5*t[i-1]+j)mod 256;
end;
for i:=0 to 7 do
begin
edit2.Text:=edit2.Text+char(t[i]);
edit4.Text:=edit4.Text+char(t[i]);
end;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
edit1.Clear;
edit2.Clear;
edit3.Clear;
edit4.Clear;
end;

end.



unit Unit2;

interface
const

//начальная перестановка (64 разряда)
n1:array[1..64]of integer=(58,50,42,34,26,18,10,2,60,52,44,36,28,20,12,4,62,54,46,38,30,22,14,6,64,56,48,40,32,24,16,8,57,49,41,33,25,17,9,1,59,51,43,35,27,19,11,3,61,53,45,37,29,21,13,5,63,55,47,39,31,23,15,7);

//Матрица перестановки для первоначальной подготовки ключа (56 разрядов)
n2:array[1..56] of integer=(57,49,41,33,25,17,9,1,58,50,42,34,26,18,10,2,59,51,43,35,27,19,11,3,60,52,44,36,63,55,47,39,31,23,15,7,62,54,46,38,30,22,14,6,61,53,45,37,29,21,13,5,28,20,12,4);

//Матрица перестановки для завершающей обработки ключа(48 разрядов)
n3:array[1..48] of integer=(14,17,11,24,1,5,3,28,15,6,21,10,23,19,12,4,26,8,16,7,27,20,13,2,41,52,31,37,47,55,30,40,51,45,33,48,44,49,39,56,34,53,46,42,50,36,29,32);

//Матрица перестановки для расширения с 32 до 48 бит
n4:array[1..48] of integer=(32,1,2,3,4,5,4,5,6,7,8,9,8,9,10,11,12,13,12,13,14,15,16,17,16,17,18,19,20,21,20,21,22,23,24,25,24,25,26,27,28,29,28,29,30,31,32,1);

//Матрицы преобразования s(i) из 6ти бит в 4ре бита
s1:array[0..3,0..15] of integer=((14,4,13,1,2,15,11,8,3,10,6,12,5,9,0,7),(0,15,7,4,14,2,13,1,10,6,12,11,9,5,3,8),(4,1,14,8,13,6,2,11,15,12,9,7,3,10,5,0),(15,12,8,2,4,9,1,7,5,11,3,14,10,0,6,13));
s2:array[0..3,0..15] of integer=((15,1,8,14,6,11,3,4,9,7,2,13,12,0,5,10),(3,13,4,7,15,2,8,14,12,0,1,10,6,9,11,5),(0,14,7,11,10,4,13,1,5,8,12,6,9,3,2,15),(13,8,10,1,3,15,4,2,11,6,7,12,0,5,14,9));
s3:array[0..3,0..15] of integer=((10,0,9,14,6,3,15,5,1,13,12,7,11,4,2,8),(13,7,0,9,3,4,6,10,2,8,5,14,12,11,15,1),(13,6,4,9,8,15,3,0,11,1,2,12,5,10,14,7),(1,10,13,0,6,9,8,7,4,15,14,3,11,5,2,12));
s4:array[0..3,0..15] of integer=((7,13,14,3,0,6,9,10,1,2,8,5,11,12,4,15),(13,8,11,5,6,15,0,3,4,7,2,12,1,10,14,9),(10,6,9,0,12,11,7,13,15,1,3,14,5,2,8,4),(3,15,0,6,10,1,13,8,9,4,5,11,12,7,2,14));
s5:array[0..3,0..15] of integer=((2,12,4,1,7,10,11,6,8,5,3,15,13,0,14,9),(14,11,2,12,4,7,13,1,5,0,15,10,3,9,8,6),(4,2,1,11,10,13,7,8,15,9,12,5,6,3,0,14),(11,8,12,7,1,14,2,13,6,15,0,9,10,4,5,3));
s6:array[0..3,0..15] of integer=((12,1,10,15,9,2,6,8,0,13,3,4,14,7,5,11),(10,15,4,2,7,12,9,5,6,1,13,14,0,11,3,8),(9,14,15,5,2,8,12,3,7,0,4,10,1,13,11,6),(4,3,2,12,9,5,15,10,11,14,1,7,6,0,8,13));
s7:array[0..3,0..15] of integer=((4,11,2,14,15,0,8,13,3,12,9,7,5,10,6,1),(13,0,11,7,4,9,1,10,14,3,5,12,2,15,8,6),(1,4,11,13,12,3,7,14,10,15,6,8,0,5,9,2),(6,11,13,8,1,4,10,7,9,5,0,15,14,2,3,12));
s8:array[0..3,0..15] of integer=((13,2,8,4,6,15,11,1,10,9,3,14,5,0,12,7),(1,15,13,8,10,3,7,4,12,5,6,11,0,14,9,2),(7,11,4,1,9,12,14,2,0,6,10,13,15,3,5,8),(2,1,14,7,4,10,8,13,15,12,9,0,3,5,6,11));

{Р - перестановка бит в 32-битовой последовательности}
n5:array[1..32] of integer=(16,7,20,21,29,12,28,17,1,15,23,26,5,18,31,10,2,8,24,14,32,27,3,9,19,13,30,6,22,11,4,25);

n6:array[1..64] of integer=(40,8,48,16,56,24,64,32,39,7,47,15,55,23,63,31,38,6,46,14,54,22,62,30,37,5,45,13,53,21,61,29,36,4,44,12,52,20,60,28,35,3,43,11,51,19,59,27,34,2,42,10,50,18,58,26,33,1,41,9,49,17,57,25);

sdv:array[1..16] of integer=(1,1,2,2,2,2,2,2,1,2,2,2,2,2,2,1);
implementation

end.
 
Алгоритм шифрования DES.
 
Определение переменных.
SOOBSHENYE, KLUCH-начальные строковые значения шифруемого сообщения и ключа соответственно;
 
I, j, mmm, chislo1,chislo2,increm - целочисленные переменные (первые три ипользуются в циклах ; chislo1,chislo2   используются для разложения чисел в битовую последовательность; increm просто счетчик ); 

nach,p1,kl,kon1,kon2- 64 битовые матрицы (nach[]-начальная последовательность щифруемого сообщения; p1[]-начальная перестановка; kl- начальная последовательность ключа; kon1-последовательность бит содержащая выходные  значения функции шифрования - L16[] и R16[]: kon2[]-матрица конечной перестановки );

l0,r0,got,modl2- 32 разрядные матрицы (l0[],r0[]-последовательности от 0.. 16 рекурсивно получаемые через функцию шифрования; got[]-выходное значение шифрующей функции; modl2[]-выходное значение сложения по модулю два ) ; 

 b,cd- 56 разрядные матрицы (b[]- Матрица первоначальной подготовки ключа; cd[]-матрица конкатенации последовательностей с1[] и d1[] ); 

c1,d1,c0,d0- 28 разрядные последовательности  (последовательности получаемые рекурсивно с применением функции сдвига ); 

shifrowka – строковая переменная используемая для  вывода всех получаемых в ходе шифрования и дешифрования значений; 

kluc[],kluc2[]-вектора 1..16 состоящие из всех последовательностей выходных значений ключей 1..48.

//начальная перестановка (64 разряда)
n1[]=(58,50,42,34,26,18,10,2,60,52,44,36,28,20,12,4,62,54,46,38,30,22,14,6,64,56,48,40,32,24,16,8,57,49,41,33,25,17,9,1,59,51,43,35,27,19,11,3,61,53,45,37,29,21,13,5,63,55,47,39,31,23,15,7);

//Матрица перестановки для первоначальной подготовки ключа (56 разрядов)
n2[]=(57,49,41,33,25,17,9,1,58,50,42,34,26,18,10,2,59,51,43,35,27,19,11,3,60,52,44,36,63,55,47,39,31,23,15,7,62,54,46,38,30,22,14,6,61,53,45,37,29,21,13,5,28,20,12,4);

//Матрица перестановки для завершающей обработки ключа(48 разрядов)
n3[]=(14,17,11,24,1,5,3,28,15,6,21,10,23,19,12,4,26,8,16,7,27,20,13,2,41,52,31,37,47,55,30,40,51,45,33,48,44,49,39,56,34,53,46,42,50,36,29,32);

//Матрица перестановки для расширения с 32 до 48 бит
n4[]=(32,1,2,3,4,5,4,5,6,7,8,9,8,9,10,11,12,13,12,13,14,15,16,17,16,17,18,19,20,21,20,21,22,23,24,25,24,25,26,27,28,29,28,29,30,31,32,1);

//Матрицы преобразования s(i) из 6ти бит в 4ре бита
s1[]=((14,4,13,1,2,15,11,8,3,10,6,12,5,9,0,7),(0,15,7,4,14,2,13,1,10,6,12,11,9,5,3,8),(4,1,14,8,13,6,2,11,15,12,9,7,3,10,5,0),(15,12,8,2,4,9,1,7,5,11,3,14,10,0,6,13));

s2[]=((15,1,8,14,6,11,3,4,9,7,2,13,12,0,5,10),(3,13,4,7,15,2,8,14,12,0,1,10,6,9,11,5),(0,14,7,11,10,4,13,1,5,8,12,6,9,3,2,15),(13,8,10,1,3,15,4,2,11,6,7,12,0,5,14,9));

s3[]=((10,0,9,14,6,3,15,5,1,13,12,7,11,4,2,8),(13,7,0,9,3,4,6,10,2,8,5,14,12,11,15,1),(13,6,4,9,8,15,3,0,11,1,2,12,5,10,14,7),(1,10,13,0,6,9,8,7,4,15,14,3,11,5,2,12));

s4[]=((7,13,14,3,0,6,9,10,1,2,8,5,11,12,4,15),(13,8,11,5,6,15,0,3,4,7,2,12,1,10,14,9),(10,6,9,0,12,11,7,13,15,1,3,14,5,2,8,4),(3,15,0,6,10,1,13,8,9,4,5,11,12,7,2,14));

s5[]=((2,12,4,1,7,10,11,6,8,5,3,15,13,0,14,9),(14,11,2,12,4,7,13,1,5,0,15,10,3,9,8,6),(4,2,1,11,10,13,7,8,15,9,12,5,6,3,0,14),(11,8,12,7,1,14,2,13,6,15,0,9,10,4,5,3));

s6[]=((12,1,10,15,9,2,6,8,0,13,3,4,14,7,5,11),(10,15,4,2,7,12,9,5,6,1,13,14,0,11,3,8),(9,14,15,5,2,8,12,3,7,0,4,10,1,13,11,6),(4,3,2,12,9,5,15,10,11,14,1,7,6,0,8,13));

s7[]=((4,11,2,14,15,0,8,13,3,12,9,7,5,10,6,1),(13,0,11,7,4,9,1,10,14,3,5,12,2,15,8,6),(1,4,11,13,12,3,7,14,10,15,6,8,0,5,9,2),(6,11,13,8,1,4,10,7,9,5,0,15,14,2,3,12));

s8=((13,2,8,4,6,15,11,1,10,9,3,14,5,0,12,7),(1,15,13,8,10,3,7,4,12,5,6,11,0,14,9,2),(7,11,4,1,9,12,14,2,0,6,10,13,15,3,5,8),(2,1,14,7,4,10,8,13,15,12,9,0,3,5,6,11));

{Р - перестановка бит в 32-битовой последовательности}
n5=(16,7,20,21,29,12,28,17,1,15,23,26,5,18,31,10,2,8,24,14,32,27,3,9,19,13,30,6,22,11,4,25);

{Конечная перестановка }
n6=(40,8,48,16,56,24,64,32,39,7,47,15,55,23,63,31,38,6,46,14,54,22,62,30,37,5,45,13,53,21,61,29,36,4,44,12,52,20,60,28,35,3,43,11,51,19,59,27,34,2,42,10,50,18,58,26,33,1,41,9,49,17,57,25);

{Матрица сдвига для последовательностей Сi и Di}
sdv =(1,1,2,2,2,2,2,2,1,2,2,2,2,2,2,1);
 
stroka-значение номера строки для матрицы si;  stolbec- значение номера столбца для матрицы si; chis1-десятичное представление номера строки; chis2-десятичное представление номера столбца, strocy-все строки  шестибитных последовательностей; stolbcy-все столбцы; bch-четырех битные десятичные значения матриц Si; s-выходная 32 битная двоичная последовательность. 

Все остальные переменные и используемые в алгоритме применяются в качестве промежуточных значений. 
 
Основные процедуры

Процедура shifr есть ничто иное как F(R,K) описанная ранее, процедура rasher расширяет входные 32 битные последовательности до 48 битных, kluchyk- создает завершающую перестановку для определения ключа, slijanieCD-процедура конкатенации последовательностей C(i)D(i), sdwig1-применяется для циклических сдвигов последовательностей C(i)D(i), modul2-процедура выполняющая операцию суммы по модулю 2 .

 

 В данной работе алгоритм расшифровки рассматриваться не будет т.к. он практически идентичен алгоритму шифрования, всех заинтересованных прошу прочесть теоретические сведения о DES описанные раннее.!!! 

Программа компилятор / интерпретатор

Однажды в далекие далекие времена... Еще когда DOS бороздил просторы перфокартных и ламповых компьютеров.. Офицер военно морского флота, причем женского пола спроектировала и разработала самую первую компиляционную программу, с этого времени и появился первый ASM.
На сегодня существует большое множество проектов посвященных созданию собственного компилятора.. Я же просто покажу свою версию, сделанную не без помощи книги Девида Креншоу и его алгоритма синтаксического анализатора написанного на Pascal и переработанного мной на систему Delphi. При этом добавлю лишь, что очень много времени извел на эту туфту и в итоге смог создать базовый практически движок для разработки интерпритационной системы... Или интерпритатор, который работает на динамической памяти и командах сопроцессора.. Простыми словами интерпритатор-это программа способная преобразовывать пользовательскую писанину в реальные коды процессора или сопроцессора.
Данный продукт имеет в своем составе имеет несколько управляющих элементов.

А именно:

1)Поле для ввода значений.

Например

(2+3.454)-34*12

2) Кнопка запуска(Compil) которая запускает программу компиляции.

3) Кнопка вывода(RESHENIE) полученного результата.

4) Поле вывода результата.

5) Поле вывода ошибок.

6) Имеется вкладка основные функции, где расположены функции применяемые в высшей математике

Код программы:
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,unit2, ExtCtrls, Menus, ComCtrls, MPlayer,ShellAPI;

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Edit1: TEdit;
Button3: TButton;
Edit2: TEdit;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
ComboBox1: TComboBox;
Label1: TLabel;
TabSheet2: TTabSheet;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Panel1: TPanel;
MediaPlayer1: TMediaPlayer;
Timer1: TTimer;
Label5: TLabel;
MainMenu1: TMainMenu;
File1: TMenuItem;
N1: TMenuItem;
procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure N1Click(Sender: TObject);


private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
//st:string;
ret:array[1..1000] of byte;
adresskuch:pointer;
adresskodow,adressvozwrata,adressperem1,adressperem2:pointer;
perem1,perem2:longint;
rety:array [1..10] of char;
perprrom:real;
adr:pointer;
flag5:boolean;
implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
label
metka1,metka2,net,dalee;
var
h:thandle;
i,j:cardinal;
g:textfile;
r,y:longword;
HandHead:cardinal;

begin
flag5:=true;
incremm:=0;
dwa:=180;
for j:=1 to 20 do
begin
st6[k]:=#0;
end;
kk:=0;
chisla:=chisla2;
dincrem:=0;
peremen:='';
flag:=false;
perem1:=0;
for i:=1 to 10 do
rety[i]:=#0;
adressperem1:=@perem1;
adressperem2:=@perem2;
adresskodow:=@ret;
memo1.Clear;
edit2.Clear;
//memo2.Clear;
st:=edit1.Text;
k:=0;
st2:='0';
Init ;
expression;
assignfile(g,'roman.txt');
rewrite(g);
for j:=1 to 200 do
writeln(g,memo1.Lines[j]);
closefile(g);
HandHead:=GetProcessHeap;
adresskuch:=HeapAlloc(HandHead,0,q+3);
BUTTON3.Enabled:=true;
asm
mov eax,offset metka2
push eax
mov ecx,q
mov esi,adresskodow
mov edi,adresskuch
rep movsb
mov ecx,1
mov eax,58h
mov ebx,q
add ebx,0
add ebx,adresskuch
mov edi,ebx
repne stosb
mov ecx,1
mov eax,0ffh
mov ebx,q
add ebx,1
add ebx,adresskuch
mov edi,ebx
repne stosb
mov ecx,1
mov eax,0e0h
mov ebx,q
add ebx,2
add ebx,adresskuch
mov edi,ebx
repne stosb
jmp adresskuch
metka2:
fld qword ptr [esi]
fst perprrom
wait
end;
button1.Enabled:=false;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
mediaplayer1.Display:=panel1;
mediaplayer1.FileName:='roman.avi';
mediaplayer1.Open;
mediaplayer1.Play;
//pagecontrol1.tabSheet1
BUTTON3.Enabled:=FALSE;
ComboBox1.Items.Add('cosyn');
ComboBox1.Items.Add('sinus');
ComboBox1.Items.Add('cor');
//ComboBox1.Items.Add('cotangens');
end;

procedure TForm1.Button3Click(Sender: TObject);
var
i:integer;

begin
button1.Enabled:=true;
button3.Enabled:=false;
edit2.Clear;
//memo2.Clear;
//memo2.Lines.Add(floattostr(perprrom));
edit2.Text:=floattostr(perprrom);
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
if ComboBox1.ItemIndex=0 then begin
edit1.SelText:='cosyn()';
end;
if ComboBox1.ItemIndex=1 then begin
edit1.SelText:='sinus()';
end;
if ComboBox1.ItemIndex=2 then begin
edit1.SelText:='cor()';
end;
//if ComboBox1.ItemIndex=3 then begin
//edit1.Text:=edit1.Text+' cotangens';
//end;

end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
mediaplayer1.Play;
end;

procedure TForm1.N1Click(Sender: TObject);
var
h: hwnd;
begin
ShellExecute(h, 'open', 'ИГС.chm', nil, nil, SW_SHOWNORMAL);
end;

end.




unit Unit2;
interface
function GetChar2:char;
procedure GetChar;
procedure Error(s: string);
procedure Abort(s: string);
procedure Expected(s: string);
procedure Match(x: char);
function IsAlpha(c: char): boolean;
function IsDigit(c: char): boolean;
function GetName: char;
function GetNum: char;
procedure Emit(s: string);
procedure EmitLn(s: string);
procedure Init;
procedure factor;
procedure multiply;
procedure divide;
procedure term;
procedure add;
procedure subtract;
procedure expression;
function IsAddop(c: char): boolean;
function GetChar3:char;
procedure Ident;

procedure adresss(rerro:integer);
const
co:string='cosyn';//#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0;
si:string='sinus';
ko:string='cor';
dwesti70:array[1..2] of real=(270,90);
trysto60:array[1..2] of real=(360,180);
var
flag:boolean;
i,i2:integer;
q:CARDINAL;
sim,sim1:char;
st:string;
st2:array[0..20] of char;
st3:array[0..20] of byte;
st4:array[1..200] of byte;
st6:array[0..20] of char;
look2:char;
k,b,k2,ch,kk:integer;
chislo:LONGWORD;
kruto:string;
kruto2:string[8];
name:string;
peremen:string;
realper:real;
din:^real;
chisla,chisla2:array[1..200] of real;
dincrem:integer;
adss:pointer;
pro,pro1:real;
dwa:real;
dopolm:integer;
nuli:integer;
slowo:word;
rr:integer;
peremen1:integer;
incremm:integer;
Look:char;
implementation

uses unit1,SysUtils,unit3,dialogs;
label
perexod;
{--------------------------------------------------------------}
{ }
const TAB = ^I;
exp:array[0..9] of longWORD=(1,10,100,1000,10000,100000,1000000,10000000,100000000,1000000000);
exp1=16;
{--------------------------------------------------------------}
{ }
{}
{--------------------------------------------------------------}

{Процедура считки символа}
procedure GetChar;
begin
inc(i);
Look:=st[i];{chitaem simwol}
end;
{--------------------------------------------------------------}

function GetChar2:char;
begin
look2:=st[i];{chitaem simwol}
result:=look2;
end;
function GetChar3:char;
begin
look2:=st[i];{chitaem simwol}
result:=upcase(look2);
end;
{ }
procedure Error(s: string);
begin
form1.Memo1.Lines.Add('');
form1.Memo1.Lines.Add(^G+'Error: '+s+'.');

end;
{--------------------------------------------------------------}

{--------------------------------------------------------------}
{ проверка на +,-}
function IsAddop(c: char): boolean;
begin
IsAddop := c in ['+', '-'];
end;
{--------------------------------------------------------------}

{ }
procedure Abort(s: string);
begin
Error(s);
Halt;
end;
{--------------------------------------------------------------}

{ }
procedure Expected(s: string);
begin
Abort(s + ' Expected');
end;
{--------------------------------------------------------------}

{если скобочка то берем новый символ }
procedure Match(x: char);
begin
if Look = x then GetChar
else Expected('''' + x + '''');
end;
{--------------------------------------------------------------}

{проверка на буквы }
function IsAlpha(c: char): boolean;
begin
IsAlpha := upcase(c) in ['A'..'Z'];
end;
{--------------------------------------------------------------}

{ проверка на числа}
function IsDigit(c: char): boolean;
begin
IsDigit := c in ['0'..'9'];
if c='.' then begin
result:=true;
end;

end;
{--------------------------------------------------------------}

{ }
function GetName: char;
begin
if not IsAlpha(Look) then Expected('Name');
GetName := UpCase(Look);
GetChar;
end;
{--------------------------------------------------------------}

{ }
function GetNum: char;
begin
if not IsDigit(Look) then Expected('Integer');
GetNum := Look;
GetChar;
end;
{--------------------------------------------------------------}

{ }
procedure Emit(s: string);
begin
form1.Memo1.Lines.Add(TAB+s);
end;
{--------------------------------------------------------------}

{ }
procedure EmitLn(s: string);
begin
Emit(s);
form1.Memo1.Lines.Add('');
end;
{--------------------------------------------------------------}

{начало работы транслятора }
procedure Init;
begin
q:=0;
i:=0;
GetChar;{chitaem simwol}
end;
{проверка на (,)}
procedure factor;
begin
if Look = '(' then begin
Match('(');//новый символ
Expression;
Match(')');
end
else
if IsAlpha(Look) then //проверка на буквы

begin {проверка на (A..Z) т.е переменные}
flag5:=true;
Ident;
{inc(q);
ret[q]:=$BE; //mov esi,[chyslo]
inc(q);
ret[q]:=$2c+(8*dincrem);
inc(q);
ret[q]:=$4c;
inc(q);
ret[q]:=$45;
inc(q);
ret[q]:=$00;
inc(kk);

inc(dincrem);}



end;

if isdigit(look) then BEGIN//если число
while (getchar2 in ['0'..'9']) or (getchar2=',') do
begin
peremen:=peremen+st[i];

inc(i);

end;
inc(kk);
chisla[kk]:=strtofloat(peremen);
adss:=@chisla[kk];
peremen1:=integer(adss);
adresss(peremen1);
////////////////////////////////////
adss:=@dwesti70;
peremen1:=integer(adss);
adresss(peremen1);
////////////////////////////////////
adss:=@slowo;
peremen1:=integer(adss);
adresss(peremen1);

//////////////////////////////////
adss:=@dwa;
realper:=chisla[kk];
peremen1:=integer(adss);
adresss(peremen1);
///////////////////////////////////
////////////////////////////////////
adss:=@trysto60;
peremen1:=integer(adss);
adresss(peremen1);

peremen:='';
dec(i);
getchar;

{Создаем для каждого числа адрес}
inc(q);
ret[q]:=$BE; //mov esi,[chyslo]
inc(q);
ret[q]:=st4[1]+(8*dincrem); // chisla[kk]
inc(q);
ret[q]:=st4[2];
inc(q);
ret[q]:=st4[3];
inc(q);
ret[q]:=st4[4];
{-------------------------------}

inc(dincrem);
k:=0;
END;

end;


procedure Ident;
var Name: string;
begin
for k:=0 to 20 do
begin
st6[k]:=#0;
end;
k:=0;
while getchar3 in ['A'..'Z'] do
begin
st6[k]:=st[i];
inc(i);
inc(k);
end;
if (st[i]<>'(') then
begin
flag5:=false;
end;
if string(st6)=co then
begin
cosinusRun;
end;
if string(st6)=si then
begin
sinusRun;
end;

if string(st6)=ko then
begin
korenrun;
end;

if (k<>0)and (flag5=true) then
begin
form1.Memo1.Lines.Add('OSHIBKA FUNCIJA '+st6+ ' NEOPREDElENA!!!');
form1.Button3.Enabled:=false;
end;
dec(i);
getchar;

end;






procedure multiply;
begin
match('*');
factor;

{Загрузка в сопроцессор умножаемых чисел}

inc(q);
ret[q]:=$DD; //В st число
inc(q);
ret[q]:=$06;

inc(q); // pop [esi] предыдущее число
ret[q]:=$5E;

inc(q);
ret[q]:=$DD; //В st число
inc(q);
ret[q]:=$06;
{----------------------------------------}

{Умножение!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!}
INC(Q);
RET[Q]:=$DE; //fmul
INC(Q);
RET[Q]:=$C9;
{----------------------------------------}

{Сохранение информации }
INC(Q);
RET[Q]:=$DD; //fst
INC(Q);
RET[Q]:=$1E;
{-----------------------------------------}

end;
procedure divide;
begin
match('/');
factor;
inc(q);
ret[q]:=$DD; //В st число
inc(q);
ret[q]:=$06;

inc(q);
ret[q]:=$5E; //pop [esi]

inc(q);
ret[q]:=$DD; //В st число
inc(q);
ret[q]:=$06;

inc(q);
ret[q]:=$DE; //Деление fdiv
inc(q);
ret[q]:=$F1;

{Сохранение информации }
INC(Q);
RET[Q]:=$DD; //fst
INC(Q);
RET[Q]:=$1E;
{-----------------------------------------}


end;
{проверка на *,/}
procedure term;
begin
factor;//на скобки
while look in ['*','/'] do
begin

inc(q);
ret[q]:=$56; //push [esi]

case look of
'*':multiply;
'/':divide;
else expected('mulor');
end;
end;
end;
procedure add;
begin
match('+');
term;

inc(q);
ret[q]:=$DD;
inc(q); //В st число
ret[q]:=$06;


INC(Q);
RET[Q]:=$DE; //fadd
INC(Q);
RET[Q]:=$C1;

INC(Q);
RET[Q]:=$DD;
INC(Q); //fst
RET[Q]:=$1E;
end;
{--------------------------------------------------------------}
procedure subtract;
begin
match('-');
term;

inc(q);
ret[q]:=$DD; //В st число
inc(q);
ret[q]:=$06;

inc(q);
RET[Q]:=$DE; //fsub
inc(q);
ret[q]:=$E9;

INC(Q);
RET[Q]:=$DD; //fst
INC(Q);
RET[Q]:=$1E;

end;
procedure expression; {Обработкка знаков(-,+)}
begin
if (look='-') then//если (-,+) то
begin {Проверяет на минус}


inc(kk);
chisla[kk]:=0;
inc(q);
ret[q]:=$BE; //[esi] равно 0
inc(q);
ret[q]:=st4[1]+(8*dincrem); // chisla[kk]
inc(q);
ret[q]:=st4[2];
inc(q);
ret[q]:=st4[3];
inc(q);
ret[q]:=st4[4];
inc(dincrem);
end
else
term;//проверка на умнож,дел
while look in ['-','+'] do
begin

inc(q);
ret[q]:=$DD; ////В st число
inc(q);
ret[q]:=$06;

case look of
'+':add;
'-':subtract
else expected('addop');
end;
end;
end;



procedure adresss(rerro:integer);

begin

kruto:=inttohex(rerro,8);
kruto2:=kruto[7]+kruto[8]+kruto[5]+kruto[6]+kruto[3]+kruto[4]+kruto[1]+kruto[2];

k2:=0;
while k2<>9 do
begin
inc(k2);
if kruto2[k2]='A'
then begin
kruto2[k2]:=':';
end;
if kruto2[k2]='B' then begin
kruto2[k2]:=';';
end;
if kruto2[k2]='C' then begin
kruto2[k2]:='<'; end; if kruto2[k2]='D' then begin kruto2[k2]:='='; end; if kruto2[k2]='E' then begin kruto2[k2]:='>';
end;
if kruto2[k2]='F' then begin
kruto2[k2]:='?';
end;
end;
st4[1+incremm]:=(ord(kruto2[2])-$30)+(ord(kruto2[1])-$30)*($10);
st4[2+incremm]:=(ord(kruto2[4])-$30)+(ord(kruto2[3])-$30)*($10);
st4[3+incremm]:=(ord(kruto2[6])-$30)+(ord(kruto2[5])-$30)*($10);
st4[4+incremm]:=(ord(kruto2[8])-$30)+(ord(kruto2[7])-$30)*($10);
st2:='0';
incremm:=incremm+4;
end;
BEGIN
{ }
end.


unit Unit3;

interface
procedure cosinus;
procedure cosinusRun;
procedure sinuss;
procedure sinusRun;
procedure koren;
procedure korenrun;
implementation
uses unit1,unit2;
procedure cosinus;

begin
////////////////////////////
inc(q);
ret[q]:=$D9; // pi
inc(q);
ret[q]:=$EB;



inc(q);
ret[q]:=$DD; //В st число
inc(q);
ret[q]:=$06;



INC(Q);
RET[Q]:=$DE; //fmul
INC(Q);
RET[Q]:=$C9;

inc(q);
ret[q]:=$BF; // 180
inc(q); //adress dwa
ret[q]:=st4[13];
inc(q);
ret[q]:=st4[14];
inc(q);
ret[q]:=st4[15];
inc(q);
ret[q]:=st4[16];

inc(q);
ret[q]:=$DD; //В st число (edi)
inc(q);
ret[q]:=$07;

inc(q);
ret[q]:=$DE; //Деление fdiv
inc(q);
ret[q]:=$F9;



inc(q);
ret[q]:=$D9; // Cos
inc(q);
ret[q]:=$FF;



//////////////////////////////
inc(q);
ret[q]:=$D9; // pi
inc(q);
ret[q]:=$EB;


inc(q);
ret[q]:=$BE; //mov esi,[chyslo]
inc(q);
ret[q]:=st4[5]+8*rr; //dwesti70
inc(q);
ret[q]:=st4[6];
inc(q);
ret[q]:=st4[7];
inc(q);
ret[q]:=st4[8];

inc(q);
ret[q]:=$DD; //В st число
inc(q);
ret[q]:=$06;



INC(Q);
RET[Q]:=$DE; //fmul
INC(Q);
RET[Q]:=$C9;

inc(q);
ret[q]:=$BF; // 180
inc(q); //adress dwa
ret[q]:=st4[13];
inc(q);
ret[q]:=st4[14];
inc(q);
ret[q]:=st4[15];
inc(q);
ret[q]:=st4[16];

inc(q);
ret[q]:=$DD; //В st число (edi)
inc(q);
ret[q]:=$07;

inc(q);
ret[q]:=$DE; //Деление fdiv
inc(q);
ret[q]:=$F9;

inc(q);
ret[q]:=$D9; // Cos
inc(q);
ret[q]:=$FF;

inc(q);
ret[q]:=$DD; // fucomp
inc(q);
ret[q]:=$E9;
//////////////////////

inc(q);
ret[q]:=$DD; //
inc(q);
ret[q]:=$3D;

//
inc(q); // !!!!!!Slowo
ret[q]:=st4[9];
inc(q);
ret[q]:=st4[10];
inc(q);
ret[q]:=st4[11];
inc(q);
ret[q]:=st4[12];

inc(q);
ret[q]:=$66; // mov ax
inc(q);
ret[q]:=$A1;

// 180
inc(q);
ret[q]:=st4[9];
inc(q);
ret[q]:=st4[10]; // !!!!!!Slowo
inc(q);
ret[q]:=st4[11];
inc(q);
ret[q]:=st4[12];

inc(q);
ret[q]:=$9E;
dec(dincrem);
inc(q);
ret[q]:=$BE; //mov esi,[chyslo]
inc(q);
ret[q]:=st4[1]+(8*dincrem);
inc(q);
ret[q]:=st4[2]; // chisla[kk]
inc(q);
ret[q]:=st4[3];
inc(q);
ret[q]:=st4[4];

{Сохранение информации }
INC(Q);
RET[Q]:=$DD; //fst
INC(Q);
RET[Q]:=$1E;
{-----------------------------------------}


inc(q);
ret[q]:=$74;
inc(q);
ret[q]:=$02;


inc(q);
ret[q]:=$75;
inc(q);
ret[q]:=$04;

inc(q);
ret[q]:=$D9;
inc(q);
ret[q]:=$EE;


inc(q);
ret[q]:=$DD;
inc(q);
ret[q]:=$1E;
inc(dincrem);

end;

procedure cosinusRun;
begin
k:=0;
look:=look2;

Name :=string(st6);
if Look = '(' then begin
Match('(');
/////////////////////////////////////
Expression;
Match(')');
rr:=0;
if (chisla[kk]<>90) then
begin
cosinus;
end;
if chisla[kk]=90 then begin
inc(rr);
cosinus;
end;
end;
end;
procedure sinuss;
begin
inc(q);
ret[q]:=$D9; // pi
inc(q);
ret[q]:=$EB;



inc(q);
ret[q]:=$DD; //В st число
inc(q);
ret[q]:=$06;



INC(Q);
RET[Q]:=$DE; //fmul
INC(Q);
RET[Q]:=$C9;

inc(q);
ret[q]:=$BF; // 180
inc(q); //adress dwa
ret[q]:=st4[13];
inc(q);
ret[q]:=st4[14];
inc(q);
ret[q]:=st4[15];
inc(q);
ret[q]:=st4[16];

inc(q);
ret[q]:=$DD; //В st число (edi)
inc(q);
ret[q]:=$07;

inc(q);
ret[q]:=$DE; //Деление fdiv
inc(q);
ret[q]:=$F9;



inc(q);
ret[q]:=$D9; // sin
inc(q);
ret[q]:=$FE;


inc(q);
ret[q]:=$D9; // pi
inc(q);
ret[q]:=$EB;


inc(q);
ret[q]:=$BE; //mov esi,[chyslo]
inc(q);
ret[q]:=st4[17]+8*rr; //dwesti70
inc(q);
ret[q]:=st4[18];
inc(q);
ret[q]:=st4[19];
inc(q);
ret[q]:=st4[20];

inc(q);
ret[q]:=$DD; //В st число
inc(q);
ret[q]:=$06;



INC(Q);
RET[Q]:=$DE; //fmul
INC(Q);
RET[Q]:=$C9;

inc(q);
ret[q]:=$BF; // 180
inc(q); //adress dwa
ret[q]:=st4[13];
inc(q);
ret[q]:=st4[14];
inc(q);
ret[q]:=st4[15];
inc(q);
ret[q]:=st4[16];

inc(q);
ret[q]:=$DD; //В st число (edi)
inc(q);
ret[q]:=$07;

inc(q);
ret[q]:=$DE; //Деление fdiv
inc(q);
ret[q]:=$F9;

inc(q);
ret[q]:=$D9; // Cos
inc(q);
ret[q]:=$FE;

inc(q);
ret[q]:=$DD; // fucomp
inc(q);
ret[q]:=$E9;
//////////////////////

inc(q);
ret[q]:=$DD; //
inc(q);
ret[q]:=$3D;

//
inc(q); // !!!!!!Slowo
ret[q]:=st4[9];
inc(q);
ret[q]:=st4[10];
inc(q);
ret[q]:=st4[11];
inc(q);
ret[q]:=st4[12];

inc(q);
ret[q]:=$66; // mov ax
inc(q);
ret[q]:=$A1;

// 180
inc(q);
ret[q]:=st4[9];
inc(q);
ret[q]:=st4[10]; // !!!!!!Slowo
inc(q);
ret[q]:=st4[11];
inc(q);
ret[q]:=st4[12];

inc(q);
ret[q]:=$9E;
dec(dincrem);
inc(q);
ret[q]:=$BE; //mov esi,[chyslo]
inc(q);
ret[q]:=st4[1]+(8*dincrem);
inc(q);
ret[q]:=st4[2]; // chisla[kk]
inc(q);
ret[q]:=st4[3];
inc(q);
ret[q]:=st4[4];

{Сохранение информации }
INC(Q);
RET[Q]:=$DD; //fst
INC(Q);
RET[Q]:=$1E;
{-----------------------------------------}


inc(q);
ret[q]:=$74;
inc(q);
ret[q]:=$02;


inc(q);
ret[q]:=$75;
inc(q);
ret[q]:=$04;

inc(q);
ret[q]:=$D9;
inc(q);
ret[q]:=$EE;


inc(q);
ret[q]:=$DD;
inc(q);
ret[q]:=$1E;
inc(dincrem);

end;
procedure sinusRun;
begin
k:=0;
look:=look2;

Name :=string(st6);
if Look = '(' then begin
Match('(');
/////////////////////////////////////
Expression;
Match(')');
rr:=0;
if (chisla[kk]<>180) then
begin
sinuss;
end;
if chisla[kk]=180 then begin
inc(rr);
sinuss;
end;
end;
end;

procedure koren;
begin

inc(q);
ret[q]:=$DD; //В st число
inc(q);
ret[q]:=$06;
{Сохранение информации }
INC(Q);
RET[Q]:=$D9; //fst
INC(Q);
RET[Q]:=$FA;
{-----------------------------------------}
{Сохранение информации }
INC(Q);
RET[Q]:=$DD; //fst
INC(Q);
RET[Q]:=$1E;
{-----------------------------------------}
end;

procedure korenrun;
begin
k:=0;
look:=look2;

Name :=string(st6);
if Look = '(' then begin
Match('(');
/////////////////////////////////////
Expression;
Match(')');
koren;
end;
end;
end.

Интересные ссылки