Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PASWIZ13.ZIP/SOURCE.ZIP/EXTMATH.PAS

Pascal/Delphi Source File | 1992-10-29 | 18.1 KB | 743 lines

{   +----------------------------------------------------------------------+
    |                                                                      |
    |        PasWiz  Copyright (c) 1990-1992  Thomas G. Hanlin III         |
    |             3544 E. Southern Ave. #104,  Mesa, AZ 85204              |
    |                                                                      |
    |                     The Pascal Wizard's Library                      |
    |                                                                      |
    +----------------------------------------------------------------------+



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 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 Csc (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 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 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;



{ ----- Cosecant ----- }
FUNCTION Csc (Number: Real): Real;
BEGIN
   Csc := 1.0 / Sin(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 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 }