[ Исходник ] - Процедура для генерации формул

Admin · #1 15.04.2012, 18:44

Имя (Ник): Наурыз Чуленбаев
E-mail: Nauryz_91_kz@mail.ru
Описание исходника: Процедура для генерации формул (математического выражения) во время выполнения программы (т.е. в ран-тайм).

Код:

{Автор: Наурыз Чуленбаев г. Байконур (Nauryz_91_kz@mail.ru)}
PROCEDURE FORMULA (F:STRING; VAR otvet:EXTENDED; perem:array of char; znperem:array of real; usevar:boolean);
var c:byte;
    skn,skk,pf:byte;

function Minus(znach:string):extended; //отрицательные числа
begin
if znach[1]='m' then begin
delete (znach,1,1);
if znach<>'' then result:=0-strtofloat (znach);
end
else result:=strtofloat (znach);
end;

function SetM(zn:string):string ; //заменяет знак минус на m
var i:byte;
begin
if zn[1]='-' then zn[1]:='m';
for i:=1 to length (zn) do
if (zn[i]='-') and (zn[i+1]='-') then begin
insert ('+',zn,i);
delete (zn,i+1,2);
end;
for i:=1 to length (zn) do
if (zn[i]='-') and (zn[i-1] in ['*','/','+','-']) then zn[i]:='m';
result:=zn;
end;

function LastPos(subst:string; const st:string):byte;  //аналог pos(),но ноходит
var  dst:string;                                      //номер последнего
     count:byte;                                     //проявления подстроки
begin
dst:=st;
count:=0;
if pos (subst,dst)<>0 then begin
result:=pos (subst,dst);
REPEAT
if result>pos (subst,dst) then result:=pos (subst,dst);
delete (dst,pos (subst,dst),length(subst));
count:=count+1;
if pos (subst,dst)<>0 then result:=pos (subst,dst);
UNTIL pos (subst,dst)=0;
result:=result+(length(subst)*(count-1));
end else
result:=0;
end;

function SetVar(st:string):string; //заменяет переменные их значениями
var j,h,d,s:byte;
begin
d:=length (st);
s:=0;
if length(perem)>1 then
for h:=0 to length(perem) do begin
while j<>d do begin
j:=j+1;
if st[j]=perem[h] then begin
delete (st,j,1);
insert (floattostr(znperem[h]),st,j);
j:=0;
end;
d:=length (st);
end;
j:=0;
end
else begin
for j:=1 to d do
if st[j]=perem[0] then begin
delete (st,j,1);
insert (floattostr(znperem[0]),st,j);
end;
d:=length (st);
end;
result:=st;
end;

//ф-я для умножения и деления
function KobeituBolu (ID:string; nomer:byte; KiliB:char; var fo:string):extended;
var tn,tk,j:byte;
zn1,zn2:real;
begin
tn:=0; tk:=0;
if KiliB='*' then
if nomer<>0 then begin

      for j:=1 to nomer do
      if ((ID[j]='+') or (ID[j]='-') or (ID[j]='/')) or ((ID[j]='*') and (j<nomer))
      then tn:=j;

      for j:=length(f) downto nomer do
      if (ID[j]='+') or (ID[j]='-') or (ID[j]='/') or ((ID[j]='*') and (j>nomer))
      then tk:=j;

      if (tn<>0) and (tk<>0) then  begin
      zn1:=Minus(copy(ID,tn+1,(nomer-tn)-1));
      zn2:=Minus(copy(ID,nomer+1,(tk-nomer)-1));
      result:=zn1*zn2;
      delete (ID,tn+1,(tk-tn)-1);
      insert (floattostr(result),ID,tn+1);
      end;

      if (tn=0) and (tk=0) then  begin
      zn1:=Minus(copy(ID,1,nomer-1));
      zn2:=Minus(copy(ID,nomer+1,length(ID)));
      result:=zn1*zn2;
      ID:=floattostr(result);
      end;

      if (tn=0) and (tk<>0) then begin
      zn1:=Minus(copy(ID,1,nomer-1));
      zn2:=Minus(copy(ID,nomer+1,(tk-nomer)-1));
      result:=zn1*zn2;
      delete (ID,1,tk-1);
      insert (floattostr(result),ID,1);
      end;

      if (tn<>0) and (tk=0) then begin
      zn1:=Minus (copy(ID,tn+1,(nomer-tn)-1));
      zn2:=Minus (copy(ID,nomer+1,length(ID)));
      result:=zn1*zn2;
      delete (ID,tn+1,length(ID)-tn);
      insert (floattostr(result),ID,tn+1);
      end;
     fo:=ID;
