home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug017.arc / HANDCALC.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  14KB  |  556 lines
  1.  
  2. Program Handcalc ;
  3.  
  4. {   This program needs to be compiled to disk.  Program modified to  }
  5. {   work with Turbo Pascal by Peter Billing.  June. 1985             }
  6. {   Source  Sig/m Disk 97.  Name of original program  Mathpack       }
  7. {   This program is intended to act as a scientific calculator, with }
  8. {   exponentiation and trancendental functions.    }
  9.  
  10. Const
  11.  Func_Len  = 6; { No. of characters allowed in a function name }
  12.  Num_Funcs = 20; { No. of functions recognized   }
  13.  Pi        = 3.1415926535897323846264338;
  14.  
  15. Type
  16.  Functions = (ArcTangent, Cosine, Logrithm, Sine, Square, Square_Root,
  17.               Exponent, Tangent, CoTangent, Secant, CoSecant,
  18.               ArcSine, ArcCosine, ArcCotangent, ArcSecant,
  19.               ArcCoSecant, Pie, Radians, Log, Factorial,
  20.               Non_Function);
  21.  
  22.  Set_of_Funcs = Set of Functions;
  23.  Func_Name = array [1..Func_Len] of char;
  24.  Func_Rec  = record
  25.              Name : Func_Name;
  26.              Func_Type : Functions
  27.              end;
  28.  Func_List = array [1..Num_Funcs] of Func_Rec;
  29.  
  30. Var
  31.  Answer          : real;
  32.  Buf             : String[255];
  33.  Z               : integer; { Index into Buf }
  34.  F_Names         : Func_List;
  35.  Non_Parm_Funcs  : Set_of_Funcs;
  36.  Debug_Mode      : boolean;
  37.  
  38. Procedure Initialize;
  39.  
  40. Var
  41.  I : integer;
  42.  
  43. Procedure Init_Funcs;
  44.  
  45.  begin { Init_Funcs }
  46.   { The order of the strings in F_Names must be alphabetical }
  47.   { This should be remembered when adding new functions    }
  48.  F_Names[1].Name := 'ARCCOS'; F_Names[1].Func_Type := ArcCosine;
  49.  F_Names[2].Name := 'ARCCOT'; F_Names[2].Func_Type := ArcCoTangent;
  50.  F_Names[3].Name := 'ARCCSC'; F_Names[3].Func_Type := ArcCoSecant;
  51.  F_Names[4].Name := 'ARCSEC'; F_Names[4].Func_Type := ArcSecant;
  52.  F_Names[5].Name := 'ARCSIN'; F_Names[5].Func_Type := ArcSine;
  53.  F_Names[6].Name := 'ARCTAN'; F_Names[6].Func_Type := ArcTangent;
  54.  F_Names[7].Name := 'COS   '; F_Names[7].Func_Type := Cosine;
  55.  F_Names[8].Name := 'COT   '; F_Names[8].Func_Type := CoTangent;
  56.  F_Names[9].Name := 'CSC   '; F_Names[9].Func_Type := CoSecant;
  57.  F_Names[10].Name:= 'EXP   '; F_Names[10].Func_Type:= Exponent;
  58.  F_Names[11].Name:= 'FACTOR'; F_Names[11].Func_Type:= Factorial;
  59.  F_Names[12].Name:= 'LN    '; F_Names[12].Func_Type:= Logrithm;
  60.  F_Names[13].Name:= 'LOG   '; F_Names[13].Func_Type:= Log;
  61.  F_Names[14].Name:= 'PI    '; F_Names[14].Func_Type:= Pie;
  62.  F_Names[15].Name:= 'RADIAN'; F_Names[15].Func_Type:= Radians;
  63.  F_Names[16].Name:= 'SEC   '; F_Names[16].Func_Type:= Secant;
  64.  F_Names[17].Name:= 'SIN   '; F_Names[17].Func_Type:= Sine;
  65.  F_Names[18].Name:= 'SQR   '; F_Names[18].Func_Type:= Square;
  66.  F_Names[19].Name:= 'SQRT  '; F_Names[19].Func_Type:= Square_Root;
  67.  F_Names[20].Name:= 'TAN   '; F_Names[20].Func_Type:= Tangent;
  68.  Non_Parm_Funcs := [Pie]
  69.  end;  { Init_Funcs }
  70.  
  71.      begin { Initialization }
  72.      clrscr;
  73.      Writeln ('Calculator');
  74.      Writeln;
  75.      Writeln ('by Warren A. Smith  --  July 29, 1981');
  76.      Writeln;
  77.      Writeln ('A ''?'' at the beginning of a line will bring up a listing');
  78.      Writeln ('  of possible functions and operators that may be used.');
  79.      Writeln;
  80.      Writeln ('A dollar sign ''$'' at the beginning of a line will');
  81.      Writeln ('  cause this program to terminate.');
  82.      Writeln;
  83.      Debug_Mode := FALSE;
  84.      Init_Funcs
  85.      end;  { Initialization }
  86.  
  87.   Function Digit (In_Char : char) : boolean ;
  88.  
  89.        begin { Digit }
  90.        Digit := In_Char in ['0','1','2','3','4','5','6','7',
  91.        '8','9']
  92.        end;  { Digit }
  93.  
  94.   Function Letter (Var In_Char : char) : boolean;
  95.  
  96.        begin { Letter }
  97.        In_Char := UpCase (In_Char);
  98.        Letter := In_Char in ['A','B','C','D','E','F','G','H',
  99.         'I','J','K','L','M','N','O','P',
  100.         'Q','R','S','T','U','V','W','X',
  101.         'Y','Z']
  102.        end;  { Letter }
  103.  
  104. Function Skip_Line (N : integer) : char;
  105.  
  106.     Var
  107.  I : integer;
  108.  
  109.     begin { Skip_Line }
  110.     For I := 1 to N do
  111.  Writeln;
  112.     Skip_Line := chr(0)
  113.     end;  { Skip_Line }
  114.  
  115. Function Tab (N : integer) : char;
  116.  
  117.     Var
  118.  I : integer;
  119.  
  120.     begin { Tab }
  121.     For I := 1 to N do
  122.  Write (' ')
  123.     end;  { Tab }
  124.  
  125. Function Upper (In_Char : char) : char;
  126.   begin Upper:=UpCase(In_Char) end;
  127. {     begin  Upper
  128.      If (In_Char >= 'a') AND (In_Char <= 'z') then
  129.          Upper := chr(ord(In_Char) + (ord('A') - ord('a')))
  130.      else
  131.          Upper := In_Char
  132.      end;   Upper
  133.  }
  134. Procedure Help;
  135.  
  136.     Var
  137.  Response : char;
  138.  
  139.     begin { Help }
  140.      clrscr;
  141.      Writeln ('  The currently available functions are :');
  142.      Writeln;
  143.      Writeln ('    ArcCosine   - ArcCos    ArcCotangent     - ArcCot');
  144.      Writeln ('    ArcCosecant - ArcCsc    ArcSecant        - ArcSec');
  145.      Writeln ('    ArcSine     - ArcSin    ArcTangent       - ArcTan');
  146.      Writeln ('    Cosine      - Cos       CoTangent        - Cot   ');
  147.      Writeln ('    CoSecant    - Csc       Natural Exponent - Exp   ');
  148.      Writeln ('    Natural Log - Ln        Secant           - Sec   ');
  149.      Writeln ('    Sine        - Sin       Square           - Sqr   ');
  150.      Writeln ('    Square Root - Sqrt      Tangent          - Tan   ');
  151.      Writeln ('    Log base 10 - Log       Factorial        - Factor');
  152.      Writeln ('    Value of Pi - Pi        ');
  153.      Writeln;
  154.      Writeln ('  Allowable operators are:');
  155.      Writeln ('      ''+'', ''-'', ''*'', ''/'', and ''^'' (exponentiation)');
  156.      Writeln;
  157.      Writeln ('  Upper case and lower case are irrelevant in function names');
  158.      Writeln ('  A ''$'' will end the program, a ''!'' turns on debug mode ');
  159.      Writeln;
  160.      Writeln ('Hit the carriage return to proceed.');
  161.      Read (Response);
  162.     end;  { Help }
  163.  
  164. Function Eoln : boolean;
  165.  
  166.     begin { Eoln }
  167.     Eoln := Z > Length(Buf)
  168.     end;  { Eoln }
  169.  
  170. Procedure Slough_Blanks;
  171.  
  172.     begin { Slough_Blanks }
  173.     While (Buf[Z] = ' ') AND (not Eoln) do
  174.        Z := Z + 1
  175.     end;  { Slough_Blanks }
  176.  
  177. Procedure Get_Expr;
  178.  
  179. begin { Get_Expr }
  180. Repeat
  181.  Writeln;
  182.  Writeln ('Type in an expression to be solved.');
  183.  Readln (Buf);
  184.  Z := 1;
  185.  Slough_Blanks
  186. Until not Eoln
  187. end;  { Get_Expr }
  188.  
  189. Function Expr : real;
  190.  
  191. Var
  192.  Unary,
  193.  Answer : real;
  194.  
  195. Function Term : real;
  196.  
  197. Var
  198.   Answer : real;
  199.  
  200. Function Expon : real;
  201.  
  202. Var
  203.   Answer : real;
  204.  
  205. Function XtoY (X, Y : real) : real;
  206.  
  207. begin { XtoY }
  208.   If X >= 0.0 then
  209.       XtoY := exp(Y * Ln(X))
  210.   else
  211.       XtoY := 0.0
  212. end;  { XtoY }
  213.  
  214. Function Factor : real;
  215.  
  216. Var
  217.    Answer,
  218.    X : real;
  219.    Func : Functions;
  220.  
  221. Procedure Read (Var Answer : real);
  222.  
  223. Var
  224.    Fact_Power : real;
  225.  
  226. begin { Read }
  227.        Answer := 0.0;
  228.        Slough_Blanks;
  229.        While Digit (Buf[Z]) AND not Eoln do
  230.    begin
  231.    Answer := Answer * 10.0 + (Ord(Buf[Z])-Ord('0'));
  232.    Z := Z + 1
  233.    end;
  234.        If (Buf[Z] = '.') AND not Eoln then
  235.    begin
  236.    Z := Z + 1;
  237.    Fact_Power := 1.0;
  238.    While Digit (Buf[Z]) AND not Eoln do
  239.        begin
  240.        Fact_Power := Fact_Power / 10.0;
  241.        Answer := Answer+(Ord(Buf[Z])-Ord('0'))*Fact_Power;
  242.        Z := Z + 1
  243.        end
  244.    end
  245. end;  { Read }
  246.  
  247.  
  248. Function Get_Func_Type : Functions;
  249.  
  250. Var
  251.    ID : Func_Name;
  252.    Index : integer;
  253.  
  254. Function Search_Funcs (ID : Func_Name) : Functions;
  255.  
  256. Var
  257.     I, J, K : integer;
  258.  
  259.      begin { Search_Funcs }
  260.      I := 1;
  261.       J := Num_Funcs;
  262.      Repeat
  263.           K := (I+J) DIV 2;      { Binary search }
  264.           With F_Names[K] do
  265.        begin
  266.        If Name <= ID  then
  267.      I := K+1;
  268.  
  269.        If Name >= ID then
  270.      J := K-1
  271.        end
  272.  
  273.      Until I > J;
  274.       If F_Names[K].Name <> ID then
  275.           Search_Funcs := Non_Function
  276.      else
  277.           Search_Funcs := F_Names[K].Func_Type
  278.      end;  { Search_Funcs }
  279.  
  280.        begin { Get_Func_Type }
  281.        Index := 1;
  282.        Repeat
  283.      ID [Index] := Buf[Z];
  284.      Z := Z + 1;
  285.      Index := Index + 1
  286.        Until Not Letter(Buf[Z]) OR Eoln OR (Index > Func_Len);
  287.        While Index <= Func_Len do
  288.      begin
  289.      ID [Index] := ' ';
  290.      Index := Index + 1
  291.      end;
  292.      Get_Func_Type := Search_Funcs (ID)
  293. end;  { Get_Func_Type }
  294.  
  295. Function Tan (X : real) : real;
  296.  
  297.       begin { Tan }
  298.       Tan := Sin(X) / Cos(X)
  299.       end;  { Tan }
  300.  
  301. Function Cot (X : real) : real;
  302.  
  303.       begin { Cot }
  304.       Cot := Cos(X) / Sin(X)
  305.       end;  { Cot }
  306.  
  307. Function Sec (X : real) : real;
  308.  
  309.       begin { Sec }
  310.       Sec := 1.0 / Cos(X)
  311.       end;  { Sec }
  312.  
  313. Function Csc (X : real) : real;
  314.  
  315.       begin { Csc }
  316.       Csc := 1.0 / Sin(X)
  317.       end;  { Csc }
  318.  
  319. Function ArcSin (X : real) : real;
  320.  
  321.       begin { ArcSin }
  322.       ArcSin := ArcTan(X / Sqrt(1.0 - Sqr(X)))
  323.       end;  { ArcSin }
  324.  
  325. Function ArcCos (X : real) : real;
  326.  
  327.       begin { ArcCos }
  328.       ArcCos := Pi / 2.0 - ArcTan (X / Sqrt(1.0 - Sqr(X)))
  329.       end;  { ArcCos }
  330.  
  331. Function ArcCot (X : real) : real;
  332.  
  333.       begin { ArcCot }
  334.       ArcCot := Pi / 2.0 - ArcTan (X)
  335.       end;  { ArcCot }
  336.  
  337. Function ArcSec (X : real) : real;
  338.  
  339.       begin { ArcSec }
  340.       ArcSec := ArcTan (Sqrt(Sqr(X) - 1.0))
  341.       end;  { ArcSec }
  342.  
  343. Function ArcCsc (X : real) : real;
  344.  
  345.       begin { ArcCsc }
  346.       ArcCsc := ArcTan (1.0 / Sqrt(Sqr(X) - 1.0))
  347.       end;  { ArcCsc }
  348.  
  349. Function Radian (X : real) : real;
  350.  
  351.       begin { Radian }
  352.       Radian := X * (Pi / 180.0)
  353.       end;  { Radian }
  354.  
  355. Function Log10 (X : real) : real;
  356.  
  357.       begin { Log10 }
  358.       Log10 := Ln(X) / Ln(10.0)
  359.       end;  { Log10 }
  360.  
  361. Function Factorl (X : real) : real;
  362.  
  363. Var
  364.    Int_X, I : integer;
  365.    Product  : real;
  366.  
  367.       begin { Factorl }
  368.       Int_X := Round(X);
  369.       If Int_X = 0 then
  370.    Factorl := 1.0
  371.       else
  372.    begin
  373.    Product := 1.0;
  374.    For I := 2 to Int_X do
  375.        Product := Product * I;
  376.    Factorl := Product
  377.    end
  378.       end;  { Factorl }
  379.  
  380.   begin { Factor }
  381.   Slough_Blanks;
  382.   If Digit (Buf[Z]) OR (Buf[Z] = '.') then
  383.        Read (Answer)
  384.   else
  385.        If Buf[Z] = '(' then
  386.      begin
  387.      Z := Z + 1;
  388.      Answer := Expr;
  389.      If Buf[Z] <> ')' then
  390.     begin
  391.     Write (Tab(Z-1),'^ ');
  392.     Writeln ('*** '')'' expected')
  393.     end
  394.      else
  395.     Z := Z + 1
  396.      end
  397.        else
  398.      If Letter (Buf[Z]) then
  399.     begin
  400.     Func := Get_Func_Type;
  401.     Slough_Blanks;
  402.     If not (Func in Non_Parm_Funcs) then
  403.         begin
  404.         If Buf[Z] = '(' then
  405.      begin
  406.      Z := Z + 1;
  407.      Answer := Expr
  408.      end
  409.         else
  410.      begin
  411.      Write (Tab(Z-1), '^ ');
  412.      Write ('*** ''('' expected, answer ');
  413.      Writeln ('may be in error')
  414.      end;
  415.         Slough_Blanks;
  416.         If Buf[Z] = ')' then
  417.      Z := Z + 1
  418.         else
  419.      begin
  420.      Write (Tab(Z-1), '^ ');
  421.      Write ('*** '')'' expected, answer ');
  422.      Writeln ('may be in error')
  423.      end
  424.         end;
  425.     Case Func of
  426.         Logrithm    : Answer := Ln (Answer);
  427.         Exponent    : Answer := Exp (Answer);
  428.         Log         : Answer := Log10 (Answer);
  429.         Square      : Answer := Sqr (Answer);
  430.         Square_Root : Answer := Sqrt (Answer);
  431.         Factorial   : Answer := Factorl (Answer);
  432.         Cosine      : Answer := Cos (Radian(Answer));
  433.         Sine        : Answer := Sin (Radian(Answer));
  434.         ArcTangent  : Answer := ArcTan (Radian(Answer));
  435.         Tangent     : Answer := Tan (Radian(Answer));
  436.         CoTangent   : Answer := Cot (Radian(Answer));
  437.         Secant      : Answer := Sec (Radian(Answer));
  438.         CoSecant    : Answer := Cos (Radian(Answer));
  439.         ArcSine     : Answer := ArcSin (Radian(Answer));
  440.         ArcCosine   : Answer := ArcCos (Radian(Answer));
  441.         ArcCoTangent: Answer := ArcCot (Radian(Answer));
  442.         ArcSecant   : Answer := ArcSec (Radian(Answer));
  443.         ArcCoSecant : Answer := ArcCsc (Answer);
  444.         Pie         : Answer := Pi;
  445.         Radians     : Answer := Radian (Answer);
  446.  
  447.         Non_Function: begin
  448.         Write (Tab(Z-1), '^ ');
  449.         Writeln
  450.       ('*** Unknown function name')
  451.         end
  452.         end; { CASE }
  453.     Slough_Blanks
  454.     end
  455.      else
  456.     begin
  457.     Write (Tab(Z-1), '^ ');
  458.     Write ('*** Unknown Syntax, answer may ');
  459.     Writeln ('be in error')
  460.     end;
  461.   If Debug_Mode then
  462.       Writeln ('Result from FACTOR = ', Answer:20:8);
  463.   Factor := Answer
  464.   end;  { Factor }
  465.  
  466.      begin { Expon }
  467.      Answer := Factor;
  468.      Slough_Blanks;
  469.      While Buf[Z] = '^' do
  470.   begin
  471.   Z := Z + 1;
  472.   Answer := XtoY (Answer, Factor);
  473.   Slough_Blanks
  474.   end;
  475.      If Debug_Mode then
  476.   Writeln ('Result from EXPON = ', Answer:20:8);
  477.      Expon := Answer
  478.      end;  { Expon }
  479.  
  480.    begin { Term }
  481.    Answer := Expon;
  482.    Slough_Blanks;
  483.    While Buf[Z] in ['*', '/'] do
  484.   begin
  485.   If Buf[Z] = '*' then
  486.        begin
  487.        Z := Z + 1;
  488.        Answer := Answer * Expon
  489.        end
  490.   else
  491.        begin
  492.        Z := Z + 1;
  493.        Answer := Answer / Expon;
  494.        end;
  495.   Slough_Blanks
  496.   end;
  497.    If Debug_Mode then
  498.   Writeln ('Result from TERM = ', Answer:20:8);
  499.    Term := Answer
  500.    end;  { Term }
  501.  
  502.      begin { Expr }
  503.      Slough_Blanks;
  504.      Unary := 1.0;
  505.      If Buf[Z] in ['+','-'] then
  506.  begin
  507.  If Buf[Z] = '-' then
  508.      Unary := -1.0;
  509.  Z := Z + 1
  510.  end;
  511.      Answer := Unary * Term;
  512.      Slough_Blanks;
  513.      While Buf[Z] in ['+', '-'] do
  514.  begin
  515.  If Buf[Z] = '+' then
  516.      begin
  517.      Z := Z + 1;
  518.      Answer := Answer + Term
  519.      end
  520.  else
  521.      begin
  522.      Z := Z + 1;
  523.      Answer := Answer - Term
  524.      end;
  525.  Slough_Blanks
  526.  end;
  527.      If Debug_Mode then
  528.  Writeln ('Result from EXPR =', Answer:20:8);
  529.      Expr := Answer
  530.      end;  { Expr }
  531.  
  532. begin { Main }
  533. Initialize;
  534. Get_Expr;
  535. While Buf[Z] <> '$' do
  536. begin
  537.      If Buf[Z] = '?' then
  538.  Help
  539.      else
  540.  If Buf[Z] = '!' then
  541.      Debug_Mode := not Debug_Mode
  542.  else
  543.      If Buf[Z] <> '$' then
  544.   begin
  545.   Answer := Expr;
  546.   Write ('The answer is ');
  547.   Write ( Answer:9:6 );
  548.   Writeln
  549.   end;
  550.      Get_Expr
  551. end;
  552. Writeln;
  553. Writeln ('Program ended');
  554. Writeln
  555. end.
  556.