Форум по Delphi программированию

Delphi Sources



Вернуться   Форум по Delphi программированию > Разное > Исходники и статьи
Ник
Пароль
Регистрация <<         Правила форума         >> FAQ Пользователи Календарь Поиск Сообщения за сегодня Все разделы прочитаны

Ответ
 
Опции темы Поиск в этой теме Опции просмотра
  #1  
Старый 15.04.2012, 18:44
Аватар для Admin
Admin Admin вне форума
Администратор
 
Регистрация: 03.10.2005
Адрес: Россия, Москва
Сообщения: 1,560
Версия Delphi: Delphi 7
Репутация: выкл
По умолчанию [ Исходник ] - Процедура для генерации формул

Имя (Ник): Наурыз Чуленбаев
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
Ответить с цитированием
  #2  
Старый 15.04.2012, 18:44
Аватар для Admin
Admin Admin вне форума
Администратор
 
Регистрация: 03.10.2005
Адрес: Россия, Москва
Сообщения: 1,560
Версия Delphi: Delphi 7
Репутация: выкл
По умолчанию

Код:
//ф-я для сложения и вычитания
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
Ответить с цитированием
  #3  
Старый 15.04.2012, 18:45
Аватар для Admin
Admin Admin вне форума
Администратор
 
Регистрация: 03.10.2005
Адрес: Россия, Москва
Сообщения: 1,560
Версия Delphi: Delphi 7
Репутация: выкл
По умолчанию

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

++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 за большой комментарий((}
..........
Ответить с цитированием
Ответ


Delphi Sources

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск
Опции просмотра

Ваши права в разделе
Вы не можете создавать темы
Вы не можете отвечать на сообщения
Вы не можете прикреплять файлы
Вы не можете редактировать сообщения

BB-коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.
Быстрый переход


Часовой пояс GMT +3, время: 13:20.


 

Сайт

Форум

FAQ

RSS лента

Прочее

 

Copyright © Форум "Delphi Sources" by BrokenByte Software, 2004-2023

ВКонтакте   Facebook   Twitter