end;   //if KiliB='*'then if nomer<>0 then

if KiliB='/' then
if nomer<>0 then begin

      for j:=1 to nomer do
      if ((ID[j]='+') or (ID[j]='-') or (ID[j]='*')) or ((ID[j]='/') and (j<nomer))
      then tn:=j;

      for j:=length(f) downto nomer do
      if (ID[j]='+') or (ID[j]='-') or (ID[j]='*') or ((ID[j]='/') and (j>nomer))
      then tk:=j;

      if (tn<>0) and (tk<>0) then  begin
      zn1:=Minus(copy(ID,tn+1,(nomer-tn)-1));
      zn2:=Minus(copy(ID,nomer+1,(tk-nomer)-1));
      result:=zn1/zn2;
      delete (ID,tn+1,(tk-tn)-1);
      insert (floattostr(result),ID,tn+1);
      end;

      if (tn=0) and (tk=0) then  begin
      zn1:=Minus(copy(ID,1,nomer-1));
      zn2:=Minus(copy(ID,nomer+1,length(ID)));
      result:=zn1/zn2;
      ID:=floattostr(result);
      end;

      if (tn=0) and (tk<>0) then begin
      zn1:=Minus(copy(ID,1,nomer-1));
      zn2:=Minus(copy(ID,nomer+1,(tk-nomer)-1));
      result:=zn1/zn2;
      delete (ID,1,tk-1);
      insert (floattostr(result),ID,1);
      end;

      if (tn<>0) and (tk=0) then begin
      zn1:=Minus (copy(ID,tn+1,(nomer-tn)-1));
      zn2:=Minus (copy(ID,nomer+1,length(ID)));
      result:=zn1/zn2;
      delete (ID,tn+1,length(ID)-tn);
      insert (floattostr(result),ID,tn+1);
      end;
     fo:=ID;
end;   //if KiliB='/'then if nomer<>0 then
end; // function Kobeitu Bolu

Admin · #2 15.04.2012, 18:44

Код:

//ф-я для сложения и вычитания
function KosuAlu (ID:string; nomer:byte; KiliB:char; var fo:string):extended;
var tn,tk,j:byte;
zn1,zn2:real;
begin
tn:=0; tk:=0;
if KiliB='+' then
if nomer<>0 then begin

      for j:=1 to nomer do
      if (ID[j]='-')  or ((ID[j]='+') and (j<nomer))
      then tn:=j;

      for j:=length(f) downto nomer do
      if (ID[j]='-')or ((ID[j]='+') and (j>nomer))
      then tk:=j;

      if (tn<>0) and (tk<>0) then  begin
      zn1:=Minus(copy(ID,tn+1,(nomer-tn)-1));
      zn2:=Minus(copy(ID,nomer+1,(tk-nomer)-1));
      result:=zn1+zn2;
      delete (ID,tn+1,(tk-tn)-1);
      insert (floattostr(result),ID,tn+1);
      end;

      if (tn=0) and (tk=0) then  begin
      zn1:=Minus(copy(ID,1,nomer-1));
      zn2:=Minus(copy(ID,nomer+1,length(ID)));
      result:=zn1+zn2;
      ID:=floattostr(result);
      end;

      if (tn=0) and (tk<>0) then begin
      zn1:=Minus(copy(ID,1,nomer-1));
      zn2:=Minus(copy(ID,nomer+1,(tk-nomer)-1));
      result:=zn1+zn2;
      delete (ID,1,tk-1);
      insert (floattostr(result),ID,1);
      end;

      if (tn<>0) and (tk=0) then begin
      zn1:=Minus (copy(ID,tn+1,(nomer-tn)-1));
      zn2:=Minus (copy(ID,nomer+1,length(ID)));
      result:=zn1+zn2;
      delete (ID,tn+1,length(ID)-tn);
      insert (floattostr(result),ID,tn+1);
      end;
     fo:=ID;
