[Back to MATH SWAG index] [Back to Main SWAG index] [Original]
{ +----------------------------------------------------------------------+
| |
| PasWiz (C) Copyright 1996 Charon Software, All Rights Reserved |
| |
+----------------------------------------------------------------------+
Extended math:
This unit contains procedures and functions that implement extensions to
Pascal's built-in math (new trig functions, et al) and an arithmetic
expression evaluator. The latter is loosely based on EXPR.C from Dr.
Dobb's Journal, Sept 1985, p.25.
}
UNIT ExtMath;
INTERFACE
FUNCTION ArcCos (Number: Real): Real;
FUNCTION ArcCosH (Number: Real): Real;
FUNCTION ArcCot (Number: Real): Real;
FUNCTION ArcCotH (Number: Real): Real;
FUNCTION ArcCsc (Number: Real): Real;
FUNCTION ArcCscH (Number: Real): Real;
FUNCTION ArcSec (Number: Real): Real;
FUNCTION ArcSecH (Number: Real): Real;
FUNCTION ArcSin (Number: Real): Real;
FUNCTION ArcSinH (Number: Real): Real;
FUNCTION ArcTanH (Number: Real): Real;
FUNCTION Ceil (Number: Real): Real;
FUNCTION CosH (Number: Real): Real;
FUNCTION Cot (Number: Real): Real;
FUNCTION CotH (Number: Real): Real;
FUNCTION Csc (Number: Real): Real;
FUNCTION CscH (Number: Real): Real;
FUNCTION Deg2Rad (Number: Real): Real;
FUNCTION e: Real;
FUNCTION Erf (Number: Real): Real;
FUNCTION Fact (Number: Integer): Real;
FUNCTION Floor (Number: Real): Real;
FUNCTION Log (Number: Real): Real;
FUNCTION Rad2Deg (Number: Real): Real;
FUNCTION Raise (Number: Real; Power: Integer): Real;
FUNCTION Sec (Number: Real): Real;
FUNCTION SecH (Number: Real): Real;
FUNCTION SgnI (Number: Integer): Integer;
FUNCTION SgnR (Number: Real): Integer;
FUNCTION SinH (Number: Real): Real;
FUNCTION Tan (Number: Real): Real;
FUNCTION TanH (Number: Real): Real;
PROCEDURE Evaluate (Expr: String; VAR Result: Real; VAR ErrCode: Integer);
{ --------------------------------------------------------------------------- }
IMPLEMENTATION
{ forward declarations for the Evaluate procedure }
FUNCTION Eval (VAR Expr: String; VAR ErrCode: Integer): Real; FORWARD;
FUNCTION Factor (VAR Expr: String; VAR ErrCode: Integer): Real; FORWARD;
FUNCTION IsDigit (Expr: String): Boolean; FORWARD;
FUNCTION Locase (Ch: Char): Char; FORWARD;
FUNCTION ParensOk (Expr: String): Boolean; FORWARD;
FUNCTION Term (VAR Expr: String; VAR ErrCode: Integer): Real; FORWARD;
PROCEDURE AddParen (VAR Expr: String; Posn, WhichWay: Integer); FORWARD;
PROCEDURE FixPrecedence (VAR Expr: String); FORWARD;
{ ----- Ceiling ----- }
FUNCTION Ceil (Number: Real): Real;
BEGIN
IF Number = INT(Number) THEN
Ceil := Number
ELSE
Ceil := INT(Number) + 1.0;
END;
{ ----- Floor ----- }
FUNCTION Floor (Number: Real): Real;
BEGIN
IF Number = INT(Number) THEN
Floor := Number
ELSE
Floor := INT(Number) - 1.0;
END;
{ ----- Inverse cosine ----- }
FUNCTION ArcCos (Number: Real): Real;
BEGIN
IF (Number < -1.0) OR (Number > 1.0) THEN { error }
ArcCos := 99999.0
ELSE
ArcCos := PI / 2.0 - ArcSin(Number);
END;
{ ----- Inverse hyperbolic cosine ----- }
FUNCTION ArcCosH (Number: Real): Real;
BEGIN
ArcCosH := Log(Number + SQRT(SQR(Number) - 1.0));
END;
{ ----- Inverse cotangent ----- }
FUNCTION ArcCot (Number: Real): Real;
BEGIN
ArcCot := -ARCTAN(Number) + PI / 2.0;
END;
{ ----- Inverse hyperbolic cotangent ----- }
FUNCTION ArcCotH (Number: Real): Real;
BEGIN
ArcCotH := LN((Number + 1.0) / (Number - 1.0)) / 2.0;
END;
{ ----- Inverse cosecant ----- }
FUNCTION ArcCsc (Number: Real): Real;
BEGIN
ArcCsc := ARCTAN(1.0 / SQRT(1.0 - SQR(Number)))
+ (SgnR(Number) - 1.0) * (PI / 2.0);
END;
{ ----- Inverse hyperbolic cosecant ----- }
FUNCTION ArcCscH (Number: Real): Real;
BEGIN
ArcCscH := LN((SgnR(Number) * SQRT(SQR(Number) + 1.0) + 1.0) / Number);
END;
{ ----- Inverse secant ----- }
FUNCTION ArcSec (Number: Real): Real;
BEGIN
ArcSec := ARCTAN(Number / SQRT(1.0 - SQR(Number)))
+ (SgnR(Number) - 1.0) * (PI / 2.0);
END;
{ ----- Inverse hyperbolic secant ----- }
FUNCTION ArcSecH (Number: Real): Real;
BEGIN
ArcSecH := LN((SQRT(1.0 - SQR(Number)) + 1.0) / Number);
END;
{ ----- Inverse sine ----- }
FUNCTION ArcSin (Number: Real): Real;
VAR
Negate: Boolean;
tmp: Real;
BEGIN
IF Number < 0.0 THEN BEGIN
Number := -Number;
Negate := TRUE;
END
ELSE
Negate := FALSE;
IF Number > 1.0 THEN BEGIN
tmp := 99999.0;
Negate := FALSE;
END
ELSE BEGIN
tmp := SQRT(1.0 - SQR(Number));
IF Number > 0.7 THEN
tmp := PI / 2.0 - ARCTAN(tmp / Number)
ELSE
tmp := ARCTAN(Number / tmp);
END;
IF Negate THEN
ArcSin := -tmp
ELSE
ArcSin := tmp;
END;
{ ----- Inverse hyperbolic sine ----- }
FUNCTION ArcSinH (Number: Real): Real;
BEGIN
ArcSinH := Log(Number + SQRT(SQR(Number) + 1.0));
END;
{ ----- Inverse hyperbolic tangent ----- }
FUNCTION ArcTanH (Number: Real): Real;
BEGIN
ArcTanH := Log((1.0 + Number) / (1.0 - Number)) / 2.0;
END;
{ ----- Convert degrees to radians ----- }
FUNCTION Deg2Rad (Number: Real): Real;
BEGIN
Deg2Rad := Number * PI / 180.0;
END;
{ ----- e (base of the natural logarithms) ----- }
FUNCTION e: Real;
BEGIN
e := 2.7182818284590452353602874713526624977572470936999595749669676;
END;
{ ----- Hyperbolic cosine ----- }
FUNCTION CosH (Number: Real): Real;
BEGIN
IF Number < 0.0 THEN
Number := - Number;
IF Number > 21.0 THEN
CosH := Exp(Number) / 2.0
ELSE
CosH := (Exp(Number) + Exp(-Number)) / 2.0;
END;
{ ----- Cotangent ----- }
FUNCTION Cot (Number: Real): Real;
BEGIN
Cot := 1.0 / Tan(Number);
END;
{ ----- Hyperbolic cotangent ----- }
FUNCTION CotH (Number: Real): Real;
VAR
tmp: REAL;
BEGIN
tmp := EXP(-Number);
CotH := tmp / (EXP(Number) - tmp) * 2.0 + 1.0;
END;
{ ----- Cosecant ----- }
FUNCTION Csc (Number: Real): Real;
BEGIN
Csc := 1.0 / Sin(Number);
END;
{ ----- Hyperbolic cosecant ----- }
FUNCTION CscH (Number: Real): Real;
BEGIN
CscH := 2.0 / (EXP(Number) - EXP(-Number));
END;
{ ----- Error Function ----- }
FUNCTION Erf (Number: Real): Real;
VAR
J, N: Integer;
S: Real;
BEGIN
N := Trunc(14.0 * Number + 3.0);
S := 1.0 / (2.0 * N - 1.0);
FOR J := N - 1 DOWNTO 1 DO
S := 1.0 / (2.0 * J - 1.0) - SQR(Number) / J * S;
Erf := Number / 0.8862269254527581 * S;
END;
{ ----- Factorial ----- }
FUNCTION Fact (Number: Integer): Real;
VAR
Result: Real;
tmp: Integer;
BEGIN
Result := 1.0;
FOR tmp := 2 TO Number DO
Result := Result * tmp;
Fact := Result;
END;
{ ----- Logarithm (base 10) ----- }
FUNCTION Log (Number: Real): Real;
BEGIN
Log := Ln(Number) / Ln(10.0);
END;
{ ----- Convert radians to degrees ----- }
FUNCTION Rad2Deg (Number: Real): Real;
BEGIN
Rad2Deg := Number * 180.0 / PI;
END;
{ ----- Raise a number to a power (a feature oddly lacking in Pascal). }
FUNCTION Raise (Number: Real; Power: Integer): Real;
VAR
tmp: Integer;
Result: Real;
BEGIN
Result := 1.0;
FOR tmp := 1 TO Power DO
Result := Result * Number;
Raise := Result;
END; { Raise }
{ ----- Secant ----- }
FUNCTION Sec (Number: Real): Real;
BEGIN
Sec := 1.0 / Cos(Number);
END;
{ ----- Hyperbolic secant ----- }
FUNCTION SecH (Number: Real): Real;
BEGIN
SecH := 2.0 / (EXP(Number) + EXP(-Number));
END;
{ ----- Signum (integer) ----- }
FUNCTION SgnI (Number: Integer): Integer;
BEGIN
IF Number < 0 THEN
SgnI := -1
ELSE IF Number > 0 THEN
SgnI := 1
ELSE
SgnI := 0;
END;
{ ----- Signum (real) ----- }
FUNCTION SgnR (Number: Real): Integer;
BEGIN
IF Number < 0.0 THEN
SgnR := -1
ELSE IF Number > 0.0 THEN
SgnR := 1
ELSE
SgnR := 0;
END;
{ ----- Hyperbolic sine ----- }
FUNCTION SinH (Number: Real): Real;
VAR
Negate: Boolean;
p0, p1, p2, p3, q0, q1, q2, tmp, tmp1, tmp2, tmpsq: Real;
BEGIN
p0 := -630767.3640497716991184787251;
p1 := -89912.72022039509355398013511;
p2 := -2894.211355989563807284660366;
p3 := -26.30563213397497062819489;
q0 := -630767.3640497716991212077277;
q1 := 15215.17378790019070696485176;
q2 := -173.678953558233699533450911;
IF Number < 0.0 THEN BEGIN
Number := -Number;
Negate := TRUE;
END
ELSE
Negate := FALSE;
IF Number > 21.0 THEN
tmp := Exp(Number) / 2.0
ELSE IF Number > 0.5 THEN
tmp := (Exp(Number) - Exp(-Number)) / 2.0
ELSE BEGIN
tmpsq := SQR(Number);
tmp1 := (((tmpsq * p3 + p2) * tmpsq + p1) * tmpsq + p0) * Number;
tmp2 := ((tmpsq + q2) * tmpsq + q1) * tmpsq + q0;
tmp := tmp1 / tmp2;
END;
IF Negate THEN
SinH := -tmp
ELSE
SinH := tmp;
END;
{ ----- Tangent ----- }
FUNCTION Tan (Number: Real): Real;
BEGIN
Tan := Sin(Number) / Cos(Number);
END;
{ ----- Hyperbolic tangent ----- }
FUNCTION TanH (Number: Real): Real;
VAR
Negate: Boolean;
tmp: Real;
BEGIN
IF Number < 0.0 THEN BEGIN
Number := -Number;
Negate := TRUE;
END
ELSE
Negate := FALSE;
IF Number > 21.0 THEN { error }
TanH := 99999
ELSE BEGIN
tmp := SinH(Number) / CosH(Number);
IF Negate THEN
TanH := -tmp
ELSE
TanH := tmp;
END;
END;
{ =========================================================================== }
{ ----- This is the main evaluation routine ----- }
PROCEDURE Evaluate (Expr: String; VAR Result: Real; VAR ErrCode: Integer);
VAR
tmp: Integer;
BEGIN
WHILE (Pos(' ', Expr) > 0) DO
Delete(Expr, Pos(' ', Expr), 1);
WHILE (Pos('**', Expr) > 0) DO BEGIN
tmp := Pos('**', Expr);
Delete(Expr, tmp, 1);
Expr[tmp] := '^';
END;
IF Length(Expr) > 0 THEN
IF ParensOk(Expr) THEN BEGIN
FOR tmp := 1 TO Length(Expr) DO
Expr[tmp] := Upcase(Expr[tmp]);
ErrCode := 0;
FixPrecedence(Expr);
Result := Eval(Expr, ErrCode);
END
ELSE
ErrCode := 4
ELSE
ErrCode := 8;
END; { Evaluate }
{ ----- This adds parentheses to force evaluation by normal algebraic
precedence (negation, exponentiation, multiplication and division,
addition and subtraction) }
PROCEDURE AddParen (VAR Expr: String; Posn, WhichWay: Integer);
VAR
Done: Boolean;
ch: Char;
Depth: Integer;
BEGIN
Done := FALSE;
IF WhichWay < 0 THEN BEGIN
REPEAT
Dec(Posn);
IF Posn < 1 THEN BEGIN
Expr := '(' + Expr;
Done := TRUE;
END
ELSE BEGIN
ch := Expr[Posn];
IF Pos(ch, '^*/+-') > 0 THEN BEGIN
Insert('(', Expr, Posn + 1);
Done := TRUE;
END
ELSE IF ch = ')' THEN BEGIN
Depth := 1;
REPEAT
Dec(Posn);
IF Posn > 0 THEN BEGIN
ch := Expr[Posn];
IF ch = '(' THEN
Dec(Depth)
ELSE IF ch = ')' THEN
Inc(Depth);
END
ELSE
Depth := 0;
UNTIL Depth = 0;
IF Posn < 1 THEN
Posn := 1;
Insert('(', Expr, Posn + 1);
Done := TRUE;
END;
END;
UNTIL Done;
END
ELSE
REPEAT
Inc(Posn);
IF Posn > Length(Expr) THEN BEGIN
Expr := Expr + ')';
Done := TRUE;
END
ELSE BEGIN
ch := Expr[Posn];
IF Pos(ch, '^*/+-') > 0 THEN BEGIN
Insert(')', Expr, Posn);
Done := TRUE;
END
ELSE IF ch = '(' THEN BEGIN
Depth := 1;
REPEAT
Inc(Posn);
IF Posn <= Length(Expr) THEN BEGIN
ch := Expr[Posn];
IF ch = ')' THEN
Dec(Depth)
ELSE IF ch = '(' THEN
Inc(Depth);
END
ELSE
Depth := 0;
UNTIL Depth = 0;
IF Posn > Length(Expr) THEN
Posn := Length(Expr);
Insert(')', Expr, Posn);
Done := TRUE;
END;
END;
UNTIL Done;
END; { AddParen }
{ ----- This recursive function is the heart of the expression evaluator. }
FUNCTION Eval (VAR Expr: String; VAR ErrCode: Integer): Real;
VAR
LVal, tmp: Real;
BEGIN
LVal := Factor(Expr, ErrCode);
IF ErrCode = 0 THEN
CASE Expr[1] OF
'+': BEGIN
Delete(Expr, 1, 1);
LVal := LVal + Eval(Expr, ErrCode);
END;
'-': BEGIN
Delete(Expr, 1, 1);
LVal := LVal - Eval(Expr, ErrCode);
END;
'*': BEGIN
Delete(Expr, 1, 1);
LVal := LVal * Eval(Expr, ErrCode);
END;
'/': BEGIN
Delete(Expr, 1, 1);
tmp := Eval(Expr, ErrCode);
IF ErrCode = 0 THEN
IF tmp = 0.0 THEN
ErrCode := 9
ELSE
LVal := LVal / tmp;
END;
'^': BEGIN
Delete(Expr, 1, 1);
LVal := Raise(LVal, Trunc(Eval(Expr, ErrCode)));
END;
')': Delete(Expr, 1, 1);
END; { CASE }
Eval := LVal;
END; { Eval }
{ ----- A recursive evaluation helper, this function gets the leftmost term
that can be dealt with at this point in the evaluation. }
FUNCTION Factor (VAR Expr: String; VAR ErrCode: Integer): Real;
VAR
Negate: Boolean;
RVal: Real;
BEGIN
RVal := 0.0;
IF Expr[1] = '-' THEN BEGIN
Negate := TRUE;
Delete(Expr, 1, 1);
END
ELSE
Negate := FALSE;
IF Expr[1] <> '(' THEN
RVal := Term(Expr, ErrCode)
ELSE BEGIN
Delete(Expr, 1, 1);
RVal := Eval(Expr, ErrCode);
END;
IF Negate THEN
Factor := -RVal
ELSE
Factor := RVal;
END; { Factor }
{ ----- Since the evaluation function doesn't naturally evaluate expressions
using algebraic precedence, but does understand parentheses...
This routine adds parentheses to force the proper precedence. }
PROCEDURE FixPrecedence (VAR Expr: String);
VAR
Posn, tmp: Integer;
BEGIN
Expr := '(' + Expr + ')';
Posn := 2;
REPEAT
IF Expr[Posn] = '-' THEN
IF NOT(Expr[Posn - 1] IN ['0'..'9','A'..'Z']) THEN BEGIN
AddParen(Expr, Posn, 1);
AddParen(Expr, Posn, -1);
Inc(Posn, 2);
END
ELSE
Inc(Posn)
ELSE
Inc(Posn);
UNTIL Posn > Length(Expr);
Posn := 1;
REPEAT
IF Expr[Posn] <> Locase(Expr[Posn]) THEN BEGIN
AddParen(Expr, Posn, 1);
AddParen(Expr, Posn, -1);
Inc(Posn, 2);
END
ELSE
Inc(Posn);
UNTIL Posn > Length(Expr);
Posn := 1;
REPEAT
IF Expr[Posn] = '^' THEN BEGIN
AddParen(Expr, Posn, 1);
AddParen(Expr, Posn, -1);
Inc(Posn, 2);
END
ELSE
Inc(Posn);
UNTIL Posn > Length(Expr);
Posn := 1;
REPEAT
IF Pos(Expr[Posn], '*/') > 0 THEN BEGIN
AddParen(Expr, Posn, 1);
AddParen(Expr, Posn, -1);
Inc(Posn, 2);
END
ELSE
Inc(Posn);
UNTIL Posn > Length(Expr);
Posn := 1;
REPEAT
IF Pos(Expr[Posn], '+-') > 0 THEN BEGIN
AddParen(Expr, Posn, 1);
AddParen(Expr, Posn, -1);
Inc(Posn, 2);
END
ELSE
Inc(Posn);
UNTIL Posn > Length(Expr);
Delete(Expr, 1, 1);
Delete(Expr, Length(Expr), 1);
END; { FixPrecedence }
{ ----- Determine whether a character may be construed as being numeric. }
FUNCTION IsDigit (Expr: String): Boolean;
BEGIN
IF Length(Expr) > 0 THEN
IsDigit := (Pos(Expr[1], '0123456789.') > 0)
ELSE
IsDigit := FALSE;
END; { IsDigit }
{ ----- Convert a character to lowercase. }
FUNCTION LoCase (ch: Char): Char;
BEGIN
IF ch IN ['A'..'Z'] THEN
LoCase := CHR(ORD(ch) XOR 32)
ELSE
LoCase := ch
END; { LoCase }
{ ----- Check to make sure parentheses are balanced. }
FUNCTION ParensOk (Expr: String): Boolean;
VAR
Parens, Posn: Integer;
BEGIN
Parens := 0;
FOR Posn := 1 TO Length(Expr) DO
IF Expr[Posn] = '(' THEN
Inc(Parens)
ELSE IF Expr[Posn] = ')' THEN
Dec(Parens);
ParensOk := (Parens = 0);
END; { ParensOk }
{ ----- This grabs a number from the expression. }
FUNCTION Term (VAR Expr: String; VAR ErrCode: Integer): Real;
VAR
junk: Integer;
RVal: Real;
ch: char;
tmp: String;
BEGIN
RVal := 0.0;
ch := Upcase(Expr[1]);
IF ch <> Locase(ch) THEN BEGIN
tmp := '';
REPEAT
tmp := tmp + ch;
Delete(Expr, 1, 1);
ch := Upcase(Expr[1]);
UNTIL (ch = Locase(ch)) OR (Length(Expr) = 0);
IF tmp = 'ABS' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := ABS(Eval(Expr, ErrCode))
END
ELSE
ErrCode := 1
ELSE IF tmp = 'ACOS' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := ArcCos(Eval(Expr, ErrCode))
END
ELSE
ErrCode := 1
ELSE IF tmp = 'ASIN' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := ArcSin(Eval(Expr, ErrCode))
END
ELSE
ErrCode := 1
ELSE IF tmp = 'ATAN' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := ARCTAN(Eval(Expr, ErrCode))
END
ELSE
ErrCode := 1
ELSE IF tmp = 'COS' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := COS(Eval(Expr, ErrCode))
END
ELSE
ErrCode := 1
ELSE IF tmp = 'FRAC' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := Eval(Expr, ErrCode);
RVal := RVal - INT(RVal);
END
ELSE
ErrCode := 1
ELSE IF tmp = 'INT' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := INT(Eval(Expr, ErrCode))
END
ELSE
ErrCode := 1
ELSE IF tmp = 'LOG' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := LOG(Eval(Expr, ErrCode))
END
ELSE
ErrCode := 1
ELSE IF tmp = 'PI' THEN
RVal := 3.141593
ELSE IF tmp = 'SIN' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := SIN(Eval(Expr, ErrCode))
END
ELSE
ErrCode := 1
ELSE IF tmp = 'SQRT' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := SQRT(Eval(Expr, ErrCode))
END
ELSE
ErrCode := 1
ELSE IF tmp = 'TAN' THEN
IF ch = '(' THEN BEGIN
Delete(Expr, 1, 1);
RVal := TAN(Eval(Expr, ErrCode))
END
ELSE
ErrCode := 1
ELSE
ErrCode := 3
END
ELSE IF IsDigit(Expr) THEN BEGIN
tmp := '';
WHILE IsDigit(Expr) DO BEGIN
tmp := tmp + Expr[1];
Delete(Expr, 1, 1);
END;
Val(tmp, RVal, junk);
END
ELSE
ErrCode := 2;
Term := RVal;
END; { Term }
END. { ExtMath UNIT }
[Back to MATH SWAG index] [Back to Main SWAG index] [Original]