mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 05:28:07 +02:00
* initial version
git-svn-id: trunk@10064 -
This commit is contained in:
marco
parent
dc56d1c82d
commit
332add0f01
14
.gitattributes
vendored
14
.gitattributes
vendored
@ -3901,6 +3901,20 @@ packages/svgalib/src/vgamouse.h svneol=native#text/plain
|
||||
packages/svgalib/src/vgamouse.pp svneol=native#text/plain
|
||||
packages/svgalib/tests/testvga.pp svneol=native#text/plain
|
||||
packages/svgalib/tests/vgatest.pp svneol=native#text/plain
|
||||
packages/symbolic/Makefile svneol=native#text/plain
|
||||
packages/symbolic/Makefile.fpc svneol=native#text/plain
|
||||
packages/symbolic/doc/optimization.txt svneol=native#text/plain
|
||||
packages/symbolic/doc/symbolic.txt svneol=native#text/plain
|
||||
packages/symbolic/examples/Makefile svneol=native#text/plain
|
||||
packages/symbolic/examples/Makefile.fpc svneol=native#text/plain
|
||||
packages/symbolic/examples/evaltest.pas svneol=native#text/plain
|
||||
packages/symbolic/examples/rpnthing.pas svneol=native#text/plain
|
||||
packages/symbolic/src/exprstrs.inc svneol=native#text/plain
|
||||
packages/symbolic/src/parsexpr.inc svneol=native#text/plain
|
||||
packages/symbolic/src/rearrang.inc svneol=native#text/plain
|
||||
packages/symbolic/src/symbexpr.inc svneol=native#text/plain
|
||||
packages/symbolic/src/symbolic.pas svneol=native#text/plain
|
||||
packages/symbolic/src/teval.inc svneol=native#text/plain
|
||||
packages/syslog/Makefile svneol=native#text/plain
|
||||
packages/syslog/Makefile.fpc svneol=native#text/plain
|
||||
packages/syslog/fpmake.pp svneol=native#text/plain
|
||||
|
||||
2289
packages/symbolic/Makefile
Normal file
2289
packages/symbolic/Makefile
Normal file
File diff suppressed because it is too large
Load Diff
30
packages/symbolic/Makefile.fpc
Normal file
30
packages/symbolic/Makefile.fpc
Normal file
@ -0,0 +1,30 @@
|
||||
#
|
||||
# Makefile.fpc for Free Pascal ImLib 1.x Packages
|
||||
#
|
||||
|
||||
[package]
|
||||
name=symbolic
|
||||
version=2.2.0
|
||||
|
||||
[target]
|
||||
units=symbolic
|
||||
|
||||
[require]
|
||||
libc=y
|
||||
|
||||
[compiler]
|
||||
includedir=src
|
||||
sourcedir=src tests
|
||||
|
||||
[install]
|
||||
fpcpackage=y
|
||||
fpcsubdir=packages
|
||||
|
||||
[default]
|
||||
fpcdir=../..
|
||||
|
||||
[shared]
|
||||
build=n
|
||||
|
||||
[rules]
|
||||
.NOTPARALLEL:
|
||||
89
packages/symbolic/doc/optimization.txt
Normal file
89
packages/symbolic/doc/optimization.txt
Normal file
@ -0,0 +1,89 @@
|
||||
Simplifications
|
||||
----------------
|
||||
|
||||
Simplification levels:
|
||||
0 Do not simplify.
|
||||
1 add real only to real and int only to int.
|
||||
2 Same as 1, but integers are added to reals. (real1=int+real2)
|
||||
3 Convert all integers to real, and then do 1.
|
||||
|
||||
SimplifyConstants:
|
||||
If Mode=0: only check integrity
|
||||
|
||||
|
||||
- Evaluates all real constants, including things like Sin(5.0)
|
||||
- Evaluates Real
|
||||
|
||||
|
||||
CO
|
||||
/ \
|
||||
/ \
|
||||
A B
|
||||
/ \ / \
|
||||
/ \ / \
|
||||
C D E F
|
||||
|
||||
|
||||
Node types:
|
||||
|
||||
Ci constant (nodetype=iconstnode)
|
||||
Cr real constant, (nodetype=constnode)
|
||||
Cy expression (ExprIsConstant IN Flags, things like Sin(5) or even 4 DIV 6 if integer to real is off)
|
||||
Cn is any of the three above constant types
|
||||
CO= Commutative Operator (mul, add)
|
||||
X Any other expression,
|
||||
|
||||
|
||||
Constants always have to be arranged Ci<Cr<Cy<
|
||||
|
||||
if A <> CO then (C and D have no relevance)
|
||||
if B <> CO then (E and F have no relevance)
|
||||
|
||||
A C D B E F
|
||||
action Cn - - CO Cn Cn (killed in SimplifyConstants}
|
||||
Cn - - CO X Cn (Changed to E=C, F=X in killed in SimplifyConstants)
|
||||
Cn - - CO Cn X (if A=Cx and E=Ci then swap(A,E))
|
||||
X - - CO
|
||||
|
||||
----------------
|
||||
(from an older version of this doc:)
|
||||
|
||||
A D Action
|
||||
Xcomm <>Xcomm Process [b c d]
|
||||
Xcomm Xcomm Process [b c e f]
|
||||
<>Xcomm Xcomm Process [a e f]
|
||||
<>Xcomm <>Xcoom Process [a d]
|
||||
|
||||
|
||||
How to process:
|
||||
|
||||
If Simplicationlevel<>0 then
|
||||
begin
|
||||
if (Simplicationlevel=3) or ((simplicationlevel=2) and (Cr in [])) then
|
||||
{convert all Ci to Cr}
|
||||
If more than one Ci in [] then
|
||||
{addall Ci's to one Ci}
|
||||
If more than one Cr in [] then
|
||||
{addall Crs to one Cr}
|
||||
end;
|
||||
{determine how many elements in set left. (in practice kept track of in code
|
||||
above)}
|
||||
If we have only one xcomm on the right, xchg right and left}
|
||||
|
||||
{Rearrange set so that
|
||||
Ci < Cr < Cx < X
|
||||
|
||||
#nodes nodes filled:
|
||||
0 Not possible.
|
||||
1 Root node only, but not possible (cases that could lead to this
|
||||
are covered by the standard simplifications)
|
||||
2 A, D
|
||||
3 A, e f
|
||||
4 b c e f
|
||||
|
||||
TreeType: 0 A d
|
||||
1 b c d
|
||||
2 A e f
|
||||
3 b c e f
|
||||
|
||||
}
|
||||
390
packages/symbolic/doc/symbolic.txt
Normal file
390
packages/symbolic/doc/symbolic.txt
Normal file
@ -0,0 +1,390 @@
|
||||
Unit Symbolic
|
||||
------------
|
||||
|
||||
Unit Symbolic is something I wrote to take care of all my needs in the fields
|
||||
of simple expression parsing and evaluating, and to act as base for more
|
||||
complex manipulation.
|
||||
|
||||
This doc originally was a notes file for myself. If it is unreadable, then
|
||||
sorry. Rewrite of docs will have to wait until FCL doc-making practices
|
||||
are clear.
|
||||
|
||||
Author:
|
||||
-------
|
||||
|
||||
Marco van de Voort (Marco@freepascal.org)
|
||||
|
||||
Target/Compiler:
|
||||
------
|
||||
|
||||
FreePascal 1.1 (post 1.0 development). www.freepascal.org
|
||||
|
||||
Should run on Delphi 4 with minimal changes. (and any Delphi that supports
|
||||
overloading). If you remove the overloading it should run on D2..D5. I never
|
||||
programmed 16-bit Object Pascal, so I don't know the D1 status
|
||||
|
||||
I tested with D4, but forgot to merge all changes.
|
||||
I fixed the more difficult Delphi problems see the ifdef near
|
||||
the pvliwevalword definition) Probably replacing all Upcase() functions with
|
||||
ansiuppercase and commenting the runerror msgs should get it to compile under
|
||||
Delphi.
|
||||
|
||||
Key features:
|
||||
--------------
|
||||
(for the meaning of abbreviations, see the glossary
|
||||
at the end of this document)
|
||||
|
||||
General:
|
||||
- 32-bit. Probably close to being 64-bit clean. (no integer <->
|
||||
pointer casts). D1 status unknown, since I never used it, and can't
|
||||
tell easily. Biggest problem for ports is probably that it doesn't
|
||||
account for aligned arrays. It also assumes pointer arithmic.
|
||||
- OOP interface design, but sometimes uses procedures internally for
|
||||
speed.
|
||||
- Doesn't use (co)processor dependant features atm. An alternate method
|
||||
in TEvaluator will have to take care of that.
|
||||
- Optimised (algorithm) with high speed repeated evaluations in mind.
|
||||
Parsing is NOT optimised, but not particulary dumb either.
|
||||
If parsing is a speed problem, one should eliminate the parsetree
|
||||
generation and conversion to back VLIWRPN, and generate VLIWRPN
|
||||
directly
|
||||
|
||||
- Expression parsing and conversion:
|
||||
- Infix to RPN
|
||||
- infix to Parsetree
|
||||
- Parsetree to infix
|
||||
- Parsetree to RPN
|
||||
|
||||
- Symbolic Expression handling.
|
||||
- Simple operators on expressions + / * - ^
|
||||
- Derivation of simple functions (all operators + most functions in math
|
||||
unit)
|
||||
- taylor polynomal.
|
||||
- Precalculate Newton. (almost non-feature :-)
|
||||
- Primitives for rearranging
|
||||
- Identifying of terms.
|
||||
- Simple simplying (2*2*x -> 4*x)
|
||||
- (de)factoring (*)
|
||||
- Rearrange so that when converted to RPN, maximal stack depth
|
||||
for evaluation is 4. This also needs a detector routine
|
||||
(determine required RPN stack room)
|
||||
- Operator overloading possible?
|
||||
|
||||
- High speed evaluating. (parse once, evaluate often principle)
|
||||
- Infinite variables
|
||||
- Infinite (symbolic) constants.
|
||||
- Fast (hopefully)
|
||||
- Structure designed so that a lowlevel (processor dependant) version of
|
||||
the core evaluating routine is possible.
|
||||
|
||||
TO DO, problems, missing features.
|
||||
------
|
||||
|
||||
The biggest feature missing for me (at the moment) is the possibility to use
|
||||
user defined (other TExpression) functions in my expressions. Only built in
|
||||
functions are allowed. A procedure variable system as seen in some freeware
|
||||
examples could be done too. Procedure variables would be faster. However they
|
||||
would be compiletime (while texpressions can be changed runtime)
|
||||
(one can workaround this for the evaluator by applying some substitutions)
|
||||
|
||||
Another problem can be seen both as bug and as missing feature: 5+x+7 doesn't
|
||||
get simplified to x+13 or 13+x. Only 5+7+x gets optimised. This also goes for
|
||||
the other infix operators.
|
||||
|
||||
- (Symbolic) Integration. At least the parts that *can* be done. Hard, there is
|
||||
no foolproof approach, and even determining *if* integration is possible is
|
||||
hard.
|
||||
User assisted? (e.g. let the user identify the partial integration terms)
|
||||
Integration further opens the door to Laplace and Fourier.
|
||||
- Equation support? Or Equation is an equity operator and 2 TExpressions?
|
||||
- Other mathematical symbolic functions.
|
||||
- The RPNCalc example is 90% of a simple (symbolic!) RPN calculator. It looks
|
||||
and feels awfull, but the base functionality is all there, and more important
|
||||
easy to use and extend.
|
||||
Maybe for the GUI freaks it is nice to have some GUI RPNcalc widget. Same for
|
||||
TUI (TV/FV/IDE)
|
||||
- Polynomal to (Jedi's or other) vector/Matrix type conversion.
|
||||
Would create entanglement between the units though. Maybe better via
|
||||
^array of arbfloat. Could need an import method in target unit somewhere.
|
||||
- Rearranging of the parsetree so that it requires maximally 4 stack
|
||||
positions to evaluate the expression (which according to RPN theory
|
||||
is possible?)
|
||||
This would allow to run the evaluator purely on the i386 coprocessor
|
||||
stack, which probably would mean an enormous speed increase.
|
||||
- As first step: inline math functions in assembler in evaluator
|
||||
(with conditional)
|
||||
- Other "smart" rearranging of expressions. Since this is not always possible
|
||||
without user intervention, this will boil down in creating the support
|
||||
methods for user assisted symbolic rearraning.
|
||||
- Clean up, real docs. I waited with real docs because Jedi and FPC use
|
||||
different document formats and philosophies with it. Personally I prefer the
|
||||
FPC way of course. A PDF loads as fast as such a html-hlp, and looks ten
|
||||
times better. AND can generate html if necessary, and get used for real books.
|
||||
- Complex?
|
||||
- Predefined symbolic constants? pi, G, h, e(logaritm), e(elementary charge)
|
||||
(comment: Essentially not necessary anymore.)
|
||||
- Some more experienced classes programmer must decide which methods to make
|
||||
virtual, and maybe rework the current inheritance between the classes.
|
||||
- Support in TEvaluator for constant substitution followed by an
|
||||
TExpression.Simplify BEFORE vliwarr generation. This to avoid recalculating
|
||||
things like h/(2*pi) in each evaluation. Will need to copy exprtree for
|
||||
this?
|
||||
- Changing parser to allow foreign characters. (anything not in a certain
|
||||
set is appended to token). Important for people using other codepages.
|
||||
- Common subexpression elimination? (probably needed in some form for some
|
||||
rearrangements)
|
||||
- XML / HTML 4.0 / \Latex formatted output expression :-)
|
||||
- (Delphi) Controls that allow you to enter mathematical expressions in
|
||||
numerical fields?
|
||||
- Graphical viewing of expressions? How to do it graph library (graph,
|
||||
graphiX,GTK,QT,directx etc etc) independant?
|
||||
(I have some idea for an algoritm for this from a LaTeX tutorial. Basically
|
||||
parse the tree and assign all end nodes a size. Parents size can be
|
||||
calculated from children. Then another pass for rendering to coordinates,
|
||||
followed by the plot. Will have to be parameterized and with callbacks for
|
||||
flexibility and system independance)
|
||||
- Doesn't check for bounderies. (treats e.g. x/x=1 but if x=0 then officially
|
||||
it isn't defined) I hope to implement a TExpression method for this
|
||||
someday. (that checks a function for continuety problem spots)
|
||||
|
||||
Class overview.
|
||||
-------------
|
||||
|
||||
1. TBaseExpression. Very basic support for creating parsetrees.
|
||||
2. TBaseExprParser(TBaseExpression) Parser class. Most basic conversion
|
||||
between the three expression types
|
||||
(infix, RPN, parsetree)
|
||||
3. TExpression(TBaseExprParser) Main class. An expression and the operations
|
||||
you can do on them.
|
||||
Can do some simple evaluation.
|
||||
4. TEvaluator Plugin evaluation class. Operates
|
||||
on a parsetree.
|
||||
|
||||
|
||||
Evaluating an expression.
|
||||
-------------------------
|
||||
|
||||
There are two ways of evaluating a simple expression, the method
|
||||
TExpression.SimplifyConstants and the class TEvaluator. The differences are:
|
||||
|
||||
- TExpression.SimplifyConstants is actually not written for evaluations but
|
||||
for flexible combining constants after derivation. ( deriv(2x^2) returns
|
||||
2*2*x, calling SimplifyConstants changes it to 4*x)
|
||||
It can be used for simple evaluations too, but it is probably too slow for
|
||||
repeated iterations. So in case of repeated iterations use TEvaluator.
|
||||
For one simple evaluation: use simplify, unless you have symbolic
|
||||
constants.
|
||||
|
||||
- TEvaluator is written for speed. More specifically for high speed *repeated*
|
||||
evaluations. So setting up the evaluation (creating the TEvaluator class),
|
||||
is a parsing process and relatively slow. Each iteration after that however
|
||||
is about as fast as I can imagine without using processor specific lowlevel
|
||||
features in a HLL. (like internal compilation, FP assembler etc)
|
||||
|
||||
- TEvaluator requires you to subst all values for symbolic constants/variables.
|
||||
Simplify doesn't allow to subst values for symbolic constants/variables.
|
||||
|
||||
TEvaluator algoritm and internals.
|
||||
--------------------
|
||||
|
||||
TEvaluator had two design requirements:
|
||||
1 High speed for repeated evaluations of the same function with slightly
|
||||
different values. (read: plot a graph reasonably fast)
|
||||
2 Must be usable to evaluate TExpressions, but not inherit directly from
|
||||
TExpression. Since TEvaluate only needs the parsetree from TExpression,
|
||||
this was easily possible.
|
||||
|
||||
The reason for requirement 1 is that on modern computers the application's
|
||||
speed won't be affected by a little more parsing overhead for a single
|
||||
evaluation, while repeated evaluations can still slow down any system.
|
||||
(people who object to this, please calculate the Wave function for all known
|
||||
organic compounds:-)
|
||||
This is implemented by moving as much as possible to the (single) parsing
|
||||
stage, and keeping the repeated part as lean and fast as possible.
|
||||
|
||||
As an application for the repeated evaluations I mainly had numerical searching
|
||||
for roots and drawing graphs in mind.
|
||||
|
||||
|
||||
The TEvaluator class generates something what I named VLIW-RPN array.
|
||||
- RPN because the array's elemental operations are equivalent to RPN stack
|
||||
operations (very comparable to a Hewlett Packard RPN calculator).
|
||||
This is mainly important because RPN is
|
||||
- parsed linearly, and
|
||||
- each operation is very simple, which is both fast.
|
||||
- VLIW because all operations are of uniform size. This makes sure that
|
||||
finding the next item is equivalent to one pointer addition instruction.
|
||||
Also looking ahead and back is easy. Contrary to "real" VLIW, only one
|
||||
instruction per word exists.
|
||||
- Array vs linked list or OOP thingy like tlist: Same reasons as VLIW.
|
||||
|
||||
In TEvaluator, symbolic values are subdivided into symbolic constants and
|
||||
variables. There is no mathematical difference (you define what a constant,
|
||||
and what is a variable. If you choose "wrong", there is a speed penalty, but
|
||||
no failure). The difference between constants and variables is that constants
|
||||
are embedded in the VLIW-RPN array before each evaluation, while variables are
|
||||
passed as parameters to each evaluation.
|
||||
Constants can be changed between each evaluation. If a variable only changes
|
||||
each 50 or more evaluations, make it a constant, and change it after 50
|
||||
evaluations.
|
||||
|
||||
Example:
|
||||
|
||||
somefunc(x,y,pi,h)=h/(2*pi)*x^2+5*x+y
|
||||
|
||||
Obviously, it is smart to choose pi and h for constants, since they won't
|
||||
change each evaluation again. (even smarter would be to evaluate h/2*pi :-)
|
||||
|
||||
|
||||
A VLIW record basically can be 4 or 5 things atm:
|
||||
|
||||
- a floating point value.
|
||||
- an integer value.
|
||||
- a RPN operator or function (which isn't a difference in RPN), though
|
||||
this routine makes a difference between one and two parameter
|
||||
functions/operators for speed. Two types:
|
||||
- An operator or a function which takes two arguments. (there is no
|
||||
difference in RPN, an operator is a function and vice versa)
|
||||
- A function that takes one argument.
|
||||
- (administrative value, no mathematical meaning) placeholder for a symbolic
|
||||
constant, to be able to to detect a constant/variable which wasn't given a
|
||||
value, and raise an exception.
|
||||
|
||||
- Symbolic variables. The variables in the expression are identified by an
|
||||
integer sequential value (first var=1, second 2 etc). Variable values ARE
|
||||
looked up each occurance during evaluation, and the only data used from
|
||||
outside the RPN-VLIW array in a standard evaluation.
|
||||
|
||||
The symbolic constants initially get the "placeholder" value, and when the
|
||||
user sets the constants via the SetConstant method, it gets a "floating point
|
||||
value" or "integer value" type.
|
||||
The class stores all references to all occurances of a constant in the VLIW
|
||||
array in a tlist.
|
||||
|
||||
The Parser
|
||||
----------
|
||||
|
||||
The parser is based on a PD stack RPN based non symbolic constant evaluator, I
|
||||
found in SWAG. It is practically rewritten, and only the elegant principle
|
||||
stands. The parser is NOT recursive-descent. It purely parses from left to
|
||||
right and creates for each token it finds a parsetree record.
|
||||
Parsetree records that can't be added to the parsetree yet, are pushed on an
|
||||
argument or separate operator stack.
|
||||
When an operator is found, then the operator stack is evaluated (popping arguments
|
||||
of the argument stack) until an operator with higher precendence than the new
|
||||
one is found. Only then the new operator is pushed on the operator stack.
|
||||
|
||||
I don't know if this is the fastest way, but it is simple, quite elegant and
|
||||
probably not very bug-sensitive. If somebody has sensible reasons to change it
|
||||
to recur. descent, please mail me.
|
||||
|
||||
Exceptions
|
||||
-------------
|
||||
|
||||
I'm still working on the errorhandling (exceptions) of the classes.
|
||||
Besides some more specific cases, there are two or three basic exception groups:
|
||||
|
||||
- (RPN)Stack under/overflow exceptions. This is not necessarily a fault
|
||||
in the program, but more likely a fault in the passed (infix) expression.
|
||||
(specially if they occur in the parser). Smartest is to log the expression
|
||||
passed to parser somewhere in such cases.
|
||||
Note: These signal problems with internal RPN stacks,
|
||||
not the processor stack. Do not mix these up. (by reraising a processor
|
||||
stack exception). The fault is not necessarily in the program.
|
||||
|
||||
- Internal errors. (IE) These are mosttimes problems in the class, and logging
|
||||
the "message" gives some information about the location of the problem.
|
||||
Most IE's are ELSE clauses that shouldn't occur, or datacorruption that
|
||||
is not acceptable. Probably they only occur if one part of the package
|
||||
is out of sync with another part, with dangling pointers etc.
|
||||
E.g. Parser is updated to support function "x", but TEvaluator.Evaluate
|
||||
wasn't. The CASE node for "x" doesn't exist, so it ends up in the ELSE
|
||||
clause which triggers the exception.
|
||||
If you use FPC, and your application is compiled with -gl, you'll probably
|
||||
get a nice backtrace with sourcename and line of the exception.
|
||||
|
||||
- Division by zero might be the third. This is NOT the processor division
|
||||
trap by zero, but a RPN stack one.
|
||||
|
||||
Glossary
|
||||
---------
|
||||
Some often used abbreviations and terms:
|
||||
|
||||
FPC : Free Pascal Compiler, the one that I use. Has a 32-bit Delphi mode.
|
||||
Misses dynamic arrays, interfaces, and nearly the entire VCL in
|
||||
production version 1.0.x. (Meanwhile, most of the language is
|
||||
already in 1.1.x development version)
|
||||
http://www.freepascal.org
|
||||
|
||||
IE : Internal error. Under FPC we try to append an ELSE clause to all
|
||||
CASE statements, even if the ELSE shouldn't occur. In such CASE
|
||||
statement the ELSE calls an internal error procedure.
|
||||
This is also used for other important decisions with situations that
|
||||
shouldn't occur. (e.g. enumerations with values that aren't defined,
|
||||
placed there by casts, circular references in linked lists etc.)
|
||||
I use the same system in these units, but with Exceptions.
|
||||
See "Exceptions" paragraph for more information about IEs.
|
||||
A good generic IE routine should be able to obtain the name of the class
|
||||
in string form.
|
||||
|
||||
Infix: The way poeple usually write down expressions. An operator between its
|
||||
operands. (5+2 operates on 5 and 2. Could also be written as add(5,2)
|
||||
or 5 2 +
|
||||
Has some advantages, but is complicated and slow to parse. However
|
||||
users(except some Hewlett Packard calculator users like me) seem to
|
||||
prefer it.
|
||||
|
||||
RPN : Reverse Polish Notation, an alternate notation of expression.
|
||||
Any operator appears AFTER its operands.
|
||||
e.g. 1+2+3*sin(4) could be written as 1 2 + 3 4 sin * +
|
||||
Biggest advantage: Linear parsing from left to right.
|
||||
Being able to convert a parsetree to RPN is also a good debugging aid.
|
||||
(since it can be simply printed instead of having to browse a
|
||||
parsetree runtime)
|
||||
You can also think of it as replacing the infix operators in an infix
|
||||
expression by functions (so add(x,y) instead of x+y), and then parse
|
||||
from end to start (the "Reverse" of RPN)
|
||||
This also displays another feature of RPN: There is no difference between
|
||||
operators and functions. There are only functions that take different
|
||||
amounts of parameters.
|
||||
|
||||
Parsetree:
|
||||
The way an expression (or even an entire program) is stored
|
||||
after parsing in compilers. Often, the main type is a variant record
|
||||
(see treenode, pnode in the source) in which an operator or a function
|
||||
has pointers to each operand. Parsetrees are often visualised as below.
|
||||
Each operation, function or constant is a record, the lines made with
|
||||
slashes are the pointers between the records. (so the top "+" has a
|
||||
pointer to another "+" record, and one to a "*" record)
|
||||
|
||||
|
||||
+
|
||||
/ \
|
||||
+ \
|
||||
/ \ \
|
||||
1 2 \
|
||||
*
|
||||
/ \
|
||||
3 SIN
|
||||
\
|
||||
4
|
||||
|
||||
Fig 1. 1+2+3*sin(4)
|
||||
|
||||
Parsetrees are the easiest way to operate on (transform, derive etc)
|
||||
expressions. Mainly because you don't have to move much data to move one
|
||||
part of the expression to another place. Parsetrees are kinda slow though)
|
||||
(compared to RPN), or VLIWRPN
|
||||
|
||||
VLIW: Very Large Instruction Word. Acronym from the RISC world that simply
|
||||
boils down to "a linear sequence (array,stream) of uniform sized
|
||||
"items" is the simplest and fastest way to parse something."
|
||||
The RISC people are of course talking about instructions to process
|
||||
and schedule. I'm using the analogy to evaluate an array of
|
||||
elementary RPN instructions.
|
||||
This principle is used to get the expression evaluator fast per
|
||||
iteration. The main difference is that in VLIW processors more than
|
||||
one operation can be packed in a VLI-Word. (which must be independant
|
||||
then). This unit doesn't :-)
|
||||
|
||||
|
||||
1967
packages/symbolic/examples/Makefile
Normal file
1967
packages/symbolic/examples/Makefile
Normal file
File diff suppressed because it is too large
Load Diff
18
packages/symbolic/examples/Makefile.fpc
Normal file
18
packages/symbolic/examples/Makefile.fpc
Normal file
@ -0,0 +1,18 @@
|
||||
#
|
||||
# Makefile.fpc for apache2.0 units example
|
||||
#
|
||||
|
||||
[target]
|
||||
programs=evaltest rpnthing
|
||||
|
||||
[require]
|
||||
packages=symbolic
|
||||
|
||||
[install]
|
||||
fpcpackage=y
|
||||
|
||||
[default]
|
||||
fpcdir=../../..
|
||||
|
||||
[rules]
|
||||
.NOTPARALLEL:
|
||||
100
packages/symbolic/examples/evaltest.pas
Normal file
100
packages/symbolic/examples/evaltest.pas
Normal file
@ -0,0 +1,100 @@
|
||||
{
|
||||
$ id: $
|
||||
Copyright (c) 2000 by Marco van de Voort (marco@freepascal.org)
|
||||
member of the Free Pascal development team
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright. (LGPL)
|
||||
|
||||
Most basic test for TEvaluator class.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************
|
||||
}
|
||||
|
||||
program EvalTest;
|
||||
|
||||
{$AppType Console}
|
||||
|
||||
Uses Classes,Symbolic, SysUtils;
|
||||
|
||||
VAR Expr : TExpression;
|
||||
SymVars : TStringList;
|
||||
I : Longint;
|
||||
VarName : TStringList;
|
||||
Eval : TEvaluator;
|
||||
Vars : Array[0..1] OF ArbFloat;
|
||||
|
||||
begin
|
||||
{Lets create in a nice equation. Totally nonsense. Don't try to
|
||||
make sense of it}
|
||||
|
||||
Expr:=TExpression.Create('pi*sin(x-x0)+x^(t-1)+exp(x*t)+5');
|
||||
Writeln('Expression after parsing :',Expr.InfixExpr);
|
||||
|
||||
{Hmm. But the user could have typed that in. Let's check if he used
|
||||
symbolic values}
|
||||
|
||||
SymVars:=Expr.SymbolicValueNames;
|
||||
|
||||
If SymVars.Count>0 Then
|
||||
For I:=0 TO SymVars.Count-1 DO
|
||||
Writeln(I:5,' ',Symvars[I]);
|
||||
|
||||
{Assume the user selected X and T from above stringlist as our variables}
|
||||
|
||||
VarName:=TStringList.Create;
|
||||
VarName.Add('X');
|
||||
VarName.Add('T');
|
||||
|
||||
{Create the Evaluator Object}
|
||||
|
||||
Eval:=TEvaluator.Create(VarName,Expr);
|
||||
|
||||
{My HP48g provided this value for PI:}
|
||||
|
||||
IF Symvars.IndexOf('PI')<>-1 THEN {If PI exists, then assume it is the
|
||||
circle radius vs diameter ratio}
|
||||
Eval.SetConstant('PI',3.14159265359);
|
||||
|
||||
IF Symvars.IndexOf('X0')<>-1 THEN {Set X0 to Douglas' number}
|
||||
Eval.SetConstant('X0',42);
|
||||
|
||||
{All this above looks slow isn't? It probably even is. Unit symbolic has
|
||||
evaluations as plus, not as target. The evaluation is built for
|
||||
fast repeated evaluations, not just one.
|
||||
However the Evaluate method is hopefully reasonably fast.
|
||||
Under FPC TEvaluator.Evaluate is about 600-700 assembler instructions,
|
||||
without operation on pointer trees and without recursion.
|
||||
If your compiler (and hopefully FPC too) can inline the math unit functions,
|
||||
the speed gain could be dramatic.}
|
||||
|
||||
Writeln('Stackdepth needed for evaluation: ',eval.EvalDepth);
|
||||
|
||||
FOR I:=1 TO 50 DO
|
||||
begin
|
||||
Vars[0]:=1/I *1.1;
|
||||
Vars[1]:=1/I*2;
|
||||
Writeln(VarName.Strings[0] + '=' + FloatToStrF(Vars[0], ffFixed, 4, 4) + ' ' +
|
||||
VarName.Strings[1] + '=' + FloatToStrF(Vars[1], ffFixed, 4, 4) + ' = ' +
|
||||
FloatToStrF(Eval.Evaluate(Vars), ffFixed, 4, 4));
|
||||
end;
|
||||
|
||||
Eval.Free;
|
||||
Expr.Free;
|
||||
SymVars.Free;
|
||||
// VarName.Free; {Is freed by TEvaluator.Destroy. Should TEvaluator copy it?}
|
||||
|
||||
Readln;
|
||||
end.
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002/12/15 21:01:22 marco
|
||||
Initial revision
|
||||
|
||||
}
|
||||
179
packages/symbolic/examples/rpnthing.pas
Normal file
179
packages/symbolic/examples/rpnthing.pas
Normal file
@ -0,0 +1,179 @@
|
||||
program RPNThing;
|
||||
{
|
||||
$ id: $
|
||||
Copyright (c) 2000 by Marco van de Voort(marco@freepascal.org)
|
||||
member of the Free Pascal development team
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright. (LGPL)
|
||||
|
||||
Much too simplistic program to test some basic features of Symbolic unit.
|
||||
It is the very rough skeleton of a symbolic RPN calculator like a HP48.
|
||||
Since there are no exception conditions in the parser or evaluator,
|
||||
please enter valid expressions.
|
||||
Don't use 5E6 notation, it is not implemented yet. You can enter
|
||||
symbolic expressions using x, integer constants and half the math
|
||||
unit's function.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
}
|
||||
|
||||
{$ifdef FPC}
|
||||
{$Mode ObjFpc}
|
||||
{$endif}
|
||||
|
||||
Uses Symbolic,Crt;
|
||||
|
||||
function GetKey:char;
|
||||
|
||||
begin
|
||||
repeat
|
||||
while keypressed DO ;
|
||||
result:=ReadKey;
|
||||
if result=#0 then {Make sure control codes are skipped apropiately}
|
||||
begin
|
||||
result:=readKey;
|
||||
result:=#0;
|
||||
end;
|
||||
until result IN ['X','x','O','o','q','Q',' ','+','-','*','/','^','e','E','d','D','T','t'];
|
||||
end;
|
||||
|
||||
|
||||
VAR Stack : array[0..100] of TExpression;
|
||||
I,StackPtr : Integer;
|
||||
InputC : Char;
|
||||
S : String;
|
||||
Flag : Boolean;
|
||||
|
||||
Procedure Redraw;
|
||||
|
||||
var I : Integer;
|
||||
|
||||
begin
|
||||
for I:=1 to 20 DO
|
||||
begin
|
||||
GotoXY(1,I);
|
||||
Write(' ':79);
|
||||
GotoXY(1,I);
|
||||
IF (StackPtr>(20-I)) then
|
||||
begin
|
||||
IF NOT Assigned(stack[20-I]) then
|
||||
begin
|
||||
gotoXY(1,1); write(' ':50);
|
||||
gotoxy(1,1); writeln(I,' ',20-I);
|
||||
Writeln(stackptr);
|
||||
HALT;
|
||||
end;
|
||||
Writeln(stack[StackPtr-(21-I)].InfixExpr);
|
||||
end
|
||||
else
|
||||
write('-');
|
||||
end;
|
||||
GotoXY(1,21);
|
||||
Write(' ':80);
|
||||
end;
|
||||
|
||||
begin
|
||||
Writeln(' + - / * ^ : perform the RPN operation');
|
||||
Writeln(' [space],'#39' : get a "prompt" to input a number or infix expression');
|
||||
Writeln(' E,e : Try to simplify/evaluate the expression. ');
|
||||
Writeln(' For now this is restricted to constant values only');
|
||||
Writeln(' D,d : Drop 1 value from the stack');
|
||||
Writeln(' Q,q : By pressing this key you agree this program is great');
|
||||
Writeln(' O,o : Derive the expression with respect to X');
|
||||
Writeln(' T,t : Taylor polynomal. Also with respect to X, and to 2nd ');
|
||||
writeln(' stacklevel degree');
|
||||
Writeln;
|
||||
Writeln('Press enter to start calculating');
|
||||
ReadLn;
|
||||
ClrScr;
|
||||
StackPtr:=0;
|
||||
repeat
|
||||
InputC:=GetKey;
|
||||
Case InputC OF
|
||||
'+','-','*','/','^' : if stackPtr>1 then
|
||||
begin
|
||||
Dec(StackPtr);
|
||||
case InputC of {Double case is ugly but short}
|
||||
'+' : Stack[StackPtr-1].AddTo(Stack[StackPtr]);
|
||||
'-' : Stack[StackPtr-1].SubFrom(Stack[StackPtr]);
|
||||
'*' : Stack[StackPtr-1].Times(Stack[StackPtr]);
|
||||
'/' : Stack[StackPtr-1].DivBy(Stack[StackPtr]);
|
||||
'^' : Stack[StackPtr-1].RaiseTo(Stack[StackPtr]);
|
||||
end;
|
||||
Stack[StackPtr].free;
|
||||
Redraw;
|
||||
end;
|
||||
'E','e' : If Stackptr>0 then
|
||||
begin
|
||||
Stack[StackPtr-1].SimplifyConstants;
|
||||
Redraw;
|
||||
end;
|
||||
'T','t' : If StackPtr>1 then {Stackptr-1=function. Stackptr-2=degree
|
||||
x is assumed, and x0 is substed}
|
||||
begin
|
||||
Flag:=True;
|
||||
Try
|
||||
i:=Stack[StackPtr-2].ValueAsInteger;
|
||||
except
|
||||
on ENotInt do
|
||||
begin
|
||||
GotoXY(1,1);
|
||||
WritelN('This constant doesn''t evaluate to an integer');
|
||||
Flag:=False;
|
||||
end;
|
||||
end;
|
||||
If I<0 then
|
||||
begin
|
||||
GotoXY(1,1);
|
||||
WritelN('I never heard of negative terms in a Taylor polynomal');
|
||||
end
|
||||
else
|
||||
If Flag then
|
||||
begin
|
||||
Stack[StackPtr-2].Free;
|
||||
Stack[StackPtr-2]:=Stack[StackPtr-1];
|
||||
Stack[StackPtr-1]:=Stack[StackPtr-2].Taylor(I,'X','0.0');
|
||||
Redraw;
|
||||
end;
|
||||
end;
|
||||
'O','o' : if StackPtr>0 then
|
||||
begin
|
||||
Stack[StackPtr]:=Stack[StackPtr-1].Derive('X');
|
||||
Inc(StackPtr);
|
||||
Redraw;
|
||||
end;
|
||||
'D','d' : If StackPtr>0 Then
|
||||
begin
|
||||
Stack[StackPtr-1].free;
|
||||
Dec(StackPtr);
|
||||
Redraw;
|
||||
end;
|
||||
' ',#39 : If Stackptr<100 then
|
||||
begin
|
||||
GotoXY(1,1); Writeln(' ':60);
|
||||
gotoxy(1,1); write('Enter expr. : '); readln(s);
|
||||
s:=upcase(S);
|
||||
stack[StackPtr]:=TExpression.Create(S);
|
||||
Stack[StackPtr].Simplificationlevel:=2; {Don't add reals to integer. Only evaluates
|
||||
(integer op integer) and (real op real) and
|
||||
function(real)}
|
||||
Inc(Stackptr);
|
||||
Redraw;
|
||||
end;
|
||||
'X','x' : begin
|
||||
ClrScr;
|
||||
Writeln(stdout,stack[StackPtr-1].InfixExpr);
|
||||
Writeln;
|
||||
Writeln(stdout,stack[StackPtr-1].RPNExpr);
|
||||
inputC:='q';
|
||||
end;
|
||||
end;
|
||||
until (InputC IN ['q','Q']);
|
||||
|
||||
If StackPtr>0 THEN
|
||||
For I:=0 To StackPtr-1 Do
|
||||
Stack[I].Free;
|
||||
end.
|
||||
40
packages/symbolic/src/exprstrs.inc
Normal file
40
packages/symbolic/src/exprstrs.inc
Normal file
@ -0,0 +1,40 @@
|
||||
{
|
||||
$ id: $
|
||||
Copyright (c) 2000 by Marco van de Voort(marco@freepascal.org)
|
||||
member of the Free Pascal development team
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright. (LGPL)
|
||||
|
||||
Some resourcestrings.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
resourcestring
|
||||
SEvalIE ='TEvaluator: Internal Error: ';
|
||||
SEvalStackDepthExceeded ='TEvaluator: Stack depth Evaluate exceeded';
|
||||
SEvalBadNumberOfVars ='TEvaluator: Invalid number of variables';
|
||||
SParsIE ='TBaseExprParser: Internal Error:';
|
||||
SParseRPNOverflow ='TBaseExprParser: RPN stack overflow';
|
||||
SParseRPNUnderflow ='TBaseExprParser: RPN stack underflow';
|
||||
SParsDiv0 ='TBaseExprParser: RPN Division by zero in parser';
|
||||
SParsOpOverflow ='TBaseExprParser: Operator stack Overflow';
|
||||
SParsOpUnderflow ='TBaseExprParser: Operator stack Underflow';
|
||||
SNILDeref ='NIL dereference';
|
||||
SExprIE ='TExpression: Internal error: ';
|
||||
SExprNotInt ='TExpression: This is not an integer';
|
||||
SExprNotFloat ='TExpression: This is not a float';
|
||||
SExprInvmsg ='TExpression: Inv(x) evaluates to 1/0';
|
||||
SExprInvSimp ='TExpression: Division by 0 encountered while simplifying';
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002/12/15 21:01:22 marco
|
||||
Initial revision
|
||||
|
||||
}
|
||||
|
||||
498
packages/symbolic/src/parsexpr.inc
Normal file
498
packages/symbolic/src/parsexpr.inc
Normal file
@ -0,0 +1,498 @@
|
||||
{
|
||||
$ id: $
|
||||
Copyright (c) 2000 by Marco van de Voort(marco@freepascal.org)
|
||||
member of the Free Pascal development team
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright. (LGPL)
|
||||
|
||||
Implementation of Infix to parsetree/RPN converter based on principles
|
||||
copied from a RPN constant expression evaluator by Trai Tran
|
||||
(PD, from SWAG.)
|
||||
|
||||
Parsetree to infix and parsetree to RPN/infix conversion
|
||||
by Marco v/d Voort
|
||||
OOP interface and vast improvements by Marco v/d Voort
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************
|
||||
|
||||
Problems:
|
||||
- -x^12 is -(x^12) or (-x)^12 ? (FIXED: Chose to do it as in FPC)
|
||||
- No errorhandling. (will be rewritten to use classes and exceptions first)
|
||||
(this is partially done now)
|
||||
|
||||
Original comments:
|
||||
|
||||
---------------------------------------------------------------------------
|
||||
THAI TRAN
|
||||
|
||||
I've netmailed you the full-featured version (800 lines!) that will do
|
||||
Functions, exponentiation, factorials, and has all the bells and whistles,
|
||||
but I thought you might want to take a look at a simple version so you can
|
||||
understand the algorithm.
|
||||
|
||||
This one only works With +, -, *, /, (, and ). I wrote it quickly, so it
|
||||
makes extensive use of global Variables and has no error checking; Use at
|
||||
your own risk.
|
||||
|
||||
Algorithm to convert infix to postfix (RPN) notation
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
Parse through the entire expression getting each token (number, arithmetic
|
||||
operation, left or right parenthesis). For each token, if it is:
|
||||
1. an operand (number) Send it to the RPN calculator
|
||||
2. a left parenthesis Push it onto the operation stack
|
||||
3. a right parenthesis Pop operators off stack and send to RPN
|
||||
calculator Until the a left parenthesis is
|
||||
on top of the stack. Pop it also, but don't
|
||||
send it to the calculator.
|
||||
4. an operator While the stack is not empty, pop operators
|
||||
off the stack and send them to the RPN
|
||||
calculator Until you reach one With a higher
|
||||
precedence than the current operator (Note:
|
||||
a left parenthesis has the least precendence).
|
||||
Then push the current operator onto the stack.
|
||||
|
||||
This will convert (4+5)*6/(2-3) to 4 5 + 6 * 2 3 - /
|
||||
|
||||
Algorithm For RPN calculator
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
Note: this Uses a different stack from the one described above.
|
||||
|
||||
In RPN, if an operand (a number) is entered, it is just pushed onto the
|
||||
stack. For binary arithmetic operators (+, -, *, /, and ^), the top two
|
||||
operands are popped off the stack, operated on, and the result pushed back
|
||||
onto the stack. if everything has gone correctly, at the end, the answer
|
||||
should be at the top of the stack.
|
||||
|
||||
Released to Public Domain by Thai Tran (if that matters).
|
||||
---------------------------------------------------------------------------
|
||||
MvdV: It does for me. My routines might end up in either FPC or Jedi, and
|
||||
anything except LGPL and PD is unacceptable. :-)
|
||||
|
||||
Modifications: (starting to get so big that the original is hardly
|
||||
recognisable)
|
||||
- OOP. Mainly to allow symbolic TExpression class to have custom parsers.
|
||||
- Working with pnode stack instead of reals. Pnodes can be any expression,
|
||||
see inteface unit symbolic. (creating a parsetree)
|
||||
- Support for functions(one or two parameter arguments), which weren't in the
|
||||
short Swag version. Most MATH functions are supported.
|
||||
- Can make a difference between the minus of (-x) and the one in (x-y).
|
||||
The first is converted to function minus(x);
|
||||
- power operator
|
||||
- Faculty operator
|
||||
- Conversions back to RPN and infix.
|
||||
- Removing of excess parentheses.
|
||||
}
|
||||
|
||||
type {Tokens generated by the parser. Anything else is a constant or variable}
|
||||
ParseOperation=(padd,psub,pmul,pdvd,ppow,pfacul,pleft,pright,
|
||||
pcos,psin,ptan,psqr,psqrt,pexp,pln,pinv,
|
||||
pminus, pcotan,parcsin,parccos,parctan,psinh,pcosh,ptanh,
|
||||
parcsinh,parccosh,parctanh,plog10,
|
||||
plog2,plnxpi,parctan2,pstep,ppower,phypot,
|
||||
plogn,pnothing);
|
||||
|
||||
CONST
|
||||
ParserFunctionNamesUpper : array[padd..pnothing] of string[7]=
|
||||
('+','-','*','/','^','!','(',')','COS','SIN',
|
||||
'TAN','SQR','SQRT','EXP','LN','INV','-',
|
||||
'COTAN','ARCSIN','ARCCOS','ARCTAN',
|
||||
'SINH','COSH','TANH','ARCSINH',
|
||||
'ARCCOSH','ARCTANH','LOG10',
|
||||
'LOG2','LNXP1','ARCTAN2','STEP',
|
||||
'POWER','HYPOT','LOGN','NOTHING');
|
||||
|
||||
{Operator or function-}
|
||||
Priority : array[padd..pnothing] of ArbInt=
|
||||
(1,1,2,2,3,0,0,0,
|
||||
4,4,4,4,4,4,4,4,
|
||||
4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,5);
|
||||
|
||||
OppsXlat='+-*/^!()'; {Must match the first entries of ParseOperation.
|
||||
Pos(OppsXlat,c)-1+ord(Padd) is typecast!}
|
||||
|
||||
Const
|
||||
RPNMax = 20; { I think you only need 4-8, but just to be safe }
|
||||
OpMax = 25;
|
||||
AllowedInToken = ['0'..'9','.','E','e'];
|
||||
|
||||
Type
|
||||
String15 = String[15];
|
||||
|
||||
Procedure ParserInternalError(const Msg:String;A,B:ArbInt);
|
||||
|
||||
VAR S,S2 : String;
|
||||
|
||||
begin
|
||||
Str(A,S); {Usually a identification number for the occurance}
|
||||
Str(B,S2); {Usually the value that tripped the IE}
|
||||
Raise EParserIE.Create(SParsIE+Msg+S+' '+S2);
|
||||
end;
|
||||
|
||||
function TBaseExprParser.InFixToParseTree(Expr : String;VAR RPNexpr: String):pnode;
|
||||
|
||||
Var
|
||||
RPNStack : Array[1..RPNMax] of PNode; { Stack For RPN calculator }
|
||||
RPNTop,
|
||||
OpTop : ArbInt;
|
||||
OpStack : Array[1..OpMax] of ParseOperation; { Operator stack For conversion }
|
||||
|
||||
Procedure RPNPush(Num : PNode); { Add an operand to the top of the RPN stack }
|
||||
begin
|
||||
if RPNTop < RPNMax then
|
||||
begin
|
||||
Inc(RPNTop);
|
||||
RPNStack[RPNTop] := Num;
|
||||
end
|
||||
else
|
||||
RAISE EParserStack.Create(SParseRPNOverflow);
|
||||
end;
|
||||
|
||||
Function RPNPop : pnode; { Get the operand at the top of the RPN stack }
|
||||
begin
|
||||
if RPNTop > 0 then
|
||||
begin
|
||||
RPNPop := RPNStack[RPNTop];
|
||||
Dec(RPNTop);
|
||||
end
|
||||
else
|
||||
RAISE EParserStack.Create(SParseRPNUnderflow);
|
||||
end;
|
||||
|
||||
Procedure RPNCalc(Token : String15); { RPN Calculator }
|
||||
Var
|
||||
treal : ArbFloat;
|
||||
tint : ArbInt;
|
||||
Error : ArbInt;
|
||||
begin
|
||||
RPNExpr:=RPNExpr+token+' ';
|
||||
Val(Token, treal, Error);
|
||||
IF (error=0) then
|
||||
begin
|
||||
if (Pos('.',token)=0) and (Pos('E',token)=0) Then
|
||||
begin
|
||||
Val(Token,tint,Error);
|
||||
RpnPush(Newiconst(tint));
|
||||
end
|
||||
else
|
||||
RPNPush(NewConst(Treal));
|
||||
end
|
||||
else { Handle error }
|
||||
RPNPush(NewVar(Token));
|
||||
end;
|
||||
|
||||
Procedure RPNOperation(Operation:ParseOperation);
|
||||
{The workhorse. Creates the tree, and associates a parseoperation with
|
||||
the TExpression enumerations. Avoids some ugly (and shaky) typecasts
|
||||
between operations like in earlier versions.}
|
||||
|
||||
var Temp: pnode;
|
||||
|
||||
begin
|
||||
RPNExpr:=RPNExpr+ParserFunctionNamesUpper[Operation]+' ';
|
||||
Case Operation of { Handle operators }
|
||||
padd : RPNPush(newcalc(addo,RPNPop,RPNPop));
|
||||
psub : begin
|
||||
Temp:=RPNPOP;
|
||||
RPNPush(NewCalc(subo,RPNPOP,Temp));
|
||||
end;
|
||||
pmul : RPNPush(newcalc(mulo,RPNPOP,RPNPop));
|
||||
pdvd : begin
|
||||
Temp := RPNPop;
|
||||
if Temp <> NIL then
|
||||
RPNPush(newcalc(dvdo,RPNPop,Temp))
|
||||
else
|
||||
Raise EDiv0.Create(SParsDiv0); { Handle divide by 0 error }
|
||||
end;
|
||||
ppow,ppower : {are only different in parsing x^y and power(x,y)}
|
||||
begin
|
||||
Temp:=RpnPop;
|
||||
RpnPush(NewCalc(powo,RpnPop,Temp));
|
||||
end;
|
||||
pfacul : RPNPush(NewFunc(faculx,RPNPOP));
|
||||
psin : RPNPush(NewFunc(sinx,RPNPop));
|
||||
pcos : RPNPush(NewFunc(cosx,RPNPop));
|
||||
ptan : RPNPush(NewFunc(tanx,RPNPop));
|
||||
psqr : RPNPush(NewFunc(sqrx,RPNPop));
|
||||
pexp : RPNPush(NewFunc(expx,RPNPop));
|
||||
pln : RPNPush(NewFunc(lnx,RPNPop));
|
||||
pinv : RPNPush(NewFunc(invx,RPNPop));
|
||||
Pminus : RPNPush(newFunc(minus,RPNPop));
|
||||
pcotan : RPNPush(NewFunc(cotanx,rpnpop));
|
||||
parcsin : RPNPush(NewFunc(arcsinx,rpnpop));
|
||||
parccos : RPNPush(NewFunc(arccosx,rpnpop));
|
||||
parctan : RPNPush(NewFunc(arctanx,rpnpop));
|
||||
psinh : RPNPush(NewFunc(sinhx,rpnpop));
|
||||
pcosh : RPNPush(NewFunc(coshx,rpnpop));
|
||||
ptanh : RPNPush(NewFunc(tanhx,rpnpop));
|
||||
parcsinh : RPNPush(NewFunc(arcsinhx,rpnpop));
|
||||
parccosh : RPNPush(NewFunc(arccoshx,rpnpop));
|
||||
parctanh : RPNPush(NewFunc(arctanhx,rpnpop));
|
||||
plog10 : RPNPush(NewFunc(log10x,rpnpop));
|
||||
plog2 : RPNPush(NewFunc(log2x,rpnpop));
|
||||
plnxpi : RPNPush(NewFunc(lnxpix,rpnpop));
|
||||
parctan2 : begin
|
||||
Temp:=RpnPop;
|
||||
RpnPush(Newfunc(arctan2x,RpnPop,temp));
|
||||
end;
|
||||
pstep : begin
|
||||
Temp:=RpnPop;
|
||||
RpnPush(Newfunc(stepx,RpnPop,temp));
|
||||
end;
|
||||
phypot: begin
|
||||
Temp:=RpnPop;
|
||||
RpnPush(Newfunc(hypotx,RpnPop,temp));
|
||||
end;
|
||||
plogn : begin
|
||||
Temp:=RpnPop;
|
||||
RpnPush(Newfunc(lognx,RpnPop,Temp));
|
||||
end;
|
||||
else
|
||||
ParserInternalError('Unknown function',1,ORD(Operation));
|
||||
end;
|
||||
end;
|
||||
|
||||
Function IsFunction(S:String):ParseOperation;
|
||||
|
||||
var Count:ParseOperation;
|
||||
|
||||
begin
|
||||
IsFunction:=pnothing;
|
||||
for Count:=pCos to pInv do {Minus is a pseudo function, and in this category
|
||||
because it has only 1 argument}
|
||||
begin
|
||||
If Copy(S,1,3)=ParserFunctionNamesUpper[Count] then
|
||||
IsFunction:=Count;
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure OpPush(operation : ParseOperation); { Add an operation onto top of the stack }
|
||||
begin
|
||||
if OpTop < OpMax then
|
||||
begin
|
||||
Inc(OpTop);
|
||||
OpStack[OpTop] := operation;
|
||||
end
|
||||
else
|
||||
RAISE EParserStack.Create(SParsOpOverflow);
|
||||
end;
|
||||
|
||||
Function OpPop : ParseOperation; { Get operation at the top of the stack }
|
||||
begin
|
||||
if OpTop > 0 then
|
||||
begin
|
||||
OpPop := OpStack[OpTop];
|
||||
Dec(OpTop);
|
||||
end
|
||||
else
|
||||
RAISE EParserStack.Create(SParsOpUnderflow);
|
||||
end;
|
||||
|
||||
Var
|
||||
I,len : ArbInt;
|
||||
Token : String15;
|
||||
OperationNr : ParseOperation;
|
||||
FunctionNr : ArbInt;
|
||||
isminus : boolean;
|
||||
|
||||
begin
|
||||
RPNExpr:='';
|
||||
OpTop := 0; { Reset stacks }
|
||||
RPNTop := 0;
|
||||
Token := '';
|
||||
{$ifdef fpc}
|
||||
Expr:=Upcase(Expr);
|
||||
{$endif}
|
||||
i:=1; len:=Length(Expr);
|
||||
while I<=Len do
|
||||
begin
|
||||
{Flush token, if we feel an infix operator coming}
|
||||
FunctionNr:=Pos(expr[I],OppsXlat);
|
||||
If (FunctionNr<>0) and (Token<>'') THEN
|
||||
begin { Send last built number to calc. }
|
||||
RPNCalc(Token);
|
||||
Token := '';
|
||||
end;
|
||||
If (FunctionNr>0) and (FunctionNr<7) then
|
||||
begin
|
||||
OperationNr:=ParseOperation(FunctionNr-1+ORD(padd));
|
||||
If (OperationNr=psub) then {Minus(x) or x-y?}
|
||||
begin
|
||||
IsMinus:=False;
|
||||
if I=1 then
|
||||
IsMinus:=true
|
||||
else
|
||||
If Expr[I-1] IN ['+','(','*','/','-','^'] then
|
||||
IsMinus:=true;
|
||||
If IsMinus then
|
||||
OperationNr:=PMinus;
|
||||
end;
|
||||
While (OpTop > 0) AND
|
||||
(Priority[OperationNr] <= Priority[OpStack[OpTop]]) DO
|
||||
RPNOperation(OpPop);
|
||||
OpPush(OperationNr);
|
||||
end
|
||||
else
|
||||
case Expr[I] of
|
||||
'0'..'9' : begin
|
||||
While (Expr[I] in AllowedInToken) and (I<=len) do
|
||||
begin
|
||||
Token:=Token+Expr[I];
|
||||
inc(i);
|
||||
end;
|
||||
dec(i);
|
||||
end;
|
||||
',' : if Token <> '' then {Two parameter functions}
|
||||
begin { Send last built number to calc. }
|
||||
RPNCalc(Token);
|
||||
Token := '';
|
||||
end;
|
||||
'(' : OpPush(pleft);
|
||||
')' : begin
|
||||
While OpStack[OpTop] <> pleft DO
|
||||
RPNOperation(OpPop);
|
||||
OpPop; { Pop off and ignore the '(' }
|
||||
end;
|
||||
'A'..'Z' : begin
|
||||
if Token <> '' then
|
||||
begin { Send last built number to calc. }
|
||||
RPNCalc(Token);
|
||||
Token := '';
|
||||
end;
|
||||
While (Expr[I] IN ['0'..'9','A'..'Z']) AND (I<=Len) DO
|
||||
begin
|
||||
Token:=Token+Expr[I];
|
||||
Inc(I);
|
||||
end;
|
||||
Dec(i);
|
||||
OperationNr:=IsFunction(Token);
|
||||
if OperationNr<>pnothing then
|
||||
begin
|
||||
Token:='';
|
||||
While (OpTop > 0) AND
|
||||
(Priority[OperationNr] <= Priority[OpStack[OpTop]]) DO
|
||||
RPNOperation(OpPop);
|
||||
OpPush(OperationNr);
|
||||
end
|
||||
else
|
||||
begin
|
||||
RpnCalc(Token);
|
||||
Token:='';
|
||||
end;
|
||||
end;
|
||||
end; { Case }
|
||||
inc(i);
|
||||
end;
|
||||
If Token<>'' Then
|
||||
RpnCalc(Token);
|
||||
|
||||
While OpTop > 0 do { Pop off the remaining operations }
|
||||
RPNOperation(OpPop);
|
||||
InFixToParseTree:=RpnPop;
|
||||
end;
|
||||
|
||||
function TBaseExprParser.ParseTreeToInfix(expr:pnode):string;
|
||||
|
||||
var S,right,left : string;
|
||||
IsSimpleExpr : boolean;
|
||||
|
||||
begin
|
||||
IF expr=nil then
|
||||
ParserInternalError(SNILDeref,5,0);
|
||||
case expr^.nodetype of
|
||||
VarNode : S:=expr^.variable;
|
||||
iconstnode: str(expr^.ivalue,S);
|
||||
ConstNode: str(expr^.value,s);
|
||||
CalcNode : begin
|
||||
right:=ParseTreeToInfix(expr^.right);
|
||||
left:=ParseTreeToInfix(expr^.left);
|
||||
S:=left+InfixOperatorName[Expr^.op]+right;
|
||||
if (expr^.op=addo) or (expr^.op=subo) then
|
||||
S:='('+S+')';
|
||||
end;
|
||||
FuncNode : begin
|
||||
left:=functionnames[expr^.fun];
|
||||
right:=ParseTreeToInfix(expr^.son);
|
||||
issimpleExpr:=false;
|
||||
If ((Expr^.fun=minus) or (Expr^.fun=faculx)) and
|
||||
(expr^.son^.nodetype in [varnode,iconstnode,constnode]) then
|
||||
issimpleExpr:=true;
|
||||
if expr^.fun<>faculx then
|
||||
begin
|
||||
If IsSimpleExpr then
|
||||
S:=Left+Right
|
||||
else
|
||||
S:=Left+'('+Right+')';
|
||||
end
|
||||
else
|
||||
If IsSimpleExpr then
|
||||
S:=Right+Left
|
||||
else
|
||||
S:='('+Right+')'+Left;
|
||||
end;
|
||||
Func2Node : begin
|
||||
S:=functionnames[expr^.fun];
|
||||
Left:=ParseTreeToInfix(Expr^.son2right);
|
||||
right:=ParseTreeToInfix(expr^.son2left);
|
||||
S:=S+'('+Left+','+Right+')';
|
||||
end;
|
||||
end;
|
||||
ParseTreeToInfix:=S;
|
||||
end;
|
||||
|
||||
function TBaseExprParser.ParseTreeToRPN(expr:pnode):string;
|
||||
{not fast because of the prepending. Creating an array of pnode would maybe
|
||||
be faster}
|
||||
|
||||
procedure SearchTree(Tree:pnode;var s:string);
|
||||
|
||||
var temp:string;
|
||||
|
||||
begin
|
||||
if tree<>nil then
|
||||
case Tree^.nodetype of
|
||||
VarNode : s:=Tree^.Variable +' '+s;
|
||||
ConstNode: begin
|
||||
str(Tree^.value:5:9,temp); {should be configurable}
|
||||
s:=temp+' '+s;
|
||||
end;
|
||||
iconstnode: begin
|
||||
str(Tree^.ivalue,temp);
|
||||
s:=temp+' '+s;
|
||||
end;
|
||||
CalcNode : begin
|
||||
s:=InfixOperatorName[Tree^.op]+' '+s;
|
||||
SearchTree(tree^.right,s);
|
||||
SearchTree(tree^.left,s);
|
||||
end;
|
||||
FuncNode: begin
|
||||
s:=functionnames[tree^.fun]+' '+s;
|
||||
SearchTree(tree^.son,s);
|
||||
end;
|
||||
Func2Node: begin
|
||||
s:=functionnames[tree^.fun]+' '+s;
|
||||
SearchTree(tree^.son2right,s);
|
||||
SearchTree(Tree^.son2left,s);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
var s : String;
|
||||
|
||||
begin
|
||||
s:='';
|
||||
searchTree(expr,s);
|
||||
ParseTreeToRPN:=S;
|
||||
end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002/12/15 21:01:24 marco
|
||||
Initial revision
|
||||
|
||||
}
|
||||
|
||||
90
packages/symbolic/src/rearrang.inc
Normal file
90
packages/symbolic/src/rearrang.inc
Normal file
@ -0,0 +1,90 @@
|
||||
|
||||
|
||||
{$IFDEF DetectConstFlagCorruption}
|
||||
TYPE
|
||||
EConstCorruption=Class(Exception);
|
||||
{$ENDIF}
|
||||
|
||||
PROCEDURE TExpression.UpdateConstants;
|
||||
|
||||
function InternalUpdateConstants(expr:pnode):boolean;
|
||||
{Shouldn't be necessary. Detects both corruption of flags if
|
||||
DetectConstFlagCorruption is defined
|
||||
and rebuilds them.}
|
||||
|
||||
begin
|
||||
if Expr<>NIL THEN
|
||||
case Expr^.NodeType of
|
||||
VarNode : begin {A symbol is not a constant}
|
||||
{$IFDEF DetectConstFlagCorruption}
|
||||
if (ExprIsConstant IN Expr^.Flags) then
|
||||
Raise EConstCorruption.Create('Corrupt Varnode');
|
||||
{$ENDIF}
|
||||
Exclude(Expr^.flags,ExprIsConstant);
|
||||
Result:=false;
|
||||
end;
|
||||
IConstNode,
|
||||
ConstNode: begin
|
||||
{$IFDEF DetectConstFlagCorruption}
|
||||
if NOT (ExprIsConstant IN Expr^.Flags) then
|
||||
Raise EConstCorruption.Create('Corrupt (I)constnode');
|
||||
{$ENDIF}
|
||||
Include(Expr^.flags,ExprIsConstant);
|
||||
Result:=TRUE;
|
||||
end;
|
||||
calcnode: begin
|
||||
Result:=InternalUpdateConstants(Expr^.Left) AND InternalUpdateConstants(Expr^.Right);
|
||||
{$IFDEF DetectConstFlagCorruption}
|
||||
if (ExprIsConstant IN Expr^.Flags)<>Result then
|
||||
Raise EConstCorruption.Create('Corrupt calcnode');
|
||||
{$ENDIF}
|
||||
IF Result THEN
|
||||
Include(Expr^.flags,ExprIsConstant)
|
||||
else
|
||||
Exclude(Expr^.flags,ExprIsConstant)
|
||||
end;
|
||||
funcnode: begin
|
||||
Result:=InternalUpdateConstants(Expr^.Son);
|
||||
{$IFDEF DetectConstFlagCorruption}
|
||||
if (ExprIsConstant IN Expr^.Flags)<>Result then
|
||||
Raise EConstCorruption.Create('Corrupt funcnode');
|
||||
{$ENDIF}
|
||||
IF Result THEN
|
||||
Include(Expr^.flags,ExprIsConstant)
|
||||
else
|
||||
Exclude(Expr^.flags,ExprIsConstant)
|
||||
end;
|
||||
func2node: begin
|
||||
Result:=InternalUpdateConstants(Expr^.Son2Left) and InternalUpdateConstants(Expr^.Son2Right);
|
||||
{$IFDEF DetectConstFlagCorruption}
|
||||
if (ExprIsConstant IN Expr^.Flags)<>Result then
|
||||
Raise EConstCorruption.Create('Corrupt func2node');
|
||||
{$ENDIF}
|
||||
IF Result THEN
|
||||
Include(Expr^.flags,ExprIsConstant)
|
||||
else
|
||||
Exclude(Expr^.flags,ExprIsConstant)
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
InternalUpdateConstants(ExprTree);
|
||||
end;
|
||||
|
||||
{
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
}
|
||||
1122
packages/symbolic/src/symbexpr.inc
Normal file
1122
packages/symbolic/src/symbexpr.inc
Normal file
File diff suppressed because it is too large
Load Diff
493
packages/symbolic/src/symbolic.pas
Normal file
493
packages/symbolic/src/symbolic.pas
Normal file
@ -0,0 +1,493 @@
|
||||
unit Symbolic;
|
||||
{
|
||||
$ id: $
|
||||
Copyright (c) 2000 by Marco van de Voort(marco@freepascal.org)
|
||||
member of the Free Pascal development team
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright. (LGPL)
|
||||
|
||||
Base types for expression trees, and some small procs to create them.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
Seems not to have memory leaks atm. If you experience them, check procedure
|
||||
newcalc first.
|
||||
}
|
||||
|
||||
interface
|
||||
|
||||
{$ifdef FPC}
|
||||
{$Mode ObjFpc}
|
||||
{$ENDIF}
|
||||
|
||||
Uses Math,Classes,Sysutils;
|
||||
|
||||
Const
|
||||
VLIWIncr = 40; { Initial size and increment of VLIW array}
|
||||
DelphiMaxOps = 5000; { Unused for FPC. Max records in VLIW array
|
||||
FPC: 2 Gb/sizeof(vliwevalword).}
|
||||
|
||||
Type {Should be somewhere in the JCLMath or even in JCLtypes unit}
|
||||
{$ifdef FPC}
|
||||
ArbFloat = float; {Float is set to mathtype used by FPC Math unit}
|
||||
ArbInt = longint;
|
||||
{$else}
|
||||
ArbFloat = extended;
|
||||
ArbInt = Integer;
|
||||
{$endif}
|
||||
|
||||
calcop=(addo,subo,mulo,dvdo,powo); {real operators}
|
||||
|
||||
FuncOp=(cosx,sinx,tanx,sqrx,sqrtx,expx,lnx,invx,minus,cotanx,arcsinx,arccosx,
|
||||
arctanx,sinhx,coshx,tanhx,arcsinhx,arccoshx,arctanhx,log10x,
|
||||
log2x,lnxpix,faculx,arctan2x,stepx,powerx,hypotx,lognx,unknown0,
|
||||
unknown1,unknown2,unknown3,unknown4);
|
||||
{functions, both one and two parameter ones. Including pseudo function
|
||||
minus}
|
||||
|
||||
CONST UnknownTokens : array[0..4] OF FuncOp =(unknown0,unknown1,unknown2,
|
||||
unknown3,unknown4);
|
||||
TYPE
|
||||
Operation=(VarNode,ConstNode,iconstnode,CalcNode,FuncNode,func2node,VLIWVar,CustomNode);
|
||||
TFlagsEnum=(ExprIsConstant); {ExprIsConstant signals that this node of
|
||||
the tree and deeper can evaluate to a single
|
||||
float constant}
|
||||
|
||||
TFlags = SET OF TFlagsEnum;
|
||||
|
||||
pnode =^treenode;
|
||||
treenode=record
|
||||
Flags : TFlags;
|
||||
case nodetype:operation of
|
||||
iconstnode: (ivalue:ArbInt);
|
||||
VarNode: (variable:string[11]);
|
||||
VLIWVar: (vliwindex:ArbInt); {^float?}
|
||||
ConstNode: (value:ArbFloat);
|
||||
CalcNode: (op:calcop;left,right:pnode);
|
||||
FuncNode: (fun:funcop;son:pnode);
|
||||
Func2Node: (fun2:funcop;son2left,son2right:pnode);
|
||||
CustomNode: (Indent:Longint);
|
||||
end;
|
||||
|
||||
ERPNStack = Class(Exception); {All RPN stack problems category}
|
||||
EIError = Class(Exception); {All internal errors. Most often
|
||||
these are raised when unknown
|
||||
function enumerations are found}
|
||||
EDiv0 = Class(Exception); {Division by zero, but RPN, not processor!}
|
||||
|
||||
TBaseExpression = class
|
||||
protected
|
||||
ExprTree : pnode;
|
||||
function NewConst(value:ArbFloat):pnode;
|
||||
function NewiConst(value:ArbInt):pnode;
|
||||
function NewCalc(op:calcop;left,right:pnode):pnode;
|
||||
function CopyTree(p :pnode):pnode;
|
||||
function NewFunc(fun:funcop;son:pnode):pnode; overload;
|
||||
function NewFunc(fun:funcop;son,son2:pnode):pnode; overload;
|
||||
function NewVar(variable:string):pnode;
|
||||
procedure DisposeExpr(p:pnode);
|
||||
end;
|
||||
|
||||
EParserStack = class(ERPNStack); {RPN stack under/overflow.}
|
||||
EParserIE = class(EIError); {Internal error}
|
||||
|
||||
TBaseExprParser= class(TBaseExpression)
|
||||
public
|
||||
function InFixToParseTree(Expr : String;VAR RPNexpr: String):pnode; virtual;
|
||||
function ParseTreeToRPN (expr:pnode):string; virtual;
|
||||
function ParseTreeToInfix(expr:pnode):string; virtual;
|
||||
end;
|
||||
|
||||
TEvaluator= CLASS;
|
||||
|
||||
EFaculNotInt = Class(exception); {Faculty on a real value deviating from an integer value by more than 0.01}
|
||||
EExprIE = Class(EIerror);
|
||||
ENotInt = Class(exception);
|
||||
ENotFloat = Class(Exception);
|
||||
|
||||
TExpression = class(TBaseExprParser)
|
||||
protected
|
||||
InfixClean : Boolean;
|
||||
InfixCache : String;
|
||||
Evaluator : TEvaluator;
|
||||
EvaluatorUpToDate : Boolean;
|
||||
function GetInfix:String;
|
||||
function GetRPN:String;
|
||||
procedure Simpleop(expr:TExpression;oper:calcop);
|
||||
function Simpleopwithresult(expr:TExpression;oper:calcop):TExpression;
|
||||
Function IntDerive(const derivvariable:String;theexpr:pnode):pnode;
|
||||
Function GetIntValue:LongInt;
|
||||
Procedure SetIntValue(val:Longint);
|
||||
Function GetFloatValue:ArbFloat;
|
||||
Procedure SetFloatValue(val:ArbFloat);
|
||||
Procedure UpdateConstants; {Kind of integrity check}
|
||||
public
|
||||
SimplificationLevel : Longint;
|
||||
CONSTRUCTOR Create(Infix:String);
|
||||
CONSTRUCTOR EmptyCreate;
|
||||
DESTRUCTOR Destroy; override;
|
||||
|
||||
Procedure SetNewInfix(Infix:String);
|
||||
Function Derive(derivvariable:String):TExpression;
|
||||
procedure SymbolSubst(ToSubst,SubstWith:String);
|
||||
function SymbolicValueNames:TStringList;
|
||||
function Taylor(Degree:ArbInt;const x,x0:String):TExpression;
|
||||
function Newton(x:String):TExpression;
|
||||
|
||||
procedure SimplifyConstants;
|
||||
|
||||
function add(Expr:TExpression):TExpression;
|
||||
function dvd(Expr:TExpression):TExpression;
|
||||
function mul(Expr:TExpression):TExpression;
|
||||
function power(Expr:TExpression):TExpression;
|
||||
function sub(Expr:TExpression):TExpression;
|
||||
|
||||
procedure Addto(Expr:TExpression);
|
||||
procedure Divby(Expr:TExpression);
|
||||
procedure RaiseTo(Expr:TExpression);
|
||||
procedure SubFrom(Expr:TExpression);
|
||||
procedure Times(Expr:texpression);
|
||||
property InfixExpr: string read GetInfix write SetNewInfix;
|
||||
property RpnExpr: string read GetRPN;
|
||||
property ValueAsInteger:longint read GetIntValue write SetIntvalue; {Default?}
|
||||
property ValueAsFloat:arbfloat read GetFloatValue write SetFloatValue;
|
||||
end;
|
||||
|
||||
|
||||
VLIWWordtype= (avariable,anoperation, afunction,
|
||||
afconstant, aiconstant,placeholder);
|
||||
|
||||
{ RPN operators or functions with two arguments are the same.}
|
||||
vliwop2=(addv,subv,mulv,dvdv,powv,arctan2v,stepv,hypotv,lognv);
|
||||
|
||||
pArbFloat = ^ArbFloat;
|
||||
{$ifdef FPC}
|
||||
pVliwArr = ^VLIWEvalWord;
|
||||
{$else} {Delphi doesn't allow referencing of ^simpletype as array,
|
||||
but does allow it for ^ array of VLIWEvalWord}
|
||||
TVLIWArr = array[0..DelphiMaxOps] of VLiwEvalWord;
|
||||
pVliwArr = ^TVliwArr;
|
||||
{$ENDIF}
|
||||
|
||||
pVLIWEvalWord = ^VLIWEvalWord;
|
||||
VLIWEvalword = record
|
||||
case VLIWEntity : VLIWWordType OF
|
||||
AVariable : (IndexOfVar : ArbInt);
|
||||
AnOperation: (op:vliwop2); {2 arguments}
|
||||
AFunction : (fun1:funcop); {functions with one argument}
|
||||
AiConstant : (ivalue:ArbInt);
|
||||
AfConstant : (value:ArbFloat);
|
||||
placeholder: (IndexOfConstant:ArbInt) ;
|
||||
end;
|
||||
|
||||
TEvaluatorNotEnoughVariables=class(Exception); {Not enough variables passed to Evaluate}
|
||||
TEvaluatorStackException =class(ERPNStack); {RPN Stack over/under flow}
|
||||
TEvaluatorBadConstant =class(Exception); {Constant value not specified}
|
||||
TEvaluatorIE =class(Exception); {Internal error. Probably something out of sync.}
|
||||
|
||||
TEvaluator = Class {Only needs the notion of a pnode }
|
||||
Private
|
||||
VariableName : TStringList;
|
||||
ConstantValue : TList;
|
||||
ConstantNames : TStringList;
|
||||
MaxStack,
|
||||
VLIWCount,
|
||||
VLIWAlloc : ArbInt;
|
||||
VLIWRPNExpr : pVLIWArr;
|
||||
public
|
||||
function Evaldepth:longint;
|
||||
PROCEDURE SetConstant(Name:String;Value:ArbFloat);
|
||||
CONSTRUCTOR Create(VariableList:TStringList;Expression:pnode);
|
||||
CONSTRUCTOR Create(VariableList:TStringList;Expression:TExpression);
|
||||
DESTRUCTOR Destroy; override;
|
||||
Procedure TreeToVLIWRPN(expr:pnode);
|
||||
function Evaluate(const variables:Array of ArbFloat):ArbFloat;
|
||||
{$IFDEF DebugDump}
|
||||
procedure debugger;
|
||||
procedure WriteVliw(p:VLIWEvalWord);
|
||||
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
{
|
||||
Structures used to index a pnode tree to identify terms.
|
||||
|
||||
PTerms = ^TTerms;
|
||||
PtermNode=^TTermNode;
|
||||
TtermNode= record
|
||||
NrTerms :ArbInt;
|
||||
Terms : Array[0..499] of PNode;
|
||||
end;
|
||||
TTerms = record
|
||||
NrTerms : ArbInt;
|
||||
Terms: Array[0..499] of PtermNode;
|
||||
end;
|
||||
}
|
||||
const InfixOperatorName : array[addo..powo] of char= ('+','-','*','/','^');
|
||||
FunctionNames : array[cosx..lognx] of string[8]=(
|
||||
'cos','sin','tan','sqr','sqrt','exp','ln','inv','-',
|
||||
'cotan','arcsin','arccos','arctan','sinh',
|
||||
'cosh','tanh','arcsinh','arccosh','arctanh',
|
||||
'log10','log2','lnxp1','!','arctan2',
|
||||
'step','power','hypot','logn');
|
||||
FunctionNamesUpper: array[cosx..lognx] of string[8]=(
|
||||
'COS','SIN','TAN','SQR','SQRT','EXP','LN','INV','-',
|
||||
'COTAN','ARCSIN','ARCCOS','ARCTAN','SINH',
|
||||
'COSH','TANH','ARCSINH','ARCCOSH','ARCTANH',
|
||||
'LOG10','LOG2','LNXP1','!','ARCTAN2',
|
||||
'STEP','POWER','HYPOT','LOGN');
|
||||
LenFunctionNames : array[cosx..lognx] of longint=
|
||||
(3,3,3,3,3,3,2,3,1,5,6,6,6,4,4,4,7,7,7,5,4,5,1,7,4,5,5,4);
|
||||
|
||||
{$I exprstrs.inc}
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
{newconst and newiconst are overloaded in FPC}
|
||||
|
||||
function TBaseExpression.NewConst(value:ArbFloat):pnode;
|
||||
{Generate a new node for a floating point constant}
|
||||
|
||||
var t : pnode;
|
||||
|
||||
begin
|
||||
new(t);
|
||||
t^.nodetype:=constnode;
|
||||
t^.value:=value;
|
||||
t^.Flags:=[ExprIsConstant];
|
||||
NewConst:=T;
|
||||
end;
|
||||
|
||||
function TBaseExpression.NewiConst(value:ArbInt):pnode;
|
||||
{Generate a new node for integer constant}
|
||||
|
||||
var t : pnode;
|
||||
|
||||
begin
|
||||
new(t);
|
||||
t^.nodetype:=iconstnode;
|
||||
t^.ivalue:=value;
|
||||
t^.Flags:=[ExprIsConstant];
|
||||
NewiConst:=T;
|
||||
end;
|
||||
|
||||
procedure TBaseExpression.DisposeExpr(p:pnode);
|
||||
{Recursively kill expression tree}
|
||||
|
||||
begin
|
||||
IF p<>NIL THEN
|
||||
begin
|
||||
case p^.nodetype of
|
||||
CalcNode : begin
|
||||
DisposeExpr(p^.right);
|
||||
DisposeExpr(p^.left);
|
||||
end;
|
||||
FuncNode : DisposeExpr(p^.son);
|
||||
end;
|
||||
Dispose(p);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBaseExpression.NewCalc(op:calcop;left,right:pnode):pnode;
|
||||
{Create NewCalc node. Left and Right may be nil because
|
||||
to avoid introducing empty nodes, the deriv()
|
||||
function may return NIL's, which are to be treated as newiconst(0);
|
||||
|
||||
Also one of the functions most likely to have memory leaks
|
||||
}
|
||||
|
||||
function isintegerone(testme:pnode) : boolean;
|
||||
begin
|
||||
Isintegerone:=(testme^.nodetype=iconstnode) and (testme^.ivalue=1);
|
||||
end;
|
||||
|
||||
var t : pnode;
|
||||
|
||||
begin
|
||||
if op=powo then
|
||||
begin
|
||||
if right=NIL then {x^0 =1 for every X}
|
||||
begin
|
||||
DisposeExpr(left);
|
||||
newcalc:=newiconst(1);
|
||||
exit;
|
||||
end;
|
||||
if left=NIL THEN { 0^y = 0 except for y=0, but that is}
|
||||
begin { covered above}
|
||||
DisposeExpr(right);
|
||||
NewCalc:=NIL;
|
||||
exit;
|
||||
end;
|
||||
if IsIntegerone(left) then {x^1 =x}
|
||||
begin
|
||||
DisposeExpr(left);
|
||||
NewCalc:=right;
|
||||
exit;
|
||||
end;
|
||||
If IsIntegerone(right) then { 1^y=1}
|
||||
begin
|
||||
DisposeExpr(left);
|
||||
NewCalc:=right;
|
||||
exit;
|
||||
end;
|
||||
end; {generate a plain power node for all other cases}
|
||||
if left=NIL then
|
||||
begin
|
||||
if (right=nil) or (op=mulo) or (op=dvdo) then { 0*0, 0*t or 0/t =0}
|
||||
begin { We have no way to check T for nul}
|
||||
IF Right<>NIL then
|
||||
DisposeExpr(Right);
|
||||
NewCalc:=NIL;
|
||||
exit;
|
||||
end;
|
||||
if op=addo then { Don't generate a calc node for 0+x, but return x}
|
||||
begin
|
||||
NewCalc:=right;
|
||||
exit;
|
||||
end;
|
||||
new(t);
|
||||
t^.nodetype:=funcnode; { 0-x = minus(x) }
|
||||
t^.fun:=minus;
|
||||
t^.son:=right;
|
||||
t^.flags:=[];
|
||||
if ExprIsConstant in t^.son^.flags then
|
||||
include(t^.flags,ExprIsConstant);
|
||||
NewCalc:=T;
|
||||
exit;
|
||||
end;
|
||||
if right=NIL then
|
||||
begin
|
||||
if (left=nil) or (op=mulo) or (op=dvdo) then { 0*0, 0*t or 0/t =0}
|
||||
begin
|
||||
IF left<>NIL then
|
||||
disposeExpr(Left);
|
||||
NewCalc:=Nil;
|
||||
exit;
|
||||
end;
|
||||
NewCalc:=Left; { for x-0 or x+0, simply return 0}
|
||||
exit;
|
||||
end;
|
||||
|
||||
If ((op=mulo) or (op=dvdo)) and isintegerone(right) then { simplify t*1 and t/1}
|
||||
begin
|
||||
DisposeExpr(right);
|
||||
NewCalc:=Left;
|
||||
exit;
|
||||
end;
|
||||
if (op=mulo) and isintegerone(left) then { simplify 1*t}
|
||||
begin
|
||||
DisposeExpr(left);
|
||||
NewCalc:=right;
|
||||
exit;
|
||||
end;
|
||||
new(t);
|
||||
t^.nodetype:=calcnode;
|
||||
t^.op:=op;
|
||||
t^.left:=left;
|
||||
t^.right:=right;
|
||||
t^.Flags:=[];
|
||||
if (ExprIsConstant In T^.Left^.Flags) and (ExprIsConstant In T^.Right^.Flags) then
|
||||
include(t^.flags,ExprIsConstant);
|
||||
newcalc:=t;
|
||||
end;
|
||||
|
||||
function TBaseExpression.CopyTree(p :pnode):pnode;
|
||||
|
||||
var newtree : pnode;
|
||||
|
||||
begin
|
||||
new(newtree);
|
||||
move(p^,Newtree^,sizeof(treenode));
|
||||
if newtree^.nodetype=CalcNode then
|
||||
begin
|
||||
newtree^.left:=CopyTree(p^.left);
|
||||
newtree^.right:=CopyTree(p^.right);
|
||||
end
|
||||
else
|
||||
if newtree^.nodetype=FuncNode then
|
||||
newtree^.son:=CopyTree(p^.son);
|
||||
CopyTree:=NewTree;
|
||||
end;
|
||||
|
||||
function TBaseExpression.NewFunc(fun:funcop;son:pnode):pnode;
|
||||
|
||||
var t : pnode;
|
||||
|
||||
begin
|
||||
IF son<>nil then
|
||||
begin
|
||||
new(t);
|
||||
t^.nodetype:=funcnode;
|
||||
t^.fun:=fun;
|
||||
t^.son:=son;
|
||||
t^.flags:=[];
|
||||
if ExprIsConstant IN son^.flags then
|
||||
Include(t^.flags,ExprIsConstant);
|
||||
NewFunc:=T;
|
||||
end
|
||||
else
|
||||
NewFunc:=NIL;
|
||||
end;
|
||||
|
||||
function TBaseExpression.NewFunc(fun:funcop;son,son2:pnode):pnode;
|
||||
|
||||
var t : pnode;
|
||||
|
||||
begin
|
||||
new(t);
|
||||
t^.nodetype:=func2node;
|
||||
t^.fun:=fun;
|
||||
t^.son2Left:=son;
|
||||
t^.son2Right:=son2;
|
||||
t^.flags:=[];
|
||||
if(ExprIsConstant IN son^.flags) and (ExprIsConstant IN son2^.flags) then
|
||||
Include(t^.flags,ExprIsConstant);
|
||||
NewFunc:=T;
|
||||
end;
|
||||
|
||||
{function TBaseExpression.NewFunc(fun:funcop;unknownIdent:longint):pnode;
|
||||
|
||||
var t : pnode;
|
||||
|
||||
begin
|
||||
new(t);
|
||||
t^.nodetype:=func2node;
|
||||
t^.fun:=fun;
|
||||
t^.son2Left:=son;
|
||||
t^.son2Right:=son2;
|
||||
t^.flags:=[];
|
||||
if(ExprIsConstant IN son^.flags) and (ExprIsConstant IN son2^.flags) then
|
||||
Include(t^.flags,ExprIsConstant);
|
||||
NewFunc:=T;
|
||||
end;}
|
||||
|
||||
|
||||
|
||||
function TBaseExpression.NewVar(variable:string):pnode;
|
||||
|
||||
var p :pnode;
|
||||
|
||||
begin
|
||||
new(p);
|
||||
p^.nodetype:=varnode;
|
||||
p^.variable:=variable;
|
||||
p^.Flags:=[];
|
||||
newvar:=p;
|
||||
end;
|
||||
|
||||
{$I parsexpr.inc} {Parser categories}
|
||||
{$I symbexpr.inc} {standard symbolic manip}
|
||||
{$I teval.inc}
|
||||
{$I rearrang.inc}
|
||||
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002/12/15 21:01:26 marco
|
||||
Initial revision
|
||||
|
||||
}
|
||||
722
packages/symbolic/src/teval.inc
Normal file
722
packages/symbolic/src/teval.inc
Normal file
@ -0,0 +1,722 @@
|
||||
{
|
||||
$ id: $
|
||||
Copyright (c) 2000 by Marco van de Voort (marco@freepascal.org)
|
||||
member of the Free Pascal development team
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright. (LGPL)
|
||||
|
||||
Evaluator class implementation. Evaluates a parsetree expression in
|
||||
a way optimized for fast repeated evaluations of the same expression
|
||||
with different variables and constants.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************
|
||||
}
|
||||
|
||||
{$IFDEF DebugDump}
|
||||
procedure TEvaluator.WriteVliw(p:VLIWEvalWord); forward;
|
||||
{$ENDIF}
|
||||
|
||||
Procedure TEvalInternalError(A,B:ArbInt);
|
||||
|
||||
VAR S,S2 : String;
|
||||
|
||||
begin
|
||||
Str(ORD(A),S);
|
||||
Str(ORD(B),S2);
|
||||
Raise TEvaluatorIE.Create(SEvalIE+S+' '+S2);
|
||||
end;
|
||||
|
||||
|
||||
CONSTRUCTOR TEvaluator.Create(VariableList:TStringList;Expression:pnode);
|
||||
{Constructor. Stringlist to set the order of variables in the function while
|
||||
xconverting the pnode tree to a TEvaluator structure. This avoids any string
|
||||
parsing during a real evaluation, and moves all stringparsing to the setup.
|
||||
|
||||
So for Func(x,y,z) Variablelist contains ('x','y','z') in that order.
|
||||
}
|
||||
|
||||
begin
|
||||
VariableName:=VariableList;
|
||||
ConstantNames:=TStringList.Create;
|
||||
ConstantValue:=TList.Create;
|
||||
Getmem(VLIWRPnExpr,SIZEOF(VLIWEvalWord)*VLIWIncr);
|
||||
VLIWCount:=0;
|
||||
VLIWAlloc:=VLIWIncr;
|
||||
MaxStack :=0;
|
||||
TreeToVLIWRPN(Expression);
|
||||
end;
|
||||
|
||||
CONSTRUCTOR TEvaluator.Create(VariableList:TStringList;Expression:TExpression);
|
||||
{Overloaded, same as other constructor. (which it even calls), except that
|
||||
it has a TExpression as argument.
|
||||
|
||||
Besides that it gets the pnode from the TExpression, it sets the
|
||||
TExpression.Evaluator to self, and a flag to set in the TExpression that its
|
||||
assiociated TEvaluator is up to date with the TExpression.
|
||||
}
|
||||
|
||||
begin
|
||||
Self.Create(VariableList,Expression.ExprTree);
|
||||
Expression.Evaluator:=Self;
|
||||
Expression.EvaluatorUpToDate:=TRUE;
|
||||
end;
|
||||
|
||||
DESTRUCTOR TEvaluator.Destroy;
|
||||
|
||||
VAR I : LONGINT;
|
||||
TmpList : Tlist;
|
||||
|
||||
begin
|
||||
VariableName.Free;
|
||||
ConstantNames.Free;
|
||||
IF ConstantValue.Count>0 THEN
|
||||
FOR I:=0 to ConstantValue.Count -1 DO
|
||||
begin
|
||||
TmpList:=TList(ConstantValue[I]);
|
||||
TmpList.Free;
|
||||
end;
|
||||
ConstantValue.Free;
|
||||
If VLIWAlloc>0 THEN
|
||||
FreeMem(VLIWRPNExpr,VLIWAlloc*SIZEOF(VLIWEvalWord));
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
PROCEDURE TEvaluator.SetConstant(Name:String;Value:ArbFloat);
|
||||
|
||||
Var Ind,I : Longint;
|
||||
TmpList : TList;
|
||||
|
||||
begin
|
||||
Ind:=ConstantNames.IndexOf(Name);
|
||||
If Ind<>-1 THEN
|
||||
begin
|
||||
TmpList:=TList(ConstantValue[Ind]);
|
||||
I:=TmpList.Count;
|
||||
If I>0 Then
|
||||
For I:=0 TO TmpList.Count-1 DO
|
||||
begin
|
||||
PVLIWEvalWord(TmpList[I])^.VLIWEntity:=AfConstant;
|
||||
PVLIWEvalWord(TmpList[I])^.Value:=Value;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TEvaluator.TreeToVLIWRPN(expr:pnode);
|
||||
|
||||
procedure CheckVLIWArr;
|
||||
|
||||
begin
|
||||
if VLIWCount=VLIWAlloc then
|
||||
begin
|
||||
ReAllocMem(VLIWRPNExpr,(VLIWAlloc+VLIWIncr)*SIZEOF(VLIWEvalWord));
|
||||
Inc(VLIWAlloc,VLIWIncr);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure searchTree(Tree:pnode);
|
||||
|
||||
var Ind : ArbInt;
|
||||
TmpList : TList;
|
||||
|
||||
begin
|
||||
if tree<>nil then
|
||||
case Tree^.nodetype of
|
||||
VarNode : begin
|
||||
{some variable or constant. First: Variable?}
|
||||
Ind:=VariableName.IndexOf(Tree^.Variable);
|
||||
If Ind<>-1 then
|
||||
begin {We have identified a variable}
|
||||
CheckVLIWArr; {Make sure there is at least room for one variable}
|
||||
WITH VLIWRPNExpr[VLIWCount] do
|
||||
begin
|
||||
VLIWEntity:=AVariable;
|
||||
IndexOfVar:=Ind;
|
||||
end;
|
||||
{$IFDEF DebugDump}
|
||||
WriteVliw(VLIWRPNExpr[VLIWCOUNT]);
|
||||
{$ENDIF}
|
||||
inc(VLIWCount);
|
||||
end
|
||||
else
|
||||
begin {We have a constant}
|
||||
ind:=ConstantNames.IndexOf(Tree^.Variable);
|
||||
if Ind=-1 then
|
||||
begin {That doesn't exist. Make sure it exists}
|
||||
ConstantNames.Add(Tree^.Variable);
|
||||
TmpList:=TList.Create;
|
||||
ConstantValue.Add(TmpList);
|
||||
end
|
||||
else
|
||||
begin
|
||||
TmpList:=tlist(ConstantValue[Ind]);
|
||||
end;
|
||||
|
||||
{Create the VLIW record}
|
||||
CheckVLIWArr;
|
||||
|
||||
WITH VLIWRPNExpr[VLIWCount] do
|
||||
begin
|
||||
VLIWEntity:=Placeholder;
|
||||
IndexOfConstant:=255;
|
||||
end;
|
||||
{$IFDEF DebugDump}
|
||||
WriteVliw(VLIWRPNExpr[VLIWCOUNT]);
|
||||
{$ENDIF}
|
||||
|
||||
{Store a pointer to the VLIW record to be able to change the
|
||||
constant}
|
||||
TmpList.Add(pointer(VLIWCount)); {Can't pick pointer here, due to realloc}
|
||||
inc(VLIWCount);
|
||||
end; {Ind<>-1}
|
||||
end;
|
||||
ConstNode: begin
|
||||
|
||||
CheckVLIWArr;
|
||||
WITH VLIWRPNExpr[VLIWCount] do
|
||||
begin
|
||||
VLIWEntity:=AfConstant;
|
||||
Value:=tree^.value;
|
||||
end;
|
||||
{$IFDEF DebugDump}
|
||||
WriteVliw(VLIWRPNExpr[VLIWCOUNT]);
|
||||
{$ENDIF}
|
||||
|
||||
inc(VLIWCount);
|
||||
end;
|
||||
iconstnode: begin
|
||||
CheckVLIWArr;
|
||||
WITH VLIWRPNExpr[VLIWCount] do
|
||||
begin
|
||||
VLIWEntity:=AiConstant;
|
||||
IValue:=tree^.ivalue;
|
||||
end;
|
||||
{$IFDEF DebugDump}
|
||||
WriteVliw(VLIWRPNExpr[VLIWCOUNT]);
|
||||
{$ENDIF}
|
||||
|
||||
inc(VLIWCount);
|
||||
end;
|
||||
CalcNode : begin
|
||||
|
||||
CheckVLIWArr;
|
||||
WITH VLIWRPNExpr[VLIWCount] do
|
||||
begin
|
||||
VLIWEntity:=AnOperation;
|
||||
op:=vliwop2(ord(Tree^.op));
|
||||
end;
|
||||
{$IFDEF DebugDump}
|
||||
WriteVliw(VLIWRPNExpr[VLIWCOUNT]);
|
||||
{$ENDIF}
|
||||
|
||||
inc(VLIWCount);
|
||||
SearchTree(tree^.left);
|
||||
SearchTree(tree^.right);
|
||||
end;
|
||||
FuncNode: begin
|
||||
|
||||
CheckVLIWArr;
|
||||
WITH VLIWRPNExpr[VLIWCount] do
|
||||
begin
|
||||
VLIWEntity:=AFunction;
|
||||
fun1:=Tree^.fun;
|
||||
end;
|
||||
{$IFDEF DebugDump}
|
||||
WriteVliw(VLIWRPNExpr[VLIWCOUNT]);
|
||||
{$ENDIF}
|
||||
|
||||
inc(VLIWCount);
|
||||
SearchTree(tree^.son);
|
||||
|
||||
end;
|
||||
Func2Node: begin
|
||||
|
||||
CheckVLIWArr;
|
||||
WITH VLIWRPNExpr[VLIWCount] do
|
||||
begin
|
||||
VLIWEntity:=AnOperation;
|
||||
if tree^.fun2=powerx then
|
||||
op:=VLIWOp2(powo)
|
||||
else
|
||||
if tree^.fun2 >powerx then
|
||||
op:=vliwop2(ord(powv)+ord(tree^.fun2)-ord(arctan2x))
|
||||
else
|
||||
op:=vliwop2(1+ord(powv)+ord(tree^.fun2)-ord(arctan2x))
|
||||
end;
|
||||
{$IFDEF DebugDump}
|
||||
WriteVliw(VLIWRPNExpr[VLIWCOUNT]);
|
||||
{$ENDIF}
|
||||
|
||||
inc(VLIWCount);
|
||||
SearchTree(tree^.son2left);
|
||||
SearchTree(tree^.son2right);
|
||||
end
|
||||
else
|
||||
TEvalInternalError(4,ORD(Tree^.nodetype ));
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure FixLists;
|
||||
{We added constants as VLIWCount indexes. To speed up we convert them to
|
||||
pointers. We couldn't do that directly as a consequence of the ReAlloc.}
|
||||
|
||||
VAR I,J : Longint;
|
||||
TmpList : TList;
|
||||
|
||||
begin
|
||||
I:=ConstantValue.Count;
|
||||
IF I>0 THEN
|
||||
FOR J:=0 TO I-1 DO
|
||||
begin
|
||||
TmpList:=TList(ConstantValue[J]);
|
||||
IF (Tmplist<>NIL) and (TmpList.Count>0) then
|
||||
for I:=0 TO TmpList.Count-1 DO
|
||||
TmpList[I]:=@VLIWRPNExpr[longint(TmpList[I])];
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
VLIWCount:=0;
|
||||
SearchTree(expr);
|
||||
FixLists;
|
||||
end;
|
||||
|
||||
function TEvaluator.Evaluate(const variables:Array of ArbFloat):ArbFloat;
|
||||
{The one that does the work}
|
||||
|
||||
CONST StackDepth=50;
|
||||
|
||||
var TheArray : pVLIWEvalWord;
|
||||
VLIWRecs : Longint;
|
||||
RPNStack : ARRAY[0..StackDepth] OF ArbFloat;
|
||||
I,
|
||||
RPNPointer : Longint;
|
||||
// S : ansiString;
|
||||
|
||||
procedure push(Val:ArbFloat); {$IFDEF FPC} InLine; {$endif}
|
||||
|
||||
begin
|
||||
IF RPNPointer=StackDepth THEN
|
||||
RAISE TEvaluatorStackException.Create(SEvalStackDepthExceeded);
|
||||
RPNStack[RpnPointer]:=Val;
|
||||
INC(RPNPointer);
|
||||
end;
|
||||
|
||||
begin
|
||||
VLIWRecs:=VariableName.Count;
|
||||
if (High(Variables)+1)<>VLIWRecs then
|
||||
Raise TEvaluatorNotEnoughVariables.Create(SeValBadNumberOfVars);
|
||||
RPNPointer:=0;
|
||||
VliwRecs:=VliwCount-1;
|
||||
TheArray:=@VLIWRPNExpr[VLIWRecs];
|
||||
REPEAT
|
||||
{$IFDEF DebugMe}
|
||||
Writeln(VliwRecs,' ',ord(TheArray^.VLIWEntity));
|
||||
{$ENDIF}
|
||||
TheArray:=@VLIWRPNExpr[VLIWRecs];
|
||||
CASE TheArray^.VLIWEntity OF
|
||||
AVariable : begin
|
||||
{$IFDEF DebugMe}
|
||||
Writeln('var:', TheArray^.IndexOfVar);
|
||||
{$ENDIF}
|
||||
Push(Variables[TheArray^.IndexOfVar]);
|
||||
end;
|
||||
|
||||
AfConstant : begin
|
||||
{$IFDEF DebugMe}
|
||||
Writeln('FP value:', TheArray^.value);
|
||||
{$ENDIF}
|
||||
Push(TheArray^.Value);
|
||||
end;
|
||||
AiConstant : begin
|
||||
{$IFDEF DebugMe}
|
||||
Writeln('Int value:', TheArray^.ivalue);
|
||||
{$ENDIF}
|
||||
Push(TheArray^.iValue);
|
||||
end;
|
||||
Placeholder: begin
|
||||
// RAISE TEvaluatorBadConstant.Create(ConstantNames[TheArray^.IndexOfConstant]);
|
||||
end;
|
||||
AnOperation: begin
|
||||
{$IFDEF DebugMe}
|
||||
Writeln('Operator value:', ord(TheArray^.op));
|
||||
{$ENDIF}
|
||||
Case TheArray^.Op of
|
||||
addv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=RPNStack[RPNPointer]+RPNStack[RPNPointer-1];
|
||||
end;
|
||||
subv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=RPNStack[RPNPointer]-RPNStack[RPNPointer-1];
|
||||
end;
|
||||
mulv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=RPNStack[RPNPointer]*RPNStack[RPNPointer-1];
|
||||
end;
|
||||
dvdv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=RPNStack[RPNPointer]/RPNStack[RPNPointer-1];
|
||||
end;
|
||||
powv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=Power(RPNStack[RPNPointer],RPNStack[RPNPointer-1]);
|
||||
end;
|
||||
arctan2v : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=ArcTan2(RPNStack[RPNPointer],RPNStack[RPNPointer-1]);
|
||||
end;
|
||||
stepv : begin
|
||||
Dec(RPNPointer);
|
||||
If RPNStack[RPNPointer-1]>RPNStack[RPNPOINTER] THEN
|
||||
RPNStack[RPNPointer-1]:=1.0
|
||||
else
|
||||
RPNStack[RPNPointer-1]:=0.0;
|
||||
end;
|
||||
hypotv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=hypot(RPNStack[RPNPointer],RPNStack[RPNPointer-1]);
|
||||
end;
|
||||
lognv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=logn(RPNStack[RPNPointer],RPNStack[RPNPointer-1]);
|
||||
end;
|
||||
else
|
||||
TEvalInternalError(1,ORD(TheArray^.op));
|
||||
end;
|
||||
end;
|
||||
AFunction : begin
|
||||
{$IFDEF DebugMe}
|
||||
Writeln('function value:', ord(TheArray^.fun1));
|
||||
{$ENDIF}
|
||||
|
||||
Case TheArray^.Fun1 of
|
||||
cosx: RPNStack[RPNPointer-1]:=cos(RPNStack[RPNPointer-1]);
|
||||
sinx: RPNStack[RPNPointer-1]:=sin(RPNStack[RPNPointer-1]);
|
||||
tanx: RPNStack[RPNPointer-1]:=tan(RPNStack[RPNPointer-1]);
|
||||
sqrx: RPNStack[RPNPointer-1]:=sqr(RPNStack[RPNPointer-1]);
|
||||
sqrtx: RPNStack[RPNPointer-1]:=sqrt(RPNStack[RPNPointer-1]);
|
||||
expx: RPNStack[RPNPointer-1]:=exp(RPNStack[RPNPointer-1]);
|
||||
lnx: RPNStack[RPNPointer-1]:=ln(RPNStack[RPNPointer-1]);
|
||||
invx: RPNStack[RPNPointer-1]:=1/RPNStack[RPNPointer-1];
|
||||
minus: RPNStack[RPNPointer-1]:=-RPNStack[RPNPointer-1];
|
||||
cotanx: RPNStack[RPNPointer-1]:=cotan(RPNStack[RPNPointer-1]);
|
||||
arcsinx: RPNStack[RPNPointer-1]:=arcsin(RPNStack[RPNPointer-1]);
|
||||
arccosx: RPNStack[RPNPointer-1]:=arccos(RPNStack[RPNPointer-1]);
|
||||
arctanx: RPNStack[RPNPointer-1]:=arctan(RPNStack[RPNPointer-1]);
|
||||
sinhx: RPNStack[RPNPointer-1]:=sinh(RPNStack[RPNPointer-1]);
|
||||
coshx: RPNStack[RPNPointer-1]:=cosh(RPNStack[RPNPointer-1]);
|
||||
tanhx: RPNStack[RPNPointer-1]:=tanh(RPNStack[RPNPointer-1]);
|
||||
arcsinhx: RPNStack[RPNPointer-1]:=ArcSinh(RPNStack[RPNPointer-1]);
|
||||
arccoshx: RPNStack[RPNPointer-1]:=ArcCosh(RPNStack[RPNPointer-1]);
|
||||
arctanhx: RPNStack[RPNPointer-1]:=ArcTanh(RPNStack[RPNPointer-1]);
|
||||
log10x: RPNStack[RPNPointer-1]:=Log10(RPNStack[RPNPointer-1]);
|
||||
log2x: RPNStack[RPNPointer-1]:=Log2(RPNStack[RPNPointer-1]);
|
||||
lnxpix: RPNStack[RPNPointer-1]:=lnxp1(RPNStack[RPNPointer-1]);
|
||||
else
|
||||
TEvalInternalError(2,ORD(TheArray^.fun1));
|
||||
end;
|
||||
end;
|
||||
else
|
||||
TEvalInternalError(3,ORD(TheArray^.VLIWEntity));
|
||||
end;
|
||||
{$Ifdef DebugDump}
|
||||
Writeln('RecordNo: ',VliwRecs);
|
||||
IF RPNPointer>0 then
|
||||
begin
|
||||
Writeln('RPN stack');
|
||||
for I:=0 TO RpnPointer-1 DO
|
||||
Writeln(I:2,' ',RpnStack[I]);
|
||||
end;
|
||||
{$Endif}
|
||||
dec(TheArray);
|
||||
dec(VliwRecs);
|
||||
UNTIL VliwRecs<0;
|
||||
Result:=RPNStack[0];
|
||||
end;
|
||||
|
||||
{
|
||||
function TEvaluator.i387Evaluate(const variables:Array of ArbFloat):ArbFloat;
|
||||
{This should become the really *cool* one in time.
|
||||
Still experimental though.
|
||||
|
||||
Current status:
|
||||
- Can be entirely FP, but isn't allowed to use more that 4 stack-pos then.
|
||||
- Math's ARCCOS ARCCOSH ARCSIN ARCSINH ARCTAN2 ARCTANH COSH COTAN HYPOT LNXP1 LOG10
|
||||
LOG2 LOGN POWER SINH TAN TANH
|
||||
and System.Exp are forbidden because they use stackroom internally.
|
||||
This is a problem, because specially Exp() is much too common.
|
||||
}
|
||||
|
||||
CONST StackDepth=50;
|
||||
|
||||
var TheArray : pVLIWEvalWord;
|
||||
VLIWRecs : Longint;
|
||||
RPNStack : ARRAY[0..StackDepth] OF ArbFloat;
|
||||
I,
|
||||
RPNPointer : Longint;
|
||||
|
||||
procedure push(Val:ArbFloat); {$IFDEF FPC} InLine; {$endif}
|
||||
|
||||
begin
|
||||
IF RPNPointer=StackDepth THEN
|
||||
RAISE TEvaluatorStackException.Create(SEvalStackDepthExceeded);
|
||||
RPNStack[RpnPointer]:=Val;
|
||||
INC(RPNPointer);
|
||||
end;
|
||||
|
||||
begin
|
||||
VLIWRecs:=VariableName.Count;
|
||||
if (High(Variables)+1)<>VLIWRecs then
|
||||
Raise TEvaluatorNotEnoughVariables.Create(SeValBadNumberOfVars);
|
||||
RPNPointer:=0;
|
||||
VliwRecs:=VliwCount-1;
|
||||
TheArray:=@VLIWRPNExpr[VLIWRecs];
|
||||
REPEAT
|
||||
{$IFDEF DebugMe}
|
||||
Writeln(VliwRecs,' ',ord(TheArray^.VLIWEntity));
|
||||
{$ENDIF}
|
||||
TheArray:=@VLIWRPNExpr[VLIWRecs];
|
||||
CASE TheArray^.VLIWEntity OF
|
||||
AVariable : begin
|
||||
{$IFDEF DebugMe}
|
||||
Writeln('var:', TheArray^.IndexOfVar);
|
||||
{$ENDIF}
|
||||
Push(Variables[TheArray^.IndexOfVar]);
|
||||
end;
|
||||
|
||||
AfConstant : begin
|
||||
{$IFDEF DebugMe}
|
||||
Writeln('FP value:', TheArray^.value);
|
||||
{$ENDIF}
|
||||
Push(TheArray^.Value);
|
||||
end;
|
||||
AiConstant : begin
|
||||
{$IFDEF DebugMe}
|
||||
Writeln('Int value:', TheArray^.ivalue);
|
||||
{$ENDIF}
|
||||
Push(TheArray^.iValue);
|
||||
end;
|
||||
Placeholder: begin
|
||||
// RAISE TEvaluatorBadConstant.Create(ConstantNames[TheArray^.IndexOfConstant]);
|
||||
end;
|
||||
AnOperation: begin
|
||||
{$IFDEF DebugMe}
|
||||
Writeln('Operator value:', ord(TheArray^.op));
|
||||
{$ENDIF}
|
||||
Case TheArray^.Op of
|
||||
addv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=RPNStack[RPNPointer]+RPNStack[RPNPointer-1];
|
||||
end;
|
||||
subv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=RPNStack[RPNPointer]-RPNStack[RPNPointer-1];
|
||||
end;
|
||||
mulv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=RPNStack[RPNPointer]*RPNStack[RPNPointer-1];
|
||||
end;
|
||||
dvdv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=RPNStack[RPNPointer]/RPNStack[RPNPointer-1];
|
||||
end;
|
||||
powv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=Power(RPNStack[RPNPointer],RPNStack[RPNPointer-1]);
|
||||
end;
|
||||
arctan2v : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=ArcTan2(RPNStack[RPNPointer],RPNStack[RPNPointer-1]);
|
||||
end;
|
||||
stepv : begin
|
||||
Dec(RPNPointer);
|
||||
If RPNStack[RPNPointer-1]>RPNStack[RPNPOINTER] THEN
|
||||
RPNStack[RPNPointer-1]:=1.0
|
||||
else
|
||||
RPNStack[RPNPointer-1]:=0.0;
|
||||
end;
|
||||
hypotv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=hypot(RPNStack[RPNPointer],RPNStack[RPNPointer-1]);
|
||||
end;
|
||||
lognv : begin
|
||||
Dec(RPNPointer);
|
||||
RPNStack[RPNPointer-1]:=logn(RPNStack[RPNPointer],RPNStack[RPNPointer-1]);
|
||||
end;
|
||||
else
|
||||
TEvalInternalError(1,ORD(TheArray^.op));
|
||||
end;
|
||||
end;
|
||||
AFunction : begin
|
||||
{$IFDEF DebugMe}
|
||||
Writeln('function value:', ord(TheArray^.fun1));
|
||||
{$ENDIF}
|
||||
|
||||
Case TheArray^.Fun1 of
|
||||
cosx: RPNStack[RPNPointer-1]:=cos(RPNStack[RPNPointer-1]);
|
||||
sinx: RPNStack[RPNPointer-1]:=sin(RPNStack[RPNPointer-1]);
|
||||
tanx: RPNStack[RPNPointer-1]:=tan(RPNStack[RPNPointer-1]);
|
||||
sqrx: RPNStack[RPNPointer-1]:=sqr(RPNStack[RPNPointer-1]);
|
||||
sqrtx: RPNStack[RPNPointer-1]:=sqrt(RPNStack[RPNPointer-1]);
|
||||
expx: RPNStack[RPNPointer-1]:=exp(RPNStack[RPNPointer-1]);
|
||||
lnx: RPNStack[RPNPointer-1]:=ln(RPNStack[RPNPointer-1]);
|
||||
invx: RPNStack[RPNPointer-1]:=1/RPNStack[RPNPointer-1];
|
||||
minus: RPNStack[RPNPointer-1]:=-RPNStack[RPNPointer-1];
|
||||
cotanx: RPNStack[RPNPointer-1]:=cotan(RPNStack[RPNPointer-1]);
|
||||
arcsinx: RPNStack[RPNPointer-1]:=arcsin(RPNStack[RPNPointer-1]);
|
||||
arccosx: RPNStack[RPNPointer-1]:=arccos(RPNStack[RPNPointer-1]);
|
||||
arctanx: RPNStack[RPNPointer-1]:=arctan(RPNStack[RPNPointer-1]);
|
||||
sinhx: RPNStack[RPNPointer-1]:=sinh(RPNStack[RPNPointer-1]);
|
||||
coshx: RPNStack[RPNPointer-1]:=cosh(RPNStack[RPNPointer-1]);
|
||||
tanhx: RPNStack[RPNPointer-1]:=tanh(RPNStack[RPNPointer-1]);
|
||||
arcsinhx: RPNStack[RPNPointer-1]:=ArcSinh(RPNStack[RPNPointer-1]);
|
||||
arccoshx: RPNStack[RPNPointer-1]:=ArcCosh(RPNStack[RPNPointer-1]);
|
||||
arctanhx: RPNStack[RPNPointer-1]:=ArcTanh(RPNStack[RPNPointer-1]);
|
||||
log10x: RPNStack[RPNPointer-1]:=Log10(RPNStack[RPNPointer-1]);
|
||||
log2x: RPNStack[RPNPointer-1]:=Log2(RPNStack[RPNPointer-1]);
|
||||
lnxpix: RPNStack[RPNPointer-1]:=lnxp1(RPNStack[RPNPointer-1]);
|
||||
else
|
||||
TEvalInternalError(2,ORD(TheArray^.fun1));
|
||||
end;
|
||||
end;
|
||||
else
|
||||
TEvalInternalError(3,ORD(TheArray^.VLIWEntity));
|
||||
end;
|
||||
{$Ifdef DebugDump}
|
||||
Writeln('RecordNo: ',VliwRecs);
|
||||
IF RPNPointer>0 then
|
||||
begin
|
||||
Writeln('RPN stack');
|
||||
for I:=0 TO RpnPointer-1 DO
|
||||
Writeln(I:2,' ',RpnStack[I]);
|
||||
end;
|
||||
{$Endif}
|
||||
dec(TheArray);
|
||||
dec(VliwRecs);
|
||||
UNTIL VliwRecs<0;
|
||||
Result:=RPNStack[0];
|
||||
end;
|
||||
}
|
||||
|
||||
function TEvaluator.Evaldepth:longint;
|
||||
{estimate stackdepth}
|
||||
|
||||
var TheArray : pVLIWEvalWord;
|
||||
VLIWRecs : Longint;
|
||||
Deepest : Longint;
|
||||
RPNPointer : Longint;
|
||||
|
||||
begin
|
||||
RPNPointer:=0;
|
||||
Deepest:=0;
|
||||
VliwRecs:=VliwCount-1;
|
||||
TheArray:=@VLIWRPNExpr[VLIWRecs];
|
||||
REPEAT
|
||||
TheArray:=@VLIWRPNExpr[VLIWRecs];
|
||||
CASE TheArray^.VLIWEntity OF
|
||||
AVariable,
|
||||
afconstant,
|
||||
aiconstant, {a placeholder always changes into a push}
|
||||
placeholder : Inc(rpnpointer);
|
||||
AnOperation : Dec(rpnpointer); {take two args, put one back}
|
||||
{ AFunction : Doesn't do anything}
|
||||
end;
|
||||
If Deepest<RPNPointer then
|
||||
Deepest:=RPNPointer;
|
||||
dec(TheArray);
|
||||
dec(VliwRecs);
|
||||
UNTIL VliwRecs<0;
|
||||
Result:=deepest;
|
||||
end;
|
||||
|
||||
{$IFDEF DebugDump}
|
||||
|
||||
CONST VLIWOPNames : array[addv..lognv] of String[9] =
|
||||
('add','sub','mul','dd','pow',
|
||||
'arctan2','step','hypot','logn');
|
||||
|
||||
procedure TEvaluator.WriteVliw(p:VLIWEvalWord);
|
||||
|
||||
begin
|
||||
Write('writevliw ',(ord(p.vliwentity)-ORD(AVariable)):2,' ');
|
||||
CASE p.VLIWEntity OF
|
||||
AVariable : Writeln('variable : ', VariableName[p.IndexOfVar]);
|
||||
AfConstant : Writeln('FP value : ', p.value);
|
||||
AiConstant : Writeln('Int value: ', p.ivalue);
|
||||
Placeholder: begin
|
||||
writeln('placeholder');
|
||||
end;
|
||||
AnOperation: begin
|
||||
Write('Operator : ');
|
||||
|
||||
IF not (p.OP IN [addv..lognv]) then
|
||||
Writeln('Bad OPERATOR!')
|
||||
ELSE
|
||||
Writeln(VLIWOpNames[p.op]);
|
||||
end;
|
||||
AFunction : begin
|
||||
Write('Function: ');
|
||||
IF not (p.fun1 IN [cosx..lognx]) then
|
||||
Writeln('xBad function')
|
||||
ELSE
|
||||
Writeln(FunctionNames[p.fun1]);
|
||||
end;
|
||||
else
|
||||
Writeln('xBAD Entity');
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TEvaluator.debugger;
|
||||
{Dump the VLIWArray in textual form for debugging}
|
||||
|
||||
var TheArray : pVLIWEvalWord;
|
||||
VLIWRecs : Longint;
|
||||
|
||||
{$IFNDEF GoUp}
|
||||
{$DEFINE GoDown}
|
||||
{$ENDIF}
|
||||
|
||||
begin
|
||||
VLIWRecs:=VariableName.Count;
|
||||
Writeln('Variables : ',VLIWRecs);
|
||||
Writeln('Constants : ',ConstantNames.Count);
|
||||
|
||||
VliwRecs:=VliwCount-1;
|
||||
Writeln('VLIWCount : ',VLIWCOUNT);
|
||||
{$IFDEF GoDown}
|
||||
TheArray:=@VLIWRPNExpr[VLIWRecs-1];
|
||||
{$ELSE}
|
||||
TheArray:=VLIWRPNExpr;
|
||||
{$ENDIF}
|
||||
REPEAT
|
||||
{$IFDEF GoDown}
|
||||
Writeln(VliwRecs,' ',ord(TheArray^.VLIWEntity));
|
||||
{$ELSE}
|
||||
Writeln(VLIWCount-VliwRecs,' ',ord(TheArray^.VLIWEntity));
|
||||
{$ENDIF}
|
||||
Writeln('------------------------------------------------------');
|
||||
WriteVliw(TheArray^);
|
||||
{$IFDEF GoDown}
|
||||
dec(TheArray);
|
||||
{$ELSE}
|
||||
INC(TheArray);
|
||||
{$ENDIF}
|
||||
dec(VliwRecs);
|
||||
UNTIL VliwRecs<0;
|
||||
end;
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002/12/15 21:01:28 marco
|
||||
Initial revision
|
||||
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user