end;   //if KiliB='+'then if nomer<>0 then

if KiliB='-' then
if nomer<>0 then begin

      for j:=1 to nomer do
      if (ID[j]='+') or ((ID[j]='-') and (j<nomer))
      then tn:=j;

      for j:=length(f) downto nomer do
      if (ID[j]='+') or ((ID[j]='-') and (j>nomer))
      then tk:=j;

      if (tn<>0) and (tk<>0) then  begin
      zn1:=Minus(copy(ID,tn+1,(nomer-tn)-1));
      zn2:=Minus(copy(ID,nomer+1,(tk-nomer)-1));
      result:=zn1-zn2;
      delete (ID,tn+1,(tk-tn)-1);
      insert (floattostr(result),ID,tn+1);
      end;

      if (tn=0) and (tk=0) then  begin
      zn1:=Minus(copy(ID,1,nomer-1));
      zn2:=Minus(copy(ID,nomer+1,length(ID)));
      result:=zn1-zn2;
      ID:=floattostr(result);
      end;

      if (tn=0) and (tk<>0) then begin
      zn1:=Minus(copy(ID,1,nomer-1));
      zn2:=Minus(copy(ID,nomer+1,(tk-nomer)-1));
      result:=zn1-zn2;
      delete (ID,1,tk-1);
      insert (floattostr(result),ID,1);
      end;

      if (tn<>0) and (tk=0) then begin
      zn1:=Minus (copy(ID,tn+1,(nomer-tn)-1));
      zn2:=Minus (copy(ID,nomer+1,length(ID)));
      result:=zn1-zn2;
      delete (ID,tn+1,length(ID)-tn);
      insert (floattostr(result),ID,tn+1);
      end;
     fo:=ID;
end;   //if KiliB='-'then if nomer<>0 then
end; // function KosuAlu

BEGIN //FORMULA
TRY

if usevar then f:=SetVar (f);
f:=SetM (f);
skn:=0; skk:=0;
//+ находим номер самой вложенной скобки (открывающей и закрывающей)
for c:=1 to length(f) do
if f[c]='(' then skn:=c;
for c:=length(f) downto 1 do
if (f[c]=')') and (c>skn) then skk:=c;
//+
if (skn=0) or (skk=0) then begin   //если скобок нету

REPEAT                                //в этом цикле умножаем или делим
c:=c+1;
if f[1]='-' then f:=SetM (f);
if (f[c]='*') or (f[c]='/') then begin
otvet:=KobeituBolu (f,c,f[c],f);
c:=0;
end;
UNTIL c=length (f);

f:=SetM (f);
c:=0;

REPEAT                           //а в этом слогаем или вычитаем
c:=c+1;
if f[1]='-' then f:=SetM (f);
if (f[c]='+') or (f[c]='-') then begin
otvet:=KosuAlu (f,c,f[c],f);
c:=0;
end;
UNTIL c=length (f);

if (pos('*',f)=0) and (pos('+',f)=0) and (pos('/',f)=0) and (pos('-',f)=0) then
otvet:=Minus(f);
end; // if (skn=0) or (skk=0) then

