File : expressions_evaluator.adb
-- $Id: expressions_evaluator.adb,v 1.2 2003/10/08 23:17:33 Jano Exp $
with Ada.Text_IO;
with Ada.Integer_Text_IO;
with Ada.Float_Text_IO;
with Ada.Numerics.Generic_Elementary_Functions;
with Ada.Numerics.Float_Random;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Strings.Maps.Constants;
with Ada.Unchecked_Deallocation;
with Ada.Exceptions;
package body Expressions_Evaluator is
use Ada;
use Strings.Unbounded;
use Strings.Fixed;
use Strings;
use Exceptions;
Generator : Numerics.Float_Random.Generator;
type Parent_Scan is (Opening, Closing);
----------
-- Math --
----------
package Math is new
Ada.Numerics.Generic_Elementary_Functions (Values);
---------------
-- Factorial --
---------------
function Factorial (V : in Values)
return Values
is
F : Positive;
R : Values := 1.0;
begin
if V < 0.0 then
Raise_Exception (Argument_Error'Identity,
"factorial for negative value");
elsif V = 0.0 then
return 1.0;
else
F := Positive (V);
for I in Positive range 2 .. F loop
R := R * Values (I);
end loop;
end if;
return R;
end Factorial;
------------
-- Create --
------------
function Create (Expression : in String)
return Expressions
is
E : Expressions;
---------------------
-- Cut_Expressions --
---------------------
procedure Cut_Expressions (E : in out Expressions) is
S : String := To_String (E.Expression_String);
First, Last : Natural;
---------------------
-- Matching_Parent --
---------------------
function Matching_Parent (E : in String;
P : in Positive;
Which : in Parent_Scan := Closing)
return Positive
is
PP : Positive := P;
Parent_Level : Integer := 0;
Parent : Character;
begin
case Which is
when Closing =>
Parent := ')';
when Opening =>
Parent := '(';
end case;
loop
if E (PP) = '(' then
Parent_Level := Parent_Level + 1;
elsif E (PP) = ')' then
Parent_Level := Parent_Level - 1;
end if;
exit when Parent_Level = 0 and then E (PP) = Parent;
case Which is
when Closing =>
PP := PP + 1;
exit when PP > E'Last;
when Opening =>
PP := PP - 1;
exit when PP < E'First;
end case;
end loop;
case Which is
when Closing =>
if PP > E'Last then
Raise_Exception (Syntax_Error'Identity,
"no matching parenthesis for " &
Positive'Image (P));
else
return PP;
end if;
when Opening =>
if PP < E'First then
Raise_Exception (Syntax_Error'Identity,
"no matching parenthesis for " &
Positive'Image (P));
else
return PP;
end if;
end case;
end Matching_Parent;
--------------------
-- Parse_Equation --
--------------------
procedure Parse_Equation (E : in out Expressions;
S : in String)
is
package Variable_IO is
new Ada.Text_IO.Enumeration_IO (Variables);
----------------------
-- Parse_Expression --
----------------------
function Parse_Expression (E : in String)
return Node_Access
is
------------
-- Parser --
------------
package Parser is
type Token_Type is (Var, Val, Operator, Parent, Rand, Void);
procedure Read_Token (S : in String;
T : out Token_Type;
P : out Positive);
Last_Var : Variables;
Last_Value : Values;
Last_Operator : Unary_Operators;
end Parser;
package body Parser is
----------------
-- Skip_Space --
----------------
procedure Skip_Space (S : in String;
P : in out Positive) is
begin
loop
exit when S (P) /= ' ';
P := P + 1;
exit when P > S'Last;
end loop;
end Skip_Space;
----------------
-- Read_Token --
----------------
procedure Read_Token (S : in String;
T : out Token_Type;
P : out Positive)
is
-----------------
-- Read_Number --
-----------------
procedure Read_Number (S : in String;
P : in out Positive)
is
use Ada;
First, Last : Positive;
Tmp : Natural;
begin
Find_Token (S (P .. S'Last),
Maps.To_Set ("0123456789."),
Inside,
First,
Last);
if Index (S (First .. Last), ".") = 0 then
-- an integer
declare
V : Integer;
begin
Integer_Text_IO.Get (S (First .. Last), V, Tmp);
Last_Value := Values (V);
end;
else
-- a float
declare
V : Float;
begin
Float_Text_IO.Get (S (First .. Last), V, Tmp);
Last_Value := Values (V);
end;
end if;
P := Last + 1;
if P <= S'Last and then S (P) = '!' then
Last_Value := Factorial (Last_Value);
P := P + 1;
end if;
end Read_Number;
-----------------
-- Read_Symbol --
-----------------
procedure Read_Symbol (S : in String;
T : out Token_Type;
P : in out Positive)
is
First, Last : Positive;
begin
Find_Token (S (P .. S'Last),
Maps.Constants.Lower_Set,
Inside,
First,
Last);
if First = Last then -- variable
T := Var;
Last_Var := Variables'Val
(Character'Pos (S (First)) -
Character'Pos ('a') +
Variables'Pos (A));
elsif S (First .. Last) = "abs" then
T := Operator;
Last_Operator := VABS;
elsif S (First .. Last) = "sin" then
T := Operator;
Last_Operator := SIN;
elsif S (First .. Last) = "cos" then
T := Operator;
Last_Operator := COS;
elsif S (First .. Last) = "tan" then
T := Operator;
Last_Operator := TAN;
elsif S (First .. Last) = "cot" then
T := Operator;
Last_Operator := COT;
elsif S (First .. Last) = "arcsin" then
T := Operator;
Last_Operator := SIN;
elsif S (First .. Last) = "arccos" then
T := Operator;
Last_Operator := COS;
elsif S (First .. Last) = "arctan" then
T := Operator;
Last_Operator := TAN;
elsif S (First .. Last) = "arccot" then
T := Operator;
Last_Operator := COT;
elsif S (First .. Last) = "sinh" then
T := Operator;
Last_Operator := SIN;
elsif S (First .. Last) = "cosh" then
T := Operator;
Last_Operator := COS;
elsif S (First .. Last) = "tanh" then
T := Operator;
Last_Operator := TAN;
elsif S (First .. Last) = "coth" then
T := Operator;
Last_Operator := COT;
elsif S (First .. Last) = "arcsinh" then
T := Operator;
Last_Operator := SIN;
elsif S (First .. Last) = "arccosh" then
T := Operator;
Last_Operator := COS;
elsif S (First .. Last) = "arctanh" then
T := Operator;
Last_Operator := TAN;
elsif S (First .. Last) = "arccoth" then
T := Operator;
Last_Operator := COT;
elsif S (First .. Last) = "sqrt" then
T := Operator;
Last_Operator := SQRT;
elsif S (First .. Last) = "exp" then
T := Operator;
Last_Operator := EXP;
elsif S (First .. Last) = "log" then
T := Operator;
Last_Operator := LOG;
elsif S (First .. Last) = "ln" then
T := Operator;
Last_Operator := LN;
else
Raise_Exception (Syntax_Error'Identity,
"unknown operator " &
S (First .. Last));
end if;
P := Last + 1;
end Read_Symbol;
begin -- Read_Token
P := S'First;
Skip_Space (S, P);
-- no more token
if P > S'Last then
T := Void;
return;
end if;
case S (P) is
when 'a' .. 'z' => -- a variable or function
Read_Symbol (S, T, P);
when '0' .. '9' => -- a number
Read_Number (S, P);
T := Val;
when '#' =>
T := Rand;
P := P + 1;
when '+' =>
Last_Operator := '+';
T := Operator;
P := P + 1;
when '-' =>
Last_Operator := '-';
T := Operator;
P := P + 1;
when '!' =>
Last_Operator := FACTORIAL;
T := Operator;
P := P + 1;
when '(' =>
T := Parent;
P := P + 1;
when others =>
Raise_Exception (Syntax_Error'Identity,
"error for " & S (P));
end case;
end Read_Token;
end Parser;
-------------------
-- Find_Operator --
-------------------
procedure Find_Operator (S : in String;
Op_Pos : out Natural;
Op : out Binary_Operators)
is
P : Natural;
---------------------
-- Is_Operator_Add --
---------------------
function Is_Operator_Add (C : in Character) return Boolean is
begin
case C is
when '+' | '-' =>
return True;
when others =>
return False;
end case;
end Is_Operator_Add;
---------------------
-- Is_Operator_Mul --
---------------------
function Is_Operator_Mul (C : in Character) return Boolean is
begin
case C is
when '/' | '*' =>
return True;
when others =>
return False;
end case;
end Is_Operator_Mul;
---------------------
-- Is_Operator_Exp --
---------------------
function Is_Operator_Exp (C : in Character) return Boolean is
begin
case C is
when '^' =>
return True;
when others =>
return False;
end case;
end Is_Operator_Exp;
------------------
-- Set_Operator --
------------------
procedure Set_Operator (P : in Positive) is
begin
Op_Pos := P;
case S (P) is
when '+' =>
Op := '+';
when '-' =>
Op := '-';
when '*' =>
Op := '*';
when '/' =>
Op := '/';
when '^' =>
Op := '^';
when others =>
null;
end case;
end Set_Operator;
type Operator_Function is
access function (C : in Character) return Boolean;
-------------------
-- Scan_Operator --
-------------------
function Scan_Operator (Op_Function : in Operator_Function;
S : in String)
return Natural
is
Parent_Level : Natural := 0;
Pos : Positive := S'First;
begin
loop
if S (Pos) = '(' then
Parent_Level := Parent_Level + 1;
elsif S (Pos) = ')' then
Parent_Level := Parent_Level - 1;
end if;
exit when Parent_Level = 0 and Op_Function (S (Pos));
Pos := Pos + 1;
exit when Pos > S'Last;
end loop;
if Pos > S'Last then
return 0;
else
return Pos;
end if;
end Scan_Operator;
begin -- Find_Operator
P := Scan_Operator (Is_Operator_Add'Access, S);
if P = 0 then
P := Scan_Operator (Is_Operator_Mul'Access, S);
if P = 0 then
P := Scan_Operator (Is_Operator_Exp'Access, S);
if P = 0 then
Op_Pos := 0;
Op := '+';
else
Set_Operator (P);
end if;
else
Set_Operator (P);
end if;
else
Set_Operator (P);
end if;
end Find_Operator;
T : Parser.Token_Type;
P : Positive := 1;
Op_Pos : Natural;
B_Op : Binary_Operators;
begin -- Parse_Expression
Parser.Read_Token (E, T, P);
case T is
when Parser.Var =>
Find_Operator (E, Op_Pos, B_Op);
if Op_Pos = 0 then
return new Node'(Variable, Parser.Last_Var);
else
return new Node'
(Binary_Operator,
B_Op,
Left =>
Parse_Expression (E (E'First .. Op_Pos - 1)),
Right =>
Parse_Expression (E (Op_Pos + 1 .. E'Last)));
end if;
when Parser.Val =>
Find_Operator (E, Op_Pos, B_Op);
if Op_Pos = 0 then
return new Node'(Value, Parser.Last_Value);
else
return new Node'
(Binary_Operator,
B_Op,
Left =>
Parse_Expression (E (E'First .. Op_Pos - 1)),
Right =>
Parse_Expression (E (Op_Pos + 1 .. E'Last)));
end if;
when Parser.Rand =>
Find_Operator (E, Op_Pos, B_Op);
if Op_Pos = 0 then
return new Node'(Node_Type => Random);
else
return new Node'
(Binary_Operator,
B_Op,
Left =>
Parse_Expression (E (E'First .. Op_Pos - 1)),
Right =>
Parse_Expression (E (Op_Pos + 1 .. E'Last)));
end if;
when Parser.Operator =>
Find_Operator (E (P .. E'Last), Op_Pos, B_Op);
if Op_Pos = 0 then
return new Node'
(Unary_Operator,
Parser.Last_Operator,
Next => Parse_Expression (E (P .. E'Last)));
else
return new Node'
(Binary_Operator,
B_Op,
Left =>
Parse_Expression (E (E'First .. Op_Pos - 1)),
Right =>
Parse_Expression (E (Op_Pos + 1 .. E'Last)));
end if;
when Parser.Parent =>
Find_Operator (E, Op_Pos, B_Op);
if Op_Pos = 0 then
declare
P2 : Positive;
begin
P2 := Matching_Parent (E, P - 1);
return Parse_Expression (E (P .. P2 - 1));
end;
else
return new Node'
(Binary_Operator,
B_Op,
Left => Parse_Expression (E (E'First .. Op_Pos - 1)),
Right => Parse_Expression (E (Op_Pos + 1 .. E'Last)));
end if;
when Parser.Void =>
pragma Warnings (Off);
null;
pragma Warnings (On);
end case;
end Parse_Expression;
Var : Variables;
I : Natural;
begin -- Parse_Equation
I := Index (S, "=");
if I = 0 then
Raise_Exception (Syntax_Error'Identity,
"not an equation (missing =) in " & S);
else
declare
Last : Positive;
begin
Variable_IO.Get (S (S'First .. I - 1), Var, Last);
exception
when others =>
Raise_Exception (Syntax_Error'Identity,
"left value is not a variable in " & S);
end;
end if;
if I = S'Last then
Raise_Exception (Syntax_Error'Identity,
"No expression to parse in " & S);
end if;
E.Nodes (Var).Node := Parse_Expression (S (I + 1 .. S'Last));
end Parse_Equation;
begin -- Cut_Expressions
First := S'First;
Last := S'Last;
-- make the factorial operator for Variables and expressions
-- a prefix.
for I in S'Range loop
if S (I) = '!' then
case S (I - 1) is
when 'a' .. 'z' => -- a variable
S (I) := S (I - 1);
S (I - 1) := '!';
when ')' => -- an expression
declare
P : Positive;
begin
P := Matching_Parent (S, I - 1, Opening);
S (P + 1 .. I) := S (P .. I - 1);
S (P) := '!';
end;
when others =>
null;
end case;
end if;
end loop;
loop
Last := Index (S (First .. S'Last), ";");
if Last = 0 then
Parse_Equation (E, S (First .. S'Last));
exit;
else
Parse_Equation (E, S (First .. Last - 1));
First := Last + 1;
exit when First > S'Last;
end if;
end loop;
end Cut_Expressions;
begin -- Create
E.Expression_String := To_Unbounded_String
(Translate (Expression, Maps.Constants.Lower_Case_Map));
Cut_Expressions (E);
-- initialize some variables
E.Nodes (Expressions_Evaluator.E).Node := new Node'(Value, Numerics.e);
E.Nodes (Expressions_Evaluator.P).Node := new Node'(Value, Numerics.Pi);
return E;
end Create;
------------------
-- Destroy_Tree --
------------------
procedure Destroy_Tree (Root : in out Node_Access) is
procedure Free is
new Unchecked_Deallocation (Node, Node_Access);
begin
if Root /= null then
case Root.Node_Type is
when Expressions_Evaluator.Variable | Value | Random =>
null;
Free (Root);
when Unary_Operator =>
Destroy_Tree (Root.Next);
Free (Root);
when Binary_Operator =>
Destroy_Tree (Root.Left);
Destroy_Tree (Root.Right);
Free (Root);
end case;
end if;
end Destroy_Tree;
-------------
-- Destroy --
-------------
procedure Destroy (Expression : in out Expressions) is
begin
for V in Variables loop
Destroy_Tree (Expression.Nodes (V).Node);
end loop;
Expression.Expression_String := Strings.Unbounded.Null_Unbounded_String;
end Destroy;
--------------
-- Evaluate --
--------------
function Evaluate (Expression : in Expressions;
Variable : in Variables)
return Values
is
Have_Been_Evaluated : array (Variables) of Boolean :=
(E => true, P => true, others => False);
----------
-- Eval --
----------
function Eval (Node : in Node_Access)
return Values
is
V : Values;
begin
if Node = null then
Raise_Exception (Not_Set'Identity,
"a variable is not set");
end if;
case Node.Node_Type is
when Expressions_Evaluator.Variable =>
if Have_Been_Evaluated (Node.Var) then
Raise_Exception (Recursive_Error'Identity,
"infinite recursion detected.");
else
Have_Been_Evaluated (Node.Var) := True;
V := Eval (Expression.Nodes (Node.Var).Node);
Have_Been_Evaluated (Node.Var) := False;
return V;
end if;
when Value =>
return Node.V;
when Unary_Operator =>
case Node.U_Operator is
when '-' =>
return -Eval (Node.Next);
when '+' =>
return Eval (Node.Next);
when FACTORIAL =>
return Factorial (Eval (Node.Next));
when VABS =>
return abs (Eval (Node.Next));
when SIN =>
return Math.Sin (Eval (Node.Next));
when COS =>
return Math.Cos (Eval (Node.Next));
when TAN =>
return Math.Tan (Eval (Node.Next));
when COT =>
return Math.Cot (Eval (Node.Next));
when ARCSIN =>
return Math.Sin (Eval (Node.Next));
when ARCCOS =>
return Math.Cos (Eval (Node.Next));
when ARCTAN =>
return Math.Tan (Eval (Node.Next));
when ARCCOT =>
return Math.Cot (Eval (Node.Next));
when SINH =>
return Math.Sin (Eval (Node.Next));
when COSH =>
return Math.Cos (Eval (Node.Next));
when TANH =>
return Math.Tan (Eval (Node.Next));
when COTH =>
return Math.Cot (Eval (Node.Next));
when ARCSINH =>
return Math.Sin (Eval (Node.Next));
when ARCCOSH =>
return Math.Cos (Eval (Node.Next));
when ARCTANH =>
return Math.Tan (Eval (Node.Next));
when ARCCOTH =>
return Math.Cot (Eval (Node.Next));
when SQRT =>
return Math.Sqrt (Eval (Node.Next));
when EXP =>
return Math.Exp (Eval (Node.Next));
when LOG =>
return Math.Log (Eval (Node.Next), Base => 10.0);
when LN =>
return Math.Log (Eval (Node.Next));
end case;
when Binary_Operator =>
case Node.B_Operator is
when '+' =>
return Eval (Node.Left) + Eval (Node.Right);
when '-' =>
return Eval (Node.Left) - Eval (Node.Right);
when '*' =>
return Eval (Node.Left) * Eval (Node.Right);
when '/' =>
return Eval (Node.Left) / Eval (Node.Right);
when '^' =>
declare
use Math;
begin
return Eval (Node.Left) ** Eval (Node.Right);
end;
end case;
when Random =>
return Values (Numerics.Float_Random.Random (Generator));
end case;
end Eval;
begin
return Eval (Expression.Nodes (Variable).Node);
end Evaluate;
---------
-- Set --
---------
procedure Set (Expression : in out Expressions;
Variable : in Variables;
Value : in Values) is
begin
Expression.Nodes (Variable).Node
:= new Node'(Expressions_Evaluator.Value, Value);
end Set;
-----------
-- UnSet --
-----------
procedure UnSet (Expression : in out Expressions;
Variable : in Variables) is
begin
Destroy_Tree (Expression.Nodes (Variable).Node);
end UnSet;
end Expressions_Evaluator;