 |
formula translation source listing |  |
 |
This is the Delphi-7 source code listing for formula translation.
Click
to return to the article on formula translation.
unit xlate;
{ translate math function / equation into sequence of basic operations
types recognized:
1. y = ...x... normal function
2. x = ...y... inverse function
3. x = ...v...; y = ...v... parametric function
4. ..x..y.. = ..x..y.. intrinsic function
variables
x, y, v, a, b, c, pi, e (a,b,c:preset constants; pi,e:math constants
functions
sin,cos,tan,asin,acos,atan,sqrt,log,ln,exp,abs,int
operators and priorities ....'(' increases priority by 10, ')' decreases
function 7
^ 6
- 5 (unairy -)
* / 4
+ - 3
= 2
; 1
multiply (*) insertion between
)...(
)...function or constant...function
constant...( or )...constant
variable...( or )...variable
constant...variable or variable...constant
postfixtable [1..maxpostfix]
-------------------------------------------
|constant/ |
|variable/ |
|empty | operation | priority |
-------------------------------------------
operation = 0 for end of table
directortable [1..maxdirtab]
-------------------------------------------------------
|operation | destination | source1 | source2 |
operation = 0 for end of table
constantstable [ 30..59] .....[1..29] is scratch
ct1 | constant1 |
ct1+1 | constant2 | etc.
operatorcodes / functioncodes
+ 1
- 2
* 3
/ 4
^ 5
- 6 (unairy -)
= 7
; 8
sin 10 (function table starts at 10)
cos 11
tan 12
asin 13
acos 14
atan 15
sqrt 16
log 17
ln 18
exp 19
abs 20
int 21
registers in REG[ ] : double
1..29 : scratch registers
30..59 : constants
60 : x
61 : y
62 : v
63 : a
64 : b
65 : c
66 : pi (preset)
67 : e (preset)
30-12-2011 : test eqdrawer type 1,2,3,4
1-01-2012 : trifolium error, corrected line 699 freereg(r2) (was r1)
2-01-2012 : version 1
}
interface
uses extctrls,sysutils,graphics,classes,math;
procedure XlateEquation(const s:string;var xcode:byte);//0:OK; <>0 error
function getEqType : byte;
procedure setconstant(a : char; d : double);//set constant 'a','b','c' to d
procedure calculate(var OK : boolean);
procedure setdebugmode(box:TPaintbox; f : boolean);
function getmessage(code : byte) : string; //get message after translation
procedure setX(d : double);
procedure setY(d : double);
procedure setV(d : double);
function getX : double;
function getY : double;
function getV : double;
implementation
procedure clearbox;forward;
procedure showconstants;forward;
procedure showPFT;forward;
procedure showDRT;forward;
type TPostfix = record
reg : byte;
opcode : byte;
priority : byte;
end;
TDirector = record
opcode : byte;
dest : byte;
src1 : byte;
src2 : byte;
end;
Toperator = record
a : char;
priority : byte;
end;
const maxPFT = 60;
maxDRT = 60;
maxreg = 29; //registers 1..29 for scratch
minconstant= 30;
maxconstant= 59;
varbias = 60;
maxprio = 200;// 20*(
functiontable : array[10..21] of string = //index = code
('sin', 'cos', 'tan', 'asin', 'acos',
'atan', 'sqrt', 'log', 'ln', 'exp',
'abs', 'int');
vartable : array[60..67] of string = //REG[] is index + 60
('x', 'y', 'v', 'a', 'b', 'c', 'pi', 'e');
opcodetable : array[1..8] of Toperator = //index = operation code
((a:'+' ; priority: 3),
(a:'-' ; priority: 3),
(a:'*' ; priority: 4),
(a:'/' ; priority: 4),
(a:'^' ; priority: 6),
(a:'-' ; priority: 5), //unairy (-)
(a:'=' ; priority: 2),
(a:';' ; priority: 1));
errormessage : array[0..13] of string =
('OK', //0
'formula too long', //1
'unknown equation type', //2
'unknown character', //3
'too many ..((..', //4
'too many ..))..', //5
'too many operators', //6 , postfix table full
'syntax error', //7
'..(( .. )).. mismatch', //8
'wrong number:', //9
'too many constants', //10
'unrecognized string:', //11
'too many intermediate results', //12
'equation too long'); //13
var debugmode : boolean = false; //write info to paintbox if true
debugbox : Tpaintbox = nil;
PFT : array[1..maxPFT] of TPostFix;
pfti : byte;//#entries in PFT
DRT : array[1..maxDRT] of Tdirector;
dix : byte;//index for DRT during calculations
valid : boolean;//during calculations
DRTtop : byte; //#entries in DRT
REG : array[1..67] of double;
csi : byte;
eqtype : byte = 0; //1,2,3,4 type of equation
basetext : string;
errorcode : byte = 0;
extramessage : string; //attached to errorcode string
dln10 : double;
procedure DetectType; //find type of equation
type Ts = (tx,ty,teq,tpc,tblank,telse);//x y = ;
var n,p : byte;
ns : Ts;
cp : array[tx..tpc,1..255] of byte; //cp: char position
cc : array[tx..tpc] of byte; //cc: char count
begin
for ns := tx to tpc do cc[ns] := 0;
p := 1; //char position minus blanks
for n := 1 to length(basetext) do //mark positions of x y = ; skip blanks
begin //p counts char position minus blanks
case basetext[n] of
'x' : ns := tx;
'y' : ns := ty;
'=' : ns := teq;
';' : ns := tpc;
' ' : ns := tblank;
else ns := telse;
end;//case
case ns of
tx,ty,teq,tpc : begin
inc(cc[ns]);
cp[ns,cc[ns]] := p;
inc(p);
end;
telse : inc(p);
end;//case
end;//for n
//test for type 1
if (cc[ty]=1) and (cp[ty,1]=1) and (cc[teq]=1) and (cp[teq,1]=2) and
(cc[tpc]=0) then begin
eqtype := 1;
exit;
end;
//test for type 2
if (cc[tx]=1) and (cp[tx,1]=1) and (cc[teq]=1) and (cp[teq,1]=2) and
(cc[tpc]=0) then begin
eqtype := 2;
exit;
end;
//test for type 3
if (cc[tx]=1) and (cc[ty]=1) and (cc[tpc]=1) and (cc[teq]=2) then
begin
if ((cp[ty,1]=1) and (cp[teq,1]=2) and (cp[tpc,1]+1=cp[tx,1]) and
(cp[tx,1]+1=cp[teq,2])) or
((cp[tx,1]=1) and (cp[teq,1]=2) and (cp[tpc,1]+1=cp[ty,1]) and
(cp[ty,1]+1=cp[teq,2])) then begin
eqtype := 3;
exit;
end;
end;
//test for type 4
if (cc[tpc]=0) and (cc[teq]=1) then eqtype := 4;
end;
procedure makePFT;
//make postfix table , put constants in regs
type Tscan = (scNone,scAlphaScan,scNumScan,scConstant,scVariable,scFunction,
scOperator,scOpen,scClose); //type of scan , element found
var i : byte; //address characters in formula string
scan : Tscan;
biasprio : byte; //priority
c : char;
s : string; //interim string
//---------
procedure nextpft;
begin
if PFTi < maxPFT then inc(pfti)
else errorcode := 6;
end;
//----------
procedure procAlpha;
//analyse + process alpha string. May be function or variable
var i : byte;
vhit : boolean;
fhit : boolean;
begin
i := 60;
vhit := false;
fhit := false;
while (i < 68) and (vhit=false) do
if vartable[i] = s then
begin
vhit := true;
PFT[pfti].reg := i;
end else inc(i);
if vhit then scan := scVariable
else
begin
i := 10;
while (i < 22) and (fhit = false) do
if functiontable[i] = s then
begin
fhit := true;
PFT[pfti].opcode := i;
PFT[pfti].priority := biasprio + 7;
nextPFT;
end else inc(i);
if fhit then scan := scFunction
else begin
errorcode := 11;//syntax error;
extramessage := s;
end;
end;//if vhit
end;
//---------
procedure procNum;
//analyse + process numeric string
var d : double;
begin
try
d := strtofloat(s);
if csi <= maxconstant then
begin
REG[csi] := d;
PFT[pfti].reg := csi;
inc(csi); //point to next register
end
else begin
errorcode := 10;
extramessage := s;
end;
scan := scConstant;
except
errorcode := 9;
extramessage := s;
end;
end;
//-----------
procedure procOperator;
//analyse operator
begin
with PFT[pfti] do
case c of
'+' : begin
opcode := 1;
priority := 3 + biasprio;
end;
'-' : begin
opcode := 2;
priority := 3 + biasprio;
end;
'*' : begin
opcode :=3 ;
priority := 4 + biasprio;
end;
'/' : begin
opcode := 4;
priority := 4 + biasprio;
end;
'^' : begin
opcode := 5;
priority := 6 + biasprio;
end;
'=' : begin
opcode := 7;
priority := 2;
end;
';' : begin
opcode := 8;
priority := 1;
end;
end;//case
nextPFT;
scan := scOperator;
end;
procedure procUminus;
//unairy - operator
begin
with PFT[pfti] do
begin
opcode := 6;
priority := 5 + biasprio;
end;
nextPFT;
scan := scOperator;
end;
procedure procIsType4;
//'=' in type 4 equation
begin
with PFT[pfti] do
begin
opcode := 2;
priority := 2
end;
nextPFT;
end;
procedure procopen;
begin
if biasprio < 200 then inc(biasprio,10)
else errorcode := 4;
scan := scOpen;
end;
procedure procClose;
begin
if biasprio >= 10 then dec(biasprio,10)
else errorcode := 5;
scan := scClose;
end;
procedure multInsert;
begin
with PFt[pfti] do
begin
opcode := 3;
priority := biasprio + 4;
end;
nextPFT;
scan := scOperator;
end;
//--------------
begin
for i := 1 to maxPFT do //clear PFT
with PFT[i] do
begin
reg := 0;
opcode := 0;
priority := 0;
end;
scan := scNone;
biasprio := 0;
s := '';
pfti := 1; //next free PFT entry
csi := minconstant; //first entry of constant
if eqtype = 4 then
with PFT[pfti] do begin //insert v=
reg := 62; opcode := 7; priority := 1;
nextPFT;
end;
for i := 1 to length(basetext) do
begin
c := basetext[i];
case c of
'(' : begin
case scan of
scNumScan : procNum;
scAlphaScan : procAlpha;
end;
case scan of
scClose,
scVariable,
scConstant : multinsert;
end;//case
procOpen;
end;// '('
')' : begin
case scan of
scOpen,
scOperator,
scfunction : errorcode := 7;
scNumScan : procNum;
scAlphaScan: procAlpha;
end;//case
procclose;
end;//')'
'=' : if biasprio <> 0 then errorcode := 8
else
begin
case scan of
scNone,
scOpen,
scfunction : errorcode := 7;
scNumScan : procNum;
scAlphaScan: procAlpha;
end;//case
if (errorcode = 0) then
if (eqtype = 4) then procIsType4
else procOperator;
scan := scNone;
end;//else
'-' : begin
case scan of
scNumscan : procNum;
scAlphascan : procAlpha;
end;
case scan of
scNone,
scOpen : procUminus;
scClose,
scConstant,
scVariable : procoperator;
scOperator,
scfunction : errorcode := 7;
end;//case
end;//'+','-'
'+',
'*',
'/',
'^' : begin
case scan of
scAlphascan : procAlpha;
scNumScan : procNum;
end;
case scan of
scNone,
scOpen,
scOperator,
scfunction : errorcode := 7;//syntax error
end;//case
procOperator;
end;//'= ...^ '
' ' : begin
case scan of
scNumScan : procNum;
scAlphaScan: procalpha;
end;//case
end;// ' '
';' : if biasprio <> 0 then errorcode := 7
else
begin
case scan of
scAlphascan : procAlpha;
scNumScan : procNum;
end;
case scan of
scNone,
scOpen,
scOperator,
scfunction : errorcode := 7;
end;//case
procOperator;
scan := scNone;
end;//else
'0'..'9','.' :
begin
if scan = scAlphascan then procAlpha;
if scan = scVariable then multinsert;
case scan of
scNone,
scOpen,
scOperator,
scClose : s := c;
scNumScan : s := s + c;
scConstant,
scfunction : errorcode := 7;
end;//case
scan := scNumscan;
end;//'0'..'9'
'a'..'z' :
begin
if scan = scNumscan then procNum;
case scan of
scClose,
scConstant : multinsert;
end;
case scan of
scNone,
scOpen,
scOperator : s := c;
scAlphaScan: s := s + c;
scVariable,
scfunction : errorcode := 7;
end;//case
scan := scAlphaScan;
end;//'a'..'z'
else begin
errorcode := 3;
extramessage := extramessage + c;
exit;
end;
end;//case
if errorcode <> 0 then exit;
end;//for i
if (scan = scOperator) or (scan = scFunction) then errorcode := 7
else if biasprio <> 0 then errorcode := 8;//() mismatch
end;
procedure makeDRT;
//break down PFT and build director table
var i,drti : byte;
r1,r2 : byte; //source registers
regcode : byte; //|src2 0,1,2 | src1 0,1,2,3| none, 1..29, >=30, xyv
maxprioline : byte;
regreserve : longInt;//bit i set means register i is free
function getfreereg : byte;
//return free scratch register 1..29
//set errorcode if no register is free
var mask : longInt;
hit : boolean;
begin
hit := false;
result := 1;
while (hit = false) and (result <= 29) do
begin
mask := 1 shl result;
if mask and regReserve <> 0 then
begin
hit := true;
regreserve := regreserve xor mask;
end else inc(result);
end;
if hit = false then errorcode := 12;//too many intermediate results
end;
procedure freeReg(k : byte);
//free scratch register k [1..29]
begin
regReserve := regreserve or (1 shl k);
end;
procedure shiftUpPFT(n : byte);
//shift PFT (n+1) to n, (n+2) to (n=1) ...etc
var k : byte;
begin
if pfti > 1 then for k := n to pfti-1 do PFT[k] := PFT[k+1];
with PFT[pfti] do
begin
opcode := 0;
priority := 0;
reg := 0;
end;
if pfti > 1 then dec(pfti);
end;
begin
regreserve := $3ffffffe; //free regs 1..29
for i := 1 to maxDRT do
with DRT[i] do //clear DRT
begin
opcode := 0;
dest := 0;
src1 := 0;
src2 := 0;
end;
drti := 0;
while (errorcode = 0) and (PFT[1].opcode <> 0) do
begin
inc(drti);
if drti > maxDRT then
begin
errorcode := 13;
exit;
end;
i:= 2; maxprioline := 1;
while (PFT[i].opcode > 0) do //find line with highest priority
begin
if (PFT[i].priority > PFT[maxprioline].priority) then maxprioline := i;
inc(i);
end;
with DRT[drti] do
begin
opcode := PFT[maxprioline].opcode;
r1 := PFT[maxprioline].reg;
r2 := PFT[maxprioline+1].reg;
regcode := 0;
case r1 of
1..29 : regcode := 1; //scratch register
30..59,
63..67 : regcode := 2; //constant
//detect transfer to x,y,v = regcode 3
60..62 : if opcode = 7 then regcode := 3 else regcode := 2; //variable
end;
case r2 of
1..29 : regcode := regcode or $10; //scratch register
30..67 : regcode := regcode or $20; //constant, variable
end;
case regcode of
$00,
$01,
$02,
$03 : errorcode := 7;
$10,
$12 : begin
dest := r2;
src1 := r1;
src2 := r2;
end;
$11 : begin
dest := r1;
src1 := r1;
src2 := r2;
freereg(r2);
end;
$13 : begin
dest := r1;
src1 := 0;
src2 := r2;
freereg(r2);
end;
$20,
$22 : begin
dest := getfreereg;
src1 := r1;
src2 := r2;
end;
$21 : begin
dest := r1;
src1 := r1;
src2 := r2;
end;
$23 : begin
dest := r1;
src1 := 0;
src2 := r2;
end;
end;//case regcode
shiftUpPFT(maxprioline);
PFT[maxprioline].reg := dest; //set new destination
end;//with DRT[drti]
end;//while
if errorcode = 0 then DRTtop := drti else DRTtop := 0;
end;
//--- calls ---
procedure XlateEquation(const s:string; var xcode:byte);
//build director table
//OK:xcode = 0
label end1;
begin
if debugmode then clearbox;
basetext := ansilowercase(s);
extramessage := '';
eqtype := 0;
errorcode := 0;
if length(basetext) > 250 then
begin
errorcode := 1; goto end1;
end;
basetext := basetext + ' ';//mark end to process all characters
detecttype;
if eqtype = 0 then
begin
errorcode := 2; goto end1;
end;
makePFT;
if errorcode <> 0 then goto end1;
if debugmode then begin
showconstants;
showPFT;
end;
makeDRT;
if debugmode and (errorcode = 0) then showDRT;
end1:
xcode := errorcode;
if xcode <> 0 then eqtype := 0
else extramessage := '(type='+inttostr(eqtype)+')'
end;
function getEqType : byte;
//return equationtype
//0: error; 1,2,3,4: OK
begin
result := eqType;
end;
procedure setconstant(a : char; d : double);
//set constant 'a','b','c' to d
begin
case a of
'a' : REG[63] := d;
'b' : REG[64] := d;
'c' : REG[65] := d;
end;//case
end;
//--- functions to calculate equations
procedure Func1; //+
begin
with DRT[dix] do
try
reg[dest] := reg[src1] + reg[src2];
except
valid := false;
end;
end;
procedure Func2; //-
begin
with DRT[dix] do
try
reg[dest] := reg[src1] - reg[src2];
except
valid := false;
end;
end;
procedure Func3;//*
begin
with DRT[dix] do
try
reg[dest] := reg[src1] * reg[src2];
except
valid := false;
end;
end;
procedure Func4; // /
begin
with DRT[dix] do
try
reg[dest] := reg[src1] / reg[src2];
except
valid := false;
end;
end;
procedure Func5; // ^
var xx, x1, x2 : double;
begin
with DRT[dix] do
try
x1 := reg[src1]; x2 := reg[src2];
if (frac(x2) = 0 ) and (x2 >= 0) and (x2 < 10) then
begin
xx := 1;
while x2 > 0 do begin
x2 := x2 -1;
xx := xx * x1;
end;
reg[dest] := xx;
end
else reg[dest] := exp(x2 * ln(x1));
except
valid := false;
end;
end;
procedure Func6; // unairy -
begin
with DRT[dix] do
try
reg[dest] := -reg[src2];
except
valid := false;
end;
end;
procedure Func7;//move
begin
with DRT[dix] do
try
reg[dest] := reg[src2];
except
valid := false;
end;
end;
procedure func8;// ; nop
begin end;
procedure func9; // n/u
begin end;
procedure Func10; //sin
begin
with DRT[dix] do
try
reg[dest] := sin(REG[src2]);
except
valid := false;
end;
end;
procedure Func11; //cos
begin
with DRT[dix] do
try
reg[dest] := cos(reg[src2]);
except
valid := false;
end;
end;
procedure Func12; //tan
begin
with DRT[dix] do
try
reg[dest] := tan(reg[src2]);
except
valid := false;
end;
end;
procedure Func13; //asin
var xx : double;
begin
with DRT[dix] do
try
xx := sqrt(1 - sqr(reg[src2]));
reg[dest] := arctan(reg[src2] / xx);
except
valid := false;
end;
end;
procedure Func14; //acos
var xx : double;
begin
with DRT[dix] do
try
xx := sqrt(1 - sqr(reg[src2]));
reg[dest] := arctan(xx / reg[src2]);
except
valid := false;
end;
end;
procedure Func15; //atan
begin
with DRT[dix] do
try
reg[dest] := arctan(reg[src2]);
except
valid := false;
end;
end;
procedure Func16; //sqrt
begin
with DRT[dix] do
try
reg[dest] := sqrt(reg[src2]);
except
valid := false;
end;
end;
procedure Func17; //log
begin
with DRT[dix] do
try
reg[dest] := ln(reg[src2])*dln10;// = 1/ln(10)
except
valid := false;
end;
end;
procedure Func18; //ln
begin
with DRT[dix] do
try
reg[dest] := ln(reg[src2]);
except
valid := false;
end;
end;
procedure Func19; //exp
begin
with DRT[dix] do
try
reg[dest] := exp(reg[src2]);
except
valid := false;
end;
end;
procedure Func20; //abs
begin
with DRT[dix] do
try
reg[dest] := abs(reg[src2]);
except
valid := false;
end;
end;
procedure Func21;//integer part of number
begin
with DRT[dix] do
try
reg[dest] := round(reg[src2]);
except
valid := false;
end;
end;
procedure calculate(var OK : boolean);
const Func : array[1..21] of procedure = //functions listed by opcode
(func1,func2,func3,func4,func5,func6,func7,func8,
func9,func10,func11,func12,func13,func14,func15,
func16,func17,func18,func19,func20,func21);
begin
dix := 0; //functions use dix to address DRT
valid := true; //functions set valid to false in case of arithmetic error
while valid and (dix < DRTtop) do
begin
inc(dix);
Func[DRT[dix].opcode];
end;
OK := valid; // OK true if successfull calculation
end;
//--- debug ---
procedure clearbox;
begin
with debugbox do with canvas do
begin
brush.style := bsSolid;
brush.color := $e0f0f0;
pen.Width := 1;
pen.color := $000000;
font.Name := 'arial';
font.Color := $000000;
font.Style := [];
rectangle(0,0,width-1,height-1);
end;
end;
procedure showconstants;
var x,y : word;
i : byte;
begin
with debugbox do with canvas do
begin
x := 5;
y := 5;
textout(x,y,'type = '+inttostr(eqtype));
inc(y,20);
textout(x,y,'constants');
inc(y,20);
i := minconstant;
while i < csi do //constants
begin
textout(x,y,inttostr(i)+':');
textout(x+30,y, formatfloat('0.###',REG[i]));
inc(y,20);
inc(i);
end;
end;
end;
function regname(r: byte) : string;
//give name of register
begin
case r of
1..59 : result := '[' + inttostr(r) + ']';
60..67 : result := vartable[r];
else result := '';
end;//case
end;
function opcodeName(c : byte) : string;
//give name of operator or function
begin
case c of
1..8 : result := opcodetable[c].a;
10..21 : result := functiontable[c];
else result := '';
end;//case
end;
procedure showPFT;
var i : byte;
x,y : word;
begin
x := 150;
y := 5;
with debugbox do with canvas do
begin
textout(x,y,'postfixtable');
inc(y,20);
textout(x,y,'reg');
textout(x+40,y,'operation');
textout(x+120,y,'priority');
for i := 1 to pfti do
with PFT[i] do
begin
inc(y,20);
textout(x,y,regname(reg));
textout(x+40,y,opcodename(opcode));
textout(x+120,y,inttostr(priority));
end;//with PFT
end;//with
end;
procedure showDRT;
var i : byte;
x,y : word;
begin
x := 400;
y := 5;
with debugbox do with canvas do
begin
textout(x,y,'director table');
inc(y,20);
textout(x,y,'opcode');
textout(x+60,y,'dest');
textout(x+100,y,'src1');
textout(x+140,y,'src2');
for i := 1 to DRTtop do
with DRT[i] do
begin
inc(y,20);
textout(x,y,opcodename(opcode));
textout(x+60,y,regname(dest));
textout(x+100,y,regname(src1));
textout(x+140,y,regname(src2));
end;
end;//with debugbox
end;
function getmessage(code : byte) : string;
//get message string of code
begin
result := errormessage[code]+ ' ' + extramessage;
end;
procedure setdebugmode(box:Tpaintbox; f : boolean);
begin
debugmode := f;
debugbox := box;
end;
procedure setX(d : double);
begin
REG[60] := d;
end;
procedure setY(d : double);
begin
reg[61] := d;
end;
procedure setV(d : double);
begin
REG[62] := d;
end;
function getX : double;
begin
result := REG[60];
end;
function getY : double;
begin
result := REG[61];
end;
function getV : double;
begin
result := REG[62];
end;
//-------------------
procedure xlatePreset;
//call before any other operation
//preset pi,e; set a,b,c to 0
var i : byte;
begin
decimalseparator := '.';
for i := 60 to 65 do REG[i] := 0;//x y v a b c
REG[66] := pi;
REG[67] := exp(1); // = e
dln10 := 1 / ln(10);
end;
initialization
xlatePreset;
end.