if (skn<>0) or (skk<>0) then begin  //если скобки есть
//без рекурсии необойтись... Решаем то что внутри скобок
FORMULA (copy(f,skn+1,(skk-skn)-1),otvet,perem,znperem,usevar);  //++++
if (lastpos ('sin',f)+3=skn) and (pos ('sin',f)<>0) then
begin
pf:=lastpos ('sin',f);
otvet:=sin(otvet)*(3.1415/180);   //вот тут  можно убрать посл скобку. Если результат не нужен в радианах
delete (f,lastpos('sin',f),skk-lastpos('sin',f)+1);
insert (floattostrf(otvet,ffgeneral,6,4),f,pf);
end  else
if (lastpos ('cos',f)+3=skn) and (pos ('cos',f)<>0) then
begin
pf:=lastpos ('cos',f);
otvet:=cos(otvet)*(3.1415/180);
delete (f,lastpos('cos',f),skk-lastpos('cos',f)+1);
insert (floattostrf(otvet,ffgeneral,6,4),f,pf);
end  else
if (lastpos ('tan',f)+3=skn) and (pos ('tan',f)<>0) and (f[lastpos ('tan',f)-2]<>'c') then
begin
pf:=lastpos ('tan',f);
otvet:=tan(otvet)*(3.1415/180);
delete (f,lastpos('tan',f),skk-lastpos('tan',f)+1);
insert (floattostrf(otvet,ffgeneral,6,4),f,pf);
end  else
if (lastpos ('sqr',f)+3=skn) and (pos ('sqr',f)<>0) then
begin
pf:=lastpos ('sqr',f);
otvet:=sqr(otvet);
delete (f,lastpos('sqr',f),skk-lastpos('sqr',f)+1);
insert (floattostrf(otvet,ffgeneral,6,4),f,pf);
end  else
if (lastpos ('cotan',f)+5=skn) and (pos ('cotan',f)<>0) then
begin
pf:=lastpos ('cotan',f);
otvet:=cotan(otvet)*(3.1415/180);
delete (f,lastpos('cotan',f),skk-lastpos('cotan',f)+1);
insert (floattostrf(otvet,ffgeneral,6,4),f,pf);
end  else
if (lastpos ('sqrt',f)+4=skn) and (pos ('sqrt',f)<>0) then
begin
pf:=lastpos ('sqrt',f);
otvet:=sqrt(otvet);
delete (f,lastpos('sqrt',f),skk-lastpos('sqrt',f)+1);
insert (floattostrf(otvet,ffgeneral,6,4),f,pf);
end else
if (lastpos ('exp',f)+3=skn) and (pos ('exp',f)<>0) then
begin
pf:=lastpos ('exp',f);
otvet:=exp(otvet);
delete (f,lastpos('exp',f),skk-lastpos('exp',f)+1);
insert (floattostrf(otvet,ffgeneral,6,4),f,pf);
end else
if (lastpos ('ln',f)+2=skn) and (pos ('ln',f)<>0) then
begin
pf:=lastpos ('ln',f);
otvet:=ln(otvet);
delete (f,lastpos('ln',f),skk-lastpos('ln',f)+1);
insert (floattostrf(otvet,ffgeneral,6,4),f,pf);
end
else begin
delete (f,skn,skk-skn+1);
insert (floattostrf(otvet,ffgeneral,6,4),f,skn);
end;
FORMULA (f,otvet,perem,znperem,usevar);  //++++
end;    // if (skn<>0) or (skk<>0) then
except
messagedlg ('Сандарды дурыстап жаз!.. Че то жумыс истей алмай жатырм.',mterror,[mbok],0);
end;
END;  //end Formula

Admin · #3 15.04.2012, 18:45

Цитата:

Процедура для генерации формулы (математического выражения) во время выполнения программы (т.е. в ран-тайм).Библиотеки и модули, используемые этой процедурой стандартные... достаточно скопировать, вставить и передать необходимые параметры процедуре.

++FORMULA (F:STRING; VAR otvet:EXTENDED; perem:array of char; znperem:array of real; usevar:boolean);++
где:
F - строка, которая хранит формулу //string
otvet - результат //extended
perem - массив переменных //array of char
znperem - массив значений для переменных //array of real
usevar - показывает процедуре будет ли она работать с переменными //boolean

Например: если надо решить формулу: x+cos(y/sqrt(7)), где x и y переменные, в процедуру надо передать параметры следующего вида:

FORMULA ('x+cos(y/sqrt(7))',rezultat,['x','y'],[1.32,2.5],true)

Одно примечание: надо уследить, чтобы переменные (н/р: ['x','y']), которые передаются процедуре в символьнои типе, не были одинаковы с переменными используемыми в программе. Например возьмем объявление процедуры в программе в выше упомянутом виде, но вместо переменной rezultat напишем y (FORMULA ('x+cos(y/sqrt(7))',y,['x','y'],[1.32,2.5],true)), то процедура выдаст ошибку!!! Также переменные для передачи в процедуру не должны входить в стандартные функции, т.е. если формула такая - sin(90)+100+(5*cos(45)), то не могут быть использованы переменные:s,i,n,o,c p.s.: sorry за большой комментарий((}

..........

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	Соглашения	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Конфиденциальность Соглашение пользователя Правила обработки cookie	О сайте Donate Контакты