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

Delphi Sources



Вернуться   Форум по Delphi программированию > Разное > Исходники и статьи
Перезагрузить страницу

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

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

Ответ
 
Опции темы Поиск в этой теме Опции просмотра
  #1  
Старый 15.04.2012, 18:44
Аватар для Admin
Admin Admin вне форума
Администратор
  
Регистрация: 03.10.2005
Адрес: Россия, Москва
Сообщения: 1,553
Версия Delphi: Delphi 7
Репутация: выкл
По умолчанию [ Исходник ] - Процедура для генерации формул
Имя (Ник): Наурыз Чуленбаев
E-mail: Nauryz_91_kz@mail.ru
Описание исходника: Процедура для генерации формул (математического выражения) во время выполнения программы (т.е. в ран-тайм).

Код:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
{Автор: Наурыз Чуленбаев г. Байконур (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,553
Версия Delphi: Delphi 7
Репутация: выкл
По умолчанию
Код:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
//ф-я для сложения и вычитания
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,553
Версия 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, время: 20:07.

Обратная связь - Главная страница сайта Delphi Sources - Вверх

 

Сайт

Форум

FAQ

Соглашения

Прочее
 

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