Author: Vimil Saju
How to convert a string to a mathematical expression and get its result.
Answer:
1 unit MathComponent;
2
3 interface
4
5 uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, math;
7
8 type
9 TOperandtype = (ttradians, ttdegrees, ttgradients);
10 TMathtype = (mtnil, mtoperator, mtlbracket, mtrbracket, mtoperand, mtfunction);
11 TMathSubtype = (msnone, mstrignometric);
12 TMathOperator = (monone, moadd, mosub, modiv, momul, mopow, momod, modivint);
13 TMathFunction = (mfnone, mfsinh, mfcosh, mftanh, mfcosech, mfsech, mfcoth, mfsin,
14 mfcos, mftan, mfcot, mfsec, mfcosec, mflog, mfln, mfsub, mfadd);
15
16 type
17 pmathchar = ^Tmathchar;
18 TMathChar = record
19 case mathtype: Tmathtype of
20 mtoperand: (data: extended);
21 mtoperator: (op: TMathOperator);
22 mtfunction: (func: TMathfunction; subtype: (mstnone, msttrignometric));
23 end;
24
25 type
26 TMathControl = class(TComponent)
27 private
28 input, output, stack: array of tmathchar;
29 fmathstring: string;
30 ftrignometrictype: Toperandtype;
31 fExpressionValid: boolean;
32 procedure removespace;
33 function isvalidchar(c: char): boolean;
34 function getresult: extended;
35 function checkbrackets: boolean;
36 function calculate(operand1, operand2, operator: Tmathchar): extended; overload;
37 function calculate(operand1, operator: Tmathchar): extended; overload;
38 function getoperator(pos: integer; var len: integer; var amathoperator:
39 TMathOperator): boolean;
40 function getoperand(pos: integer; var len: integer; var value: extended):
41 boolean;
42 function getmathfunc(pos: integer; var len: integer; var amathfunc:
43 TmathFunction): boolean;
44 function processstring: boolean;
45 procedure convertinfixtopostfix;
46 function isdigit(c: char): boolean;
47 function getprecedence(mop: TMathchar): integer;
48 protected
49 procedure loaded; override;
50 published
51 property MathExpression: string read fmathstring write fmathstring;
52 property MathResult: extended read getresult;
53 property ExpressionValid: boolean read fExpressionvalid;
54 property Trignometrictype: Toperandtype read ftrignometrictype write
55 ftrignometrictype;
56 end;
57
58 procedure register;
59
60 implementation
61
62 function tmathcontrol.calculate(operand1, operator: Tmathchar): extended;
63 begin
64 result := 0;
65 if (operator.subtype = msttrignometric) then
66 begin
67 if ftrignometrictype = ttdegrees then
68 operand1.data := operand1.data * (pi / 180);
69 if ftrignometrictype = ttgradients then
70 operand1.data := GradToRad(operand1.data);
71 end;
72 case operator.func of
73 mfsub: result := -operand1.data;
74 mfadd: result := operand1.data;
75 mfsin: result := sin(operand1.data);
76 mfcos: result := cos(operand1.data);
77 mfcot: result := 1 / tan(operand1.data);
78 mfcosec: result := 1 / sin(operand1.data);
79 mfsec: result := 1 / cos(operand1.data);
80 mftan: result := tan(operand1.data);
81 mflog: result := log10(operand1.data);
82 mfln: result := ln(operand1.data);
83 end;
84 end;
85
86 function tmathcontrol.getmathfunc(pos: integer; var len: integer; var amathfunc:
87 TmathFunction): boolean;
88 var
89 tmp: string;
90 i: integer;
91 begin
92 amathfunc := mfnone;
93 result := false;
94 tmp := '';
95 if (fmathstring[pos] = '+') then
96 begin
97 amathfunc := mfadd;
98 len := 1;
99 result := true;
100 end;
101 if (fmathstring[pos] = '-') then
102 begin
103 amathfunc := mfsub;
104 len := 1;
105 result := true;
106 end;
107 if (fmathstring[pos] = 's') then
108 begin
109 for i := pos to pos + 3 do
110 tmp := tmp + fmathstring[i];
111 if strcomp(pchar(tmp), 'sin(') = 0 then
112 begin
113 amathfunc := mfsin;
114 len := 3;
115 result := true;
116 end
117 else if strcomp(pchar(tmp), 'sec(') = 0 then
118 begin
119 amathfunc := mfsec;
120 len := 3;
121 result := true;
122 end;
123 end;
124 if (fmathstring[pos] = 'c') then
125 begin
126 for i := pos to pos + 5 do
127 tmp := tmp + fmathstring[i];
128 if strlcomp(pchar(tmp), 'cos(', 4) = 0 then
129 begin
130 amathfunc := mfcos;
131 len := 3;
132 result := true;
133 end
134 else if strlcomp(pchar(tmp), 'cot(', 4) = 0 then
135 begin
136 amathfunc := mfcot;
137 len := 3;
138 result := true;
139 end
140 else if strlcomp(pchar(tmp), 'cosec(', 6) = 0 then
141 begin
142 amathfunc := mfcosec;
143 len := 3;
144 result := true;
145 end
146 end;
147 if (fmathstring[pos] = 't') then
148 begin
149 for i := pos to pos + 3 do
150 tmp := tmp + fmathstring[i];
151 if strlcomp(pchar(tmp), 'tan(', 4) = 0 then
152 begin
153 amathfunc := mflog;
154 len := 3;
155 result := true;
156 end;
157 end;
158 if (fmathstring[pos] = 'l') then
159 begin
160 for i := pos to pos + 3 do
161 tmp := tmp + fmathstring[i];
162 if strlcomp(pchar(tmp), 'log(', 4) = 0 then
163 begin
164 amathfunc := mflog;
165 len := 3;
166 result := true;
167 end
168 else if strlcomp(pchar(tmp), 'ln(', 3) = 0 then
169 begin
170 amathfunc := mfln;
171 len := 3;
172 result := true;
173 end
174 end;
175 end;
176
177 procedure tmathcontrol.loaded;
178 begin
179 inherited;
180 fexpressionvalid := processstring;
181 end;
182
183 procedure tmathcontrol.removespace;
184 var
185 i: integer;
186 tmp: string;
187 begin
188 tmp := '';
189 for i := 1 to length(fmathstring) do
190 if fmathstring[i] <> ' ' then
191 tmp := tmp + fmathstring[i];
192 fmathstring := tmp;
193 end;
194
195 function tmathcontrol.isvalidchar(c: char): boolean;
196 begin
197 result := true;
198 if (not (isdigit(c))) and (not (c in ['(', ')', 't', 'l', 'c', 'm', 'd', 's', '*',
199 '/', '+', '-', '^'])) then
200 result := false;
201 end;
202
203 function tmathcontrol.checkbrackets: boolean;
204 var
205 i: integer;
206 bracketchk: integer;
207 begin
208 result := true;
209 bracketchk := 0;
210 i := 1;
211 if length(fmathstring) = 0 then
212 result := false;
213 while i <= length(fmathstring) do
214 begin
215 if fmathstring[i] = '(' then
216 bracketchk := bracketchk + 1
217 else if fmathstring[i] = ')' then
218 bracketchk := bracketchk - 1;
219 i := i + 1;
220 end;
221 if bracketchk <> 0 then
222 result := false;
223 end;
224
225 function Tmathcontrol.calculate(operand1, operand2, operator: Tmathchar): extended;
226 begin
227 result := 0;
228 case operator.op of
229 moadd:
230 result := operand1.data + operand2.data;
231 mosub:
232 result := operand1.data - operand2.data;
233 momul:
234 result := operand1.data * operand2.data;
235 modiv:
236 if (operand1.data <> 0) and (operand2.data <> 0) then
237 result := operand1.data / operand2.data
238 else
239 result := 0;
240 mopow: result := power(operand1.data, operand2.data);
241 modivint:
242 if (operand1.data <> 0) and (operand2.data <> 0) then
243 result := round(operand1.data) div round(operand2.data)
244 else
245 result := 0;
246 momod:
247 if (operand1.data >= 0.5) and (operand2.data >= 0.5) then
248 result := round(operand1.data) mod round(operand2.data)
249 else
250 result := 0;
251 end;
252 end;
253
254 function Tmathcontrol.getresult: extended;
255 var
256 i: integer;
257 tmp1, tmp2, tmp3: tmathchar;
258 begin
259 fExpressionValid := processstring;
260 if fExpressionValid = false then
261 begin
262 result := 0;
263 exit;
264 end;
265 convertinfixtopostfix;
266 setlength(stack, 0);
267 for i := 0 to length(output) - 1 do
268 begin
269 if output[i].mathtype = mtoperand then
270 begin
271 setlength(stack, length(stack) + 1);
272 stack[length(stack) - 1] := output[i];
273 end
274 else if output[i].mathtype = mtoperator then
275 begin
276 tmp1 := stack[length(stack) - 1];
277 tmp2 := stack[length(stack) - 2];
278 setlength(stack, length(stack) - 2);
279 tmp3.mathtype := mtoperand;
280 tmp3.data := calculate(tmp2, tmp1, output[i]);
281 setlength(stack, length(stack) + 1);
282 stack[length(stack) - 1] := tmp3;
283 end
284 else if output[i].mathtype = mtfunction then
285 begin
286 tmp1 := stack[length(stack) - 1];
287 setlength(stack, length(stack) - 1);
288 tmp2.mathtype := mtoperand;
289 tmp2.data := calculate(tmp1, output[i]);
290 setlength(stack, length(stack) + 1);
291 stack[length(stack) - 1] := tmp2;
292 end;
293 end;
294 result := stack[0].data;
295 setlength(stack, 0);
296 setlength(input, 0);
297 setlength(output, 0);
298 end;
299
300 function Tmathcontrol.getoperator(pos: integer; var len: integer; var amathoperator:
301 TMathOperator): boolean;
302 var
303 tmp: string;
304 i: integer;
305 begin
306 tmp := '';
307 result := false;
308 if fmathstring[pos] = '+' then
309 begin
310 amathoperator := moadd;
311 len := 1;
312 result := true;
313 end
314 else if fmathstring[pos] = '*' then
315 begin
316 amathoperator := momul;
317 len := 1;
318 result := true;
319 end
320 else if fmathstring[pos] = '/' then
321 begin
322 amathoperator := modiv;
323 len := 1;
324 result := true;
325 end
326 else if fmathstring[pos] = '-' then
327 begin
328 amathoperator := mosub;
329 len := 1;
330 result := true;
331 end
332 else if fmathstring[pos] = '^' then
333 begin
334 amathoperator := mopow;
335 len := 1;
336 result := true;
337 end
338 else if fmathstring[pos] = 'd' then
339 begin
340 for i := pos to pos + 2 do
341 tmp := tmp + fmathstring[i];
342 if strcomp(pchar(tmp), 'div') = 0 then
343 begin
344 amathoperator := modivint;
345 len := 3;
346 result := true;
347 end;
348 end
349 else if fmathstring[pos] = 'm' then
350 begin
351 for i := pos to pos + 2 do
352 tmp := tmp + fmathstring[i];
353 if strcomp(pchar(tmp), 'mod') = 0 then
354 begin
355 amathoperator := momod;
356 len := 3;
357 result := true;
358 end;
359 end;
360 end;
361
362 function Tmathcontrol.getoperand(pos: integer; var len: integer; var value:
363 extended):
364 boolean;
365 var
366 i, j: integer;
367 tmpnum: string;
368 dotflag: boolean;
369 begin
370 j := 1;
371 result := true;
372 dotflag := false;
373 for i := pos to length(fmathstring) - 1 do
374 begin
375 if isdigit(fmathstring[i]) then
376 begin
377 if (fmathstring[i] = '.') and (dotflag = true) then
378 begin
379 result := false;
380 break;
381 end
382 else if (fmathstring[i] = '.') and (dotflag = false) then
383 dotflag := true;
384 tmpnum := tmpnum + fmathstring[i];
385 j := j + 1;
386 end
387 else
388 break;
389 end;
390 if result = true then
391 begin
392 value := strtofloat(tmpnum);
393 len := j - 1;
394 end;
395 end;
396
397 function Tmathcontrol.processstring: boolean;
398 var
399 i: integer;
400 mov: integer;
401 tmpfunc: tmathfunction;
402 tmpop: tmathoperator;
403 numoperators: integer;
404 numoperands: integer;
405 begin
406 i := 0;
407 mov := 0;
408 numoperators := 0;
409 numoperands := 0;
410 setlength(output, 0);
411 setlength(input, 0);
412 setlength(stack, 0);
413 removespace;
414 result := true;
415 if checkbrackets = false then
416 begin
417 result := false;
418 exit;
419 end;
420 fmathstring := '(' + fmathstring + ')';
421 while i <= length(fmathstring) - 1 do
422 begin
423 if not (isvalidchar(fmathstring[i + 1])) then
424 begin
425 result := false;
426 break;
427 end;
428 if fmathstring[i + 1] = '(' then
429 begin
430 setlength(input, length(input) + 1);
431 input[length(input) - 1].mathtype := mtlbracket;
432 i := i + 1;
433 end
434 else if fmathstring[i + 1] = ')' then
435 begin
436 setlength(input, length(input) + 1);
437 input[length(input) - 1].mathtype := mtrbracket;
438 i := i + 1;
439 end
440 else if getoperator(i + 1, mov, tmpop) then
441 begin
442 if (tmpop <> moadd) and (tmpop <> mosub) then
443 begin
444 if i = 0 then //first character cannot be an operator
445 begin // other than a '+' or '-'.
446 result := false;
447 break;
448 end;
449 setlength(input, length(input) + 1);
450 input[length(input) - 1].mathtype := mtoperator;
451 input[length(input) - 1].op := tmpop;
452 i := i + mov;
453 numoperators := numoperators + 1;
454 end
455 else if (tmpop = mosub) or (tmpop = moadd) then
456 begin
457 if (i = 0) or (input[length(input) - 1].mathtype = mtoperator) or
458 (input[length(input) - 1].mathtype = mtlbracket) then
459 begin //makes use of fact the if the first part of if expression is true
460 then
461 //remaining parts are not evaluated thus preventing a
462 //exception from occuring.
463 setlength(input, length(input) + 1);
464 input[length(input) - 1].mathtype := mtfunction;
465 getmathfunc(i + 1, mov, tmpfunc);
466 input[length(input) - 1].func := tmpfunc;
467 i := i + mov;
468 end
469 else
470 begin
471 setlength(input, length(input) + 1);
472 numoperators := numoperators + 1;
473 input[length(input) - 1].mathtype := mtoperator;
474 input[length(input) - 1].op := tmpop;
475 i := i + 1;
476 end;
477 end;
478 end
479 else if isdigit(fmathstring[i + 1]) then
480 begin
481 setlength(input, length(input) + 1);
482 input[length(input) - 1].mathtype := mtoperand;
483 if getoperand(i + 1, mov, input[length(input) - 1].data) = false then
484 begin
485 result := false;
486 break;
487 end;
488 i := i + mov;
489 numoperands := numoperands + 1;
490 end
491 else
492 begin
493 getmathfunc(i + 1, mov, tmpfunc);
494 if tmpfunc <> mfnone then
495 begin
496 setlength(input, length(input) + 1);
497 input[length(input) - 1].mathtype := mtfunction;
498 input[length(input) - 1].func := tmpfunc;
499 if tmpfunc in [mfsin, mfcos, mftan, mfcot, mfcosec, mfsec] then
500 input[length(input) - 1].subtype := msttrignometric
501 else
502 input[length(input) - 1].subtype := mstnone;
503 i := i + mov;
504 end
505 else
506 begin
507 result := false;
508 break;
509 end;
510 end;
511 end;
512 if numoperands - numoperators <> 1 then
513 result := false;
514 end;
515
516 function Tmathcontrol.isdigit(c: char): boolean;
517 begin
518 result := false;
519 if ((integer(c) > 47) and (integer(c) < 58)) or (c = '.') then
520 result := true;
521 end;
522
523 function Tmathcontrol.getprecedence(mop: TMathchar): integer;
524 begin
525 result := -1;
526 if mop.mathtype = mtoperator then
527 begin
528 case mop.op of
529 moadd: result := 1;
530 mosub: result := 1;
531 momul: result := 2;
532 modiv: result := 2;
533 modivint: result := 2;
534 momod: result := 2;
535 mopow: result := 3;
536 end
537 end
538 else if mop.mathtype = mtfunction then
539 result := 4;
540 end;
541
542 procedure Tmathcontrol.convertinfixtopostfix;
543 var
544 i, j, prec: integer;
545 begin
546 for i := 0 to length(input) - 1 do
547 begin
548 if input[i].mathtype = mtoperand then
549 begin
550 setlength(output, length(output) + 1);
551 output[length(output) - 1] := input[i];
552 end
553 else if input[i].mathtype = mtlbracket then
554 begin
555 setlength(stack, length(stack) + 1);
556 stack[length(stack) - 1] := input[i];
557 end
558 else if (input[i].mathtype = mtoperator) then
559 begin
560 prec := getprecedence(input[i]);
561 j := length(stack) - 1;
562 if j >= 0 then
563 begin
564 while (getprecedence(stack[j]) >= prec) and (j >= 0) do
565 begin
566 setlength(output, length(output) + 1);
567 output[length(output) - 1] := stack[j];
568 setlength(stack, length(stack) - 1);
569 j := j - 1;
570 end;
571 setlength(stack, length(stack) + 1);
572 stack[length(stack) - 1] := input[i];
573 end;
574 end
575 else if input[i].mathtype = mtfunction then
576 begin
577 setlength(stack, length(stack) + 1);
578 stack[length(stack) - 1] := input[i];
579 end
580 else if input[i].mathtype = mtrbracket then
581 begin
582 j := length(stack) - 1;
583 if j >= 0 then
584 begin
585 while (stack[j].mathtype <> mtlbracket) and (j >= 0) do
586 begin
587 setlength(output, length(output) + 1);
588 output[length(output) - 1] := stack[j];
589 setlength(stack, length(stack) - 1);
590 j := j - 1;
591 end;
592 if j >= 0 then
593 setlength(stack, length(stack) - 1);
594 end;
595 end;
596 end;
597 end;
598
599 procedure register;
600 begin
601 RegisterComponents('Samples', [TMathControl]);
602 end;
603
604 end.
|
