SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00069 MATH ROUTINES 1 05-28-9313:50ALL SWAG SUPPORT TEAM 3DPOINTS.PAS IMPORT 7 ₧¿ {π> Could someone please explain how to plot a 3-D points? How do you convertπ> a 3D XYZ value, to an XY value that can be plotted onto the screen?π}ππFunction x3d(x1, z1 : Integer) : Integer;πbeginπ x3d := Round(x1 - (z1 * Cos(Theta)));πend;ππFunction y3d(y1, z1 : Integer) : Integer;πbeginπ y3d := Round(y1 - (z1 * Sin(Theta)));πend;ππ{πSo a Function that plots a 3d pixel might look like this:ππProcedure plot3d(x, y, z : Integer);πbeginπ plot(x3d(x, z), y3d(y, z));πend;ππThe theta above is the angle on the screen on which your are "simulating"πyour z axis. This is simplistic, but should get you started. Just rememberπyou are simulating 3 dimensions on a 2 dimension media (the screen). Trigπhelps. ;-)π} 2 05-28-9313:50ALL SWAG SUPPORT TEAM CIRCLE3P.PAS IMPORT 28 ₧▐ Program ThreePoints_TwoPoints;π{ππ I Really appreciate ya helping me With this 3 points on aπcircle problem. The only thing is that I still can't get itπto work. I've tried the Program you gave me and it spits outπthe wrong answers. I don't know if there are parentheses in theπwrong place or what. Maybe you can find the error.π π You'll see that I've inserted True coordinates For this test.π πThank you once again...and please, when you get any more informationπon this problem...call me collect person to person or leave it on myπBBS. I get the turbo pascal echo from a California BBS and that sureπis long distance. Getting a good pascal Procedure For this isπimportant to me because I am using it in a soon to be released mathπProgram called Mr. Machinist! I've been racking my brain about thisπfor 2 weeks now and I've even been dream'in about it!π πYour help is appreciated!!!π π +π+AL+π π(716) 434-7823 Voiceπ(716) 434-1448 BBS ... if none of these, then leave Program on TP echo.π π}π πUsesπ Crt;πConstπ x1 = 4.0642982;π y1 = 0.9080732;π x2 = 1.6679862;π y2 = 2.8485684;π x3 = 4.0996421;π y3 = 0.4589868;ππVarπ Selection : Integer;πProcedure ThreePoints;πVarπ Slope1,π Slope2,π Mid1x,π Mid1y,π Mid2x,π Mid2y,π Cx,π Cy,π Radius : Real;πbeginπ ClrScr;π Writeln('3 points on a circle');π Writeln('====================');π Writeln;π Writeln('X1 -> 4.0642982');π Writeln('Y1 -> 0.9080732');π Writeln;π Writeln('X2 -> 1.6679862');π Writeln('Y2 -> 2.8485684');π Writeln('X3 -> 4.0996421');π Writeln('Y3 -> 0.4589868');π Writeln;π Slope1 := (y2 - y1) / (x2 - x1);π Slope2 := (y3 - y2) / (x3 - x2);π Mid1x := (x1 + x2) / 2;π Mid1y := (y1 + y2) / 2;π Mid2x := (x2 + x3) / 2;π Mid2y := (y2 + y3) / 2;π Slope1 := -1 * (1 / Slope1);π Slope2 := -1 * (1 / Slope2);π Cx := (Slope2 * x2 - y2 - Slope1 * x1 + y1) / (Slope1 - Slope2);π Cy := Slope1 * (Cx + x1) - y1;ππ {π I believe you missed out on using Cx and Cy in next line,π Radius := sqrt(((x1 - x2) * (x1 - x2)) + ((y1 - y2) * (y1 - y2)));π I think it should be . . .π }ππ Radius := Sqrt(Sqr((x1 - Cx) + (y1 - Cy)));π Writeln;π Writeln('X center line (Program answer) is ', Cx : 4 : 4);π Writeln('Y center line (Program answer) is ', Cy : 4 : 4);π Writeln('The radius (Program answer) is ', Radius : 4 : 4);π Writeln;π Writeln('True X center = 1.7500');π Writeln('True Y center = 0.5000');π Writeln('True Radius = 2.3500');π Writeln('Strike any key to continue . . .');π ReadKey;πend;ππProcedure Distance2Points;πVarπ x1, y1,π x2, y2,π Distance : Real;πbeginπ ClrScr;π Writeln('Distance between 2 points');π Writeln('=========================');π Writeln;π Write('X1 -> ');π Readln(x1);π Write('Y1 -> ');π Readln(y1);π Writeln;π Write('X2 -> ');π Readln(x2);π Write('Y2 -> ');π Readln(y2);π Writeln;π Writeln;π Distance := Sqrt((Sqr(x2 - x1)) + (Sqr(y2 - y1)));π Writeln('Distance between point 1 and point 2 = ', Distance : 4 : 4);π Writeln;π Writeln('Strike any key to continue . . .');ππ ReadKey;πend;ππbeginπ ClrScr;π Writeln;π Writeln;π Writeln('1) Distance between 2 points');π Writeln('2) 3 points on a circle test Program');π Writeln('0) Quit');π Writeln;π Write('Choose a menu number: ');π Readln(Selection);π Case Selection ofπ 1 : Distance2Points;π 2 : ThreePoints;π end;π ClrScr;πend.π 3 05-28-9313:50ALL SWAG SUPPORT TEAM EQUATE.PAS IMPORT 29 ₧α { Author: Gavin Peters. }ππProgram PostFixConvert;π(*π * This Program will convert a user entered expression to postfix, andπ * evaluate it simultaniously. Written by Gavin Peters, based slightlyπ * on a stack example given in Algorithms (Pascal edition), pgπ *π *)πVarπ Stack : Array[1 .. 3] of Array[0 .. 500] of LongInt;ππProcedure Push(which : Integer; p : LongInt);πbeginπ Stack[which,0] := Stack[which,0]+1;π Stack[which,Stack[which,0]] := pπend;ππFunction Pop(which : Integer) : LongInt;πbeginπ Pop := Stack[which,Stack[which,0]];π Stack[which,0] := Stack[which,0]-1πend;ππVarπ c : Char;π x,t,π bedmas : LongInt;π numbers : Boolean;ππProcedure Evaluate( ch : Char );ππ Function Power( exponent, base : LongInt ) : LongInt;π beginπ if Exponent > 0 thenπ Power := Base*Power(exponent-1, base)π ELSEπ Power := 1π end;ππbeginπ Write(ch);π if Numbers and not (ch = ' ') thenπ x := x * 10 + (Ord(c) - Ord('0'))π ELSEπ beginπ Case ch OFπ '*' : x := pop(2)*pop(2);π '+' : x := pop(2)+pop(2);π '-' : x := pop(2)-pop(2);π '/' : x := pop(2) div pop(2);π '%' : x := pop(2) MOD pop(2);π '^' : x := Power(pop(2),pop(2));π 'L' : x := pop(2) SHL pop(2);π 'R' : x := pop(2) SHR pop(2);π '|' : x := pop(2) or pop(2);π '&' : x := pop(2) and pop(2);π '$' : x := pop(2) xor pop(2);π '=' : if pop(2) = pop(2) thenπ x := 1π elseπ x := 0;π '>' : if pop(2) > pop(2) thenπ x := 1π elseπ x := 0;π '<' : if pop(2) < pop(2) thenπ x := 1π elseπ x := 0;π '0','1'..'9' :π beginπ Numbers := True;π x := Ord(c) - Ord('0');π Exitπ end;π ' ' : if not Numbers thenπ Exit;π end;ππ Numbers := False;π Push(2,x);π end;πend;ππbeginπ Writeln('Gavin''s calculator, version 1.00');π Writeln;π For x := 1 to 3 DOπ Stack[x, 0] := 0;π x := 0;π numbers := False;π Bedmas := 50;π Writeln('Enter an expression in infix:');π Repeatπ Read(c);π Case c OFπ ')' :π beginπ Bedmas := Pop(3);π Evaluate(' ');π Evaluate(Chr(pop(1)));π end;ππ '^','%','+','-','*','/','L','R','|','&','$','=','<','>' :π beginπ t := bedmas;π Case c Ofππ '>','<' : bedmas := 3;π '|','$',π '+','-' : bedmas := 2;π '%','L','R','&',π '*','/' : bedmas := 1;π '^' : bedmas := 0;π end;π if t <= bedmas thenπ beginπ Evaluate(' ');π Evaluate(Chr(pop(1)));π end;π Push(1,ord(c));π Evaluate(' ');π end;π '(' :π beginπ Push(3,bedmas);π bedmas := 50;π end;π '0','1'..'9' : Evaluate(c);π end;ππ Until Eoln;ππ While Stack[1,0] <> 0 DOπ beginπ Evaluate(' ');π Evaluate(Chr(pop(1)));π end;π Evaluate(' ');π Writeln;π Writeln;π Writeln('The result is ',Pop(2));πend.ππ{πThat's it, all. This is an evaluator, like Reuben's, With a fewπmore features, and it's shorter.ππOkay, there it is (the above comment was in the original post). I'veπnever tried it, but it looks good. :-) BTW, if it does work you mightπwant to thank Gavin Peters... after all, he wrote it. I was justπinterested when I saw it, and stored it along With a bunch of otherπsource-code tidbits I've git here...π}π 4 05-28-9313:50ALL SWAG SUPPORT TEAM FIBONACC.PAS IMPORT 5 ₧≤½ {π>The problem is to Write a recursive Program to calculate Fibonacci numbers.π>The rules For the Fibonacci numbers are:π>π> The Nth Fib number is:π>π> 1 if N = 1 or 2π> The sum of the previous two numbers in the series if N > 2π> N must always be > 0.π}ππFunction fib(n : LongInt) : LongInt;πbeginπ if n < 2 thenπ fib := nπ elseπ fib := fib(n - 1) + fib(n - 2);πend;ππVarπ Count : Integer;ππbeginπ Writeln('Fib: ');π For Count := 1 to 15 doπ Write(Fib(Count),', ');πend. 5 05-28-9313:50ALL SWAG SUPPORT TEAM GAUSS.PAS IMPORT 121 ₧áÑ Program Gauss_Elimination;ππUses Crt,Printer;ππ(***************************************************************************)π(* STEPHEN ABRAHAM *)π(* MCEN 3030 Comp METHODS *)π(* ASSGN #3 *)π(* DUE: 2-12-93 *)π(* *)π(* GAUSS ELIMinATION (TURBO PASCAL VERSION by STEPHEN ABRAHAM) *)π(* *)π(***************************************************************************)π{ }π{ }π{------------------VarIABLE DECLARATION and DEFinITIONS--------------------}ππConstπ MAXROW = 50; (* Maximum # of rows in a matrix *)π MAXCOL = 50; (* Maximum # of columns in a matrix *)ππTypeπ Mat_Array = Array[1..MAXROW,1..MAXCOL] of Real; (* 2-D Matrix of Reals *)π Col_Array = Array[1..MAXCOL] of Real; (* 1-D Matrix of Real numbers *)π Int_Array = Array[1..MAXCOL] of Integer; (* 1-D Matrix of Integers *)ππVarπ N_EQNS : Integer; (* User Input : Number of equations in system *)π COEFF_MAT : Mat_Array; (* User Input : Coefficient Matrix of system *)π COL_MAT : Col_Array; (* User Input : Column matrix of Constants *)π X_MAT : Col_Array; (* OutPut : Solution matrix For unknowns *)π orDER_VECT : Int_Array; (* Defined to pivot rows where necessary *)π SCALE_VECT : Col_Array; (* Defined to divide by largest element in *)π (* row For normalizing effect *)π I,J,K : Integer; (* Loop control and Array subscripts *)π Ans : Char; (* Yes/No response to check inputted matrix *)πππ{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}ππππ{^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^}π{>>>>>>>>>>>>>>>>>>>>>>>>> ProcedureS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<}π{...........................................................................}πππProcedure Home; (* clears screen and positions cursor at (1,1) *)πbeginπ ClrScr;π GotoXY(1,1);πend; (* Procedure Home *)ππ{---------------------------------------------------------------------------}πππProcedure Instruct; (* provides user instructions if wanted *)ππVarπ Ans : Char; (* Yes/No answer by user For instructions or not *)ππbeginπ Home; (* calls Home Procedure *)π GotoXY(22,8); Writeln('STEVE`S GAUSSIAN ELIMinATION Program');π GotoXY(36,10); Writeln('2-12-92');π GotoXY(31,18); Write('Instructions(Y/N):');π GotoXY(31,49); readln(Ans);π if Ans in ['Y','y'] thenπ beginπ Home; (* calls Home Procedure *)π Writeln(' Welcome to Steve`s Gaussian elimination Program. With this');π Writeln('Program you will be able to enter the augmented matrix of ');π Writeln('your system of liNear equations and have returned to you the ');π Writeln('solutions For each unknown. The Computer will ask you to ');π Writeln('input the number of equations in your system and will then ');π Writeln('have you input your coefficient matrix and then your column ');π Writeln('matrix. Please remember For n unknowns, you will need to ');π Writeln('have n equations. ThereFore you should be entering a square ');π Writeln('(nxn) coefficient matrix. Have FUN!!!! ');π Writeln('(hit <enter> to continue...)'); (* Delay *)π readln;π end;πend;πππ{---------------------------------------------------------------------------}πππProcedure Initialize_Array( Var Coeff_Mat : Mat_Array ;π Var Col_Mat,X_Mat, Scale_Vect : Col_Array;π Var order_Vect : Int_Array);ππ(*** This Procedure initializes all matrices to be used in Program ***)π(*** ON ENTRY : Matrices have undefined values in them ***)π(*** ON Exit : All Matrices are zero matrices ***)πππConstπ MAXROW = 50; { maximum # of rows in matrix }π MAXCOL = 50; { maximum # of columns in matrix }ππVarπ I : Integer; { I & J are both loop control and Array subscripts }π J : Integer;ππbeginπ For I := 1 to MaxRow do { row indices }π beginπ Col_Mat[I] := 0;π X_Mat[I] := 0;π order_Vect[I] := 0;π Scale_Vect[I] := 0;π For J := 1 to MaxCol do { column indices }π Coeff_Mat[I,J] := 0;π end;πend; (* Procedure initialize_Array *)πππ{---------------------------------------------------------------------------}ππProcedure Input(Var N : Integer;π Var Coeff_Mat1 : Mat_Array;π Var Col_Mat1 : Col_Array);ππ(*** This Procedure lets the user input the number of equations and the ***)π(*** augmented matrix of their system of equations ***)π(*** ON ENTRY : N => number of equations : UNDEFinEDπ Coeff_Mat1 => coefficient matrix : UNDEFinEDπ Col_Mat1 => column matrix :UNDEFinEDπ ON Exit : N => # of equations input by userπ Coeff_Mat1 => defined coefficient matrixπ Col_Mat1 => defined column matrix input by user ***)ππππVarπ I,J : Integer; (* loop control and Array indices *)ππbeginπ Home; (* calls Procedure Home *)π Write('Enter the number of equations in your system: ');π readln(N);π Writeln;π Writeln('Now you will enter your coefficient and column matrix:');π For I := 1 to N do { row indice }π beginπ Writeln('ROW #',I);π For J := 1 to N do {column indice }π beginπ Write('a(',I,',',J,'):');π readln(Coeff_Mat1[I,J]); {input of coefficient matrix}π end;π Write('c(',I,'):');π readln(Col_Mat1[I]); {input of Constant matrix}π end;π readln;πend; (* Procedure Input *)πππ{---------------------------------------------------------------------------}πππProcedure Check_Input( Coeff_Mat1 : Mat_Array;π N : Integer; Var Ans : Char);ππ(*** This Procedure displays the user's input matrix and asks if it is ***)π(*** correct. ***)π(*** ON ENTRY : Coeff_Mat1 => inputted matrixπ N => inputted number of equationsπ Ans => UNDEFinED ***)π(*** ON Exit : Coeff_Mat1 => n/aπ N => n/aπ Ans => Y,y or N,n ***)πππVarπ I,J : Integer; (* loop control and Array indices *)ππbeginπ Home; (* calls Home Procedure *)π Writeln; Writeln('Your inputted augmented matrix is:');Writeln;Writeln;ππ For I := 1 to N do { row indice }π beginπ For J := 1 to N do { column indice }π Write(Coeff_Mat[I,J]:12:4);π Writeln(Col_Mat[I]:12:4);π end;π Writeln; Write('Is this your desired matrix?(Y/N):'); (* Gets Answer *)π readln(Ans);πend; (* Procedure Check_Input *)πππ{---------------------------------------------------------------------------}πππProcedure order(Var Scale_Vect1 : Col_Array;π Var order_Vect1 : Int_Array;π Var Coeff_Mat1 : Mat_Array;π N : Integer);ππ(*** This Procedure finds the order and scaling value For each row of theπ inputted coefficient matrix. ***)π(*** ON ENTRY : Scale_Vect1 => UNDEFinEDπ order_Vect1 => UNDEFinEDπ Coeff_Mat1 => as inputtedπ N => # of equationsπ ON Exit : Scale_Vect1 => contains highest value For each row of theπ coefficient matrixπ order_Vect1 => is assigned the row number of each row fromπ the coefficient matrix in orderπ Coeff_Mat => n/aπ N => n/a ***)πππVarπ I,J : Integer; {loop control and Array indices}ππbeginπFor I := 1 to N doπ beginπ order_Vect1[I] := I; (* ordervect gets the row number of each row *)π Scale_Vect1[I] := Abs(Coeff_Mat1[I,1]); (* gets the first number of each row *)π For J := 2 to N do { goes through the columns }π begin (* Compares values in each row of the coefficient matrix andπ stores this value in scale_vect[i] *)π if Abs(Coeff_Mat1[I,J]) > Scale_Vect1[I] thenπ Scale_Vect1[I] := Abs(Coeff_Mat1[I,J]);π end;π end;πend; (* Procedure order *)πππ{---------------------------------------------------------------------------}πππProcedure Pivot(Var Scale_Vect1 : Col_Array;π Coeff_Mat1 : Mat_Array;π Var order_Vect1 : Int_Array;π K,N : Integer);ππ(*** This Procedure finds the largest number in each column after it has beenπ scaled and Compares it With the number in the corresponding diagonalπ position. For example, in column one, a(1,1) is divided by the scalingπ factor of row one. then each value in the matrix that is in column oneπ is divided by its own row's scaling vector and Compared With theπ position above it. So a(1,1)/scalevect[1] is Compared to a[2,1]/scalevect[2]π and which ever is greater has its row number stored as pivot. Once theπ highest value For a column is found, rows will be switched so that theπ leading position has the highest possible value after being scaled. ***)ππ(*** ON ENTRY : Scale_Vect1 => the normalizing value of each rowπ Coeff_Mat1 => the inputted coefficient matrixπ order_Vect1 => the row number of each row in original orderπ K => passed in from the eliminate Procedureπ N => number of equationsπ ON Exit : Scale_Vect => sameπ Coeff_Mat1 => sameπ order_Vect => contains the row number With highest scaledπ valueπ k => n/aπ N => n/a ***)ππVarπ I : Integer; {loop control and Array indice }π Pivot, Idum : Integer; {holds temporary values For pivoting }π Big,Dummy : Real; {used to Compare values of each column }πbeginπ Pivot := K;π Big := Abs(Coeff_Mat1[order_Vect1[K],K]/Scale_Vect1[order_Vect1[K]]);π For I := K+1 to N doπ beginπ Dummy := Abs(Coeff_Mat1[order_Vect1[I],K]/Scale_Vect1[order_Vect1[I]]);π if Dummy > Big thenπ beginπ Big := Dummy;π Pivot := I;π end;π end;π Idum := order_Vect1[Pivot]; { switching routine }π order_Vect1[Pivot] := order_Vect1[K];π order_Vect1[K] := Idum;πend; { Procedure pivot }πππ{---------------------------------------------------------------------------}ππProcedure Eliminate(Var Col_Mat1, Scale_Vect1 : Col_Array;π Var Coeff_Mat1 : Mat_Array;π Var order_Vect1 : Int_Array;π N : Integer);πππVarπ I,J,K : Integer;π Factor : Real;ππbeginπ For K := 1 to N-1 doπ beginπ Pivot (Scale_Vect1,Coeff_Mat1,order_Vect1,K,N);π For I := K+1 to N doπ beginπ Factor := Coeff_Mat1[order_Vect1[I],K]/Coeff_Mat1[order_Vect1[K],K];π For J := K+1 to N doπ beginπ Coeff_Mat1[order_Vect1[I],J] := Coeff_Mat1[order_Vect1[I],J] -π Factor*Coeff_Mat1[order_Vect1[K],J];π end;π Col_Mat1[order_Vect1[I]] := Col_Mat1[order_Vect1[I]] - Factor*Col_Mat1[order_Vect1[K]];π end;π end;πend;πππ{---------------------------------------------------------------------------}πππProcedure Substitute(Var Col_Mat1, X_Mat1 : Col_Array;π Coeff_Mat1 : Mat_Array;π Var order_Vect1 : Int_Array;π N : Integer);ππ(*** This Procedure will backsubstitute to find the solutions to yourπ system of liNear equations.π ON ENTRY : Col_Mat => your modified Constant column matrixπ X_Mat1 => UNDEFinEDπ Coeff_Mat1 => modified into upper triangular matrixπ order_Vect => contains the order of your rowsπ N => number of equationsπ ON Exit : Col_Mat => n/aπ X_MAt1 => your solutions !!!!!!!!!!!!!π Coeff_Mat1 => n/aπ order_Vect1 => who caresπ N => n/a ***)πππVarπ I, J : Integer; (* loop and indice of Array control *)π Sum : Real; (* used to sum each row's elements *)ππbeginπ X_Mat1[N] := Col_Mat1[order_Vect1[N]]/Coeff_Mat1[order_Vect1[N],N];π (***** This gives you the value of x[n] *********)ππ For I := N-1 downto 1 doπ beginπ Sum := 0.0;π For J := I+1 to N doπ Sum := Sum + Coeff_Mat1[order_Vect1[I],J]*X_Mat1[J];π X_Mat1[I] := (Col_Mat1[order_Vect1[I]] - Sum)/Coeff_Mat1[order_Vect1[I],I];π end;πend; (** Procedure substitute **)πππ{---------------------------------------------------------------------------}πππProcedure Output(X_Mat1: Col_Array; N : Integer);ππ(*** This Procedure outputs the solutions to the inputted system of ***)π(*** equations ***)π(*** ON ENTRY : X_Mat1 => the solutions to the system of equationsπ N => the number of equationsπ ON Exit : X_Mat1 => n/aπ N => n/a ***)πππVarπ I : Integer; (* loop control and Array indice *)ππbeginπ Writeln;Writeln;Writeln; (* skips lines *)π Writeln('The solutions to your sytem of equations are:');π For I := 1 to N doπ Writeln('X(',I,') := ',X_Mat1[I]);πend; (* Procedure /output *)ππππ{---------------------------------------------------------------------------}π(* *)π(* *)π(* *)π(***************************************************************************)ππbeginππ Repeatπ Instruct; (* calls Procedure Instruct *)π Initialize_Array(Coeff_Mat, Col_Mat, X_Mat, Scale_Vect, order_Vect);π (* calls Procedure Initialize_Array *)π Repeatπ Input(N_EQNS, Coeff_Mat, Col_Mat); (* calls Procedure Input *)π Check_Input(Coeff_Mat,N_EQNS,Ans); (* calls Procedure check_Input *)π Until Ans in ['Y','y']; (* loops Until user inputs correct matrix *)ππ order(Scale_Vect,order_Vect,Coeff_Mat,N_EQNS); (* calls Procedure order *)π Eliminate(Col_Mat,Scale_Vect,Coeff_Mat,order_Vect,N_EQNS); (*etc..*)π Substitute(Col_Mat,X_Mat,Coeff_Mat,order_Vect,N_EQNS); (*etc..*)π Output(X_Mat,N_EQNS); (*etc..*)ππ Writeln;π Write('Do you wish to solve another system of equations?(Y/N):');π readln(Ans);π Until Ans in ['N','n'];πππend. (*************** end of Program GAUSS_ELIMinATION *******************)π 6 05-28-9313:50ALL SWAG SUPPORT TEAM GCD.PAS IMPORT 3 ₧ {Greatest common divisor}πProgram GCD;ππVarπ x, y : Integer;ππbeginπ read(x);ππ While x <> 0 doπ beginπ read(y);ππ While x <> y doπ if x > y thenπ x := x - yπ elseπ y := y - x;ππ Write(x);π read(x);ππ end;πend.π 7 05-28-9313:50ALL SWAG SUPPORT TEAM LOGRITHM.PAS IMPORT 2 ₧╩ Function NlogX(X: Real; N:Real): Real;ππbeginπ NlogX = Ln(X) / Ln(N);πend;ππ 8 05-28-9313:50ALL SWAG SUPPORT TEAM MATHSPD.PAS IMPORT 10 ₧Vm {π> I was just wondering how to speed up some math-intensiveπ> routines I've got here. For example, I've got a Functionπ> that returns the distance between two Objects:ππ> Function Dist(X1,Y1,X2,Y2 : Integer) : Real;π> beginπ> Dist := Round(Sqrt(Sqr(X1-X2)+Sqr(Y1-Y2)));π> end;ππ> This is way to slow. I know assembly can speed it up, butπ> I know nothing about as. so theres the problem. Pleaseπ> help me out, any and all source/suggestions welcome!ππX1, Y1, X2, Y2 are all Integers. Integer math is faster than Real (justπabout anything is). Sqr and Sqrt are not Integer Functions. Try forπfun...π}ππFunction Dist( X1, Y1, X2, Y2 : Integer) : Real;πVarπ XTemp,π YTemp : Integer;π{ the allocation of these takes time. if you don't want that time taken,π make them global With care}πbeginπ XTemp := X1 - X2;π YTemp := Y1 - Y2;π Dist := Sqrt(XTemp * XTemp + YTemp * YTemp);πend;ππ{πif you have a math coprocessor or a 486dx, try using DOUBLE instead ofπReal, and make sure your compiler is set to compile For 287 (or 387).π}ππbeginπ Writeln('Distance Between (3,9) and (-2,-3) is: ', Dist(3,9,-2,-3) : 6 : 2);πend. 9 05-28-9313:50ALL SWAG SUPPORT TEAM PARSMATH.PAS IMPORT 19 ₧`┼ │I'm writing a Program that draws equations. It's fairly easy if you putπ│the equation in a pascal Variable like Y := (X+10) * 2, but I would likeπ│the user to enter the equation, but I don't see any possible way to doπ│it.πππ ...One way of doing it is by using an "expression trees". Supposeπyou have the equation Y := 20 ÷ 2 + 3. In this equation, you can representπthe expression 20 ÷ 2 + 3 by using "full" binary trees as such:πππfigure 1 a ┌─┐π │+│ <----- root of your expressionπ └─┘π b / \π ┌─┐ ┌─┐ eπ │÷│ │3│π └─┘ └─┘π / \π c ┌──┐ ┌─┐ dπ │20│ │2│π └──┘ └─┘πππ(Note: a "leaf" is a node With no left or right children - ie: a value )ππ...The above expression are called infix arithmetic expressions; theπoperators are written in between the things on which they operate.ππIn our example, the nodes are visited in the order c, d, b, e, a, andπtheir Labels in this order are 20, 2, ÷, 3, +.πππFunction Evaluate(p: node): Integer;π{ return value of the expression represented by the tree With root p }π{ p - points to the root of the expression tree }πVarπ T1, T2: Integer;π op: Char;πbeginπ if (p^.left = nil) and (p^.right = nil) then { node is a "leaf" }π Evaluate := (p^.Value) { simple Case }π elseπ beginπ T1 := Evaluate(p^.Left);π T2 := Evaluate(p^.Right);π op := p^.Label;π { apply operation }π Case op ofπ '+': Evaluate := (T1 + T2);π '-': Evaluate := (T1 - T2);π '÷': Evaluate := (T1 div T2);π '*': Evaluate := (T1 * T2);π end;π endπend;πππ...Thus, using figure 1, we have:ππ ┌── ┌──π │ │ Evaluate(c) = 20π │ Evaluate(b) │ Evaluate(d) = 2π │ │ ApplyOp('÷',20,2) = 10π Evaluate(a)│ └──π │ Evaluate(e) = 3π │π │ ApplyOp('+',10,3) = 13π └─π 10 05-28-9313:50ALL SWAG SUPPORT TEAM PERMUTA1.PAS IMPORT 8 ₧╘∙ {π> Does anyone have an idea to perform permutations With pascal 7.0 ?π> As an example finding the number of 5 card hands from a total of 52 cards.π> Any help would be greatly appreciated.ππThis Program should work fine. I tested it a few times and it seemed to work.πIt lets you call the Functions For permutation and combination just as youπwould Write them: P(n,r) and C(n,r).π}ππ{$E+,N+}πProgram CombPerm;ππVarπ Result:Extended;πFunction Factorial(Num: Integer): Extended;πVarπ Counter: Integer;π Total: Extended;πbeginπ Total:=1;π For Counter:=2 to Num doπ Total:=Total * Counter;π Factorial:=Total;πend;ππFunction P(N: Integer; R: Integer): Extended;πbeginπ P:=Factorial(N)/Factorial(N-R);πend;ππFunction C(N: Integer; R: Integer): Extended;πbeginπ C:=Factorial(N)/(Factorial(N-R)*Factorial(R));πend;ππbeginπ Writeln(P(52,5));πend. 11 05-28-9313:50ALL SWAG SUPPORT TEAM PERMUTA2.PAS IMPORT 18 ₧n┴ {πI'm working on some statistical process control Charts and amπlearning/using Pascal. The current Chart Uses permutations andπI have been successful in determing the number of combinationsπpossible, but I want to be able to choose a few of those possibleπcombinations at random For testing purposes.ππThrough some trial and error, I've written the following Programπwhich calculates the number of possible combinations of x digitsπwith a certain number of digits in each combination. For exampleπa set of 12 numbers With 6 digits in each combination gives anπanswer of 924 possible combinations. After all that, here is theπquestion: Is there a Formula which would calculate what those 924πcombinations are? (ie: 1,2,3,4,5,6 then 1,2,3,4,5,7 then 1,2,3,4,5,8π... 1,2,3,4,5,12 and so on? Any help would be appreciated and anyπcriticism will be accepted.π}ππProgram permutations;ππUses Crt;ππType hold_em_here = Array[1..15] of Integer;ππVar numbers,combs,bot2a : Integer;π ans,top,bot1,bot2b : Real;π hold_Array : hold_em_here;ππFunction permutate_this(number1 : Integer) : Real;πVar i : Integer;π a : Real;πbeginπ a := number1;π For i := (number1 - 1) doWNto 1 do a := a * i;π permutate_this := a;πend;ππProcedure input_numbers(Var hold_Array : hold_em_here; counter : Integer);πVar i,j : Integer;πbeginπ For i := 1 to counter do beginπ Write(' Input #',i:2,': ');π READLN(j);π hold_Array[i] := j;π end;πend;ππProcedure show_numbers(hold_Array : hold_em_here; counter : Integer);πVar i,j : Integer;πbeginπ WriteLN;π Write('Array looks like this: ');π For i := 1 to counter do Write(hold_Array[i]:3);π WriteLNπend;ππbeginπ ClrScr;π WriteLN;π WriteLN(' Permutations');π WriteLN;π Write(' Enter number of digits (1-15): ');π READLN(numbers);π Write('Enter number in combination (2-10): ');π READLN(combs);π top := permutate_this(numbers);π bot1 := permutate_this(combs);π bot2a := numbers - combs;π bot2b := permutate_this(bot2a);π ans := top/(bot1*bot2b);π WriteLN(' total permutations For above is: ',ans:3:0);π WriteLN;π input_numbers(hold_Array,numbers);π show_numbers(hold_Array,numbers);πEND. 12 05-28-9313:50ALL SWAG SUPPORT TEAM PERMUTA3.PAS IMPORT 25 ₧} {π> I want to create all permutations.ππ Okay. I should have first asked if you Really mean permutaions.π Permutations mean possible orders. I seem to recall your orginal messageπ had to do With card hands. They usually involve combinations, notπ permutations. For example, all possible poker hands are the COMBinATIONSπ of 52 cards taken 5 at a time. Bridge hands are the combinations of 52π cards taken 13 at a time. if you master the following Program, you shouldπ be able to figure out how to create all combinations instead ofπ permutations.ππ However, if you mean permutations, here is an example Program to produceπ permutations. (You will have to alter it to your initial conditions.) Itπ involves a recursive process (a process which Uses itself). Recursiveπ processes are a little dangerous. It is easy to step on your ownπ privates writing them. They also can use a lot of stack memory. Youπ ought to be able to take the same general methods to produceπ combinations instead of permutations if need be.ππ I suggest you Compile and run the Program and see all the permutationsπ appear on the screen beFore reading further. (BTW, counts permutationsπ as well as producing them and prints out the count at the end.)ππ The Procedure Permut below rotates all possible items into the firstπ Array position. For each rotation it matches the item With all possibleπ permutations of the remaining positions. Permut does this by callingπ Permut For the Array of remaining positions, which is now one itemπ smaller. When the remaining Array is down to one position, only oneπ permutaion is possible, so the current Array is written out as one ofπ the results.ππ Once you get such a Program working, it is theoretically possible toπ convert any recursive Program to a non-recursive one. This often runsπ faster. Sometimes the conversion is not easy, however.ππ One final caution. The following Program Writes to the screen. You willπ see that as the number of items increases, the amount of outputπ increases tremendously. if you were to alter the Program to Writeπ results to a File and to allow more than 9 items, you could easilyπ create a File as big as your hard drive.π}ππProgram Permutes;ππUsesπ Crt;ππTypeπ TArry = Array[1..9] of Byte;ππVarπ Arry : TArry;π Size,X : Word;π NumbofPermutaions : LongInt;ππProcedure Permut(Arry : TArry; Position,Size : Word);πVarπ I,J : Word;π Swap: Byte;πbeginπ if Position = Size thenπ{ beginπ For I := 1 to Size doπ Write(Arry[I]:1);π} inc(NumbofPermutaions)π{ Writelnπ endπ} elseπ beginπ For J := Position to Size doπ beginπ Swap := Arry[J];π Arry[J] := Arry[Position];π Arry[Position] := Swap;π Permut(Arry,Position+1,Size)π endπ endπend;ππbeginπ ClrScr;π Write('How many elements (1 to 9)? ');π readln(Size);π ClrScr;π For X := 1 to Size doπ Arry[X] := X; {put item values in Array}π NumbofPermutaions := 0;π Permut(Arry,1,Size);π Writeln;π Writeln('Number of permutations = ',NumbofPermutaions);π Writeln('Press <Enter> to Exit.');π readlnπend.π 13 05-28-9313:50ALL SWAG SUPPORT TEAM PERMUTA4.PAS IMPORT 5 ₧╘∙ {π> Does anyone have an idea to perForm permutations With pascal 7.0 ?π> As an example finding the number of 5 card hands from a total of 52 carπ> Any help would be greatly appreciated.ππ}ππFunction Permutation(things, atatime : Word) : LongInt;πVarπ i : Word;π temp : LongInt;πbeginπ temp := 1;π For i := 1 to atatime doπ beginπ temp := temp * things;π dec(things);π end;π Permutation := temp;πend;ππbeginπ Writeln('7p7 = ',Permutation(7,7));πend. 14 05-28-9313:50ALL SWAG SUPPORT TEAM PERMUTA5.PAS IMPORT 11 ₧ {π>it. While I'm at it, does anyone have any ideas For an algorithm to generateπ>and test all possible combinations of a group of letters For Real Words.ππI'm sure it wouldn't take long to modify this Program I wrote, whichπproduces all combinations of "n" numbers.ππI got the idea from "Algorithms", by Robert Sedgewick. Recommended.π}πProgram ShowPerms;ππUsesπ Crt;ππConstπ digits = 4; {How many digits to permute: n digits = n! perms!}ππVarπ PermArray : Array [1..digits] of Byte; {Permutation holder}π ThisDigit : Integer;ππProcedure WritePerm;πVarπ loop : Byte;πbeginπ For loop := 1 to 4 doπ Write(PermArray[loop]);π Writeln;πend;ππProcedure PermuteAtLevel(Level : Integer);πVarπ loop : Integer;ππbeginπ inc(ThisDigit);π PermArray[Level] := ThisDigit;π if ThisDigit = digits thenπ Writeperm; {if we've accounted For all digits}π For loop := 1 to digits doπ if PermArray[loop] = 0 thenπ PermuteAtLevel(loop);π dec(ThisDigit);π PermArray[Level] := 0;πend;ππbeginπ ClrScr;π ThisDigit := -1; {Left of Left-hand-side}π FillChar (PermArray, sizeof(PermArray),#0); {Make it zeroes}π PermuteAtLevel(0); {Start at the bottom}πend.π- 15 05-28-9313:50ALL SWAG SUPPORT TEAM PI1.PAS IMPORT 13 ₧5▐ {$N+}ππProgram CalcPI(input, output);ππ{ Not the most efficient Program I've ever written. Mostly it's quick andπ dirty. The infinite series is very effective converging very quickly.π It's much better than Pi/4 = 1 - 1/3 + 1/5 - 1/7 ... which convergesπ like molasses. }ππ{ Pi / 4 = 4 * (1/5 - 1/(3*5^3) + 1/(5*5^5) - 1/(7*5^7) + ...) -π (1/239 - 1/(3*239^3) + 1/(5*239^5) - 1/(7*239^7) + ...) }ππ{* Infinite series courtesy of Machin (1680 - 1752). I found it in myπ copy of Mathematics and the Imagination by Edward Kasner andπ James R. Newman (Simon and Schuster, New York 1940, p. 77) * }ππUsesπ Crt;πππVarπ Pi_Fourths,π Pi : Double;π Temp : Double;π ct : Integer;π num : Integer;πππFunction Power(Number, Exponent : Integer) : double;πVarπ ct : Integer;π temp : double;ππbeginπ temp := 1.00;π For ct := 1 to Exponent DOπ temp := temp * number;π Power := tempπend;ππbeginπ ClrScr;π ct := 1;π num := 1;π Pi_Fourths := 0;ππ While ct < 15 DOπ beginπ Temp := (1.0 / (Power(5, num) * num)) * 4;ππ if ct MOD 2 = 1 thenπ Pi_Fourths := Pi_Fourths + Tempπ ELSEπ Pi_Fourths := Pi_Fourths - Temp;ππ Temp := 1.0 / (Power(239, num) * num);ππ if ct MOD 2 = 1 thenπ Pi_Fourths := Pi_Fourths - Tempπ ELSEπ Pi_Fourths := Pi_Fourths + Temp;ππ ct := ct + 1;π num := num + 2;π end;ππ Pi := Pi_Fourths * 4.0;π Writeln( 'PI = ', Pi);πend.π 16 05-28-9313:50ALL SWAG SUPPORT TEAM PI2.PAS IMPORT 26 ₧┤║ {π Here's a good (but a little slow) Program to calculate theπ decimals of Pi :πππTHIS Program CompUTES THE DIGITS of PI USinG THE ARCTANGENT ForMULAπ(1) PI/4 = 4 ARCTAN 1/5 - ARCTAN 1/239πin CONJUNCTION With THE GREGorY SERIESππ(2) ARCTAN X = SUM (-1)^N*(2N + 1)^-1*X^(2N+1) N=0 to inFinITY.ππSUBSTITUTinG into (2) A FEW VALUES of N and NESTinG WE HAVE,ππPI/4 = 1/5[4/1 + 1/25[-4/3 + 1/25[4/5 + 1/25[-4/7 + ...].].]ππ - 1/239[1/1 + 1/239^2[-1/3 + 1/239^2[1/5 + 1/239^2[-1/7 +...].].]ππUSinG THE LONG divISION ALGorITHM, THIS ( NESTED ) inFinITE SERIES CAN BEπUSED to CALCULATE PI to A LARGE NUMBER of DECIMAL PLACES in A REASONABLEπAMOUNT of TIME. A TIME Function IS inCLUDED to SHOW HOW SLOW THinGSπGET WHEN N IS LARGE. IMPROVEMENTS CAN BE MADE BY CHANGinG THE SIZE ofπTHE Array ELEMENTS HOWEVER IT GETS A BIT TRICKY.ππ}ππUsesπ Crt;ππVarπ B,C,V,P1,S,K,N,I,J,Q,M,M1,X,R,D : Integer;π P,A,T : Array[0..5000] of Integer;ππConst F1=5;πConst F2=239;πProcedure divIDE(D : Integer);π beginπ R:=0;π For J:=0 to M doπ beginπ V:= R*10+P[J];π Q:=V div D;π R:=V Mod D;π P[J]:=Q;π end;πend;πProcedure divIDEA(D : Integer);π beginπ R:=0;π For J:=0 to M doπ beginπ V:= R*10+A[J];π Q:=V div D;π R:=V Mod D;π A[J]:=Q;π end;π end;πProcedure SUBT;πbeginπB:=0;πFor J:=M Downto 0 doπ if T[J]>=A[J] then T[J]:=T[J]-A[J] elseπ beginπ T[J]:=10+T[J]-A[J];π T[J-1]:=T[J-1]-1;π end;πFor J:=0 to M doπA[J]:=T[J];πend;πProcedure SUBA;πbeginπFor J:=M Downto 0 doπ if P[J]>=A[J] then P[J]:=P[J]-A[J] elseπ beginπ P[J]:=10+P[J]-A[J];π P[J-1]:=P[J-1]-1;π end;πFor J:= M Downto 0 doπA[J]:=P[J];πend;πProcedure CLEARP;π beginπ For J:=0 to M doπ P[J]:=0;π end;πProcedure ADJUST;πbeginπP[0]:=3;πP[M]:=10;πFor J:=1 to M-1 doπP[J]:=9;πend;ππProcedure ADJUST2;πbeginπP[0]:=0;πP[M]:=10;πFor J:=1 to M-1 doπP[J]:=9;πend;ππProcedure MULT4;π beginπ C:=0;π For J:=M Downto 0 doπ beginπ P1:=4*A[J]+C;π A[J]:=P1 Mod 10;π C:=P1 div 10;π end;π end;ππProcedure SAVEA;πbeginπFor J:=0 to M doπT[J]:=A[J];πend;ππProcedure TERM1;πbeginπ I:=M+M+1;π A[0]:=4;πdivIDEA(I*25);πWhile I>3 doπbeginπI:=I-2;πCLEARP;πP[0]:=4;πdivIDE(I);πSUBA;πdivIDEA(25);πend;πCLEARP;πADJUST;πSUBA;πdivIDEA(5);πSAVEA;πend;πProcedure TERM2;πbeginπ I:=M+M+1;π A[0]:=1;πdivIDEA(I);πdivIDEA(239);πdivIDEA(239);πWhile I>3 doπbeginπI:=I-2;πCLEARP;πP[0]:=1;πdivIDE(I);πSUBA;πdivIDEA(239);πdivIDEA(239);πend;πCLEARP;πADJUST2;πSUBA;πdivIDEA(239);πSUBT;πend;ππ{MAin Program}ππ beginπ ClrScr;π WriteLn(' THE CompUTATION of PI');π WriteLn(' -----------------------------');π WriteLn('inPUT NO. DECIMAL PLACES');π READLN(M1);π M:=M1+4;π For J:=0 to M doπ beginπ A[J]:=0;π T[J]:=0;π end;π TERM1;π TERM2;π MULT4;π WriteLn;WriteLn;π Write('PI = 3.');π For J:=1 to M1 doπ beginπ Write(A[J]);π if J Mod 5 =0 then Write(' ');π if J Mod 50=0 then Write(' ');π end;π WriteLn;WriteLn;π WriteLn;πend.π 17 05-28-9313:50ALL SWAG SUPPORT TEAM PRIMES1.PAS IMPORT 12 ₧├~ {πSAM HASINOFFππLoopNum forget who first asked this question, but here is some code to helpπyou find your prime numbers in its entirety (tested):π}ππUsesπ Crt;ππLabelπ get_out;πVarπ LoopNum,π Count,π MinPrime,π MaxPrime,π PrimeCount : Integer;π Prime : Boolean;π max : String[20];π ECode : Integer;πbeginπ minprime := 0;π maxprime := 0;ππ ClrScr;π Write('Lower limit For prime number search [1]: ');π readln(max);π val(max, minprime, ECode);ππ if (minprime < 1) thenπ minprime := 1;π Repeatπ GotoXY(1, 2);π ClrEol;π Write('Upper limit: ');π readln(max);π val(max, maxprime, ECode);π Until (maxprime > minprime);ππ WriteLn;π PrimeCount := 0;ππ For LoopNum := minprime to maxprime doπ beginπ prime := True;π Count := 2;ππ While (Count <= (LoopNum div 2)) and (Prime) doπ beginπ if (LoopNum mod Count = 0) thenπ prime := False;π Inc(Count);π end;ππ if (Prime) thenπ beginπ Write('[');π TextColor(white);π Write(LoopNum);π TextColor(lightgray);π Write('] ');π Inc(PrimeCount);π if WhereX > 75 thenπ Write(#13#10);π end;π if WhereY = 24 thenπ beginπ Write('-- More --');π ReadKey;π ClrScr;π end;π prime := False;π end;π Write(#13#10#10);π Writeln(PrimeCount, ' primes found.', #13#10);πend.π 18 05-28-9313:50ALL SWAG SUPPORT TEAM PRIMES2.PAS IMPORT 9 ₧
k {πBRIAN PAPEππ> Go to the library and look up the Sieve of Eratosthenes; it's a veryπ>interesting and easy method For "finding" prime numbers in a certainπ>range - and kinda fun to Program in Pascal, I might add...π}ππProgram aristophenses_net;π{π LCCC Computer Bowl November 1992 Team members:π Brian Pape, Mike Lazar, Brian Grammer, Kristy Reed - total time: 5:31π}ππConstπ size = 5000;πVarπ b : Array [1..size] of Boolean;π i, j,π count : Integer;ππbeginπ count := 0;π Writeln;π Write('WORKING: ', ' ' : 6, '/', size : 6);π For i := 1 to 13 doπ Write(#8);π fillChar(b, sizeof(b), 1);ππ For i := 2 to size doπ if b[i] thenπ beginπ Write(i : 6, #8#8#8#8#8#8);π For j := i + 1 to size doπ if j mod i = 0 thenπ b[j] := False;π end; { For }ππ Writeln;ππ For i := 1 to size doπ if b[i] thenπ beginπ Write(i : 8);π inc(count);π end;ππ Writeln;π Write('The number of primes from 1 to ', size, ' is ', count, '.');πend.ππ 19 05-28-9313:50ALL SWAG SUPPORT TEAM PRIMES3.PAS IMPORT 40 ₧H {π Hi, to All:ππ ...While recently "tuning up" one of my Programs I'm currentlyπ working on, I ran a little test to Compare the perfomanceπ of the different versions of Turbo Pascal from 5.0 throughπ to 7.0. The results were quite suprizing, and I thought I'dπ share this With you guys/gals.ππ Here are the results of a "sieve" Program to find all the primesπ in 1 - 100,000, running on my AMI 386SX-25 CPU desktop PC:ππ CompILER EXECUTION TIME RELATIVE TIME FACtoRπ ==================================================π TP 7.0 46.7 sec 1.00π TP 6.0 137.8 sec 2.95π TP 5.5 137.5 sec 2.94π TP 5.0 137.6 sec 2.95ππ Running the same Program to find all the primes in 1 - 10,000,π running on my 8086 - 9.54 Mhz NEC V20 CPU laptop PC:ππ CompILER EXECUTION TIME RELATIVE TIME FACtoRπ ==================================================π TP 7.0 14.1 sec 1.00π TP 6.0 28.3 sec 2.00ππ notE: This would seem to indicate that the TP 7.0 386 math-π library is kicking in when run on a 386 CPU.ππ Here is the source-code to my "seive" Program:π------------------------------------------------------------------------π}π {.$DEFinE DebugMode}π {$DEFinE SaveData}ππ {$ifDEF DebugMode}π {$ifDEF VER70}π {$ifDEF DPMI}π {$A+,B-,D+,E-,F-,G-,I+,L+,N-,P+,Q+,R+,S+,T+,V+,X-}π {$else}π {$A+,B-,D+,E-,F-,G-,I+,L+,N-,O-,P+,Q+,R+,S+,T+,V+,X-}π {$endif}π {$else}π {$ifDEF VER60}π {$A+,B-,D+,E-,F-,G-,I+,L+,N-,O-,R+,S+,V+,X-}π {$else}π {$A+,B-,D+,E-,F-,I+,L+,N-,O-,R+,S+,V+}π {$endif}π {$endif}π {$else}π {$ifDEF VER70}π {$ifDEF DPMI}π {$A+,B-,D-,E-,F-,G-,I-,L-,N-,P-,Q-,R-,S+,T-,V-,X-}π {$else}π {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X-}π {$endif}π {$else}π {$ifDEF VER60}π {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S+,V-,X-}π {$else}π {$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S+,V-}π {$endif}π {$endif}π {$endif}ππ (* Find prime numbers - Guy McLoughlin, 1993. *)πProgram Find_Primes;ππ (***** Check if a number is prime. *)π (* *)π Function Prime({input } lo_in : LongInt) : {output} Boolean;π Varπ lo_Stop,π lo_Loop : LongInt;π beginπ if (lo_in mod 2 = 0) thenπ beginπ Prime := (lo_in = 2);π Exitπ end;π if (lo_in mod 3 = 0) thenπ beginπ Prime := (lo_in = 3);π Exitπ end;ππ if (lo_in mod 5 = 0) thenπ beginπ Prime := (lo_in = 5);π Exitπ end;π lo_Stop := 7;π While ((lo_Stop * lo_Stop) <= lo_in) doπ inc(lo_Stop, 2);π lo_Loop := 7;π While (lo_Loop < lo_Stop) doπ beginπ inc(lo_Loop, 2);π if (lo_in mod lo_Loop = 0) thenπ beginπ Prime := False;π Exitπ endπ end;π Prime := Trueπ end; (* Prime. *)ππ (***** Check For File IO errors. *)π (* *)π Procedure CheckIOerror;π Varπ by_Error : Byte;π beginπ by_Error := ioresult;π if (by_Error <> 0) thenπ beginπ Writeln('File Error = ', by_Error);π haltπ endπ end; (* CheckIOerror. *)ππVarπ bo_Temp : Boolean;π wo_PrimeCount : Word;π lo_Temp,π lo_Loop : LongInt;π fite_Data : Text;ππbeginπ lo_Temp := 100000;π {$ifDEF SaveData}π {$ifDEF VER50}π assign(fite_Data, 'PRIME.50');π {$endif}π {$ifDEF VER55}π assign(fite_Data, 'PRIME.55');π {$endif}π {$ifDEF VER60}π assign(fite_Data, 'PRIME.60');π {$endif}π {$ifDEF VER70}π assign(fite_Data, 'PRIME.70');π {$endif}π {$I-}π reWrite(fite_Data);π {$I+}π CheckIOerror;π {$endif}π wo_PrimeCount := 0;π For lo_Loop := 2 to lo_Temp doπ if Prime(lo_Loop) thenπ {$ifDEF SaveData}π beginπ Write(fite_Data, lo_Loop:6);π Write(fite_Data, ', ');π inc(wo_PrimeCount);π if ((wo_PrimeCount mod 10) = 0) thenπ Writeln(fite_Data)π end;π close(fite_Data);π CheckIOerror;π {$else}π inc(wo_PrimeCount);π {$endif}π Writeln(wo_PrimeCount, ' primes between: 1 - ', lo_Temp)πend.ππ{π ...This little test would put TP 7.0's .EXE's between 2 to 3π times faster than TP4 - TP6 .EXE's. (I've found simmilar resultsπ in testing other Programs I've written.) I guess this is one moreπ reason to upgrade to TP 7.0 .ππ ...I'd be curious to see how StonyBrook's Pascal+ 6.1 Comparesπ to TP 7.0, in terms of execution speed With this Program.ππ - Guyπ}π 20 05-28-9313:50ALL SWAG SUPPORT TEAM SQRT.PAS IMPORT 13 ₧EÑ (***** Find the square-root of an Integer between 1..2,145,635,041 *)π(* *)πFunction FindSqrt({input} lo_in : LongInt) : {output} LongInt;ππ (***** SUB : Find square-root For numbers less than 65417. *)π (* *)π Function FS1({input } wo_in : Word) : {output} Word;π Varπ wo_Temp : Word;π beginπ wo_Temp := 1;π While ((wo_Temp * wo_Temp) < wo_in) doπ inc(wo_Temp, 11);π While((wo_Temp * wo_Temp) > wo_in) doπ dec(wo_Temp);π FS1 := wo_Tempπ end; (* SUB : FS1. *)ππ (***** SUB : Find square-root For numbers greater than 65416. *)π (* *)π Function FS2(lo_in : LongInt) : LongInt;π Varπ lo_Temp : LongInt;π beginπ lo_Temp := 1;π While ((lo_Temp * lo_Temp) < lo_in) doπ inc(lo_Temp, 24);π While((lo_Temp * lo_Temp) > lo_in) doπ dec(lo_Temp);π FS2 := lo_Tempπ end; (* SUB : FS2. *)ππbeginπ if (lo_in < 64517) thenπ FindSqrt := FS1(lo_in)π elseπ FindSqrt := FS2(lo_in)πend; (* FindSqrt. *)ππ{π ...I've now re-written the "seive" Program, and it appears to nowπ run about twice as fast. I'll post the new improved source-code inπ another message.π} 21 05-31-9308:04ALL FLOOR NAAIJKENS Trig & Calc Functions IMPORT 133 ₧Qc ==============================================================================π BBS: «« The Information and Technology Exchanπ To: JEFFREY HUNTSMAN Date: 11-27─91 (09:08)πFrom: FLOOR NAAIJKENS Number: 3162 [101] PASCALπSubj: CALC (1) Status: Publicπ------------------------------------------------------------------------------π{$O+}π{π F i l e I n f o r m a t i o nππ* DESCRIPTIONπSupplies missing trigonometric functions for Turbo Pascal 5.5. Alsoπprovides hyperbolic, logarithmic, power, and root functions. All trigπfunctions accessibile by radians, decimal degrees, degrees-minutes-secondsπand a global DegreeType.ππ}πunit PTD_Calc;ππ(* PTD_Calc - Supplies missing trigonometric functions for Turbo Pascal 5.5π * Also provides hyperbolic, logarithmic, power, and root functions.π * All trig functions accessible by radians, decimal degrees,π * degrees-minutes-seconds, and a global DegreeType. Conversionsπ * between these are supplied.π *π *)ππinterfaceππtypeπ DegreeType = recordπ Degrees, Minutes, Seconds : real;π end;πconstπ Infinity = 9.9999999999E+37;ππ{ Radians }π{ sin, cos, and arctan are predefined }ππfunction Tan( Radians : real ) : real;πfunction ArcSin( InValue : real ) : real;πfunction ArcCos( InValue : real ) : real;ππ{ Degrees, expressed as a real number }ππfunction DegreesToRadians( Degrees : real ) : real;πfunction RadiansToDegrees( Radians : real ) : real;πfunction Sin_Degree( Degrees : real ) : real;πfunction Cos_Degree( Degrees : real ) : real;πfunction Tan_Degree( Degrees : real ) : real;πfunction ArcSin_Degree( Degrees : real ) : real;πfunction ArcCos_Degree( Degrees : real ) : real;πfunction ArcTan_Degree( Degrees : real ) : real;ππ{ Degrees, in Degrees, Minutes, and Seconds, as real numbers }ππfunction DegreePartsToDegrees( Degrees, Minutes, Seconds : real ) : real;πfunction DegreePartsToRadians( Degrees, Minutes, Seconds : real ) : real;πprocedure DegreesToDegreeParts( DegreesIn : real;π var Degrees, Minutes, Seconds : real );πprocedure RadiansToDegreeParts( Radians : real;π var Degrees, Minutes, Seconds : real );πfunction Sin_DegreeParts( Degrees, Minutes, Seconds : real ) : real;πfunction Cos_DegreeParts( Degrees, Minutes, Seconds : real ) : real;πfunction Tan_DegreeParts( Degrees, Minutes, Seconds : real ) : real;πfunction ArcSin_DegreeParts( Degrees, Minutes, Seconds : real ) : real;πfunction ArcCos_DegreeParts( Degrees, Minutes, Seconds : real ) : real;πfunction ArcTan_DegreeParts( Degrees, Minutes, Seconds : real ) : real;ππ{ Degrees, expressed as DegreeType ( reals in record ) }ππfunction DegreeTypeToDegrees( DegreeVar : DegreeType ) : real;πfunction DegreeTypeToRadians( DegreeVar : DegreeType ) : real;πprocedure DegreeTypeToDegreeParts( DegreeVar : DegreeType;π var Degrees, Minutes, Seconds : real );πprocedure DegreesToDegreeType( Degrees : real; var DegreeVar : DegreeType );πprocedure RadiansToDegreeType( Radians : real; var DegreeVar : DegreeType );πprocedure DegreePartsToDegreeType( Degrees, Minutes, Seconds : real;π var DegreeVar : DegreeType );πfunction Sin_DegreeType( DegreeVar : DegreeType ) : real;πfunction Cos_DegreeType( DegreeVar : DegreeType ) : real;πfunction Tan_DegreeType( DegreeVar : DegreeType ) : real;πfunction ArcSin_DegreeType( DegreeVar : DegreeType ) : real;πfunction ArcCos_DegreeType( DegreeVar : DegreeType ) : real;πfunction ArcTan_DegreeType( DegreeVar : DegreeType ) : real;ππ{ Hyperbolic functions }ππfunction Sinh( Invalue : real ) : real;πfunction Cosh( Invalue : real ) : real;πfunction Tanh( Invalue : real ) : real;πfunction Coth( Invalue : real ) : real;πfunction Sech( Invalue : real ) : real;πfunction Csch( Invalue : real ) : real;πfunction ArcSinh( Invalue : real ) : real;πfunction ArcCosh( Invalue : real ) : real;πfunction ArcTanh( Invalue : real ) : real;πfunction ArcCoth( Invalue : real ) : real;πfunction ArcSech( Invalue : real ) : real;πfunction ArcCsch( Invalue : real ) : real;ππ{ Logarithms, Powers, and Roots }ππ{ e to the x is exp() }π{ natural log is ln() }πfunction Log10( InNumber : real ) : real;πfunction Log( Base, InNumber : real ) : real; { log of any base }πfunction Power( InNumber, Exponent : real ) : real;πfunction Root( InNumber, TheRoot : real ) : real;πππ{----------------------------------------------------------------------}πimplementationππconstπ RadiansPerDegree = 0.017453292520;π DegreesPerRadian = 57.295779513;π MinutesPerDegree = 60.0;π SecondsPerDegree = 3600.0;π SecondsPerMinute = 60.0;π LnOf10 = 2.3025850930;ππ{-----------}π{ Radians }π{-----------}ππ{ sin, cos, and arctan are predefined }ππfunction Tan { ( Radians : real ) : real };π { note: returns Infinity where appropriate }π varπ CosineVal : real;π TangentVal : real;π beginπ CosineVal := cos( Radians );π if CosineVal = 0.0 thenπ Tan := Infinityπ elseπ beginπ TangentVal := sin( Radians ) / CosineVal;π if ( TangentVal < -Infinity ) or ( TangentVal > Infinity ) thenπ Tan := Infinityπ elseπ Tan := TangentVal;π end;π end;ππfunction ArcSin{ ( InValue : real ) : real };π { notes: 1) exceeding input range of -1 through +1 will cause runtime error }π { 2) only returns principal values }π { ( -pi/2 through pi/2 radians ) ( -90 through +90 degrees ) }π beginπ if abs( InValue ) = 1.0 thenπ ArcSin := pi / 2.0π elseπ ArcSin := arctan( InValue / sqrt( 1 - InValue * InValue ) );π end;ππfunction ArcCos{ ( InValue : real ) : real };π { notes: 1) exceeding input range of -1 through +1 will cause runtime error }π { 2) only returns principal values }π { ( 0 through pi radians ) ( 0 through +180 degrees ) }π varπ Result : real;π beginπ if InValue = 0.0 thenπ ArcCos := pi / 2.0π elseπ beginπ Result := arctan( sqrt( 1 - InValue * InValue ) / InValue );π if InValue < 0.0 thenπ ArcCos := Result + piπ elseπ ArcCos := Result;π end;π end;ππ{---------------------------------------}π{ Degrees, expressed as a real number }π{---------------------------------------}ππfunction DegreesToRadians{ ( Degrees : real ) : real };π beginπ DegreesToRadians := Degrees * RadiansPerDegree;π end;ππfunction RadiansToDegrees{ ( Radians : real ) : real };π beginπ RadiansToDegrees := Radians * DegreesPerRadian;π end;ππfunction Sin_Degree{ ( Degrees : real ) : real };π beginπ Sin_Degree := sin( DegreesToRadians( Degrees ) );π end;ππfunction Cos_Degree{ ( Degrees : real ) : real };π beginπ Cos_Degree := cos( DegreesToRadians( Degrees ) );π end;ππfunction Tan_Degree{ ( Degrees : real ) : real };π beginπ Tan_Degree := Tan( DegreesToRadians( Degrees ) );ππ<ORIGINAL MESSAGE OVER 200 LINES, SPLIT IN 2 OR MORE>π==============================================================================π BBS: «« The Information and Technology Exchanπ To: JEFFREY HUNTSMAN Date: 11-27─91 (09:08)πFrom: FLOOR NAAIJKENS Number: 3163 [101] PASCALπSubj: CALC (1) <CONT> Status: Publicπ------------------------------------------------------------------------------π end;ππfunction ArcSin_Degree{ ( Degrees : real ) : real };π beginπ ArcSin_Degree := ArcSin( DegreesToRadians( Degrees ) );π end;ππfunction ArcCos_Degree{ ( Degrees : real ) : real };π beginπ ArcCos_Degree := ArcCos( DegreesToRadians( Degrees ) );π end;ππfunction ArcTan_Degree{ ( Degrees : real ) : real };π beginπ ArcTan_Degree := arctan( DegreesToRadians( Degrees ) );π end;ππ--- D'Bridge 1.30 demo/922115π * Origin: EURO-ONLINE Home of The Fast Commander (2:500/233)π==============================================================================π BBS: «« The Information and Technology Exchanπ To: JEFFREY HUNTSMAN Date: 11-27─91 (09:08)πFrom: FLOOR NAAIJKENS Number: 3164 [101] PASCALπSubj: CALC (2) Status: Publicπ------------------------------------------------------------------------------ππ{--------------------------------------------------------------}π{ Degrees, in Degrees, Minutes, and Seconds, as real numbers }π{--------------------------------------------------------------}ππfunction DegreePartsToDegrees{ ( Degrees, Minutes, Seconds : real ) : real };π beginπ DegreePartsToDegrees := Degrees + ( Minutes / MinutesPerDegree ) +π ( Seconds / SecondsPerDegree );π end;ππfunction DegreePartsToRadians{ ( Degrees, Minutes, Seconds : real ) : real };π beginπ DegreePartsToRadians := DegreesToRadians( DegreePartsToDegrees( Degrees,π Minutes, Seconds ) );π end;ππprocedure DegreesToDegreeParts{ ( DegreesIn : real;π var Degrees, Minutes, Seconds : real ) };π beginπ Degrees := int( DegreesIn );π Minutes := ( DegreesIn - Degrees ) * MinutesPerDegree;π Seconds := frac( Minutes );π Minutes := int( Minutes );π Seconds := Seconds * SecondsPerMinute;π end;ππprocedure RadiansToDegreeParts{ ( Radians : real;π var Degrees, Minutes, Seconds : real ) };π beginπ DegreesToDegreeParts( RadiansToDegrees( Radians ),π Degrees, Minutes, Seconds );π end;ππfunction Sin_DegreeParts{ ( Degrees, Minutes, Seconds : real ) : real };π beginπ Sin_DegreeParts := sin( DegreePartsToRadians( Degrees, Minutes, Seconds ) );π end;ππfunction Cos_DegreeParts{ ( Degrees, Minutes, Seconds : real ) : real };π beginπ Cos_DegreeParts := cos( DegreePartsToRadians( Degrees, Minutes, Seconds ) );π end;ππfunction Tan_DegreeParts{ ( Degrees, Minutes, Seconds : real ) : real };π beginπ Tan_DegreeParts := Tan( DegreePartsToRadians( Degrees, Minutes, Seconds ) );π end;ππfunction ArcSin_DegreeParts{ ( Degrees, Minutes, Seconds : real ) : real };π beginπ ArcSin_DegreeParts := ArcSin( DegreePartsToRadians( Degrees,π Minutes, Seconds ) );π end;ππfunction ArcCos_DegreeParts{ ( Degrees, Minutes, Seconds : real ) : real };π beginπ ArcCos_DegreeParts := ArcCos( DegreePartsToRadians( Degrees,π Minutes, Seconds ) );π end;ππfunction ArcTan_DegreeParts{ ( Degrees, Minutes, Seconds : real ) : real };π beginπ ArcTan_DegreeParts := arctan( DegreePartsToRadians( Degrees,π Minutes, Seconds ) );π end;ππ{-------------------------------------------------------}π{ Degrees, expressed as DegreeType ( reals in record ) }π{-------------------------------------------------------}ππfunction DegreeTypeToDegrees{ ( DegreeVar : DegreeType ) : real };π beginπ DegreeTypeToDegrees := DegreePartsToDegrees( DegreeVar.Degrees,π DegreeVar.Minutes, DegreeVar.Seconds );π end;ππfunction DegreeTypeToRadians{ ( DegreeVar : DegreeType ) : real };π beginπ DegreeTypeToRadians := DegreesToRadians( DegreeTypeToDegrees( DegreeVar ) );π end;ππprocedure DegreeTypeToDegreeParts{ ( DegreeVar : DegreeType;π var Degrees, Minutes, Seconds : real ) };π beginπ Degrees := DegreeVar.Degrees;π Minutes := DegreeVar.Minutes;π Seconds := DegreeVar.Seconds;π end;ππprocedure DegreesToDegreeType{ ( Degrees : real; var DegreeVar : DegreeType )};π beginπ DegreesToDegreeParts( Degrees, DegreeVar.Degrees,π DegreeVar.Minutes, DegreeVar.Seconds );π end;ππprocedure RadiansToDegreeType{ ( Radians : real; var DegreeVar : DegreeType )};π beginπ DegreesToDegreeParts( RadiansToDegrees( Radians ), DegreeVar.Degrees,π DegreeVar.Minutes, DegreeVar.Seconds );π end;ππprocedure DegreePartsToDegreeType{ ( Degrees, Minutes, Seconds : real;π var DegreeVar : DegreeType ) };π beginπ DegreeVar.Degrees := Degrees;π DegreeVar.Minutes := Minutes;π DegreeVar.Seconds := Seconds;π end;ππfunction Sin_DegreeType{ ( DegreeVar : DegreeType ) : real };π beginπ Sin_DegreeType := sin( DegreeTypeToRadians( DegreeVar ) );π end;ππfunction Cos_DegreeType{ ( DegreeVar : DegreeType ) : real };π beginπ Cos_DegreeType := cos( DegreeTypeToRadians( DegreeVar ) );π end;ππfunction Tan_DegreeType{ ( DegreeVar : DegreeType ) : real };π beginπ Tan_DegreeType := Tan( DegreeTypeToRadians( DegreeVar ) );π end;ππ--- D'Bridge 1.30 demo/922115π * Origin: EURO-ONLINE Home of The Fast Commander (2:500/233)π==============================================================================π BBS: «« The Information and Technology Exchanπ To: JEFFREY HUNTSMAN Date: 11-27─91 (09:08)πFrom: FLOOR NAAIJKENS Number: 3165 [101] PASCALπSubj: CALC (3) Status: Publicπ------------------------------------------------------------------------------πfunction ArcSin_DegreeType{ ( DegreeVar : DegreeType ) : real };π beginπ ArcSin_DegreeType := ArcSin( DegreeTypeToRadians( DegreeVar ) );π end;ππfunction ArcCos_DegreeType{ ( DegreeVar : DegreeType ) : real };π beginπ ArcCos_DegreeType := ArcCos( DegreeTypeToRadians( DegreeVar ) );π end;ππfunction ArcTan_DegreeType{ ( DegreeVar : DegreeType ) : real };π beginπ ArcTan_DegreeType := arctan( DegreeTypeToRadians( DegreeVar ) );π end;ππ{------------------------}π{ Hyperbolic functions }π{------------------------}ππfunction Sinh{ ( Invalue : real ) : real };π constπ MaxValue = 88.029691931; { exceeds standard turbo precision }π varπ Sign : real;π beginπ Sign := 1.0;π if Invalue < 0 thenπ beginπ Sign := -1.0;π Invalue := -Invalue;π end;π if Invalue > MaxValue thenπ Sinh := Infinityπ elseπ Sinh := ( exp( Invalue ) - exp( -Invalue ) ) / 2.0 * Sign;π end;ππfunction Cosh{ ( Invalue : real ) : real };π constπ MaxValue = 88.029691931; { exceeds standard turbo precision }π beginπ Invalue := abs( Invalue );π if Invalue > MaxValue thenπ Cosh := Infinityπ elseπ Cosh := ( exp( Invalue ) + exp( -Invalue ) ) / 2.0;π end;ππfunction Tanh{ ( Invalue : real ) : real };π beginπ Tanh := Sinh( Invalue ) / Cosh( Invalue );π end;ππfunction Coth{ ( Invalue : real ) : real };π beginπ Coth := Cosh( Invalue ) / Sinh( Invalue );π end;ππfunction Sech{ ( Invalue : real ) : real };π beginπ Sech := 1.0 / Cosh( Invalue );π end;ππfunction Csch{ ( Invalue : real ) : real };π beginπ Csch := 1.0 / Sinh( Invalue );π end;ππfunction ArcSinh{ ( Invalue : real ) : real };π varπ Sign : real;π beginπ Sign := 1.0;π if Invalue < 0 thenπ beginπ Sign := -1.0;π Invalue := -Invalue;π end;π ArcSinh := ln( Invalue + sqrt( Invalue*Invalue + 1 ) ) * Sign;π end;ππfunction ArcCosh{ ( Invalue : real ) : real };π varπ Sign : real;π beginπ Sign := 1.0;π if Invalue < 0 thenπ beginπ Sign := -1.0;π Invalue := -Invalue;π end;π ArcCosh := ln( Invalue + sqrt( Invalue*Invalue - 1 ) ) * Sign;π end;ππfunction ArcTanh{ ( Invalue : real ) : real };π varπ Sign : real;π beginπ Sign := 1.0;π if Invalue < 0 thenπ beginπ Sign := -1.0;π Invalue := -Invalue;π end;π ArcTanh := ln( ( 1 + Invalue ) / ( 1 - Invalue ) ) / 2.0 * Sign;π end;ππfunction ArcCoth{ ( Invalue : real ) : real };π beginπ ArcCoth := ArcTanh( 1.0 / Invalue );π end;ππfunction ArcSech{ ( Invalue : real ) : real };π beginπ ArcSech := ArcCosh( 1.0 / Invalue );π end;ππfunction ArcCsch{ ( Invalue : real ) : real };π beginπ ArcCsch := ArcSinh( 1.0 / Invalue );π end;ππ{---------------------------------}π{ Logarithms, Powers, and Roots }π{---------------------------------}ππ{ e to the x is exp() }π{ natural log is ln() }ππfunction Log10{ ( InNumber : real ) : real };π beginπ Log10 := ln( InNumber ) / LnOf10;π end;ππfunction Log{ ( Base, InNumber : real ) : real }; { log of any base }π beginπ Log := ln( InNumber ) / ln( Base );π end;ππfunction Power{ ( InNumber, Exponent : real ) : real };π beginπ if InNumber > 0.0 thenπ Power := exp( Exponent * ln( InNumber ) )π else if InNumber = 0.0 thenπ Power := 1.0π else { WE DON'T force a runtime error, we define a function to provideπ negative logarithms! }π If Exponent=Trunc(Exponent) Thenπ Power := (-2*(Trunc(Exponent) Mod 2)+1) * Exp(Exponent * Ln( -InNumber ) )π Else Power := Trunc(1/(Exponent-Exponent));π { NOW WE generate a runtime error }π end;ππfunction Root{ ( InNumber, TheRoot : real ) : real };π beginπ Root := Power( InNumber, ( 1.0 / TheRoot ) );π end;ππend. { unit PTD_Calc }ππππππP.S. Enjoy yourself!ππ--- D'Bridge 1.30 demo/922115π * Origin: EURO-ONLINE Home of The Fast Commander (2:500/233)π 22 06-22-9309:14ALL SWAG SUPPORT TEAM Factoral Program IMPORT 35 ₧╧D PROGRAM Fact;π{************************************************π* FACTOR - Lookup table demonstration using the *π* factorial series. *π* *π*************************************************}ππ{$N+,E+} {Set so you can use other real types}πUSES Crt,Dos,Timer; { t1Start, t1Get, t1Format }πCONSTπ BigFact = 500; {largest factorial is for 1754}πTYPE {defined type for file definition later}π TableType = ARRAY [0..BigFact] OF Extended;πVARπ Table : TableType;ππ{************************************************π* factorial - compute the factorial of a number *π* *π* INP: i - the # to compute the factorial of *π* OUT: The factorial of the number, unless a *π* number greater than BIG_FACT or less *π* than zero is passed in (which results *π* in 0.0). *π*************************************************}ππFUNCTION Factorial(I: Integer): Extended;πVARπ K : Integer;π F : Extended;πBEGINπ IF I = 0 THENπ F := 1π ELSEπ BEGINπ IF (I > 0) AND (I <= BigFact) THENπ BEGINπ F := 1;π FOR K := 1 TO I DOπ F := F * Kπ ENDπ ELSEπ F := 0π END;π Factorial := FπEND;ππ{************************************************π* Main - generate & save table of factorials *π*************************************************}ππVARπ I, J, N : Integer;π F : Extended;π T1, T2, T3 : Longint;π Facts : FILE OF TableType;πBEGINπ { STEP 1 - compute each factorial 5 times }π ClrScr;π WriteLn('Now computing each factorial 5 times');π T1 := tStart;π FOR I :=0 TO 4 DOπ FOR J := 0 TO BigFact DOπ F := Factorial(J); { f=j! }π T2 := tGet;π WriteLn('Computing all factorials from 0..n ');π WriteLn('5 times took ',tFormat(T1,T2),π ' secs.');π WriteLn;π { STEP 2 - compute the table, then look upπ each factorial 5 times. }π WriteLn('Now compute table and look up each ',π 'factorial 5 times.');π T1 := tStart;π FOR I := 0 TO BigFact DOπ Table[I] := Factorial(I);π T2 := tGet;π FOR I := 0 TO 4 DOπ FOR J :=0 TO BigFact DOπ F := Table[J]; { f=j! }π T3 := tGet;π WriteLn('Computing table took ',tFormat(T1,T2),π ' seconds');π WriteLn('Looking up each factorial 5 times to',π 'ok ',tFormat(T2,T3),' seconds');π WriteLn('Total: ',tFormat(T1,T3),' seconds');π WriteLn;π{STEP 3 - Compute each factorial as it is needed}π WriteLn('Clearing the table,',π ' and computing each ');π WriteLn('factorial as it is needed',π ' (for 5) lookups.');π WriteLn;π T1 := tStart;π FOR I := 0 TO BigFact DOπ Table[I] := -1; { unknown Val }π FOR I := 0 TO 4 DOπ FOR J := 0 TO BigFact DOπ BEGINπ F := Table[J];π IF F < 0 THENπ BEGINπ F := Factorial(J);π Table[J] := F { F = J! }π ENDπ END;π T2 := tGet;π WriteLn('Clearing table and computing each');π WriteLn(' factorial as it was needed for 5');π WriteLn('lookups took ',tFormat(T1,T2),π ' secs.');π { STEP 4 - write the table to disk (we areπ not timing this step, because if you areπ loading it from disk, you presumably do notπ care how long it took to compute it. }π Assign(Facts,'Fact_tbl.tmp');π Rewrite(Facts);π Write(Facts,Table);π Close(Facts);π { Flush the disk buffer, so that the timeπ is not affected by having the data in aπ disk buffer. }π Exec('C:\COMMAND.COM','/C CHKDSK');π { STEP 5 - read the table from disk, andπ use each factorial 5 times }π T1 := tStart;π Assign(Facts,'Fact_tbl.TMP');π Reset(Facts);π Read(Facts,Table);π Close(Facts);π T2 := tGet;π FOR I := 0 TO 4 DOπ FOR J :=0 TO BigFact DOπ F := Table[J]; { f=j! }π T3 := tGet;π WriteLn('Reading the Table from disk took ',π tFormat(T1,T2),' seconds.');π WriteLn('Looking up each Factorial 5 times ',π 'to ok took ',tFormat(T2,T3),' seconds.');π WriteLn('Total: ',tFormat(T1,T3),' seconds.');π WriteLn;π WriteLn('Press Enter TO see the factorials');π ReadLN;π FOR I:=0 TO BigFact DOπ WriteLn('[',I,'] = ',Table[I]);πend.π 23 07-17-9307:28ALL GAYLE DAVIS Math Conversion Unit IMPORT 64 ₧j4 { MATH Unit for various conversions }π{$DEFINE Use8087} { define this for EXTENDED 8087 floating point math }ππUNIT MATH;ππ{$IFDEF Use8087}π{$N+}π{$ELSEπ{$N-}π{$ENDIF}ππINTERFACEππTYPEπ {$IFDEF Use8087}π FLOAT = EXTENDED;π {$ELSE}π FLOAT = REAL;π {$ENDIF}ππFUNCTION FahrToCent(FahrTemp: FLOAT): FLOAT;πFUNCTION CentToFahr(CentTemp: FLOAT): FLOAT;πFUNCTION KelvToCent(KelvTemp: FLOAT): FLOAT;πFUNCTION CentToKelv(CentTemp: FLOAT): FLOAT;πPROCEDURE InchToFtIn(Inches: FLOAT; VAR ft,ins: FLOAT);πFUNCTION FtInToInch(ft,ins: FLOAT): FLOAT;πFUNCTION InchToYard(Inches: FLOAT): FLOAT;πFUNCTION YardToInch(Yards: FLOAT): FLOAT;πFUNCTION InchToMile(Inches: FLOAT): FLOAT;πFUNCTION MileToInch(Miles: FLOAT): FLOAT;πFUNCTION InchToNautMile(Inches: FLOAT): FLOAT;πFUNCTION NautMileToInch(NautMiles: FLOAT): FLOAT;πFUNCTION InchToMeter(Inches: FLOAT): FLOAT;πFUNCTION MeterToInch(Meters: FLOAT): FLOAT;πFUNCTION SqInchToSqFeet(SqInches: FLOAT): FLOAT;πFUNCTION SqFeetToSqInch(SqFeet: FLOAT): FLOAT;πFUNCTION SqInchToSqYard(SqInches: FLOAT): FLOAT;πFUNCTION SqYardToSqInch(SqYards: FLOAT): FLOAT;πFUNCTION SqInchToSqMile(SqInches: FLOAT): FLOAT;πFUNCTION SqMileToSqInch(SqMiles: FLOAT): FLOAT;πFUNCTION SqInchToAcre(SqInches: FLOAT): FLOAT;πFUNCTION AcreToSqInch(Acres: FLOAT): FLOAT;πFUNCTION SqInchToSqMeter(SqInches: FLOAT): FLOAT;πFUNCTION SqMeterToSqInch(SqMeters: FLOAT): FLOAT;πFUNCTION CuInchToCuFeet(CuInches: FLOAT): FLOAT;πFUNCTION CuFeetToCuInch(CuFeet: FLOAT): FLOAT;πFUNCTION CuInchToCuYard(CuInches: FLOAT): FLOAT;πFUNCTION CuYardToCuInch(CuYards: FLOAT): FLOAT;πFUNCTION CuInchToCuMeter(CuInches: FLOAT): FLOAT;πFUNCTION CuMeterToCuInch(CuMeters: FLOAT): FLOAT;πFUNCTION FluidOzToPint(FluidOz: FLOAT): FLOAT;πFUNCTION PintToFluidOz(Pints: FLOAT): FLOAT;πFUNCTION FluidOzToImpPint(FluidOz: FLOAT): FLOAT;πFUNCTION ImpPintToFluidOz(ImpPints: FLOAT): FLOAT;πFUNCTION FluidOzToGals(FluidOz: FLOAT): FLOAT;πFUNCTION GalsToFluidOz(Gals: FLOAT): FLOAT;πFUNCTION FluidOzToImpGals(FluidOz: FLOAT): FLOAT;πFUNCTION ImpGalsToFluidOz(ImpGals: FLOAT): FLOAT;πFUNCTION FluidOzToCuMeter(FluidOz: FLOAT): FLOAT;πFUNCTION CuMeterToFluidOz(CuMeters: FLOAT): FLOAT;πPROCEDURE OunceToLbOz(Ounces: FLOAT; VAR lb,oz: FLOAT);πFUNCTION LbOzToOunce(lb,oz: FLOAT): FLOAT;πFUNCTION OunceToTon(Ounces: FLOAT): FLOAT;πFUNCTION TonToOunce(Tons: FLOAT): FLOAT;πFUNCTION OunceToLongTon(Ounces: FLOAT): FLOAT;πFUNCTION LongTonToOunce(LongTons: FLOAT): FLOAT;πFUNCTION OunceToGram(Ounces: FLOAT): FLOAT;πFUNCTION GramToOunce(Grams: FLOAT): FLOAT;ππππIMPLEMENTATIONππ{ Temperature conversion }ππFUNCTION FahrToCent(FahrTemp: FLOAT): FLOAT;ππ BEGINπ FahrToCent:=(FahrTemp+40.0)*(5.0/9.0)-40.0;π END;πππFUNCTION CentToFahr(CentTemp: FLOAT): FLOAT;ππ BEGINπ CentToFahr:=(CentTemp+40.0)*(9.0/5.0)-40.0;π END;πππFUNCTION KelvToCent(KelvTemp: FLOAT): FLOAT;ππ BEGINπ KelvToCent:=KelvTemp-273.16;π END;πππFUNCTION CentToKelv(CentTemp: FLOAT): FLOAT;ππ BEGINπ CentToKelv:=CentTemp+273.16;π END;ππππ{ Linear measurement conversion }ππPROCEDURE InchToFtIn(Inches: FLOAT; VAR ft,ins: FLOAT);ππ BEGINπ ft:=INT(Inches/12.0);π ins:=Inches-ft*12.0;π END;πππFUNCTION FtInToInch(ft,ins: FLOAT): FLOAT;ππ BEGINπ FtInToInch:=ft*12.0+ins;π END;πππFUNCTION InchToYard(Inches: FLOAT): FLOAT;ππ BEGINπ InchToYard:=Inches/36.0;π END;πππFUNCTION YardToInch(Yards: FLOAT): FLOAT;ππ BEGINπ YardToInch:=Yards*36.0;π END;πππFUNCTION InchToMile(Inches: FLOAT): FLOAT;ππ BEGINπ InchToMile:=Inches/63360.0;π END;πππFUNCTION MileToInch(Miles: FLOAT): FLOAT;ππ BEGINπ MileToInch:=Miles*63360.0;π END;πππFUNCTION InchToNautMile(Inches: FLOAT): FLOAT;ππ BEGINπ InchToNautMile:=Inches/72960.0;π END;πππFUNCTION NautMileToInch(NautMiles: FLOAT): FLOAT;ππ BEGINπ NautMileToInch:=NautMiles*72960.0;π END;πππFUNCTION InchToMeter(Inches: FLOAT): FLOAT;ππ BEGINπ InchToMeter:=Inches*0.0254;π END;πππFUNCTION MeterToInch(Meters: FLOAT): FLOAT;ππ BEGINπ MeterToInch:=Meters/0.0254;π END;ππππ{ Area conversion }ππFUNCTION SqInchToSqFeet(SqInches: FLOAT): FLOAT;ππ BEGINπ SqInchToSqFeet:=SqInches/144.0;π END;πππFUNCTION SqFeetToSqInch(SqFeet: FLOAT): FLOAT;ππ BEGINπ SqFeetToSqInch:=SqFeet*144.0;π END;πππFUNCTION SqInchToSqYard(SqInches: FLOAT): FLOAT;ππ BEGINπ SqInchToSqYard:=SqInches/1296.0;π END;πππFUNCTION SqYardToSqInch(SqYards: FLOAT): FLOAT;ππ BEGINπ SqYardToSqInch:=SqYards*1296.0;π END;πππFUNCTION SqInchToSqMile(SqInches: FLOAT): FLOAT;ππ BEGINπ SqInchToSqMile:=SqInches/4.0144896E9;π END;πππFUNCTION SqMileToSqInch(SqMiles: FLOAT): FLOAT;ππ BEGINπ SqMileToSqInch:=SqMiles*4.0144896E9;π END;πππFUNCTION SqInchToAcre(SqInches: FLOAT): FLOAT;ππ BEGINπ SqInchToAcre:=SqInches/6272640.0;π END;πππFUNCTION AcreToSqInch(Acres: FLOAT): FLOAT;ππ BEGINπ AcreToSqInch:=Acres*6272640.0;π END;πππFUNCTION SqInchToSqMeter(SqInches: FLOAT): FLOAT;ππ BEGINπ SqInchToSqMeter:=SqInches/1550.016;π END;πππFUNCTION SqMeterToSqInch(SqMeters: FLOAT): FLOAT;ππ BEGINπ SqMeterToSqInch:=SqMeters*1550.016;π END;ππππ{ Volume conversion }ππFUNCTION CuInchToCuFeet(CuInches: FLOAT): FLOAT;ππ BEGINπ CuInchToCuFeet:=CuInches/1728.0;π END;πππFUNCTION CuFeetToCuInch(CuFeet: FLOAT): FLOAT;ππ BEGINπ CuFeetToCuInch:=CuFeet*1728.0;π END;πππFUNCTION CuInchToCuYard(CuInches: FLOAT): FLOAT;ππ BEGINπ CuInchToCuYard:=CuInches/46656.0;π END;πππFUNCTION CuYardToCuInch(CuYards: FLOAT): FLOAT;ππ BEGINπ CuYardToCuInch:=CuYards*46656.0;π END;πππFUNCTION CuInchToCuMeter(CuInches: FLOAT): FLOAT;ππ BEGINπ CuInchToCuMeter:=CuInches/61022.592;π END;πππFUNCTION CuMeterToCuInch(CuMeters: FLOAT): FLOAT;ππ BEGINπ CuMeterToCuInch:=CuMeters*61022.592;π END;πππ{ Liquid measurement conversion }ππFUNCTION FluidOzToPint(FluidOz: FLOAT): FLOAT;ππ BEGINπ FluidOzToPint:=FluidOz/16.0;π END;πππFUNCTION PintToFluidOz(Pints: FLOAT): FLOAT;ππ BEGINπ PintToFluidOz:=Pints*16.0;π END;πππFUNCTION FluidOzToImpPint(FluidOz: FLOAT): FLOAT;ππ BEGINπ FluidOzToImpPint:=FluidOz/20.0;π END;πππFUNCTION ImpPintToFluidOz(ImpPints: FLOAT): FLOAT;ππ BEGINπ ImpPintToFluidOz:=ImpPints*20.0;π END;πππFUNCTION FluidOzToGals(FluidOz: FLOAT): FLOAT;ππ BEGINπ FluidOzToGals:=FluidOz/128.0;π END;πππFUNCTION GalsToFluidOz(Gals: FLOAT): FLOAT;ππ BEGINπ GalsToFluidOz:=Gals*128.0;π END;πππFUNCTION FluidOzToImpGals(FluidOz: FLOAT): FLOAT;ππ BEGINπ FluidOzToImpGals:=FluidOz/160.0;π END;πππFUNCTION ImpGalsToFluidOz(ImpGals: FLOAT): FLOAT;ππ BEGINπ ImpGalsToFluidOz:=ImpGals*160.0;π END;πππFUNCTION FluidOzToCuMeter(FluidOz: FLOAT): FLOAT;ππ BEGINπ FluidOzToCuMeter:=FluidOz/33820.0;π END;πππFUNCTION CuMeterToFluidOz(CuMeters: FLOAT): FLOAT;ππ BEGINπ CuMeterToFluidOz:=CuMeters*33820.0;π END;πππ{ Weight conversion }ππPROCEDURE OunceToLbOz(Ounces: FLOAT; VAR lb,oz: FLOAT);ππ BEGINπ lb:=INT(Ounces/16.0);π oz:=Ounces-lb*16.0;π END;πππFUNCTION LbOzToOunce(lb,oz: FLOAT): FLOAT;ππ BEGINπ LbOzToOunce:=lb*16.0+oz;π END;πππFUNCTION OunceToTon(Ounces: FLOAT): FLOAT;ππ BEGINπ OunceToTon:=Ounces/32000.0;π END;πππFUNCTION TonToOunce(Tons: FLOAT): FLOAT;ππ BEGINπ TonToOunce:=Tons*32000.0;π END;πππFUNCTION OunceToLongTon(Ounces: FLOAT): FLOAT;ππ BEGINπ OunceToLongTon:=Ounces/35840.0;π END;πππFUNCTION LongTonToOunce(LongTons: FLOAT): FLOAT;ππ BEGINπ LongTonToOunce:=LongTons*35840.0;π END;πππFUNCTION OunceToGram(Ounces: FLOAT): FLOAT;ππ BEGINπ OunceToGram:=Ounces*28.35;π END;πππFUNCTION GramToOunce(Grams: FLOAT): FLOAT;ππ BEGINπ GramToOunce:=Grams/28.35;π END;πππEND.ππ 24 08-27-9321:17ALL LOU DUCHEZ Factoring Program IMPORT 8 ₧∞@ {LOU DUCHEZππ> Could anybody explain how to Write such a routine in Pascal?ππHere's a dorky little "Factoring" Program I wrote to display the factorsπof a number:π}ππProgram factors;πVarπ lin,π lcnt : LongInt;πbeginπ Write('Enter number to factor: ');π readln(lin);π lcnt := 2;π While lcnt * lcnt <= lin doπ beginπ if lin mod lcnt = 0 thenπ Writeln('Factors:', lcnt : 9, (lin div lcnt) : 9);π lcnt := lcnt + 1;π end;πend.ππ{πNotice that I only check For factors up to the square root of the numberπTyped in. Also, notice the "mod" operator: gives the remainder of Integerπdivision ("div" gives the Integer result of division).ππNot Really knowing exactly what you want to accomplish, I don't Really knowπif the above is of much help. But what the hey.π} 25 08-27-9321:29ALL SEAN PALMER Dividing Fixed Integers IMPORT 12 ₧╖Σ {πSEAN PALMERππI'm using TP. Here are the fixed division routines I'm currently usingπ(they are, as you can see, quite specialized)ππI had to abandon the original fixed division routines because I didn'tπknow how to translate the 386-specific instructions using DB. (MOVSX,πSHLD, etc)π}ππtypeπ fixed = recordπ f : word;π i : integer;π end;ππ shortFixed = recordπ f : byte;π i : shortint;π end;ππ{ this one divides a fixed by a fixed, result is fixed needs 386 }ππfunction fixedDiv(d1, d2 : longint) : longint; assembler;πasmπ db $66; xor dx, dxπ mov cx, word ptr D1 + 2π or cx, cxπ jns @Sπ db $66; dec dxπ @S:π mov dx, cxπ mov ax, word ptr D1π db $66; shl ax, 16π db $66; idiv word ptr d2π db $66; mov dx, axπ db $66; shr dx, 16πend;ππ{ this one divides a longint by a longint, result is fixed needs 386 }ππfunction div2Fixed(d1, d2 : longint) : longint; assembler;πasmπ db $66; xor dx, dxπ db $66; mov ax, word ptr d1π db $66; shl ax, 16π jns @S;π db $66; dec dxπ @S:π db $66; idiv word ptr d2π db $66; mov dx, axπ db $66; shr dx, 16πend;ππ{ this one divides an integer by and integer, result is shortFixed }ππfunction divfix(d1, d2 : integer) : integer; assembler;πasmπ mov al, byteπ ptr d1 + 1π cbwπ mov dx, axπ xor al, alπ mov ah, byte ptr d1π idiv d2πend;πππ 26 08-27-9321:34ALL DJ MURDOCH Matrix Math IMPORT 33 ₧ z {πDJ MURDOCHππ>The solution I use For dynamic Objects (I don't have any Complex code) isπ>to keep a counter in each matrix Record; every Function decrements theπ>counter, and when it reaches 0, disposes of the Object. if you need toπ>use an Object twice, you increment the counter once before using it.ππ> if you allocate an Object twice, how do you get the first address back intoπ> the Pointer Variable so it can be disposed? I must not understand theπ> problem. if I do:ππ> new(p); new(p);ππ> Unless I save the value of the first p, how can I dispose it? And if Iπ> save it, why not use two Pointer Variables, p1 and p2, instead?ππYou're right, there's no way to dispose of the first p^. What I meant isπsomething like this: Suppose X and Y are Pointers to matrix Objects. if Iπwant to calculate Z as their product, and don't have any need For them anyπmore, then it's fine if MatMul disposes of them inππ Z := MatMul(X,Y);ππIn fact, it's Really handy, because it lets me calculate X Y Z asππ W := MatMul(X, MatMul(Y,Z));ππThe problem comes up when I try to calculate something like X^2, because MatMulπwould get in trouble trying to dispose of X twice inππ Y := MatMul(X, X);ππThe solution I use is to keep a counter in every Object, and to follow a rigidπdiscipline:ππ 1. Newly created Objects (Function results) always have the counter set toπ zero.ππ 2. Every Function which takes a Pointer to one of these Objects as anπ argument is sure to "touch" the Pointer, by passing it exactly once toπ another Function. (There's an exception below that lets you pass it moreπ than once if you need to.)ππ3. if a Function doesn't need to pass the Object to another Function, thenπ it passes it to the special Function "Touch()", to satisfy rule 2.π Touch checks the counter; if it's zero, it disposes of the Object,π otherwise, it decrements it by one.ππ4. The way to get around the "exactly once" rule 2 is to call the "Protect"π Function before you pass the Object. This just increments the counter.ππ5. Functions should never change Objects being passed to them as arguments;π there's a Function called "Local" which makes a local copy to work on ifπ you need it. What Local does is to check the counter; if it's zero,π Local just returns the original Object, otherwise it asks the Object toπ make a copy of itself.ππFor example, to do the line above safely, I'd code it asππ Y := MatMul(X, Protect(X));ππMatMul would look something like this:π}ππFunction MatMul(Y, Z : PMatrix) : PMatrix;πVarπ result : PMatrix;πbeginπ { Allocate result, fill in the values appropriately, then }π Touch(Y);π Touch(Z);π MatMul := result;πend;ππ{πThe first Touch would just decrement the counter in X, and the second wouldπdispose of it (assuming it wasn't already protected before the creation of Y).ππI've found that this system works Really well, and I can sleep at night,πknowing that I never leave dangling Pointers even though I'm doing lots ofπallocations and deallocations.ππHere, in Case you're interested, is the Real matrix multiplier:π}ππFunction MProd(x, y : PMatrix) : PMatrix;π{ Calculate the matrix product of x and y }πVarπ result : PMatrix;π i, j, k : Word;π mp : PFloat;πbeginπ if (x = nil) or (y = nil) or (x^.cols <> y^.rows) thenπ MProd := nilπ elseπ beginπ result := Matrix(x^.rows, y^.cols, nil, True);π if result <> nil thenπ With result^ doπ beginπ For i := 1 to rows doπ With x^.r^[i]^ doπ For j := 1 to cols doπ beginπ mp := pval(i,j);π mp^ := 0;π For k := 1 to x^.cols doπ mp^ := mp^ + c[k] * y^.r^[k]^.c[j];π end;π end;π MProd := result;π Touch(x);π Touch(y);π end;πend;ππ{πAs you can see, the memory allocation is a pretty minor part of it. Theπdynamic indexing is Really ugly (I'd like to use "y[k,j]", but I'm stuck usingπ"y^.r^[k]^.c[j]"), but I haven't found any way around that.π}ππ 27 08-27-9321:45ALL MICHAEL BYRNE Prime Numbers IMPORT 7 ₧ຠ{πMICHAEL M. BYRNEππ> the way, it took about 20 mins. on my 386/40 to get prime numbersπ> through 20000. I tried to come up With code to do the same Withπ> Turbo but it continues to elude me. Could anybody explainπ> how to Write such a routine in Pascal?ππHere is a simple Boolean Function For you to work With.π}ππFunction Prime(N : Integer) : Boolean;π{Returns True if N is a prime; otherwise returns False. Precondition: N > 0.}πVarπ I : Integer;πbeginπ if N = 1 thenπ Prime := Falseπ elseπ if N = 2 thenπ Prime := Trueπ elseπ begin { N > 2 }π Prime := True; {tentatively}π For I := 2 to N - 1 doπ if (N mod I = 0) thenπ Prime := False;π end; { N > 2 }πend;π 28 08-27-9321:45ALL JONATHAN WRITE More Prime Numbers IMPORT 9 ₧dz {πJONATHAN WRIGHTππHere is source For finding primes. I just pulled this off of an OLD backupπdisk, so I don't Really know how optimized it is, but it works:π}ππConstπ FirstPrime = 2;π MaxPrimes = 16000; (* Limit 64k For one Array, little more work For more *)ππVarπ Primes : Array [1..MaxPrimes] of LongInt;ππ PrimesFound : LongInt;π TestNumber : LongInt;π Count : LongInt;ππ IsPrime : Boolean;ππbeginπ PrimesFound := 1;π TestNumber := FirstPrime + 1;ππ For Count := 1 to MaxPrimes DOπ Primes[Count] := 0;ππ Primes[1] := FirstPrime;ππ Repeatπ Count := 1;π IsPrime := True;ππ Repeatπ if Odd (TestNumber) thenπ if TestNumber MOD Primes[Count] = 0 thenπ IsPrime := False;π INC (Count);π Until (IsPrime = False) or (Count > PrimesFound);ππ if IsPrime = True thenπ beginπ INC (PrimesFound);π Primes[PrimesFound] := TestNumber;π Write (TestNumber, ', ');π end;π INC (TestNumber);π Until PrimesFound = MaxPrimes;πend.π 29 08-27-9321:45ALL GUY MCLOUGHLIN Still More Primes IMPORT 20 ₧?█ {πGUY MCLOUGHLINππ>the way, it took about 20 mins. on my 386/40 to get prime numbersπ>through 20000. I tried to come up With code to do the same Withπ>Turbo but it continues to elude me. Could anybody explainπ>how to Write such a routine in Pascal?ππ ...The following PRIME routine should prove to be a bit faster:π}ππ{ Find the square-root of a LongInt. }πFunction FindSqrt(lo_IN : LongInt) : LongInt;ππ { SUB : Find square-root For numbers less than 65536. }π Function FS1(wo_IN : Word) : Word;π Varπ wo_Temp1,π wo_Temp2 : Word;π lo_Error : Integer;π beginπ if (wo_IN > 0) thenπ beginπ wo_Temp1 := 1;π wo_Temp2 := wo_IN;π While ((wo_Temp1 shl 1) < wo_Temp2) doπ beginπ wo_Temp1 := wo_Temp1 shl 1;π wo_Temp2 := wo_Temp2 shr 1;π end;π Repeatπ wo_Temp1 := (wo_Temp1 + wo_Temp2) div 2;π wo_Temp2 := wo_IN div wo_Temp1;π lo_Error := (LongInt(wo_Temp1) - wo_Temp2);π Until (lo_Error <= 0);π FS1 := wo_Temp1;π endπ elseπ FS1 := 0;π end;ππ { SUB : Find square-root For numbers greater than 65535. }π Function FS2(lo_IN : longInt) : longInt;π Varπ lo_Temp1,π lo_Temp2,π lo_Error : longInt;π beginπ if (lo_IN > 0) thenπ beginπ lo_Temp1 := 1;π lo_Temp2 := lo_IN;π While ((lo_Temp1 shl 1) < lo_Temp2) doπ beginπ lo_Temp1 := lo_Temp1 shl 1;π lo_Temp2 := lo_Temp2 shr 1;π end;ππ Repeatπ lo_Temp1 := (lo_Temp1 + lo_Temp2) div 2;π lo_Temp2 := lo_IN div lo_Temp1;π lo_Error := (lo_Temp1 - lo_Temp2);π Until (lo_Error <= 0);π FS2 := lo_Temp1;π endπ elseπ FS2 := 0;π end;ππbeginπ if (lo_IN < 65536) thenπ FindSqrt := FS1(lo_IN)π elseπ FindSqrt := FS2(lo_IN);πend;ππ{ Check if a number is prime. }πFunction Prime(lo_IN : LongInt) : Boolean;πVarπ lo_Sqrt,π lo_Loop : LongInt;πbeginπ if not odd(lo_IN) thenπ beginπ Prime := (lo_IN = 2);π Exit;π end;π if (lo_IN mod 3 = 0) thenπ beginπ Prime := (lo_IN = 3);π Exit;π end;π if (lo_IN mod 5 = 0) thenπ beginπ Prime := (lo_IN = 5);π Exit;π end;ππ lo_Sqrt := FindSqrt(lo_IN);π lo_Loop := 7;π While (lo_Loop < lo_Sqrt) doπ beginπ inc(lo_Loop, 2);π if (lo_IN mod lo_Loop = 0) thenπ beginπ Prime := False;π Exit;π end;π end;π Prime := True;πend;π 30 08-27-9321:46ALL JANOS SZAMOSFALVI More Primes Yet !! IMPORT 7 ₧Ma {πJANOS SZAMOSFALVIππthe following routine uses a brute force approach with someπoptimization; it took less than 3 minutes with a 286/12 to findπand print all primes up to 32768, about 50 seconds w/o printingπthem; it becomes a bit slow when you get into a 6 digit rangeπ}ππPROGRAM Primes;πVARπ number,π max_div,π divisor : INTEGER;π prime : BOOLEAN;πBEGINπ writeln('Primes:');π writeln('2');π FOR number := 2 TO MAXINT DOπ BEGINπ max_div := Round(sqrt(number) + 0.5);π prime := number MOD 2 <> 0;π divisor := 3;π WHILE prime AND (divisor < max_div) DOπ BEGINπ prime := number MOD divisor <> 0;π divisor := divisor + 2;π END;π IF prime THENπ writeln(number);π END;πEND.π 31 08-27-9321:47ALL MARK LEWIS Pythagorean Triples IMPORT 44 ₧┌ó Program PYTHAGOREAN_TRIPLES;π{written by Mark Lewis, April 1, 1990}π{developed and written in Turbo Pascal v3.0}ππConstπ hicnt = 100;π ZERO = 0;ππTypeπ PythagPtr = ^PythagRec; {Pointer to find the Record}π PythagRec = Record {the Record we are storing}π A : Real;π B : Real;π C : Real;π total : Real;π next : PythagPtr {Pointer to next Record in line}π end;ππVarπ Root : PythagPtr; {the starting point}π QUIT : Boolean;π ch : Char;ππProcedure listdispose(Var root : pythagptr);ππVarπ holder : pythagptr;ππbeginπ if root <> nil then {if we have Records in the list}π Repeat {...}π holder := root^.next; {save location of next Record}π dispose(root); {remove this Record}π root := holder; {go to next Record}π Until root = nil; {Until they are all gone}πend;ππProcedure findpythag(Var root : pythagptr);πVarπ x,y,z,stored : Integer;π xy,zz,xx,yy : Real;π abandon : Boolean;π workrec : pythagrec;π last,current : pythagptr;ππbeginπ stored := zero; {init count at ZERO}π For z := 1 to hicnt do {start loop 3}π beginπ zz := sqr(z); {square loop counter}π if zz < zero thenπ zz := 65536.0 + zz; {twiddle For negatives}π For y := 1 to hicnt do {start loop 2}π beginπ yy := sqr(y); {square loop counter}π if yy < zero thenπ yy := 65536.0 + yy; {twiddle For negatives}π For x := 1 to hicnt do {start loop 1}π beginπ abandon := False; {keep this one}π xx := sqr(x); {square loop counter}π xy := xx + yy; {add sqr(loop2) and sqr(loop1)}π if not ((xy <> zz) or ((xy = zz) and (xy = 1.0))) thenπ beginπ With workrec doπ beginπ a := x; {put them into our storage Record}π b := y;π c := z;π total := zz;π end;π if root = nil then {is this the first Record?}π beginπ new(root); {allocate space}π workrec.next := nil; {anchor the Record}π root^ := workrec; {store it}π stored := succ(stored); {how many found?}π endπ else {this is not the first Record}π beginπ current := root; {save where we are now}π Repeat {walk Records looking For dups}π if (current^.total = workrec.total) thenπ abandon := True; {is this one a dup?}{abandon it}π last := current; {save where we are}π current := current^.next {go to next Record}π Until (current = nil) or abandon;π if not abandon then {save this one?}π beginπ {we're going to INSERT this Record into the}π {line between the ones greater than and less}π {than the A Var in the Record}π {ie: 5,12,13 goes between 3,4,5 and 6,8,10}π if root^.a > workrec.a thenπ beginπ new(root); {allocate mem For this one}π workrec.next := last; {point to next rec}π root^ := workrec; {save this one}π stored := succ(stored); {how many found?}π endπ else {insert between last^.next and current}π beginπ new(last^.next); {allocate memory}π workrec.next := current; {point to current}π last^.next^ := workrec; {save this one}π stored := succ(stored); {how many found?}π end;π end;π end;π end;π end;π end;π end;π Writeln('I have found and stored ',stored,' Pythagorean Triples.');πend;ππProcedure showRecord(workrec : pythagrec);ππbeginπ With workrec doπ beginπ Writeln('A = ',a:6:0,' ',sqr(a):6:0);π Writeln('B = ',b:6:0,' ',sqr(b):6:0,' ',sqr(a)+sqr(b):6:0);π Writeln('C = ',c:6:0,' ',sqr(c):6:0,' <-^');π endπend;ππProcedure viewlist(root : pythagptr);ππVarπ i : Integer;π current : pythagptr;ππbeginπ if root = nil thenπ beginπ Writeln('<< Your list is empty! >>');π Write('>> Press (CR) to continue: ');π readln;π endπ elseπ beginπ Writeln('Viewing Records');π current := root;π While current <> nil doπ beginπ showRecord(current^);π Write('Press (CR) to view next Record. . . ');π readln;π current := current^.nextπ end;π endπend;ππbeginπ Writeln('PYTHAGOREAN TRIPLES');π Writeln('-------------------');π Writeln;π Writeln('Remember the formula For a Right Triangle?');π Writeln('A squared + B squared = C squared');π Writeln;π Writeln('I call the set of numbers that fits this formula');π Writeln(' Pythagorean Triples');π Writeln;π Writeln('This Program Uses a "brute force" method of finding all');π Writeln('the Pythagorean Triples between 1 and 100');π Writeln;π root := nil;π quit := False;π Repeatπ Writeln('Command -> [F]ind, [V]iew, [D]ispose, [Q]uit ');π readln(ch);π Case ch ofπ 'q','Q' : quit := True;π 'f','F' : findpythag(root);π 'v','V' : viewlist(root);π 'd','D' : listdispose(root);π end;π Until quit;π if root <> nil thenπ listdispose(root);π Writeln('Normal Program Termination');πend.ππ 32 09-26-9310:15ALL RYAN THOMPSON Math Parsing Unit IMPORT 32 ₧PΓ (*πFrom: RYAN THOMPSONπSubj: RE: MATH PARSINGπ*)ππFunction Evaluate(Equation : String) : String;π Varπ Temp, Operand, Front, Rear : String;π X, Y, Par1, Par2 : Integer;π Value1, Value2, Valtemp : Real;π OperOK,π BadExp : Boolean;π Beginπ If Equation = Error then beginπ Evaluate:= Error;π Exit;π end;π While Pos(' ', Equation) > 0 doπ Delete(Equation, Pos(' ', Equation), 1);π repeatπ X:= 1;π Par1:= 0;π Par2:= 0;π repeatπ If Equation[X] = '(' then Par1:= X;π If Equation[X] = ')' then Par2:= X;π Inc(X);π until (X = Length(Equation) + 1) or ((Par1 > 0) and (Par2 > 0));π If (Par2 > 0) and (Par2+1 < Length(Equation)) andπ (Equation[Par2 + 1] = '(')π then Insert('x', Equation, Par2 + 1);π If (Par2 > Par1) then beginπ Temp:= Equation;π Rear:= Copy(Temp, Par2 + 1, 255);π Delete(Temp, Par2, 255);π Front:= Copy(Temp, 1, Par1 - 1);π Delete(Temp, 1, Par1);π Temp:= Evaluate(Temp);π Equation:= Front + Temp + Rear;π While Pos(' ', Equation) > 0 doπ Delete(Equation, Pos(' ', Equation), 1);π endπ else if Par2 < Par1 then beginπ Evaluate:= Error;π Exit;π end;π until Par2 <= Par1;π Value1:= 0;π repeatπ If (Length(Equation) > 0) then beginπ Operand:= '';π X:= 1;π While ((Equation[X] < '0') or (Equation[X] > '9'))π and (Equation[X] <> '.')π and (X < Length(Equation) + 1)π do beginπ Operand:= Operand + Equation[X];π Inc(X);π end;π Delete(Equation, 1, X - 1);π end;π If Length(Equation) > 0 then beginπ Temp:= '0';π X:= 1;π while (((Equation[X] <= '9') and (Equation[X] >= '0'))π or (Equation[X] = '.')) and (X < Length(Equation) + 1) doπ beginπ Temp:= Temp + Equation[X];π Inc(X);π end;π If (X > 10) and (Pos('.', Equation) > 9) then beginπ Evaluate:= Error;π Exit;π end;π Delete(Equation, 1, X - 1);π Val(Temp, Value2, Y);π If Y <> 0 then beginπ Evaluate:= Error;π Exit;π end;π end;π Temp:= '';π If Length(Operand) > 1 then beginπ Temp:= Operand;π Delete(Temp, Pos('+', Temp), 1);π If Pos('-', Temp) <> Length(Temp)π then Delete(Temp, Pos('-', Temp), 1);π Delete(Temp, Pos('x', Temp), 1);π Delete(Temp, Pos('/', Temp), 1);π Delete(Temp, Pos('^', Temp), 1);π If Pos('+', Operand) = 1 then Operand:= '+'π else if Pos('-', Operand) = 1 then Operand:= '-'π else if Pos('x', Operand) = 1 then Operand:= 'x'π else if Pos('/', Operand) = 1 then Operand:= '/'π else if Pos('^', Operand) = 1 then Operand:= '^'π else Operand:= '';π end;π OperOK:= False;π If Temp = 'SIN' then beginπ OperOK:= True;π Value2:= Sin(Rad(Value2));π end;π If Temp = 'COS' then beginπ OperOK:= True;π Value2:= Cos(Rad(Value2));π end;π If Temp = 'TAN' then if Cos(Rad(Value2)) <> 0 then beginπ OperOK:= True;π Value2:= (Sin(Rad(Value2)) / Cos(Rad(Value2)));π endπ else beginπ Evaluate:= Error;π Exit;π end;π If Temp = 'SQR' then beginπ OperOK:= True;π Value2:= Sqrt(Value2);π end;π If Temp = 'ASIN' then beginπ OperOK:= True;π Valtemp:= 1 - Sqr(Value2);π If Valtemp < 0 then beginπ Evaluate:= Error;π Exit;π endπ else If Sqrt(Valtemp) = 0 then Value2:= 90π else Value2:= Deg(ArcTan(Value2 / Sqrt(Valtemp)));π end;π If Temp = 'ACOS' then beginπ OperOK:= True;π Valtemp:= 1 - Sqr(Value2);π If Valtemp < 0 then beginπ Evaluate:= Error;π Exit;π endπ else If Value2 = 0 then Value2:= 90π else Value2:= Deg(Arctan(Sqrt(Valtemp) / Value2))π end;π 33 11-02-9305:05ALL LOU DUCHEZ CALCULUS IMPORT 41 ₧█q { Updated NUMBERS.SWG on November 2, 1993 }ππ{πLOU DUCHEZππHey everybody! This unit performs calculus operations via basic numericalπmethods : integrals, derivatives, and extrema. By Lou DuChez. I don'tπwant any money for this; please just leave my name in the source codeπsomewhere, since this is the closest I'll ever get to being famous.ππAll functions return real values. The last parameter in each function isπa pointer to a "real" function that takes a single "real" parameter:πfor example, y(x). See prior message to Timothy C. Novak for sample prog }ππunit calculus;πinterfaceππfunction integral(a, b, h : real; f : pointer) : real;πfunction derivative(x, dx : real; f : pointer) : real;πfunction extremum(x, dx, tolerance : real; f : pointer) : real;ππimplementationππtypeπ fofx = function(x : real) : real; { needed for function-evaluating }ππfunction integral(a, b, h : real; f : pointer) : real;πvarπ x, summation : real;π y : fofx;πbegin { Integrates function from a to b, }π @y := f; { by approximating function with }π summation := 0; { rectangles of width h. }π x := a + h/2;π while x < b doπ begin { Answer is sum of rectangle areas, }π summation := summation + h*y(x); { each area being h*y(x). X is at }π x := x + h; { the middle of the rectangle. }π end;π integral := summation;πend;ππfunction derivative(x, dx : real; f : pointer) : real;πvarπ y : fofx;πbegin { Derivative of function at x: delta y over delta x }π @y := f; { You supply x & delta x }π derivative := (y(x + dx/2) - y(x - dx/2)) / dx;πend;πππfunction extremum(x, dx, tolerance : real; f : pointer) : real;π{ This function uses DuChez's Method for finding extrema of a function (yes,π I seem to have invented it): taking three points, finding the parabolaπ that connects them, and hoping that an extremum of the function is nearπ the vertex of the parabola. If not, at least you have a new "x" to try...ππ X is the initial value to go extremum-hunting at; dx is how far on eitherπ side of x to look. "Tolerance" is a parameter: if two consecutiveπ iterations provide x-values within "tolerance" of each other, the answerπ is the average of the two. }πvarπ y : fofx;π gotanswer,π increasing,π decreasing : boolean;π oldx : real;π itercnt : word;πbeginπ @y := f;π gotanswer := false;π increasing := false;π decreasing := false;π itercnt := 1;π repeat { repeat until you have answer }π oldx := x;π x := oldx - dx*(y(x+dx) - y(x-dx)) / { this monster is the new value }π (2*(y(x+dx) - 2*y(x) + y(x-dx))); { of "x" based DuChez's Method }π if abs(x - oldx) <= tolerance thenπ gotanswer := true { within tolerance: got an answer }π elseπ if (x > oldx) thenπ beginπ if decreasing thenπ begin { If "x" is increasing but it }π decreasing := false; { had been decreasing, we're }π dx := dx/2; { oscillating around the answer. }π end; { Cut "dx" in half to home in on }π increasing := true; { the extremum. }π endπ elseπ if (x < oldx) thenπ beginπ if increasing thenπ begin { same thing here, except "x" }π increasing := false; { is now decreasing but had }π dx := dx/2; { been increasing }π end;π decreasing := true;π end;π until gotanswer;ππ extremum := (x + oldx) / 2; { spit out answer }πend;ππend.ππππ{πI've put together a unit that does calculus. This unit could be used, forπexample, to approximate the area under a curve (like a circle).ππBecause of the funny way my offline reader breaks up messages, I'm goingπto send you a "test" program first -- which just happens to calculateπthe area under a quarter circle -- then the following message (I hope)πwill be the unit source code.π}ππprogram mathtest;πusesπ calculus;ππvarπ answer : real;ππ{$F+} { WARNING! YOU NEED "FAR" FUNCTIONS! }πfunction y(x : real) : real;πbeginπ y := 4 * sqrt(1 - x * x);πend;ππbeginπ writeln('Function: y = (1 - x^2)^(1/2) (i.e., top half of a circle)');π writeln;ππ{ Calc operations here are: }ππ{ Integrate function from 0 to 1, in increments of 0.001. A quarter circle. }π{ Get slope of function at 0 by evaluating points 0.01 away from each other. }π{ Find extremum of function, starting at 0.4, initially looking at pointsπ 0.1 on either side of 0.4, and not stopping until we have two x-valuesπ within 0.001 of each other. }ππ answer := integral(0, 1, 0.001, @y);π writeln('Integ: ', answer:13:9);ππ answer := derivative (0, 0.01, @y);π writeln('Deriv: ', answer:13:9);ππ answer := extremum(0.4, 0.1, 0.001, @y);π writeln('Extrm: ', answer:13:9);πend.ππ 34 11-02-9305:07ALL CORY ALBRECHT BASE36 Conversion IMPORT 16 ₧ê÷ { Updated NUMBERS.SWG on November 2, 1993 }ππ{πCORY ALBRECHTππ> Can someone please show me how I would convert a base 10 number toπ> base 36? (The one used by RIP)ππI presume you mean turning a Variable of Type Byte, Word, Integer, orπLongInt to a String representation of that number in base 36? Just checking,πsince once I had someone who had two Word Variables who asked me how theyπcould change Word1 to hexadecimal For putting it in Word2. The followingπcode will turn any number from 0 to 65535 to a String representation ofπthat number in any base from 2 to 36.π}ππUnit Conversion;ππInterfaceππConstπ BaseChars : Array [0..35] Of Char = ('0', '1', '2', '3', '4', '5',π '6', '7', '8', '9', 'A', 'B',π 'C', 'D', 'E', 'F', 'G', 'H',π 'I', 'J', 'K', 'L', 'M', 'N',π 'O', 'P', 'Q', 'R', 'S', 'T',π 'U', 'V', 'W', 'X', 'Y', 'Z');ππ{ n - number to convertπ b - base to convert toπ s - String to store result in }ππProcedure NumToStr(n : Word; b : Byte; Var s);ππImplementationππProcedure NumToStr(n : Word; b : Byte; Var s);πVarπ i,π res,π rem : Word;πbeginπ s := '';π if ((b < 2) or (b > 36)) Thenπ Exit;π res := n;π i := 1;π { Get the digits of number n in base b }π Repeatπ rem = res MOD b;π res := res div b;π s[i] := BaseChars[rem - 1];π Inc(s[0]);π Until rem = 0;π { Reverse s since the digits were stored backwards }π i := 1;π Repeatπ s[i] := Chr(Ord(s[i]) xor Ord(s[Length(s) - (i - 1)]));π s[Length(s) - (i - 1)] := Chr(Ord(s[Length(s) - (i - 1)]) xor Ord(s[i]));π s[i] := Chr(Ord(s[i]) xor Ord(s[Length(s) - (i - 1)]));π Inc(i);π Until i >= (Length(s) - (i - 1));πend;ππend.π 35 11-02-9305:08ALL JOHN GUILLORY Change Number Base IMPORT 6 ₧ê÷ { Updated NUMBERS.SWG on November 2, 1993 }ππ{πJOHN GUILLORYππ> Can someone please show me how I would convert a base 10 number to base 36?π}ππFunction BaseChange(Num, NewBase : Word) : String;πConstπ BaseChars : Array [0..36] of Char = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';πVarπ St : String;πbeginπ St := '';π Repeatπ St := BaseChars[Num MOD NewBase] + St;π Num := Num Div NewBase;π Until Num = 0;π BaseChange := St;πend;ππ{πThis will convert a number in Base10 (Stored in Orig) to any Base in theπrange of 2 through 36 (Please, no base-1's/0's)π}ππbeginπ Writeln(Basechange(33, 3));πend.π 36 11-02-9305:14ALL TIM MCKAY Conversion to Base 36 IMPORT 14 ₧wå (*πFrom: TIM MCKAYπSubj: RE: COVERTING TO BASE 36ππ JF> Can someone please show me how I would convert a base 10 number toπ JF> base 36? (The one used by RIP)π*)ππprogram convertbase;ππ const B: integer = 36; { B = the base to convert to }π S: string = ''; { S = the string representation of theπ result }π done: boolean = false;ππ var X, I, F: integer; { X = the original base 10 numberπ I = the integer portion of the resultπ F = the fractional portion of theπ result }π R: real; { R = theπintermediate real result }ππ beginπ readln(X); { Get original base 10 number }π R:=X;π while (not done) do begin { This loop continues to divide the }π R:= R/B; { result by the base until it reaches 0 }π I:= int (R); { The integer portion of the result is }π R:= I; { reassigned to R }π F:= frac(R) * B; { The fractional portion is converted to}π if f<10 then begin { an integer remainder of the original }π S:=chr(f+$30) + S; { base and converted to a character to }π end else begin { be added to the string representation }π S:=chr(f+$37) + S;π end;π if R<=0 then done:=true; { When R reaches 0 then you're done }π end;π writeln(S);π end.ππ 37 11-02-9305:27ALL ROBERT ROTHENBURG Complex Math IMPORT 5 ₧░ {πROBERT ROTHENBURGππ> Can you compute complex numbers and/or "i" in Pascal...if so, how.ππNot too hard. I've done that With some fractal Programs, which wereπwritten For TP5 (it might be easier using OOP With the later versions).ππI use two Variables For a complex number of a+bi, usually expressed asπxa and xb (or x.a and x.b as a Record).ππFor addition/subtraction (complex z=x+y):ππ z.a:=x.a+y.a;π z.b:=x.b+y.b;ππFor multiplication:ππ z.a:=(x.a*y.a)-(x.b*y.b);π z.b:=(x.a*y.b)+(x.b*y.a);π}π 38 11-02-9305:35ALL DEVEN HICKINGBOTHAM Trapping 8087 Errors IMPORT 32 ₧å┬ {π> I know that in pascal there is some way to create the Programπ> from crashing if the users does something wrong. I need to know how toπTo prevent Type errors on input always use Strings and convert themπafterwards using the VAL Procedure.ππTry this to trap arithmetic errors.π}ππ{$N+,G+}πUnit op8087;ππ{ The routines below duplicate two Op8087 routines For use in TPW, +π Exceptions8087 and Error8087. These routines are helpful when +π doing Real math and you don't want to explicitly check For divide +π by zero, underflow, and overflow. Need to use the compiler +π directives N+ and G+. See OPro or 8087 documentation For a complete +π description of the 8087 status Word returned by Error8087.ππ Do not embed Error8087 in a Write statement as the 8087 status Word +π will be cleared, and the result meaningless.ππ Version 1.00 09/17/92ππ Deven Hickingbotham, Tamarack Associates, 72365,46ππ -----------------------------------------------------------------π Added infinity and NAN 'Constants' and created Unit December 1992π Kevin Whitefoot, Aasgaten 45, N-3060 Svelvik, Norway.ππ After this Unit has initialized 8087 exceptions will be OFF and the NANπ and INF Variables set to NAN and INF respectively. These Variables can beπ used in comparisons or to indicate uninitialized Variables. The Variablesπ are of Type extended but are compatible With singles and doubles too. Youπ cannot assign the value in INF or NAN to a Real because the Real cannotπ represent these values (if you do you will get error 105).π -----------------------------------------------------------------ππ}πππInterfaceππProcedure Exceptions8087(On : Boolean);πFunction Error8087 : Word; {Assumes $G+, 287 or better }ππFunction isdoublenan(r : double) : Boolean;πFunction issinglenan(r : single) : Boolean;ππ{These two Functions are used instead of direct comparisons With NANs asπall numbers are = to NAN; very strange}ππConstπ nanpattern : Array [0..9] of Byte =π ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF);π { This is the bit pattern of an extended 'not a number'. The +π Variable NAN is overlaid on this as we cannot create a NAN in a +π normal Constant declaration.}πVarπ nan : extended Absolute nanpattern;π { not a number'; this is convenient For uninitialized numbers, +π errors and so on, parsers can be designed to return this when +π the input is not a number so that the error remains visible even +π if the user or Program takes no corrective action}π inf : extended;π { The initialization of this routine deliberately executes a +π divide by zero so as to create and infinity and stores it here +π For general use.}ππ singlenan : single;π doublenan : double;ππImplementationππFunction isdoublenan(r : double) : Boolean;πVarπ l1 : Array [0..1] of LongInt Absolute singlenan;π l2 : Array [0..1] of LongInt Absolute r;πbeginπ isdoublenan := (l1[0] = l2[0]) and (l1[1] = l2[1]);πend;ππFunction issinglenan(r : single) : Boolean;πVarπ l1 : LongInt Absolute singlenan;π l2 : LongInt Absolute r;πbeginπ issinglenan := l1 = l2;πend;ππProcedure Exceptions8087(On : Boolean); Assembler;πVarπ CtrlWord : Word;πAsmπ MOV AL, Onπ or AL, ALπ JZ @ExceptionsOffππ MOV CtrlWord, 0372H { Unmask IM, ZM, OM }π JMP #ExceptionsDoneππ @ExceptionsOff:π FSTCW CtrlWord { Get current control Word }π or CtrlWord, 00FFh { Mask all exceptions }ππ @ExceptionsDone:π FLDCW CtrlWord { Change 8087 control Word }πend;πππFunction Error8087 : Word; Assembler; {Assumes $G+, 287 or better }πAsmπ FSTSW AX { Get current status Word }π and AX, 03Fh { Just the exception indicators }π FCLEX { Clear exception indicators }πend;ππbeginπ Exceptions8087(False);π inf := 0; { Use a Variable not a Constant or the expression will beπ resolved at compile time and the compiler will complain }π inf := 1 / inf;π singlenan := nan;π doublenan := nan;πend.π 39 11-02-9305:38ALL THAI TRAN Expression Evaluator IMPORT 47 ₧<τ {π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πoperator, 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 operator 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).π}ππ{$X+}πProgram Expression_Evaluator;ππConstπ RPNMax = 10; { I think you only need 4, but just to be safe }π OpMax = 25;ππTypeπ String15 = String[15];ππVarπ Expression : String;π RPNStack : Array[1..RPNMax] of Real; { Stack For RPN calculator }π RPNTop : Integer;π OpStack : Array[1..OpMax] of Char; { Operator stack For conversion }π OpTop : Integer;ππProcedure RPNPush(Num : Real); { Add an operand to the top of the RPN stack }πbeginπ if RPNTop < RPNMax thenπ beginπ Inc(RPNTop);π RPNStack[RPNTop] := Num;π endπ else { Put some error handler here }πend;ππFunction RPNPop : Real; { Get the operand at the top of the RPN stack }πbeginπ if RPNTop > 0 thenπ beginπ RPNPop := RPNStack[RPNTop];π Dec(RPNTop);π endπ else { Put some error handler here }πend;ππProcedure RPNCalc(Token : String15); { RPN Calculator }πVarπ Temp : Real;π Error : Integer;πbeginπ Write(Token, ' '); { This just outputs the RPN expression }ππ if (Length(Token) = 1) and (Token[1] in ['+', '-', '*', '/']) thenπ Case Token[1] of { Handle operators }π '+' : RPNPush(RPNPop + RPNPop);π '-' : RPNPush(-(RPNPop - RPNPop));π '*' : RPNPush(RPNPop * RPNPop);π '/' :π beginπ Temp := RPNPop;π if Temp <> 0 thenπ RPNPush(RPNPop/Temp)π else { Handle divide by 0 error }π end;π endπ elseπ begin { Convert String to number and add to stack }π Val(Token, Temp, Error);π if Error = 0 thenπ RPNPush(Temp)π else { Handle error }π end;πend;ππProcedure OpPush(Operator : Char); { Add an operator onto top of the stack }πbeginπ if OpTop < OpMax thenπ beginπ Inc(OpTop);π OpStack[OpTop] := Operator;π endπ else { Put some error handler here }πend;ππFunction OpPop : Char; { Get operator at the top of the stack }πbeginπ if OpTop > 0 thenπ beginπ OpPop := OpStack[OpTop];π Dec(OpTop);π endπ else { Put some error handler here }πend;ππFunction Priority(Operator : Char) : Integer; { Return priority of operator }πbeginπ Case Operator OFπ '(' : Priority := 0;π '+', '-' : Priority := 1;π '*', '/' : Priority := 2;π else { More error handling }π end;πend;ππProcedure Evaluate(Expr : String); { Guess }πVarπ I : Integer;π Token : String15;πbeginπ OpTop := 0; { Reset stacks }π RPNTop := 0;π Token := '';ππ For I := 1 to Length(Expr) DOπ if Expr[I] in ['0'..'9'] thenπ begin { Build multi-digit numbers }π Token := Token + Expr[I];π if I = Length(Expr) then { Send last one to calculator }π RPNCalc(Token);π endπ elseπ if Expr[I] in ['+', '-', '*', '/', '(', ')'] thenπ beginπ if Token <> '' thenπ begin { Send last built number to calc. }π RPNCalc(Token);π Token := '';π end;ππ Case Expr[I] OFπ '(' : OpPush('(');π ')' :π beginπ While OpStack[OpTop] <> '(' DOπ RPNCalc(OpPop);π OpPop; { Pop off and ignore the '(' }π end;ππ '+', '-', '*', '/' :π beginπ While (OpTop > 0) ANDπ (Priority(Expr[I]) <= Priority(OpStack[OpTop])) DOπ RPNCalc(OpPop);π OpPush(Expr[I]);π end;π end; { Case }π endπ else;π { Handle bad input error }ππ While OpTop > 0 do { Pop off the remaining operators }π RPNCalc(OpPop);πend;ππbeginπ Write('Enter expression: ');π Readln(Expression);ππ Write('RPN Expression = ');π Evaluate(Expression);π Writeln;π Writeln('Answer = ', RPNPop : 0 : 4);πend.π 40 11-02-9306:22ALL GERD KORTEMEYER Getting a Square Root IMPORT 7 ₧{⌠ {πkortemey@rudolf.nscl.msu.edu (Gerd Kortemeyer)ππ>Does anyone have a Turbo Pascal 6.0/7.0 Function that will return theπ>square root of a regular 6 Byte Real argument. I need a faster one thanπ>the one the comes With TP7.0 because my Program is spending a lot of timeπ>in it.ππif you Really need to do fast FP-calculations you should use a coprocessorπ(or a 486DX) together With its dataTypes SINGLE, DOUBLE and EXTendED.ππif you already got a copro and still use Real, that's the worst thing youπcan do. In fact using Real With copro is often slower than Without becauseπthe 6 Byte Real always has to be converted into a copro dataType.ππNow here is what you can Write instead of x:=sqrt(a);π}πAsmπ fld aπ fsqrtπ fstp xπend;πππ 41 11-02-9306:28ALL LOU DUCHEZ Test of CALCULUS Unit IMPORT 9 ₧ü_ { LOU DUCHEZ }πprogram mathtest;πusesπ calculus;ππvarπ answer : real;ππ{$F+} { WARNING! YOU NEED "FAR" FUNCTIONS! }πfunction y(x : real) : real;πbeginπ y := 2 * sqrt(4 - x * x);πend;π{$F-}ππbeginπ Writeln;π Writeln('Function: y = 2 * (4 - x^2)^(1/2) (i.e., Circle Radius 2)');π Writeln;ππ{ Calc operations here are: }ππ{ Integrate function from -2 to 2, in increments of 0.001. A half circle. }π{ However since equation multiplies it by 2, then we get area of full circle }π{ Get slope of function at 0 by evaluating points 0.01 away from each other. }π{ Find extremum of function, starting at 0.4, initially looking at pointsπ 0.1 on either side of 0.4, and not stopping until we have two x-valuesπ within 0.001 of each other. }ππ answer := integral(-2, 2, 0.001, @y); writeln('Integ: ', answer:13:9);π answer := derivative(1, 0.001, @y); writeln('Deriv: ', answer:13:9);π answer := extremum(0.4, 0.1, 0.001, @y); writeln('Extrm: ', answer:13:9);π Writeln(4*Pi:0:6);πend.π 42 11-02-9306:31ALL LOU DUCHEZ Compute Angles IMPORT 18 ₧Hé {πLOU DUCHEZππ>I'm looking for the way turbo pascal computes the angle.π>Now how can I compute for the Angles C & B.ππ> b, c, a, B_angle, C_angle: real;ππ> ┌─┐B angleπ> │ └─────┐ aπ> b│ └─────┐π> │ └─────┐π> │A = 90 └─────┐π> └─────────────────────────┘ C angleπ> cππOkay, you've got b and c. There is an ArcTan function that returnsπan angle in radians. Try this:π}ππ b := abs(b); { these lines keep the operator from getting "cute" }π c := abs(c);π if c <> 0 thenπ begin { prevents "division by zero" thing }π C_angle := arctan(b/c);π B_angle := (pi/2) - C_angle; { 90 degrees minus the one angle }π endπ elseπ if b <> 0 thenπ begin { ditto }π B_angle := arctan(c/b);π C_angle := (pi/2) - B_angle;π endπ elseπ begin { you'll get here only if b = c = 0 }π B_angle := 0;π C_angle := 0;π writeln('That''s a dot, not a triangle!');π end;π{πMight I recommend that you have the user do data entry in a "repeat" loop,πso that he can get out only when he's put in actual positive values? Iπthink you'll discover that a little caution at data-entry time is worth itπin spared headaches later. (Note all the error-checking I had to do ...)ππOh, you wanted degrees, minutes, seconds. I don't know of any built-inπroutines for this (I admit I may have missed something), but here's someπtotally untested code to convert radians to degrees, minutes, seconds:π}πprocedure r2dms(rad : real; var deg, min, sec : real);πbeginπ deg := rad * 180 / pi; { conversion to degrees }π min := frac(deg) * 60; { convert remainder to minutes }π deg := trunc(deg); { lose the remainder on degrees }π sec := frac(min) * 60; { convert "minutes" remainder to seconds }π min := trunc(min); { lose the remainder on minutes }πend;ππ{ Here's the reverse journey: }ππprocedure dms2r(deg, min, sec : real; var rad : real);πbeginπ rad := pi * (deg + 60 * min + 3600 * sec) / 180;πend;π 43 11-02-9310:30ALL LOU DUCHEZ Pascal Triangle IMPORT 14 ₧╚╪ {πLOU DUCHEZππ>Also, does anyone have anycode to do Pascal's Triangle?ππThe pattern is:ππ 1 1π 1 2 1π 1 3 3 1π 1 4 6 4 1ππwhere each element = the sum of the two above it.ππArrange it like this:ππ0110 -- The zeros are needed so that the algorithm can process the 1's.π01210π013310π0146410ππI'd have two Arrays: one shows the last row's figures, and the other holdsπthe current row's figures. Each "new" element (call the index "i") = theπsum of "previous" element "i" + "previous" element "i - 1".π}ππProcedure CalcPascalRow(r : Word); { which row to calculate }ππVarπ prows : Array[0..1, 0..100] of Word;{ your two Arrays }π thisrow,π lastrow : Byte; { point to this row & last row }π i, j : Word; { counters }ππbeginπ lastrow := 0; { set up "which row is which" }π thisrow := 1;π prows[lastrow, 0] := 0; { set up row "1": 0110 }π prows[lastrow, 1] := 1;π prows[lastrow, 2] := 1;π prows[lastrow, 3] := 0;π For j := 2 to r doπ begin { generate each "line" starting w/2 }π prows[thisrow, 0] := 0;π For i := 1 to j + 1 doπ begin { each "new" element = sum of "old" }π prows[thisrow, i] := { element + predecessor to "old" }π prows[lastrow, i] + { element }π prows[lastrow, i - 1];π end;π prows[thisrow, j + 2] := 0;π lastrow := thisrow; { prepare For next iteration }π thisrow := (thisrow + 1) mod 2;π end;π For i := 1 to r + 1 doπ { Write each element of desired line }π Write(prows[lastrow, i] : 4);π Writeln;πend;π 44 11-02-9310:30ALL WILLIAM SCHROEDER PATTERNS IMPORT 30 ₧τå {πWILLIAM SCHROEDERππI'd like to extend thanks to everyone For helping me set up a PATTERN Program.πYes, I have done it! Unfortunatley, this Program doesn't have all possibleπpattern searches, but I figured out an algorithm For increasing size geometricπpatterns such as 2 4 7 11. The formula produced is as follows: N = the Nthπterm. So whatever the formula, if you want to find an Nth term, get out someπpaper and replace N! :) Well, here's the Program, folks. I hope somebody canπmake some improvements on it...π}πProgram PatternFinder;ππUsesπ Crt;ππVarπ ans : Char;π PatType : Byte;π n1, n2,π n3, n4 : Integer;ππProcedure GetInput;πbeginπ ClrScr;π TextColor(lightcyan);π Writeln('This Program finds patterns For numbers in increasing size.');π Write('Enter the first four terms in order: ');π TextColor(yellow);π readln(n1, n2, n3, n4);πend;ππProcedure TestRelations;πbeginπ PatType := 0;π { 1 3 5 }π if (n3 - n2 = n2 - n1) and ((n4 - n3) = n2 - n1) thenπ PatType := 1π elseπ { 1 3 9 }π if (n3 / n2) = (n4 / n3) thenπ PatType := 2π elseπ { 1 1 2 }π if (n3 = n2 + n1) and (n4 = (n3 + n2)) thenπ PatType := 3π elseπ { 1 2 4 7 11 }π if ((n4 - n3) - (n3 - n2)) = ((n3 - n2) - (n2 - n1)) thenπ PatType := 4;πend;ππProcedure FindFormula;ππ Procedure DoGeoCalc;π Varπ Factor : Real;π Dif,π Shift,π tempn,π nx, ny : Integer;π beginπ Dif := (n3 - n2) - (n2 - n1);π Factor := Dif * 0.5;π Shift := 0;π ny := n2;π nx := n1;π if ny > nx thenπ While (ny-nx) <> dif doπ beginπ Inc(Shift);π tempn := nx;π nx := nx - ((ny - nx) - dif);π ny := tempn;π end;π if Factor <> 1 thenπ Write('(', Factor : 0 : 1, ')');π if Shift = 0 thenπ Write('(N + 0)(N - 1)')π elseπ beginπ if Shift > 0 thenπ beginπ Write('(N + ', shift, ')(N');π if Shift = 1 thenπ Write(')')π elseπ Write(' + ', shift - 1, ')');π end;π end;π if nx <> 0 thenπ Writeln(' + ', nx)π elseπ Writeln;π end;ππbeginπ TextColor(LightGreen);π Writeln('Formula =');π TextColor(white);π Case PatType ofπ 1 :π beginπ { Nth term = first term + difference * (N - 1) }π if n2 - n1 = 0 thenπ Writeln(n1)π elseπ if (n2 - n1 = 1) and (n1 - 1 = 0) thenπ Writeln('N')π elseπ if n2 - n1 = 1 thenπ Writeln('N + ', n1 - 1)π elseπ if (n2 - n1) = n1 thenπ Writeln(n1, 'N')π elseπ Writeln(n2 - n1, '(N - 1) + ', n1);π end;ππ 2 :π beginπ { Nth term = first term * ratio^(N - 1) }π if n1 = 1 thenπ Writeln(n2 / n1 : 0 : 0, '^(N - 1)')π elseπ Writeln(n1, ' x ', n2 / n1 : 0 : 0, '^(N - 1)');π end;ππ 3 :π beginπ { Fibonacci Sequence }π Writeln('No formula: Fibonacci Sequence (Term1 + Term2 = Term3)');π Writeln(' ',π n1 : 5, ' + ', n2 : 5, ' = ', (n1 + n2) : 5);π end;ππ 4 :π beginπ { Geometric Patterns }π DoGeoCalc;π end;π end;πend;ππbeginπ GetInput;π TestRelations;π TextColor(LightRed);π Writeln;π if PatType <> 0 thenπ FindFormulaπ elseπ Writeln('No pattern found: This Program may not know how to look '+π 'for that pattern.');π TextColor(lightred);π Writeln;π Write('Press any key...');π ans := ReadKey;π ClrScr;πend.ππ{πThat's all folks! if you can find and fix any bugs For me, please send me thatπsection of the code so I can change it. if anybody cares to ADD to the patternπcheck, be my guest! This Program can be altered and used by ANYBODY. I'd justπlike to expand it a bit. Have fun!π}π 45 11-02-9310:31ALL LOU DUCHEZ Calculate PI IMPORT 18 ₧å {πLOU DUCHEZππATTENTION, whoever was trying to calculate PI! Here's a swell program,πas a follow-up to a recent post of mine about approximating techniques!ππ}ππprogram calcpi; { Calculates pi by getting the area of one-quarter of aπ circle of radius 1, and then multiplying by 4. The areaπ is an approximation, derived by Simpson's method: seeπ previous post for explanation of that technique. }ππusesπ crt;ππconstπ lowerbound = 0; { The interval we're evaluating is from 0 to 1. }π higherbound = 1; { I put the 0 and 1 here for clarity. }ππvarπ incs : word;π quartpi,π h, x : real;ππfunction y(x : real) : real; { Feed it an x-value, and it tells you the }πbegin { corresponding y-value on the unit circle. }π y := sqrt(1 - x * x); { A no-brainer. }πend;ππbeginπ { I leave you to do the error-checking on input. }π clrscr;π write('Enter a WORD (1 - 32767) for the number of parabolas to do: ');π readln(incs);ππ { The answer for a quarter of pi will be accumulated into QuartPi. }π quartpi := 0;ππ { H is the interval to increment on. X is the "middle" x value for eachπ parabola in Simpson's method. Here it is set equal to one intervalπ above the lower bound: Simpson's method looks at points on either sideπ of "X", so my reasoning is obvious. Note also that, by magicalπ coincidence, the last evaluation will have "X" equal to the higherπ bound of the interval minus H. }ππ h := (higherbound - lowerbound) / (1 + 2 * incs);π x := lowerbound + h;ππ { This loop accumulates a value for pi/4. }π while incs > 0 doπ beginπ if x < 0 thenπ x := 0;π quartpi := quartpi + y(x - h) + 4 * y(x) + y(x + h);ππ { Move X two increments to the right, and decrease the number of parabolasπ we still have to do. }π x := x + 2 * h;π dec(incs);π end;ππ { Simpson's method has you multiply the sum by H/3. }π quartpi := h * quartpi / 3;ππ { Print answer. }π writeln(4 * quartpi : 12 : 8);π writeln('This has been a display of Simpson''s method. D''ohh!');πend.π 46 11-02-9310:31ALL BEN CURTIS Derive PI in Pascal IMPORT 12 ₧01 {πBEN CURTISππHere is a Program that I have written to derive Pi. The formula isπ4 - 4/3 + 4/5 - 4/7 + 4/9... ad infinitum. Unfortunately, I can only getπ14 decimal places using TP 6. if there is a way For me to be able to getπmore than 14 decimal places, please let me know.ππNB: Program Modified by Kerry Sokalsky to increase speed by over 40% -π I'm sure tons more can be done to speed this up even more.π}ππ{$N+}ππUsesπ Dos, Crt;ππVarπ sum : Real;π x, d,π Count : LongInt;π Odd : Boolean;ππbeginπ x := 3;π d := 4;π Sum := 4;π Odd := True;π Count := 0;ππ Writeln(#13#10, 'Iteration Value', #13#10);ππ ClrScr;ππ Repeatπ Inc(Count);π if Odd thenπ Sum := Sum - d/xπ elseπ Sum := Sum + d/x;π Inc(x, 2);ππ Odd := (Not Odd);ππ GotoXY(1, 3);π Write(Count);π GotoXY(12, 3);π Write(Sum : 0 : 7);π Until KeyPressed;ππend.ππ{π I have to warn you, it took me two hours to get a definite answerπfor 6 decimal places on my 486sx25. I guess it would be faster on a dx.πI'll run it on a 486dx2/66 on Tuesday and see if I can get it out to 14πdecimal places. It takes about 135000 iterations to get 4 decimal places.πAgain, please let me know if you know of a way to get more than 14 decimalπplaces -- I would love to get this sucker out to more. :)π}π 47 11-02-9316:08ALL LOU DUCHEZ BASE of a Number IMPORT 36 ₧Ç { Three ways to find the BASE of a number }πππfunction base2l(strin: string; base: byte): longint;ππ{ converts a string containing a "number" in another base into a decimalπ longint }ππvar cnter, len: byte;π dummylint: longint;π seendigit, negatize: boolean;π begalpha, endalpha, thschr: char;πbeginπ dummylint := 0;π begalpha := char(65);π endalpha := char(64 + base - 10);π negatize := false;π seendigit := false;π len := length(strin);π cnter := 1;ππ { the following loop processes each character }ππ while cnter <= len do beginπ thschr := upcase(strin[cnter]);π case thschr ofπ '-': if seendigit then cnter := len else negatize := true;ππ { if we haven't seen any "digits" yet, it'll be a negativeπ number; otherwise the hyphen is an extraneous character soπ we're done processing the string }ππ '0' .. '9': if byte(thschr) - 48 < base then beginπ dummylint := base*dummylint + byte(thschr) - 48;π seendigit := true;π endπ else cnter := len;ππ { 0-9: if the base supports the digit, use it; otherwise,π it's an extraneous character and we're done }ππ ' ': if seendigit then cnter := len;ππ { space: if we've already encountered some digits, we're done }ππ else beginππ { all other characters }ππ if (thschr >= begalpha) and (thschr <= endalpha) thenππ { an acceptable character for this base }ππ dummylint := base*dummylint + byte(thschr) - 65 + 10π elseππ { not acceptabe: we're done }ππ cnter := len;π end;π end;π cnter := cnter + 1;π end;π if negatize then dummylint := -dummylint;π base2l := dummylint;π end;ππ{Another way:}ππfunction l2base(numin: longint; base, numplaces: byte; leadzero: boolean): string;ππ{ Converts a longint into a string representing the number in another base.π Numin = the longint; base = base; numplaces is how many characters the answerπ should go in; leadzero indicates whether to put leading zeros. }ππvar tmpstr: string;π remainder, cnter, len: byte;π negatize: boolean;πbeginπ negatize := (numin < 0);π if negatize then numin := abs(numin);ππ { assign number of places in string }ππ tmpstr[0] := char(numplaces);π len := numplaces;ππ { now fill those places from right to left }ππ while numplaces > 0 do beginπ remainder := numin mod base;π if remainder > 9 thenπ tmpstr[numplaces] := char(remainder + 64 - 9)π elseπ tmpstr[numplaces] := char(remainder + 48);π numin := numin div base;π numplaces := numplaces - 1;π end;ππ { not enough room assigned: fill with asterisks }ππ if (numin <> 0) or (negatize and (tmpstr[1] <> '0')) thenπ for numplaces := 1 to byte(tmpstr[0]) do tmpstr[numplaces] := '*';ππ { put in minus sign }ππ if leadzero then beginπ if negatize and (tmpstr[1] = '0') then tmpstr[1] := '-'π endπ else beginπ cnter := 1;π while (cnter < len) and (tmpstr[cnter] = '0') do beginπ tmpstr[cnter] := ' ';π cnter := cnter + 1;π end;π if negatize and (cnter > 1) then tmpstr[cnter - 1] := '-';π end;π l2base := tmpstr;π end;ππ{ Yet another way }ππProgram ConvertBase;ππProcedure UNTESTEDConvertBase(BaseN:Byte; BaseNNumber:String;π BaseZ:Byte; var BaseZNumber:String);ππvarπ I: Integer;π Number,Remainder: LongInt;ππbeginπ Number := 0;π for I := 1 to Length (BaseNNumber) doπ case BaseNNumber[I] ofπ '0'..'9': Number := Number * BaseN + Ord (BasenNumber[I]) - Ord ('0');π 'A'..'Z': Number := Number * BaseN + Ord (BasenNumber[I]) -π Ord ('A') + 10;π 'a'..'z': Number := Number * BaseN + Ord (BasenNumber[I]) -π Ord ('a') + 10;π end; BaseZNumber := ''; while Number > 0 doπ beginπ Remainder := Number mod BaseZ;π Number := Number div BaseZ;π case Remainder ofπ 0..9: BaseZNumber := Char (Remainder + Ord ('0')) + BaseZNumber;π 10..36: BaseZNumber := Char (Remainder - 10 + Ord ('A')) + BaseZNumber;π end;ππend; end;πππvar BaseN,BaseZ:Byte;π BaseNNumber,π BaseZNumber:String;ππBeginππ Write(' BASE N > ');π Readln(BaseN);π Write(' NUMBER N> ');π Readln(BaseNNumber);π Write(' BASE Z > ');π Readln(BaseZ);π Write(' NUMBER Z> ');π UntestedConvertBase(BaseN,BaseNNumber,BaseZ,BaseZNumber);π Writeln(BaseZNumber);π Readln;πend.π 48 11-21-9309:29ALL WARREN PORTER Math Evaluations IMPORT 72 ₧ ï {πFrom: WARREN PORTERπSubj: evalπProgram to evaluate expressions using a stack. }ππconstπ Maxstack = 100;ππtypeππ stack = recordπ top : 0..Maxstack;π Item : array[1..Maxstack] of charπ end;ππ RealStack = recordπ top: 0..Maxstack;π Item : array[1..Maxstack] of realπ end;ππ xptype = recordπ oper : char;π opnd : realπ end;ππFunction Empty(var A:stack):boolean;ππBeginπ Empty:= A.top = 0;πEnd;ππFunction Pop(var A:stack):char;ππBeginπ if A.Top < 1 thenπ beginπ writeln('Attempt to pop an empty stack');π halt(1)π end;π Pop:= A.item[A.top];π A.top:= A.top - 1πEnd;ππProcedure Push(var A:stack; Nchar:char);ππBeginπ if A.Top = Maxstack thenπ beginπ writeln('Stack already full');π halt(1)π end;π A.top:= A.top + 1;π A.item[A.top]:=NcharπEnd;ππ {The following functions are for the real stack only.}ππFunction REmpty(var D:RealStack):boolean;ππBeginπ REmpty:= D.top = 0;πEnd;ππFunction RPop(var D:RealStack):real;ππBeginπ if D.Top < 1 thenπ beginπ writeln('Attempt to pop an empty RealStack');π halt(1)π end;π RPop:= D.item[D.top];π D.top:= D.top - 1πEnd;ππProcedure RPush(var D:RealStack; Nreal:real);ππBeginπ if D.Top = MaxStack thenπ beginπ writeln('Stack already full');π halt(1)π end;π D.top:= D.top + 1;π D.item[D.top]:=NrealπEnd;ππFunction pri(op1, op2:char):boolean;ππvarπ tpri: boolean;πBeginπ if op2 = ')' thenπ tpri:= true elseπ if (op1 = '$') and (op2 <> '$') and (op2 <> '(') thenπ tpri:= true elseπ if (op1 in ['*','/']) and (op2 in ['+','-']) thenπ tpri:= trueπ elseπ tpri:= false;π pri:= tpri{;π write('Eval op 1= ',op1, ' op2 = ',op2);π if tpri= false thenπ writeln(' false')π elseπ writeln(' true')}πEnd;ππFunction ConvReal(a:real;NumDec:integer):real;ππvarπ i, tenpower: integer;ππBeginπ tenpower:= 1;π for i:= 1 to NumDec doπ tenpower:= tenpower * 10;π ConvReal:= a / tenpowerπEnd;ππFunction ROper(opnd1, opnd2: real; oper: char):real;πVar temp: real;ππBeginπ Case oper ofπ '+': temp:= opnd1 + opnd2;π '-': temp:= opnd1 - opnd2;π '*': temp:= opnd1 * opnd2;π '/': temp:= opnd1 / opnd2;π '$': temp:= exp(ln(opnd1) * opnd2)π End {Case} ;π {Writeln(opnd1:6:3,' ',oper,' ',opnd2:6:3 ,' = ',temp:6:3);}π ROper := tempπEnd; {R oper}ππ{Main procedure starts here}ππvarπ A: stack;π Inbuff:string[Maxstack];π len, i, j, NumDecPnt, lenexp: integer;π temp, opnd1, opnd2, result : real;π valid, expdigit, expdec, isneg, openok: boolean;π operators, digits : set of char;π HoldTop : char;π B: array[1..Maxstack] of xptype;π C: array[1..Maxstack] of xptype;π D: RealStack;ππBeginπ digits:= ['0'..'9'];π operators:= ['$','*','/','+','-','(',')'];π Writeln('Enter expression to evaluate or RETURN to stop');π Writeln('A space should follow a minus sign unless it is used to');π Writeln('negate the following number. Real numbers with multi-');π Writeln('digits and decimal point (if needed) may be entered.');π Writeln;π Readln(Inbuff);π len:=length(Inbuff);ππ repeatπ i:= 1;π A.top:= 0;π valid:= true;π repeatπ if Inbuff[i] in ['(','[','{'] thenπ push(A,Inbuff[i])π elseπ if Inbuff[i] in [')',']','}'] thenπ if empty(A) thenπ valid:= falseπ elseπ if (ord(Inbuff[i]) - ord(Pop(A))) > 2 thenπ valid:= false;π i:= i + 1π until (i > len) or (not valid);π if not empty(A) thenπ valid:= false;π if not valid thenπ Writeln('The expression is invalid')π elseπ Beginπ {Change all groupings to parenthesis}π for i:= 1 to len do Beginπ if Inbuff[i] in ['[','{'] thenπ Inbuff[i]:= '(' elseπ if Inbuff[i] in [']','}'] thenπ Inbuff[i]:= ')';π B[i].oper:= ' ';π B[i].opnd:= 0;π C[i].oper:= ' ';π C[i].opnd:= 0 End;ππ { The B array will be the reformatted input string.π The C array will be the postfix expression. }ππ i:= 1; j:= 1; expdigit:= false; expdec:= false; isneg:= false;π while i <= len doπ Beginπ if (Inbuff[i] = '-') and (Inbuff[i + 1] in digits) thenπ Beginπ isneg:= true;π i:= i + 1π End;π if (Inbuff[i] = '.' ) then Beginπ i:= i + 1;π expdec:= true End;π if Inbuff[i] in digits thenπ Beginπ if expdec thenπ NumDecPnt:= NumDecPnt + 1;π if expdigit thenπ temp:= temp * 10 + ord(inbuff[i]) - ord('0')π else Beginπ temp:= ord(inbuff[i]) - ord('0');π expdigit:= true Endπ Endπ elseπ if expdigit = true then Beginπ if isneg thenπ temp:= temp * -1;π B[j].opnd:= ConvReal(temp,NumDecPnt);π j:= j + 1;π expdigit := false;π expdec := false;π NumDecPnt:= 0;π isneg:= false End;ππ If Inbuff[i] in operators then Beginπ B[j].oper:= Inbuff[i];π j:= j + 1 End;ππ if not (Inbuff[i] in digits) andπ not (Inbuff[i] in operators) andπ not (Inbuff[i] = ' ') then Beginπ Writeln('Found invalid operator: ',Inbuff[i]);π valid:= false End;ππ i:= i + 1;ππ End; {While loop to parse string.}ππ if expdigit = true then Beginπ if isneg thenπ temp:= temp * -1;π B[j].opnd:= ConvReal(temp,NumDecPnt);π j:= j + 1;π expdigit := false;π expdec := false;π NumDecPnt:= 0;π isneg:= false End;ππ End; {First if valid loop. Next one won't run if invalid operator}ππ if valid thenπ Beginπ lenexp:= j - 1; {Length of converted expression}π writeln;π for i:= 1 to lenexp doπ Beginπ if B[i].oper = ' ' thenπ write(B[i].opnd:2:3)π elseπ write(B[i].oper);π write(' ')π End;ππ {Ready to create postfix expression in array C }ππ A.top:= 0;π j:= 0;ππ for i:= 1 to lenexp doπ Beginπ {writeln('i = ',i);}π if B[i].oper = ' ' then Beginπ j:= j + 1;π C[j].opnd:= B[i].opnd Endπ elseπ Beginπ openok := true;π while (not empty(A) and openok andπ pri(A.item[A.top],B[i].oper)) doπ Beginπ HoldTop:= pop(A);π if HoldTop = '(' thenπ openok:= falseπ elseπ Beginπ j:= j + 1;π C[j].oper:=HoldTopπ Endπ End;π if B[i].oper <> ')' thenπ push(A,B[i].oper);π End; {Else}π End; {For loop}ππ while not empty(A) doπ Beginπ HoldTop:= pop(A);π if HoldTop <> '(' thenπ Beginπ j:= j + 1;π C[j].oper:=HoldTopπ Endπ End;ππ lenexp:= j; {Since parenthesis are not included in postfix.}ππ for i:= 1 to lenexp doπ Beginπ if C[i].oper = ' ' thenπ write(C[i].opnd:2:3)π elseπ write(C[i].oper);π write(' ')π End;ππ {The following evaluates the expression in the real stack}ππ D.top:=0;π for i:= 1 to lenexp doπ Beginπ if C[i].oper = ' ' thenπ Rpush(D,C[i].opnd)π elseπ Beginπ opnd2:= Rpop(D);π opnd1:= Rpop(D);π result:= ROper(opnd1,opnd2,C[i].oper);π Rpush(D,result)π End {else}π End; {for loop}π result:= Rpop(D);π if Rempty(D) thenπ writeln(' = ',result:2:3)π elseπ writeln(' Could not evaluate',chr(7))π End;ππ Readln(Inbuff);π len:= length(Inbuff)π until len = 0πEnd.ππ 49 11-21-9309:37ALL GREG VIGNEAULT 32Bit unsigned integers IMPORT 49 ₧c {πFrom: GREG VIGNEAULTπSubj: 32-bit unsigned integersπDoes there exist a 32 BIT unsigned (0..xxxx) word in pascal ??πi've got a hexidecimal string (ex. 'E72FAB32') .. now i want toπconvert this to a decimal value (not below 0 such as longint andπextended do) so i can devide this by for example 5000000πππ (Note: check at END of code for the required ULONGS.OBJ file)π}ππ(*******************************************************************)πPROGRAM Longs; { compiler: Turbo Pascal v4.0+ }π { 18-Nov-93 Greg Vigneault }π{ Purpose: arithmetic functions for unsigned long integers in TP... }π(*-----------------------------------------------------------------*)π{ The following external (assembly) functions *MUST* be linked into }π{ the main Program, _not_ a Unit. }ππ{$L ULONGS.OBJ} { link in the assembly code }πFUNCTION LongADD (Addend1,Addend2:LONGINT):LONGINT; EXTERNAL;πFUNCTION LongSUB (LongWord,Subtrahend:LONGINT):LONGINT; EXTERNAL;πFUNCTION LongMUL (Multiplicand,Multiplier:LONGINT):LONGINT; EXTERNAL;πFUNCTION LongDIV (Dividend,Divisor:LONGINT):LONGINT; EXTERNAL;πFUNCTION LongMOD (Dividend,Divisor:LONGINT):LONGINT; EXTERNAL;πPROCEDURE WriteULong (LongWord:LONGINT; { the longword }π Width:BYTE; { _minimum_ field width }π FillChar:CHAR; { leading space char }π Base:BYTE); EXTERNAL; { number base 2..26 }π(*-----------------------------------------------------------------*)πPROCEDURE TestLongs ( Long1,Long2 :LONGINT;π Width :BYTE;π Fill :CHAR;π Base :BYTE);π PROCEDURE Reduce1;π BEGINπ WriteULong (Long1,1,Fill,10); Write (',');π WriteULong (Long2,1,Fill,10); Write (') result: ');π END {Reduce1};π PROCEDURE Reduce2;π BEGINπ CASE Base OFπ 2 : WriteLn (' binary'); { base 2: binary }π 10 : WriteLn (' dec'); { base 10: familiar decimal }π 16 : WriteLn (' hex'); { base 16: hexadecimal }π END;π END {Reduce2};π BEGIN {TestLongs}π Write ('LongADD ('); Reduce1;π WriteULong ( LongADD(Long1,Long2),Width,Fill,Base ); Reduce2;π Write ('LongSUB ('); Reduce1;π WriteULong ( LongSUB(Long1,Long2),Width,Fill,Base ); Reduce2;π Write ('LongMUL ('); Reduce1;π WriteULong ( LongMUL(Long1,Long2),Width,Fill,Base ); Reduce2;π Write ('LongDIV ('); Reduce1;π WriteULong ( LongDIV(Long1,Long2),Width,Fill,Base ); Reduce2;π Write ('LongMOD ('); Reduce1;π WriteULong ( LongMOD(Long1,Long2),Width,Fill,Base ); Reduce2;π WriteLn;π END {TestLongs};π(*-----------------------------------------------------------------*)ππVAR Long1, Long2 :LONGINT;π Width, Base :BYTE;ππBEGINππ Long1 := 2147483647;π Long2 := 1073741823;π Width := 32;ππ WriteLn;π FOR Base := 2 TO 16 DOπ IF Base IN [2,10,16] THENπ TestLongs (Long1,Long2,Width,'_',Base);ππEND.ππ---------------------------------------------------------------------------ππ Run this program, it will create ULONGS.ZIP, which contains theπ ULONGS.OBJ file needed for the LongXXX functions...ππ(*********************************************************************)π PROGRAM A; VAR G:File; CONST V:ARRAY [ 1..701 ] OF BYTE =(π80,75,3,4,20,0,0,0,8,0,236,50,114,27,51,246,185,93,71,2,0,0,189,3,0,0,π10,0,0,0,85,76,79,78,71,83,46,79,66,74,189,83,77,104,19,65,20,126,179,π187,217,196,53,104,67,176,162,1,181,135,10,118,80,212,158,36,151,166,π110,215,22,154,4,76,119,133,66,75,241,160,23,169,146,102,123,14,132,80,π233,92,4,65,132,122,8,197,91,142,198,155,212,52,238,138,181,136,157,205,π65,75,15,5,91,145,18,255,64,76,80,138,248,54,19,17,4,193,147,11,111,190,π247,190,247,189,111,222,30,38,31,6,205,190,118,125,250,234,204,169,68,π38,249,228,78,24,64,209,19,99,9,229,124,90,31,234,185,27,132,169,19,32,π73,164,142,217,192,126,73,150,201,158,91,195,0,82,112,52,157,186,144,π208,245,9,128,118,154,76,235,5,34,82,125,196,250,218,97,51,230,224,141,π95,2,115,116,1,64,187,116,113,100,108,200,244,9,0,168,220,84,0,22,9,47,π157,4,2,255,254,157,45,69,37,9,192,100,239,153,161,244,109,23,171,185,π36,251,204,12,141,89,225,254,21,246,154,213,250,189,86,243,118,171,57,π87,207,36,138,85,251,67,209,179,119,152,17,234,219,142,47,207,70,216,π58,93,102,207,42,210,188,165,190,232,121,211,98,171,21,105,60,255,252,π116,254,251,185,89,57,95,11,34,247,113,162,166,117,204,153,165,202,70,π40,106,105,19,181,144,160,52,106,168,217,195,118,8,253,168,161,100,187,π16,153,133,164,18,179,84,95,68,171,212,107,52,81,186,251,24,128,122,216,π46,239,93,195,49,60,115,91,180,90,46,211,13,186,66,189,167,42,192,49,π62,173,242,73,101,166,75,198,34,122,4,99,31,70,55,0,63,142,209,253,59,π126,32,111,123,172,222,89,2,141,119,255,112,190,239,59,35,143,43,151,π153,161,150,253,114,105,192,95,166,125,27,118,120,47,55,37,110,42,220,π84,249,26,175,115,206,189,56,90,103,207,196,209,60,75,227,120,125,182,π55,142,139,100,143,82,60,99,88,199,176,19,67,77,33,64,10,166,4,5,83,193,π80,33,101,63,96,1,102,74,127,221,198,150,119,240,215,255,235,66,254,46,π218,189,6,56,37,32,132,128,179,164,16,226,172,138,252,37,130,12,78,29,π33,0,206,43,132,32,56,27,162,183,41,122,91,162,247,78,244,26,254,240,π55,204,15,129,27,65,136,128,75,69,53,136,112,16,220,97,132,3,224,166,π16,162,224,142,9,201,184,128,73,65,94,22,146,43,98,96,174,61,94,92,192,π135,164,17,119,81,40,31,9,207,186,144,172,139,129,77,49,254,86,72,26,π2,62,9,242,139,144,180,218,3,15,231,241,5,228,126,2,80,75,1,2,20,0,20,π0,0,0,8,0,236,50,114,27,51,246,185,93,71,2,0,0,189,3,0,0,10,0,0,0,0,0,π0,0,0,0,32,0,0,0,0,0,0,0,85,76,79,78,71,83,46,79,66,74,80,75,5,6,0,0,π0,0,1,0,1,0,56,0,0,0,111,2,0,0,0,0π); BEGIN Assign(G,'ULONGS.ZIP'); Rewrite(G,SizeOf(V));π BlockWrite(G,V,1); Close(G); END {Gbug1.5b}.π(*********************************************************************)π 50 11-26-9317:05ALL LARS FOSDAL Nice Expression Parser IMPORT 41 ₧╨┼ PROGRAM Expr;ππ{π Simple recursive expression parser based on the TCALC example of TP3.π Written by Lars Fosdal 1987π Released to the public domain 1993π}ππPROCEDURE Eval(Formula : String; { Expression to be evaluated}π VAR Value : Real; { Return value }π VAR ErrPos : Integer); { error position }π CONSTπ Digit: Set of Char = ['0'..'9'];π VARπ Posn : Integer; { Current position in Formula}π CurrChar : Char; { character at Posn in Formula }πππPROCEDURE ParseNext; { returnerer neste tegn i Formulaen }πBEGINπ REPEATπ Posn:=Posn+1;π IF Posn<=Length(Formula) THEN CurrChar:=Formula[Posn]π ELSE CurrChar:=^M;π UNTIL CurrChar<>' ';πEND { ParseNext };πππFUNCTION add_subt: Real;π VARπ E : Real;π Opr : Char;ππ FUNCTION mult_DIV: Real;π VARπ S : Real;π Opr : Char;ππ FUNCTION Power: Real;π VARπ T : Real;ππ FUNCTION SignedOp: Real;ππ FUNCTION UnsignedOp: Real;π TYPEπ StdFunc = (fabs, fsqrt, fsqr, fsin, fcos,π farctan, fln, flog, fexp, ffact);π StdFuncList = ARRAY[StdFunc] of String[6];ππ CONSTπ StdFuncName: StdFuncList =π ('ABS','SQRT','SQR','SIN','COS',π 'ARCTAN','LN','LOG','EXP','FACT');π VARπ E, L, Start : Integer;π Funnet : Boolean;π F : Real;π Sf : StdFunc;ππ FUNCTION Fact(I: Integer): Real;π BEGINπ IF I > 0 THEN BEGIN Fact:=I*Fact(I-1); ENDπ ELSE Fact:=1;π END { Fact };ππ BEGIN { FUNCTION UnsignedOp }π IF CurrChar in Digit THENπ BEGINπ Start:=Posn;π REPEAT ParseNext UNTIL not (CurrChar in Digit);π IF CurrChar='.' THEN REPEAT ParseNext UNTIL not (CurrChar in Digit);π IF CurrChar='E' THENπ BEGINπ ParseNext;π REPEAT ParseNext UNTIL not (CurrChar in Digit);π END;π Val(Copy(Formula,Start,Posn-Start),F,ErrPos);π END ELSEπ IF CurrChar='(' THENπ BEGINπ ParseNext;π F:=add_subt;π IF CurrChar=')' THEN ParseNext ELSE ErrPos:=Posn;π END ELSEπ BEGINπ Funnet:=False;π FOR sf:=fabs TO ffact DOπ IF not Funnet THENπ BEGINπ l:=Length(StdFuncName[sf]);π IF Copy(Formula,Posn,l)=StdFuncName[sf] THENπ BEGINπ Posn:=Posn+l-1; ParseNext;π f:=UnsignedOp;π CASE sf ofπ fabs: f:=abs(f);π fsqrt: f:=SqrT(f);π fsqr: f:=Sqr(f);π fsin: f:=Sin(f);π fcos: f:=Cos(f);π farctan: f:=ArcTan(f);π fln : f:=LN(f);π flog: f:=LN(f)/LN(10);π fexp: f:=EXP(f);π ffact: f:=fact(Trunc(f));π END;π Funnet:=True;π END;π END;π IF not Funnet THENπ BEGINπ ErrPos:=Posn;π f:=0;π END;π END;π UnsignedOp:=F;π END { UnsignedOp};ππ BEGIN { SignedOp }π IF CurrChar='-' THENπ BEGINπ ParseNext; SignedOp:=-UnsignedOp;π END ELSE SignedOp:=UnsignedOp;π END { SignedOp };ππ BEGIN { Power }π T:=SignedOp;π WHILE CurrChar='^' DOπ BEGINπ ParseNext;π IF t<>0 THEN t:=EXP(LN(abs(t))*SignedOp) ELSE t:=0;π END;π Power:=t;π END { Power };πππ BEGIN { mult_DIV }π s:=Power;π WHILE CurrChar in ['*','/'] DOπ BEGINπ Opr:=CurrChar; ParseNext;π CASE Opr ofπ '*': s:=s*Power;π '/': s:=s/Power;π END;π END;π mult_DIV:=s;π END { mult_DIV };ππ BEGIN { add_subt }π E:=mult_DIV;π WHILE CurrChar in ['+','-'] DOπ BEGINπ Opr:=CurrChar; ParseNext;π CASE Opr ofπ '+': e:=e+mult_DIV;π '-': e:=e-mult_DIV;π END;π END;π add_subt:=E;π END { add_subt };ππBEGIN {PROC Eval}π IF Formula[1]='.'π THEN Formula:='0'+Formula;π IF Formula[1]='+'π THEN Delete(Formula,1,1);π FOR Posn:=1 TO Length(Formula)π DO Formula[Posn] := Upcase(Formula[Posn]);π Posn:=0;π ParseNext;π Value:=add_subt;π IF CurrChar=^M THEN ErrPos:=0 ELSE ErrPos:=Posn;πEND {PROC Eval};ππVARπ Formula : String;π Value : Real;π i, Err : Integer;πBEGINπ REPEATπ Writeln;π Write('Enter formula (empty exits): '); Readln(Formula);π IF Formula='' THEN Exit;π Eval(Formula, Value, Err);π Write(Formula);π IF Err=0π THEN Writeln(' = ',Value:0:5)π ELSE BEGINπ Writeln;π FOR i:=1 TO Err-1 DO Write(' ');π Writeln('^-- Error in formula');π END;π UNTIL False;πEND.ππ 51 11-26-9317:37ALL SWAG SUPPORT GROUP Computer POWER of Number IMPORT 8 ₧G πProcedure Power(Var Num,Togo,Sofar:LongInt);ππBeginπ If Togo = 0 thenπ Exit;π If Sofar = 0 thenπ Sofar := numπ Elseπ Sofar := Sofar*Num;π Togo := Togo-1;π Power(Num,Togo,Sofar)πEnd;ππ{π While this is programatically elegant, an iterative routine would beπ more efficient:π}ππ function power(base,exponent:longint):longint;π varπ absexp,temp,loop:longint;ππ beginπ power := 0; { error }π if exponent > 0π then exit;ππ temp := 1;π for loop := 1 to exponentπ do temp := temp * base;π power := temp;π end;ππ{πWell it all looks nice, but this is problably the easiest wayπ}ππfunction Power(base,p : real): real;ππ{ compute base^p, with base>0 }πbeginπ power := exp(p*log(base))πend;π 52 01-27-9411:45ALL SEAN PALMER Real Calculations IMPORT 23 ₧ ╚ {π>How about using fixed point math to speed things up even more - notπ>everyone has a math coproccesor (either my routines suck, or REALπ>calculations aren't fast, BTW I got most of my routines from Flights ofπ>Fantasy).ππ> Well, its a combination, from my experience of flights ofπ> fantasy, I'd say that it really isn't too speedy. But then REALπ> calculations are not notoriously quick either. I think FOF is a Goodπ> resource, it teaches 3d fundamentals well, and in general is prettyπ> nice, but the code is a little slow... What I ended up doing isπ> reading through the book and writing from what they said. (for the mostπ> part I skipped their code bits..) I am not familiar with fixed pointπ> math... I know what it is, but don't know how to implement it... Couldπ> ya help a little?ππJust (in this implementation) a longint, with the high 16 bits representing theπinteger part, and the low 16 representing the binary fraction (to 16 binaryπplaces). Basically a 32-bit binary number with the binary point fixed at theπ16th position.ππAdding and subtracting such numbers is just like working with straightπlongints. No problem. But when multiplying and dividing the number must beπshifted so the binary point's still in the right place.ππThese are inline procedures, for speed, and only work on 386 or better,πto save me headaches while coding this sucker.π}ππtypeπ fixed = recordπ case byte ofπ 0 : (f : word;π i : integer);π 1 : (l : longint);π end;ππ{typecast parms to longint, result to fixed}πfunction fixedDiv(d1, d2 : longint) : longint;πinline(π $66/$59/ {pop ecx}π $58/ {pop ax}π $5A/ {pop dx}π $66/$0F/$BF/$D2/ {movsx edx,dx}π $66/$C1/$E0/$10/ {shl eax,16}π $66/$F7/$F9/ {idiv ecx}π $66/$0F/$A4/$C2/$10); {shld edx,eax,16} {no rounding}ππ{typecast parms to longint, result to fixed}πfunction fixedMul(d1, d2 : longint) : longint;πinline(π $66/$59/ {pop ecx}π $66/$58/ {pop eax}π $66/$F7/$E9/ {imul ecx}π $66/$C1/$E8/$10); {shr eax,16}ππfunction scaleFixed(i, m, d : longint) : longint;πinline( {mul, then div, no ovfl}π $66/$5B/ {pop ebx}π $66/$59/ {pop ecx}π $66/$58/ {pop eax}π $66/$F7/$E9/ {imul ecx}π $66/$F7/$FB/ {idiv ebx}π $66/$0F/$A4/$C2/$10); {shld edx,eax,16}ππvarπ a, b : fixed;ππbeginπ a.l := $30000;π outputFixed(a.l + fixedDiv(a.l, $20000));π b.l := fixedMul(a.l, $48000);π outputFixed(b.l);π outputFixed(fixedDiv(b.l, $60000 + a.l));π outputFixed(scaleFixed($30000, $48000, $60000));πend.ππI'll let you figure out outputFixed for yourself.π 53 01-27-9412:00ALL RAINER HUEBENTHAL Expression Evaluator IMPORT 38 ₧x╔ {π>Does anyone have any source for evaluating math expressions? I would like toπ>find some source that can evaluate an expression likeπ>π> 5 * (3 + 4) or B * 3 + Cπ}ππProgram Test;ππUsesπ Strings; {You have to use your own unit}ππVarπ x : Real;π maxvar : Integer;π s : String;ππConstπ maxfun = 21;π func : Array[1..maxfun] Of String[9] =π ('LN', 'SINH', 'SIN', 'COSH', 'COS', 'TANH', 'TAN', 'COTH', 'COT',π 'SQRT', 'SQR', 'EXP', 'ARCSIN', 'ARSINH', 'ARCCOS', 'ARCOSH',π 'ARCTAN', 'ARTANH', 'ARCCOT', 'ARCOTH', 'NEG');ππVarπ errnum : Integer;ππFunction Calculate(f : String) : Real;ππVarπ{ errnum : Integer;}π eps : Real;ππ Function Eval(l, r : Integer) : Real;ππ Varπ i, j, k, wo, op : Integer;π result, t1, t2 : real;ππ Beginπ If errnum > 0 Then Exit;π wo := 0; op := 6; k := 0;ππ While (f[l] = '(') And (f[r] = ')') Do Beginπ Inc(l); Dec(r);π End;ππ If l > r Then Beginπ errnum := 1; eval := 0.0; Exit;π End;ππ For i := l To r Do Beginππ Case f[i] ofπ '(': Inc(k);π ')': Dec(k);π Else If k = 0 Thenπ Case f[i] ofππ '+' : Beginπ wo := i; op := 1π End;ππ '-' : Beginπ wo := i; op := 2π End;ππ '*' : If op > 2 Then Beginπ wo := i; op := 3π End;ππ '/' : If op > 2 Then Beginπ wo := i; op := 4π End;ππ '^' : If op > 4 Then Beginπ wo := i; op := 5π End;ππ End;π End;π End;ππ If k <> 0 Then Beginπ errnum := 2; eval := 0.0; Exit;π End;ππ If op < 6 Then Beginπ t1 := eval(l, wo-1); If errnum > 0 Then Exit;π t2 := eval(wo+1, r); If errnum > 0 Then Exit;π End;ππ Case op ofπ 1 : Beginπ eval := t1 + t2;π End;ππ 2 : Beginπ eval := t1 - t2;π End;ππ 3 : Beginπ eval := t1 * t2;π End;ππ 4 : Beginπ If Abs(t2) < eps Then Begin errnum := 4; eval := 0.0; Exit; End;π eval := t1 / t2;π End;ππ 5 : Beginπ If t1 < eps Then Begin errnum := 3; eval := 0.0; Exit; End;π eval := exp(t2*ln(t1));π End;ππ 6 : Beginππ i:=0;π Repeatπ Inc(i);π Until (i > maxfun) Or (Pos(func[i], f) = l);ππ If i <= maxfun Then t1 := eval(l+length(func[i]), r);π If errnum > 0 Then Exit;ππ Case i Ofπ 1 : Beginπ eval := ln(t1);π End;ππ 2 : Beginπ eval := (exp(t1)-exp(-t1))/2;π End;ππ 3 : Beginπ eval := sin(t1);π End;ππ 4 : Beginπ eval := (exp(t1)+exp(-t1))/2;π End;ππ 5 : Beginπ eval := cos(t1);π End;ππ 6 : Beginπ eval := exp(-t1)/(exp(t1)+exp(-t1))*2+1;π End;ππ 7 : Beginπ eval := sin(t1)/cos(t1);π End;ππ 8 : Beginπ eval := exp(-t1)/(exp(t1)-exp(-t1))*2+1;π End;ππ 9 : Beginπ eval := cos(t1)/sin(t1);π End;ππ 10 : Beginπ eval := sqrt(t1);π End;ππ 11 : Beginπ eval := sqr(t1);π End;ππ 12 : Beginπ eval := exp(t1);π End;ππ 13 : Beginπ eval := arctan(t1/sqrt(1-sqr(t1)));π End;ππ 14 : Beginπ eval := ln(t1+sqrt(sqr(t1+1)));π End;ππ 15 : Beginπ eval := -arctan(t1/sqrt(1-sqr(t1)))+pi/2;π End;ππ 16 : Beginπ eval := ln(t1+sqrt(sqr(t1-1)));π End;ππ 17 : Beginπ eval := arctan(t1);π End;ππ 18 : Beginπ eval := ln((1+t1)/(1-t1))/2;π End;ππ 19 : Beginπ eval := arctan(t1)+pi/2;π End;ππ 20 : Beginπ eval := ln((t1+1)/(t1-1))/2;π End;ππ 21 : Beginπ eval := -t1;π End;ππ Elseπ If copy(f, l, r-l+1) = 'PI' Thenπ eval := Piπ Else If copy(f, l, r-l+1) = 'E' Thenπ eval := 2.718281828π Else Beginπ Val(copy(f, l, r-l+1), result, j);π If j = 0 Then Beginπ eval := result;π End Else Beginπ {here you can handle other variables}π errnum := 5; eval := 0.0; Exit;π End;π End;ππ Endπ Endπ Endπ End;ππBeginπ{ errnum := 0;} eps := 1.0E-9;ππ f := StripBlanks(UpStr(f));π Calculate := Eval(1, length(f));πEnd;ππBeginπREADLN(s);πWhile length(s) > 0 do Beginπ errnum := 0; x := calculate(s);π writeln('Ergebnis : ',x:14:6, ' Fehlercode : ', errnum);π readln(s);πEnd;πEnd.ππ{πYou have to write your own function STRIPBLANKS, which eliminates ALLπblanks in a string. And the only variables supported are e and pi. Butπit is not difficult to handle other variables.ππ} 54 01-27-9412:07ALL LOU DUCHEZ Gravity IMPORT 21 ₧ó¢ (*π>Does anyone have any equations for gravity??ππIt's not as tough as you probably think it is. The way I work motion inπmy programs is, I keep track of the acceleration, velocity, and positionπof an object in both the x and y directions. In other words, I have theseπvariables:ππ var ax, ay, vx, vy, px, py: integer;ππWhen you have a force -- like gravity, or wind resistance, or whatever --πyou need to recalculate the accelerations every game round. Then youπalter the velocities accordingly, and after that you change the positions.πFor example, each round you execute code like this:ππ ax := {formula for force in the "x" direction};π ay := {formula for force in the "y" direction};ππ vx := vx + ax;π vy := vy + ay;ππ px := px + vx;π py := py + vy;ππNotice how simple it is to keep track of motion: all you need to do isπsupply a formula for acceleration, and the program runs "blind" afterπthat point.ππSo gravity is just a matter of supplying the right "acceleration" formulas.πIf you are talking gravity near the surface of the earth, gravity providesπvery nearly a constant acceleration. In which case:ππ ax := 0; {no "horizontal" gravity}π ay := g; {a constant -- assign whatever value you like}ππFor objects to fall "down" the screen, "g" should be positive. Motionπtowards the top of the screen would mean a negative velocity. That'sπbecause "y" coordinates increase from top to bottom, and frankly thatπconfuses me and it confuses the numbers. You might do well to do this:πhave your calculations assume that "y" coordinates increase from bottomπto top, and then draw at position (px, GetMaxY + 1 - py). With coordinatesπincreasing from bottom to top, "g" should be negative and upward motionπmeans positive "vy".ππIf you want gravity as applies to celestial objects in orbit, the formulasπfor acceleration would be:ππ x := px - sx; { new variables: sx and sy are the locations of the sun or }π y := py - sy; { whatever, and x and y are thus the distances from it }ππ ax := g*x / exp(3*ln(x*x + y*y)/2);π ay := g*y / exp(3*ln(x*x + y*y)/2);ππAgain, I recommend plotting at (px, GetMaxY + 1 - py); and again, "g"πshould be negative.ππBe advised that there is a singularity at the location of the sun orπwhatever: the "ln" calculations will fail. Another gravity formula I'veπseen used is "bowl" gravity, like a marble rolling around in a bowl. It'sπunrealistic, but it "feels" good and doesn't have a singularity. In whichπcase:ππ ax := g*x; { negative "g" again }π ay := g*y;ππ*) 55 01-27-9412:17ALL JASEN BETTS Perspective IMPORT 12 ₧8" {π> If I get inspired, I will add simple perspective transform to these.π> There, got inspired. Made mistakes. Foley et al are not very good atπ> tutoring perspective and I'm kinda ready to be done and post this.ππ> line(round(x1)+200,round(y1)+200,π> round(x2)+200,round(y2)+200);ππtry this for perspective (perspecitve is easy to calculate but hard toπexplain... I worked it out with a pencil and paper using "similarπtriangles, and a whole heap of other math I never thought I'd need, itπtook me the best part of 30 minutes but when I saw how simple it reallyπis...)ππ this code gives an approximation of perspective... it's pretty goodπ when K is more than 3 times the size (maximum dimension) of the objectππK is some constant... (any constant, about 3-10 times the size of theπobject is good) (K is actually the displacement of the viewpoint downπthe -Z axis. or something like) K=600 would be a good starting pointπ}ππ line(round(x1/(K+z1)*K)+200,round(y1/(K/z1)*K)+200,π round(x2/(K+z2)*K)+200,round(y2/(K/z2)*K)+200);ππ{ not computationally efficient but it shows how it works.π Here's one that gives "real perspective"π}ππ line(round(x1/sqrt(sqr(K+z1)+sqr(x1)+sqr(y1))*K,π round(y1/sqrt(sqr(K+y1)+sqr(y1)+sqr(y1))*K,π round(x2/sqrt(sqr(K+z2)+sqr(x2)+sqr(y2))*K,π round(y2/sqrt(sqr(K+y2)+sqr(y2)+sqr(y2))*K);ππ 56 01-27-9412:17ALL GARETH BRAID Super Fast Pi IMPORT 6 ₧░0 {πThis is a small program which is faster than any of the writings on the echoπon calculating Pi. It uses some Calculus (In an exam I did 2/3 weeks ago).π}ππProgram CalcPi;π{$N+,E+}ππVarπ Result : Extended;π A : Byte;ππbeginπ Result := 3; {Needs a approximation of Pi}π For A := 1 to 3 do {Only needs three goes to get as accurate as possibleπ with TP variables.}π beginπ RESULT := RESULT - Sin(result) * Cos(result);π {this is a simplified version of Newton Raphson Elimation using Tan(Pi)=0}π Writeln(RESULT : 0 : 18);π {18 decimal places - as good as TP gets }π end;πend.π 57 01-27-9412:20ALL VARIOUS - SEE BELOW Roman-Decimal Conversion IMPORT 9 ₧E
{π>I would like to know if there is a function to convert a year to Romanπ>Numerals (1993 to MCMCMIII).ππ Brian Pape, Brian Grammer, Mike Lazar, Christy Reed, Matt Hayesπ}ππprogram roman;ππconstπ num = 'IVXLCDM';π value : array [1..7] of integer = (1, 5, 10, 50, 100, 500, 1000);πvarπ i : byte;π s : string;π sum : integer;πbeginπ writeln('Enter the Roman Numerals: ');π readln(s);π i := length(s);π while (i >= 1) doπ beginπ if i > 1 thenπ beginπ if pos(s[i], num) <= (pos(s[i - 1], num)) thenπ beginπ sum := sum + value[pos(s[i], num)];π dec(i);π endπ elseπ beginπ sum := sum + value[pos(s[i],num)] - value[pos(s[i - 1], num)];π dec(i, 2);π end;π endπ elseπ beginπ sum := sum + value[pos(s[1], num)];π dec(i);π end;π end;π WRITELN;π writeln('Roman numeral: ', s);π writeln(' Arabic value: ', sum);πend.ππ 58 01-27-9412:20ALL MARC HEYVAERT Roots IMPORT 11 ₧]5 {π> I am trying to write a program that will find the cube root of theπ> numbers 1 to 50.ππOK. You will have to use the EXP and LN functions as follows (full explanationπof mathematics involved, to give you the general background)ππ X=log Y means Y = a^X (1)π aππ and log X = LN(X) ; e^X = EXP(X) and EXP(LN(X))=X (2)π eππYour problem is e.g. 10 = a^3 and you want to find a solution for aππ now from (1)ππ 10 = a^3 so 3=log 10π aπ log kπWe lose the a by using the rule log k = -------- (the base is not important)π a log aππ log 10π so 3 = ------π log aππ LN(10)π or using base e, in Pascal 3 = ------π LN(a)ππ LN(10)π LN(a) = ------ = 0.76752836433π 3ππ to find a we have to raise e to this power and EXP(....)= 2.15443469003ππ which is the 3rd root of 10ππThis works for all root calculations soπππ ROOT(X,Y):=EXP(LN(Y)/X)ππ}π 59 01-27-9412:23ALL WIM VAN DER VEGT Text Formula Parser IMPORT 273 ₧╙ {π│ I've written a pwoerfull formula evaluator which can be extendedπ│ during run-time by adding fuctions, vars and strings containingπ│ Because its not very small post me a message if you want to receive it.ππHere it goes. It's a unit and an example/demo of some features.ππ{---------------------------------------------------------}π{ Project : Text Formula Parser }π{ Auteur : G.W. van der Vegt }π{---------------------------------------------------------}π{ Datum .tijd Revisie }π{ 900530.1900 Creatie (function call/exits removed) }π{ 900531.1900 Revisie (Boolean expressions) }π{ 900104.2100 Revisie (HEAP Function Storage) }π{ 910327.1345 External Real string vars (tfp_realstr) }π{ are corrected the same way as the parser }π{ corrects them before using TURBO's VAL }π{---------------------------------------------------------}ππUNIT Tfp_01;ππINTERFACEππ{---------------------------------------------------------}π{----Initializes function database }π{---------------------------------------------------------}ππPROCEDURE Tfp_init(no : INTEGER);ππ{---------------------------------------------------------}π{----Parses s and returns REAL or STR(REAL:m:n) }π{---------------------------------------------------------}ππFUNCTION Tfp_parse2real(s : STRING) : REAL;ππFUNCTION Tfp_parse2str(s : STRING;m,n : INTEGER) : STRING;ππ{---------------------------------------------------------}π{----Tfp_errormsg(tfp_ernr) returns errormessage }π{---------------------------------------------------------}ππVARπ Tfp_ernr : BYTE; {----Errorcode}ππFUNCTION Tfp_errormsg(nr : INTEGER) : STRING;πππ{---------------------------------------------------------}π{----Internal structure for functions/vars }π{---------------------------------------------------------}ππTYPEπ tfp_fname = STRING[12]; {----String name }ππ tfp_ftype = (tfp_noparm, {----Function or Function() }π tfp_1real, {----Function(VAR r) }π tfp_2real, {----Function(VAR r1,r2) }π tfp_nreal, {----Function(VAR r;n INTEGER) }π tfp_realvar, {----Real VAR }π tfp_intvar, {----Integer VAR }π tfp_boolvar, {----Boolean VAR }π tfp_realstr); {----Real String VAR }ππCONSTπ tfp_true = 1.0; {----REAL value for BOOLEAN TRUE }π tfp_false = 0.0; {----REAL value for BOOLEAN FALSE }ππ{---------------------------------------------------------}π{----Adds own FUNCTION or VAR to the parser }π{ All FUNCTIONS & VARS must be compiled }π{ with the FAR switch on }π{---------------------------------------------------------}ππPROCEDURE Tfp_addobj(a : pointer;n : tfp_fname;t : tfp_ftype);πππ{---------------------------------------------------------}π{----Add Internal Function Packs }π{---------------------------------------------------------}ππPROCEDURE Tfp_addgonio;ππPROCEDURE Tfp_addlogic;ππPROCEDURE Tfp_addmath;ππPROCEDURE Tfp_addmisc;ππ{---------------------------------------------------------}ππIMPLEMENTATIONππCONSTπ maxreal = +9.99999999e37; {----Internal maxreal }π maxparm = 16; {----Maximum number of parameters }ππVARπ maxfie : INTEGER; {----max no of functions & vars }π fiesiz : INTEGER; {----current no of functions & vars }ππTYPEπ fie = RECORDπ fname : tfp_fname; {----Name of function or var }π faddr : POINTER; {----FAR POINTER to function or var }π ftype : tfp_ftype; {----Type of entry }π END;ππ fieptr = ARRAY[1..1] OF fie; {----Will be used as [1..maxfie] }ππVARπ fiearr : ^fieptr; {----Array of functions & vars }ππ{---------------------------------------------------------}ππVARπ Line : STRING; {----Internal copy of string to Parse}π Lp : INTEGER; {----Parsing Pointer into Line }π Nextchar : CHAR; {----Character at Lp Postion }ππ{---------------------------------------------------------}π{----Tricky stuff to call FUNCTIONS }π{---------------------------------------------------------}ππ{$F+}ππVARπ GluePtr : POINTER;ππFUNCTION Call_noparm : REAL;ππ INLINE($FF/$1E/GluePtr); {CALL DWORD PTR GluePtr}ππFUNCTION Call_1real(VAR r) : REAL;ππ INLINE($FF/$1E/GluePtr); {CALL DWORD PTR GluePtr}ππFUNCTION Call_2real(VAR r1,r2) : REAL;ππ INLINE($FF/$1E/GluePtr); {CALL DWORD PTR GluePtr}ππFUNCTION Call_nreal(VAR r,n) : REAL;π INLINE($FF/$1E/GluePtr); {CALL DWORD PTR GluePtr}ππ{$F-}ππ{---------------------------------------------------------}π{----This routine skips one character }π{---------------------------------------------------------}ππPROCEDURE Newchar;ππBEGINπ IF (lp<LENGTH(Line))π THEN INC(Lp);π Nextchar:=UPCASE(Line[Lp]);πEND;ππ{---------------------------------------------------------}π{----This routine skips one character and }π{ all folowing spaces from an expression }π{---------------------------------------------------------}ππPROCEDURE Skip;ππBEGINπ REPEATπ Newchar;π UNTIL (Nextchar<>' ');πEND;ππ{---------------------------------------------------------}π{ Number = Real (Bv 23.4E-5) }π{ Integer (Bv -45) }π{---------------------------------------------------------}ππFUNCTION Eval_number : REAL;ππVARπ Temp : STRING;π Err : INTEGER;π value : REAL;ππBEGINπ{----Correct .xx to 0.xx}π IF (Nextchar='.')π THEN Temp:='0'+Nextcharπ ELSE Temp:=Nextchar;ππ Newchar;ππ{----Correct ±.xx to ±0.xx}π IF (LENGTH(temp)=1) AND (Temp[1] IN ['+','-']) AND (Nextchar='.')π THEN Temp:=Temp+'0';ππ WHILE Nextchar IN ['0'..'9','.','E'] DOπ BEGINπ Temp:=Temp+Nextchar;π IF (Nextchar='E')π THENπ BEGINπ {----Correct ±xxx.E to ±xxx.0E}π IF (Temp[LENGTH(Temp)-1]='.')π THEN INSERT('0',Temp,LENGTH(Temp));π Newchar;π IF (Nextchar IN ['+','-'])π THENπ BEGINπ Temp:=Temp+Nextchar;π Newchar;π END;π ENDπ ELSE Newchar;π END;ππ{----Skip trailing spaces}π IF (line[lp]=' ')π THEN WHILE (Line[lp]=' ') DO INC(lp);π nextchar:=line[lp];ππ{----Correct ±xx. to ±xx.0 but NOT ±xxE±yy.}π IF (temp[LENGTH(temp)]='.') ANDπ (POS('E',temp)=0)π THEN Temp:=Temp+'0';ππ VAL(Temp,value,Err);ππ IF (Err<>0) THEN tfp_ernr:=1;ππ IF (tfp_ernr=0)π THEN Eval_number:=valueπ ELSE Eval_number:=0;πEND;ππ{---------------------------------------------------------}ππFUNCTION Eval_b_expr : REAL; FORWARD;ππ{---------------------------------------------------------}π{ Factor = Number }π{ (External) Function() }π{ (External) Function(Expr) }π{ (External) Function(Expr,Expr) }π{ External Var Real }π{ External Var Integer }π{ External Var Boolean }π{ External Var realstring }π{ (R_Expr) }π{---------------------------------------------------------}ππFUNCTION Eval_factor : REAL;ππVARπ ferr : BOOLEAN;π param : INTEGER;π dummy : ARRAY[0..maxparm] OF REAL;π value,π dummy1,π dummy2 : REAL;π temp : tfp_fname;π e,π i,π index : INTEGER;π temps : STRING;ππBEGINπ CASE Nextchar OFπ '+' : BEGINπ Newchar;π value:=+Eval_factor;π END;π '-' : BEGINπ Newchar;π value:=-Eval_factor;π END;ππ '0'..'9',π '.' : value:=Eval_number;π 'A'..'Z'π : BEGINπ ferr:=TRUE;π Temp:=Nextchar;π Skip;π WHILE Nextchar IN ['0'..'9','_','A'..'Z'] DOπ BEGINπ Temp:=Temp+Nextchar;π Skip;π END;ππ {----Seek function and CALL it}π {$R-}π FOR Index:=1 TO Fiesiz DOπ WITH fiearr^[index] DOπ IF (fname=temp)π THENπ BEGINπ ferr:=FALSE;ππ CASE ftype OFππ {----Function or Function()}π tfp_noparm : IF (nextchar='(')π THENπ BEGINπ Skip;ππ IF (nextchar<>')')π THEN tfp_ernr:=15;ππ Skip;π END;ππ {----Function(r)}π tfp_1real : IF (nextchar='(')π THENπ BEGINπ Skip;ππ dummy1:=Eval_b_expr;ππ IF (tfp_ernr=0) ANDπ (nextchar<>')')π THEN tfp_ernr:=15;ππ Skip; {----Dump the ')'}π ENDπ ELSE tfp_ernr:=15;ππ {----Function(r1,r2)}π tfp_2real : IF (nextchar='(')π THENπ BEGINπ Skip;ππ dummy1:=Eval_b_expr;ππ IF (tfp_ernr=0) ANDπ (nextchar<>',')π THEN tfp_ernr:=15;ππ Skip; {----Dump the ','}π dummy2:=Eval_b_expr;ππ IF (tfp_ernr=0) ANDπ (nextchar<>')')π THEN tfp_ernr:=15;ππ Skip; {----Dump the ')'}π ENDπ ELSE tfp_ernr:=15;ππ {----Function(r,n)}π tfp_nreal : IF (nextchar='(')π THENπ BEGINπ param:=0;ππ Skip;π dummy[param]:=Eval_b_expr;ππ IF (tfp_ernr=0) ANDπ (nextchar<>',')π THEN tfp_ernr:=15π ELSEπ WHILE (tfp_ernr=0) ANDπ (nextchar=',') ANDπ (param<maxparm) DOπ BEGINπ Skip; {----Dump the ','}π INC(param);π dummy[param]:=Eval_b_expr;π END;ππ IF (tfp_ernr=0) ANDπ (nextchar<>')')π THEN tfp_ernr:=15;ππ Skip; {----Dump the ')'}π ENDπ ELSE tfp_ernr:=15;π {----Real Var}π tfp_realvar : dummy1:=REAL(faddr^);ππ {----Integer Var}π tfp_intvar : dummy1:=1.0*INTEGER(faddr^);ππ {----Boolean Var}π tfp_boolvar : dummy1:=1.0*ORD(BOOLEAN(faddr^));ππ {----Real string Var}π tfp_realstr : BEGINπ temps:=STRING(faddr^);ππ {----Delete Leading Spaces}π WHILE (Length(temps)>0) ANDπ (temps[1]=' ') DOπ Delete(temps,1,1);ππ {----Delete Trailing Spaces}π WHILE (Length(temps)>0) ANDπ (temps[Length(temps)]=' ') Doπ Delete(temps,Length(temps),1);ππ {----Correct .xx to 0.xx}π IF (LENGTH(temps)>=1) ANDπ (LENGTH(temps)<255) ANDπ (temps[1]='.')π THEN Insert('0',temps,1);ππ {----Correct ±.xx to ±0.xx}π IF (LENGTH(temps)>=2) ANDπ (LENGTH(temps)<255) ANDπ (temps[1] IN ['+','-']) ANDπ (temps[2]='.')π THEN Insert('0',temps,2);ππ {----Correct xx.Eyy to xx0.Exx}π IF (Pos('.E',temps)>0) ANDπ (Length(temps)<255)π THEN Insert('0',temps,Pos('.E',temps));ππ {----Correct xx.eyy to xx0.exx}π IF (Pos('.e',temps)>0) ANDπ (Length(temps)<255)π THEN Insert('0',temps,Pos('.e',temps));π {----Correct ±xx. to ±xx.0 but NOT ±}π IF (temps[LENGTH(temps)]='.') ANDπ (POS('E',temps)=0) ANDπ (POS('e',temps)=0) ANDπ (Length(temps)<255)π THEN Temps:=Temps+'0';ππ VAL(temps,dummy1,e);π IF (e<>0)π THEN tfp_ernr:=1;π END;π END;ππ IF (tfp_ernr=0)π THENπ BEGINπ glueptr:=faddr;ππ CASE ftype OFπ tfp_noparm : value:=call_noparm;π tfp_1real : value:=call_1real(dummy1);π tfp_2real : value:=call_2real(dummy1,dummy2);π tfp_nreal : value:=call_nreal(dummy,param);π tfp_realvar,π tfp_intvar,π tfp_boolvar,π tfp_realstr : value:=dummy1;π END;π END;π END;π IF (ferr=TRUE)π THEN tfp_ernr:=2;ππ {$R+}π END;ππ '(' : BEGINπ Skip;ππ value:=Eval_b_expr;ππ IF (tfp_ernr=0) AND (nextchar<>')') THEN tfp_ernr:=3;ππ Skip; {----Dump the ')'}π END;ππ ELSE tfp_ernr:=2;π END;ππ IF (tfp_ernr=0)π THEN Eval_factor:=valueπ ELSE Eval_factor:=0;ππEND;ππ{---------------------------------------------------------}π{ Term = Factor ^ Factor }π{---------------------------------------------------------}ππFUNCTION Eval_term : REAL;ππVARπ value,π Exponent,π dummy,π Base : REAL;ππBEGINπ value:=Eval_factor;ππ WHILE (tfp_ernr=0) AND (Nextchar='^') DOπ BEGINπ Skip;ππ Exponent:=Eval_factor;ππ Base:=value;π IF (tfp_ernr=0) AND (Base=0)π THEN value:=0π ELSEπ BEGINππ {----Over/Underflow Protected}π dummy:=Exponent*LN(ABS(Base));π IF (dummy<=LN(MAXREAL))π THEN value:=EXP(dummy)π ELSE tfp_ernr:=11;π END;ππ IF (tfp_ernr=0) AND (Base<0)π THENπ BEGINπ {----allow only whole number exponents}π IF (INT(Exponent)<>Exponent) THEN tfp_ernr:=4;ππ IF (tfp_ernr=0) AND ODD(ROUND(exponent)) THEN value:=-value;π END;π END;ππ IF (tfp_ernr=0)π THEN Eval_term:=valueπ ELSE Eval_term:=0;πEND;ππ{---------------------------------------------------------}π{----Subterm = Term * Term }π{ Term / Term }π{---------------------------------------------------------}ππFUNCTION Eval_subterm : REAL;ππVARπ value,π dummy : REAL;ππBEGINπ value:=Eval_term;ππ WHILE (tfp_ernr=0) AND (Nextchar IN ['*','/']) DOπ CASE Nextchar OFππ {----Over/Underflow Protected}π '*' : BEGINπ Skip;ππ dummy:=Eval_term;ππ IF (tfp_ernr<>0) OR (value=0) OR (dummy=0)π THEN value:=0π ELSE IF (ABS( LN(ABS(value)) + LN(ABS(dummy)) )<LN(Maxreal))π THEN value:= value * dummyπ ELSE tfp_ernr:=11;π END;ππ {----Over/Underflow Protected}π '/' : BEGINπ Skip;ππ dummy:=Eval_term;ππ IF (tfp_ernr=0)π THENπ BEGINππ {----Division by ZERO Protected}π IF (dummy<>0)π THENπ BEGINπ {----Underflow Protected}π IF (value<>0)π THENπ IF (ABS( LN(ABS(value))-LN(ABS(dummy)) )π <LN(Maxreal))π THEN value:=value/dummyπ ELSE tfp_ernr:=11π ENDπ ELSE tfp_ernr:=9;π END;π END;π END;ππ IF (tfp_ernr=0)π THEN Eval_subterm:=valueπ ELSE Eval_subterm:=0;πEND;ππ{---------------------------------------------------------}π{ Real Expr = Subterm + Subterm }π{ Subterm - Subterm }π{---------------------------------------------------------}ππFUNCTION Eval_r_expr : REAL;ππVARπ dummy,π dummy2,π value : REAL;ππBEGINπ value:=Eval_subterm;ππ WHILE (tfp_ernr=0) AND (Nextchar IN ['+','-']) DOπ CASE Nextchar OFππ '+' : BEGINπ Skip;ππ dummy:=Eval_subterm;ππ IF (tfp_ernr=0)π THENπ BEGINππ {----Overflow Protected}π IF (ABS( (value/10)+(dummy/10) )<(Maxreal/10))π THEN value:=value+dummyπ ELSE tfp_ernr:=11;π END;π END;ππ '-' : BEGINπ Skip;π dummy2:=value;ππ dummy:=Eval_subterm;ππ IF (tfp_ernr=0)π THENπ BEGINππ {----Overflow Protected}π IF (ABS( (value/10)-(dummy/10) )<(Maxreal/10))π THEN value:=value-dummyπ ELSE tfp_ernr:=11;ππ {----Underflow Protected}π IF (value=0) AND (dummy<>dummy2)π THEN tfp_ernr:=11;π END;ππ END;π END;ππ{----At this point the current char must beπ 1. the EOLN marker orπ 2. a right bracketπ 3. start of a boolean operator }ππ IF NOT (Nextchar IN [#00,')','>','<','=',','])π THEN tfp_ernr:=2;ππ IF (tfp_ernr=0)π THEN Eval_r_expr:=valueπ ELSE Eval_r_expr:=0;πEND;ππ{---------------------------------------------------------}π{ Boolean Expr = R_Expr < R_Expr }π{ R_Expr <= R_Expr }π{ R_Expr <> R_Expr }π{ R_Expr = R_Expr }π{ R_Expr >= R_Expr }π{ R_Expr > R_Expr }π{---------------------------------------------------------}ππFUNCTION Eval_b_expr : REAL;ππVARπ value : REAL;ππBEGINπ value:=Eval_r_expr;ππ IF (tfp_ernr=0) AND (Nextchar IN ['<','>','='])π THENπ CASE Nextchar OFππ '<' : BEGINπ Skip;π IF (Nextchar IN ['>','='])π THENπ CASE Nextchar OFπ '>' : BEGINπ Skip;π IF (value<>Eval_r_expr)π THEN value:=tfp_trueπ ELSE value:=tfp_false;π END;π '=' : BEGINπ Skip;π IF (value<=Eval_r_expr)π THEN value:=tfp_trueπ ELSE value:=tfp_false;π END;π ENDπ ELSEπ BEGINπ IF (value<Eval_r_expr)π THEN value:=tfp_trueπ ELSE value:=tfp_false;π END;π END;ππ '>' : BEGINπ Skip;π IF (Nextchar='=')π THENπ BEGINπ Skip;π IF (value>=Eval_r_expr)π THEN value:=tfp_trueπ ELSE value:=tfp_false;π ENDπ ELSEπ BEGINπ IF (value>Eval_r_expr)π THEN value:=tfp_trueπ ELSE value:=tfp_false;π END;π END;π '=' : BEGINπ Skip;π IF (value=Eval_r_expr)π THEN value:=tfp_trueπ ELSE value:=tfp_false;π END;π END;ππ IF (tfp_ernr=0)π THEN Eval_b_expr:=valueπ ELSE Eval_b_expr:=0.0;πEND;ππ{---------------------------------------------------------}ππPROCEDURE Tfp_init(no : INTEGER);ππBEGINπ IF (maxfie>0)π THEN FREEMEM(fiearr,maxfie*SIZEOF(fiearr^));ππ GETMEM(fiearr,no*SIZEOF(fiearr^));ππ maxfie:=no;π fiesiz:=0;πEND;ππ{---------------------------------------------------------}ππFUNCTION Tfp_parse2real(s : string) : REAL;ππVARπ i,h : INTEGER;π value : REAL;ππBEGINπ tfp_ernr:=0;ππ{----Test for match on numbers of ( and ) }π h:=0;π FOR i:=1 TO LENGTH(s) DOπ CASE s[i] OFπ '(' : INC(h);π ')' : DEC(h);π END;ππ IF (h=0)π THENπ BEGINππ {----Continue init}π lp:=0;ππ {----Add a CHR(0) as an EOLN marker}π line:=S+#00;π Skip;ππ {----Try parsing if any characters left}π IF (Line[Lp]<>#00)π THEN value:=Eval_b_exprπ ELSE tfp_ernr:=6;π ENDπ ELSE tfp_ernr:=3;ππ IF (tfp_ernr<>0)π THEN tfp_parse2real:=0.0π ELSE tfp_parse2real:=value;πEND;ππ{---------------------------------------------------------}ππFUNCTION Tfp_parse2str(s : STRING;m,n : INTEGER) : STRING;ππVARπ r : REAL;π tmp : STRING;ππBEGINπ r:=Tfp_parse2real(s);π IF (tfp_ernr=0)π THEN STR(r:m:n,tmp)π ELSE tmp:='';π Tfp_parse2str:=tmp;πEND;ππ{---------------------------------------------------------}ππFUNCTION Tfp_errormsg;ππBEGINπ CASE nr OFπ 0 : Tfp_errormsg:='Correct resultaat'; {Error 0 }π 1 : Tfp_errormsg:='Ongeldig getal formaat'; {Error 1 }π 2 : Tfp_errormsg:='Onbekende functie'; {Error 2 }π 3 : Tfp_errormsg:='Een haakje mist'; {Error 3 }π 4 : Tfp_errormsg:='Reele exponent geeft een complex getal'; {Error 4 }π 5 : Tfp_errormsg:='TAN( (2n+1)*PI/2 ) bestaat niet'; {Error 5 }π 6 : Tfp_errormsg:='Lege string'; {Error 6 }π 7 : Tfp_errormsg:='LN(x) of LOG(x) met x<=0 bestaat niet'; {Error 7 }π 8 : Tfp_errormsg:='SQRT(x) met x<0 bestaat niet'; {Error 8 }π 9 : Tfp_errormsg:='Deling door nul'; {Error 9 }π 10 : Tfp_errormsg:='Teveel functies & constanten'; {Error 10}π 11 : Tfp_errormsg:='Tussenresultaat buiten getalbereik'; {Error 11}π 12 : Tfp_errormsg:='Illegale tekens in functienaam'; {Error 12}π 13 : Tfp_errormsg:='Geen (on)gelijkheid / te complex'; {Error 13}π 14 : Tfp_errormsg:='Geen booleaanse expressie'; {Error 14}π 15 : Tfp_errormsg:='Verkeerd aantal parameters'; {Error 15}π ELSE Tfp_errormsg:='Onbekende fout'; {Error xx}π END;πEND;ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addobj(a : pointer;n : tfp_fname;t : tfp_ftype);ππVARπ i : INTEGER;ππBEGINπ {$R-}π IF (fiesiz<maxfie)π THENπ BEGINπ INC(fiesiz);π WITH fiearr^[fiesiz] DOπ BEGINπ faddr:=a;π fname:=n;π FOR i:=1 TO LENGTH(fname) DOπ IF (UPCASE(fname[i]) IN ['0'..'9','_','A'..'Z'])π THEN fname[i]:=UPCASE(fname[i])π ELSE tfp_ernr:=12;π IF (LENGTH(fname)>0) ANDπ NOT (fname[1] IN ['A'..'Z'])π THEN tfp_ernr:=12;π ftype:=t;π ENDπ ENDπ ELSE tfp_ernr:=10π {$R+}πEND;ππ{---------------------------------------------------------}π{----Internal Functions }π{---------------------------------------------------------}ππ{$F+}πFUNCTION xABS(VAR r : REAL) : REAL;ππBEGINπ xabs:=ABS(r);πEND;ππFUNCTION xAND(VAR r;VAR n : INTEGER) : REAL;ππTYPEπ tmp = ARRAY[0..0] OF REAL;ππVARπ x : REAL;π i : INTEGER;ππBEGINπ{$R-}π FOR i:=0 TO n DOπ IF (tmp(r)[i]<>tfp_false) AND (tmp(r)[i]<>tfp_true)π THENπ BEGINπ IF (tfp_ernr=0)π THEN tfp_ernr:=14;π END;π IF (tfp_ernr=0) AND (n>0)π THENπ BEGINπ x:=tfp_true*ORD(tmp(r)[0]=tfp_true);π FOR i:=1 TO n DOπ x:=tfp_true*ORD((x=tfp_true) AND (tmp(r)[i]=tfp_true))π ENDπ ELSE tfp_ernr:=15;π IF tfp_ernr=0π THEN xAND:=xπ ELSE xAND:=0.0;π{$R+}πEND;ππFUNCTION xARCTAN(VAR r : REAL) : REAL;ππBEGINπ xARCTAN:=ARCTAN(r);πEND;ππFUNCTION xCOS(VAR r : REAL) : REAL;ππBEGINπ xCOS:=COS(r);πEND;ππFUNCTION xDEG(VAR r : REAL) : REAL;ππBEGINπ xDEG:=(r/pi)*180;πEND;ππFUNCTION xE : REAL;ππBEGINπ xE:=EXP(1);πEND;ππFUNCTION xEXP(VAR r : REAL) : REAL;ππBEGINπ xEXP:=0;π IF (ABS(r)<LN(MAXREAL))π THEN xEXP:=EXP(r)π ELSE tfp_ernr:=11;πEND;ππFUNCTION xFALSE : REAL;ππBEGINπ xFALSE:=tfp_false;πEND;ππFUNCTION xFRAC(VAR r : REAL) : REAL;ππBEGINπ xFRAC:=FRAC(r);πEND;ππFUNCTION xINT(VAR r : REAL) : REAL;ππBEGINπ xINT:=INT(r);πEND;ππFUNCTION xLN(VAR r : REAL) : REAL;ππBEGINπ xLN:=0;π IF (r>0)π THEN xLN:=LN(r)π ELSE tfp_ernr:=7;πEND;ππFUNCTION xLOG(VAR r : REAL) : REAL;ππBEGINπ xLOG:=0;π IF (r>0)π THEN xLOG:=LN(r)/LN(10)π ELSE tfp_ernr:=7;πEND;ππFUNCTION xMAX(VAR r;VAR n : INTEGER) : REAL;ππTYPEπ tmp = ARRAY[0..0] OF REAL;ππVARπ max : REAL;π i : INTEGER;ππBEGINπ{$R-}π max:=tmp(r)[0];π FOR i:=1 TO n DOπ IF (tmp(r)[i]>max)π THEN max:=tmp(r)[i];π xMAX:=max;π{$R+}πEND;ππFUNCTION xMIN(VAR r;VAR n : INTEGER) : REAL;ππTYPEπ tmp = ARRAY[0..0] OF REAL;ππVARπ min : REAL;π i : INTEGER;ππBEGINπ{$R-}π min:=tmp(r)[0];π FOR i:=1 TO n DOπ IF (tmp(r)[i]<min)π THEN min:=tmp(r)[i];π xMIN:=min;π{$R+}πEND;πFUNCTION xIOR(VAR r;VAR n : INTEGER) : REAL;ππTYPEπ tmp = ARRAY[0..0] OF REAL;ππVARπ x : REAL;π i : INTEGER;ππBEGINπ{$R-}π FOR i:=0 TO n DOπ IF (tmp(r)[i]<>tfp_false) AND (tmp(r)[i]<>tfp_true)π THENπ BEGINπ IF (tfp_ernr=0)π THEN tfp_ernr:=14;π END;π IF (tfp_ernr=0) AND (n>0)π THENπ BEGINπ x:=tfp_true*ORD(tmp(r)[0]=tfp_true);π FOR i:=1 TO n DOπ x:=tfp_true*ORD((x=tfp_true) OR (tmp(r)[i]=tfp_true))π ENDπ ELSE tfp_ernr:=15;π IF tfp_ernr=0π THEN xIOR:=xπ ELSE xIOR:=0.0;π{$R+}πEND;ππFUNCTION xPI : REAL;ππBEGINπ xPI:=PI;πEND;ππFUNCTION xRAD(VAR r : REAL) : REAL;ππBEGINπ xRAD:=(r/180)*pi;πEND;ππFUNCTION xROUND(VAR r : REAL) : REAL;ππBEGINπ xROUND:=ROUND(r);πEND;ππFUNCTION xSGN(VAR r : REAL) : REAL;ππBEGINπ IF (r>=0)π THEN xSgn:=+1π ELSE xSgn:=-1;πEND;ππFUNCTION xSIN(VAR r : REAL) : REAL;ππBEGINπ xSIN:=SIN(r);πEND;ππFUNCTION xSQR(VAR r : REAL) : REAL;ππBEGINπ xSQR:=0;π IF ( ABS(2*LN(ABS(r))) )<LN(MAXREAL)π THEN xSQR:=EXP( 2*LN(ABS(r)) )π ELSE tfp_ernr:=11;πEND;ππFUNCTION xSQRT(VAR r : REAL) : REAL;ππBEGINπ xSQRT:=0;π IF (r>=0)π THEN xSQRT:=SQRT(r)π ELSE tfp_ernr:=8;πEND;ππFUNCTION xTAN(VAR r : REAL) : REAL;ππBEGINπ xTAN:=0;π IF (COS(r)=0)π THEN tfp_ernr:=5π ELSE xTAN:=SIN(r)/COS(r);πEND;ππFUNCTION xTRUE : REAL;ππBEGINπ xTRUE:=tfp_true;πEND;ππFUNCTION xXOR(VAR r1,r2 : REAL) : REAL;ππBEGINπ IF ((r1<>tfp_false) AND (r1<>tfp_true)) ORπ ((r2<>tfp_false) AND (r2<>tfp_true))π THENπ BEGINπ IF (tfp_ernr=0)π THEN tfp_ernr:=14;π ENDπ ELSE xxor:=tfp_true*ORD((r1=tfp_true) XOR (r2=tfp_true));πEND;ππ{$F-}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addgonio;ππBEGINπ Tfp_addobj(@xARCTAN,'ARCTAN',tfp_1real);π Tfp_addobj(@xCOS ,'COS' ,tfp_1real);π Tfp_addobj(@xDEG ,'DEG' ,tfp_1real);π Tfp_addobj(@xPI ,'PI' ,tfp_noparm);π Tfp_addobj(@xRAD ,'RAD' ,tfp_1real);π Tfp_addobj(@xSIN ,'SIN' ,tfp_1real);π Tfp_addobj(@xTAN ,'TAN' ,tfp_1real);πEND;ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addlogic;ππBEGINπ Tfp_addobj(@xAND ,'AND' ,tfp_nreal);π Tfp_addobj(@xFALSE ,'FALSE' ,tfp_noparm);π Tfp_addobj(@xIOR ,'OR' ,tfp_nreal);π Tfp_addobj(@xTRUE ,'TRUE' ,tfp_noparm);π Tfp_addobj(@xXOR ,'XOR' ,tfp_2real);πEND;ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addmath;πBEGINπ Tfp_addobj(@xABS ,'ABS' ,tfp_1real);π Tfp_addobj(@xEXP ,'EXP' ,tfp_1real);π Tfp_addobj(@xE ,'E' ,tfp_noparm);π Tfp_addobj(@xLN ,'LN' ,tfp_1real);π Tfp_addobj(@xLOG ,'LOG' ,tfp_1real);π Tfp_addobj(@xSQR ,'SQR' ,tfp_1real);π Tfp_addobj(@xSQRT ,'SQRT' ,tfp_1real);πEND;ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addmisc;ππBEGINπ Tfp_addobj(@xFRAC ,'FRAC' ,tfp_1real);π Tfp_addobj(@xINT ,'INT' ,tfp_1real);π Tfp_addobj(@xMAX ,'MAX' ,tfp_nreal);π Tfp_addobj(@xMIN ,'MIN' ,tfp_nreal);π Tfp_addobj(@xROUND ,'ROUND' ,tfp_1real);π Tfp_addobj(@xSGN ,'SGN' ,tfp_1real);πEND;ππ{---------------------------------------------------------}ππBEGINπ{----Module Init}π tfp_ernr:=0;π fiesiz:=0;π maxfie:=0;π fiearr:=NIL;πEND.ππ-------------------------------------------------------------<cut hereππProgram Tfptst;ππUsesπ crt,π tfp_01;ππ{$F+} {----Important don't forget it !!!}ππVarπ r : real;π i : Integer;π t,π s : String;ππFUNCTION xFUZZY(VAR r : REAL) : REAL;ππBEGINπ IF (r>0.5)π THEN xFUZZY:=0.5π ELSE xFUZZY:=0.4;πEND; {of xFUZZY}ππFUNCTION xAGE : REAL;ππVARπ s : string;π e : Integer;π r : Real;ππBEGINπ{----default value in case of error}π xAGE:=0;ππ Write('Enter your age : '); Readln(s);π Val(s,r,e);ππ{----Setting tfp_ernr will flag an error.π Can be a user defined value}ππ IF e<>0π THEN tfp_ernr:=1π ELSE xAGE:=r;πEND; {of xAge}π{$F-}ππBeginπ Tfp_init(40);ππ{----Add internal function packs}π Tfp_addgonio;π Tfp_addlogic;π Tfp_addmath;π Tfp_addmisc;ππ{----Add external functions}π Tfp_addobj(@r ,'TEMP' ,tfp_realvar);π Tfp_addobj(@i ,'COUNTER',tfp_intvar);π Tfp_addobj(@t ,'USER' ,tfp_realstr);π Tfp_addobj(@xfuzzy,'FUZZY' ,tfp_1real);π Tfp_addobj(@xage ,'AGE' ,tfp_noparm);ππ i:=1;π t:='1.25';π s:='2*COUNTER';ππ Clrscr;ππ{----Example #1 using FOR index in expression}π Writeln(tfp_errormsg(tfp_ernr));π FOR i:=1 TO 3 DOπ Writeln(s,' := ',Tfp_parse2real(s):0:2);π Writeln(tfp_errormsg(tfp_ernr));ππ{----Example #2 using a real from the main program}π r:=15;π s:='TEMP';π Writeln(r:0:2,' := ',Tfp_parse2real(s):0:2);ππ{----Example #3 using a function that does something strange}π s:='AGE-1';π Writeln('Last years AGE := ',Tfp_parse2real(s):0:2);ππ{----Example #4 using a number in a stringπ This version doesn't allow recusive formula's yetπ Have a version that does!}π s:='USER';π Writeln('USER := ',Tfp_parse2real(s):0:2);ππ{----All of the above + Internal function PI, &π Boolean expressions should return 1 because it can't be 1π Booleans are reals with values of 1.0 and 0.0}π s:='(SIN(COUNTER+TEMP*FUZZY(AGE)*PI)<>1)=TRUE';π Writeln('? := ',Tfp_parse2real(s):0:6);ππ{----Your example goes here, try a readln(s)}ππ Writeln(tfp_errormsg(tfp_ernr));πEnd.π 60 01-27-9417:37ALL PAT DANT Math Expression EvaluatioIMPORT 37 ₧⌐▒ unit Eval;πinterfaceππ function ExpValue (ExpLine : string; var Error : boolean) : real;ππimplementationππ function ExpValue (ExpLine : string; var Error : boolean) : real;π varπ Index : integer;π Ltr : char;π NextLtr : char;π Token : char;π TokenValue : real;ππ procedure GetLtr;π begin {GetLtr}π Ltr := NextLtr;π if Index < length (ExpLine) then beginπ Index := succ (Index);π NextLtr := ExpLine [Index];π end else beginπ NextLtr := '%';π end;π end;ππ procedure GetToken;π procedure GetNum;π varπ Str : string;π E : integer;π beginπ Str := '0'+Ltr; {Avoids problems if first char is '.'}π while NextLtr in ['0'..'9'] do beginπ GetLtr;π Str := Str + Ltr;π end; {while}π if NextLtr = '.' then beginπ GetLtr;π Str := Str + Ltr;π while NextLtr in ['0'..'9'] do beginπ GetLtr;π Str := Str + Ltr;π end; {while}π Str := Str + '0'; {Avoids problems if last char is '.'}π end;π val (Str,TokenValue,E);π Error := E <> 0;π end;ππ begin {GetToken}π GetLtr;π while Ltr = ' ' do GetLtr;π if Ltr in ['0'..'9','.'] then beginπ GetNum;π Token := '#';π end else beginπ Token := Ltr;π end;π end;ππfunction Expression : real;π varπ IExp : real;ππ function Term : real;π varπ ITerm : real;π TFact : real;ππ function Factor : real;π varπ IFact : real;ππ begin {Factor}π case Token ofπ '(' :π beginπ GetToken;π IFact := Expression;π if Token <> ')' then Error := true;π end;π '#' :π beginπ IFact := TokenValue;π end;π elseπ Error := true;π end;π Factor := IFact;π GetToken;π end;ππ begin {Term}π if Token = '-' then beginπ GetToken;π ITerm := -Factor;π end else beginπ if Token = '+' then beginπ GetToken;π end;π ITerm := Factor;π end;π if not Error then beginπ while Token in ['*','/'] do beginπ case Token ofπ '*' :π beginπ GetToken;π ITerm := ITerm * Factor;π end;π '/' :π beginπ GetToken;π TFact := Factor;π if TFact <> 0 then beginπ ITerm := ITerm / TFact;π end else beginπ Error := true;π end;π end;π end; {case}π end; {while}π end; {if}π Term := ITerm;π end; {Term}ππ begin {Expression}π IExp := Term;π if not Error then beginπ while Token in ['+','-'] do beginπ case Token ofπ '+' :π beginπ GetToken;π IExp := IExp + Term;π end;π '-' :π beginπ GetToken;π IExp := IExp - Term;π end;π end; {case}π end; {while}π end; {if}π Expression := IExp;π end; {Expression}ππ begin {ExpValue};π Error := false;π Index := 0;π NextLtr := ' ';π GetLtr;π GetToken;π if Token = '%' then beginπ ExpValue := 0.0;π end else beginπ ExpValue := Expression;π if Token <> '%' then Error := true;π end;π end;ππend.ππ{ -------------------------------- DEMO --------------------- }ππProgram Evaluate;π(* 10/1189 *)π(* Uploaded by Pat Dant *)π(* Based on the Pascal Unit Eval that allows you to take a stringπ and perform a recurssive math function on the string resultingπ in a real answer.π This Exe version allows the command line argument to be the stringπ and will print the answer on the screen at the current cursor position.*)ππ(* ExpValue unit is designed by Don McIver in his very well written programπ SCB Checkbook Program. Currently version 4.2.*)ππUses Dos, Crt, Eval;ππconstπ EvalStrPos = 1;ππvarπ EvalString : string;π Answer : real;π EvalError : Boolean;ππ beginπ ClrScr;π Answer := 0;π EvalError := False;π Answer := ExpValue(ParamStr(EvalStrPos),EvalError );π if EvalError then beginπ Writeln('Error in Command Line Format : ',Answer:8:2);π Halt;π end;π Write(Answer:8:2);π end.πππ 61 01-27-9411:59ALL KD TART EQUATION parser IMPORT 48 ₧y┬ {π> I'm currently working on a small program for a Turbo Pascal classπ> I am taking. The assignment is to write a program that solves a systemπ> of equations via Cramer's Rule. For example:π>π> 4x - 3y + 9z = 21π> 5x - 43y - 3z = 45π> 34x - 394y + 32z = 9π>π> and then find values for x, y, and z.π>π> Now this is no problem: I simply get input into a 3 x 4 array, whichπ> would look like this for the sample above:π>π> 4 -3 9 21π> 5 -43 -3 45π> 34 -394 32 9π>π> The problem I am having is getting this input from the user. Now Iπ> have thought of a few ways to accomplish this, namely:π>π> (1) Ask the user to enter the coefficients and the answer on a line andπ> hit return, and do this for each equation--this method allows me to put theπ> data directly into the array.π>π> (2) Give a rigid example of how and where to enter the equation, forπ> example #####x(sign)#####y(sign)#####z = #####π> so I know where to read for the values to put into the array.π>π> (3) Possibly use the Val procedure and ask the user to input all numberπ> as in #1, but separate the numbers with dashes.π>π> (4) Possibly convert string values to their ascii equivalent, and see ifπ> they are numbers, turning non numbers into spaces.π>π> But, what I would rather do is to prompt the user for the whole equationπ> and have him/her type it out naturally and then pick the numbers out ofπ> it to put into the 3x4 array. Example:π>π> Enter equation #1:π> 3x + 4y - 8z = 45π> ...π>π> This would seem to require storing the input as a string, and as farπ> as I know, you can't pick values of a string (except in a limited senseπ> with the Val function as touched upon above). But I think that it hasπ> to be possible for me to process a naturally typed out equation! And Iπ> would appreciate pointers to that effect.ππThe following code, written in Turbo Pascal 6, should do what youπwant. You may want to test it more thoroughly than I did, and tidy upπthe code a bit. It checks for validity of input. Values are stored asπreals.ππIt reads in the equation, and puts the values into the global arrayπeq_array.π}ππprogram input_equations(input, output);ππtypeπ eq_string = string[40];ππvarπ instr :eq_string;π eq_array :array [1..3, 1..4] of real;π eq_num :byte;π x, y, z, answer :real;π eq_ok :boolean;πππprocedure prepare_equation_string (var s :eq_string);π{ Removes spaces and converts all letter to upper case }πvarπ tempstr :eq_string;π n :byte;πbeginπ tempstr := '';π for n := 1 to length(s) doπ if s[n] <> ' ' then tempstr := tempstr + upcase(s[n]);π s := tempstrπend;ππfunction get_arguments (s :eq_string; var a1, a2, a3 :eq_string) :boolean;π{ Splits equation into argument.π eg, if s='3X+4Y-Z', then a1='3X', a2='+4Y', a3='-Z'.ππIf any argument is blank, or there are more than 3 arguments,πreturns FALSE, otherwise returns TRUE }ππ function next_arg (s :eq_string) :eq_string;π varπ n :byte;π beginπ n := 2;π while (n <= length(s)) and not (s[n] in ['+', '-']) doπ inc (n);π next_arg := copy (s, 1, n-1);π end;ππbeginπ a1 := next_arg (s);π delete (s, 1, length(a1));π a2 := next_arg (s);π delete (s, 1, length(a2));π a3 := next_arg (s);π delete (s, 1, length(a3));π get_arguments := ((length(a1)*length(a2)*length(a3)) > 0) andπ (s = '')πend;ππfunction assign_values (var x, y, z :real; a1, a2, a3 :eq_string) :boolean;πvarπ x_assigned, y_assigned, z_assigned, ok_so_far :boolean;ππ function assign_value (s :eq_string) :boolean;π varπ id :char;π value :real;π resultcode :integer;π ok :boolean;π beginπ id := s[length(s)];π delete (s, length(s), 1);π if (s = '') or (s = '+') thenπ s := '1';π if s = '-' thenπ s := '-1';π val (s, value, resultcode);π ok := (resultcode = 0);π case id ofπ 'X' : beginπ x := value;π x_assigned := trueπ end;π 'Y' : beginπ y := value;π y_assigned := trueπ end;π 'Z' : beginπ z := value;π z_assigned := trueπ endπ elseπ ok := falseπ end;π assign_value := okπ end;ππbeginπ x_assigned := false;π y_assigned := false;π z_assigned := false;π ok_so_far := assign_value (a1);π ok_so_far := ok_so_far and assign_value (a2);π ok_so_far := ok_so_far and assign_value (a3);π assign_values := ok_so_far and x_assigned and y_assigned and z_assigned;πend;ππfunction extract_values(s : eq_string; var x, y, z, ans : real) : boolean;πvarπ ok_so_far : boolean;π n : byte;π lhs, rhs,π a1, a2, a3 : eq_string;π resultcode : integer;ππbeginπ ok_so_far := true;π prepare_equation_string(s);π n := pos ('=', s);π if n = 0 thenπ ok_so_far := false { No = in equation }π elseπ beginπ rhs := copy (s, n+1, length(s)-n);π if pos ('=', rhs) > 0 thenπ ok_so_far := false { More than one = in equation }π elseπ beginπ lhs := copy (s, 1, n-1);π if (lhs = '') or (rhs = '') thenπ ok_so_far := false { At least one side of equation }π else { is blank }π beginπ ok_so_far := get_arguments (lhs, a1, a2, a3);π ok_so_far := ok_so_far and assign_values (x, y, z, a1, a2, a3);π val (rhs, ans, resultcode);π ok_so_far := ok_so_far and (resultcode = 0)π end;π end;π end;π extract_values := ok_so_far;πend;ππbeginπ for eq_num := 1 to 3 doπ beginπ repeatπ write ('Equation ', eq_num, ': ');π readln (instr);π eq_ok := extract_values (instr, x, y, z, answer);π if not eq_ok thenπ writeln ('Equation not in suitable format, try again');π until eq_ok;π eq_array [eq_num, 1] := x;π eq_array [eq_num, 2] := y;π eq_array [eq_num, 3] := z;π eq_array [eq_num, 4] := answer;π end;πend.ππ 62 02-03-9416:16ALL SWAG SUPPORT TEAM Lot of Math Code IMPORT 50 ₧9U CONST e = 2.7182818;ππFunction Exponent(Base: Real; Power: Integer): Real;π{Base can be real, power must be an integer}π VARπ X: INTEGER;π E: REAL;ππBEGIN;π E:=1;π If Power = 0 then E:=1π Else If Power = 1 then E:=Baseπ Else For X:=1 to ABS(Power) do E:=E*Base;π If Power < 0 then E:=1/E;π Exponent:=E;πEND;ππFunction Log(Base, Expnt: Real): Real;π{returns common (base 10) logarithm}πBegin;π Log:=ln(Expnt)/ln(Base);πEnd;ππFunction Prime(N: LongInt): Boolean;π{Determines if argument is prime}π Var C: LongInt;π S: Real;π X: Boolean;πBegin;π N:=ABS(N);π S:=SQRT(N);π X:=( (N<=2) OR (ODD(N)) AND (S <> INT(S) ) );π If X then Beginπ C:=3;π While (X AND (C < Int(S))) do Beginπ X:=((N Mod C) > 0);π C:=C+2;π End; {While}π End; {If X}π Prime:=X;πEnd; {Prime}ππFunction Whole(X: Real): Boolean;πBegin;π Whole:=INT(X) = X;πEnd;ππFunction Seconds_to_Words(Sec: LongInt): String;π CONSTπ SecDay=86400;π SecHr=3600;π SecMin=60;π VARπ Days, Hours, Minutes, Seconds: LONGINT;π L: BYTE;π T, X: STRING;ππBEGIN;ππ Days:=Sec DIV SecDay;π Sec:=Sec-(SecDay*Days);π Hours:=Sec DIV SecHr;π Sec:=Sec-(SecHr*Hours);π Minutes:=Sec DIV SecMin;π Sec:=Sec-(SecMin*Minutes);π Seconds:=Sec;ππ T:='';ππ If Days > 0 then Beginπ Str(Days,T);π T := T + ' Day';π If Days > 1 then T := T + 's';π T := T + ', ';π End; {If Days}ππ If Hours > 0 then Beginπ Str(Hours,X);π T := T + X + ' Hour';π If Hours > 1 then T := T + 's';π T := T + ', ';π End; {If Hours}ππ If Minutes > 0 then Beginπ Str(Minutes,X);π T := T + X + ' Minute';π If Minutes > 1 then T := T + 's';π T := T + ', ';π End; {If Minutes}ππ If Seconds > 0 then Beginπ Str(Seconds,X);π T := T + X + ' Second';π If Seconds > 1 then T := T + 's';π End; {If Seconds}ππ L:=Length(T)-1;ππ If T[L] = ',' then T:=Copy(T,1,(L-1));ππ Seconds_To_Words:=T;ππEND; {Seconds to Words}ππFunction DegToRad(D: Real): Real;πBegin;π DegToRad:=D*Pi/180;πEnd; {DegToRad}ππFunction GradToRad(G: Real): Real;πBegin;π GradToRad:=G*Pi/200;πEnd; {GradToRad}ππFunction DegToGrad(D: Real): Real;πBegin;π DegToGrad:=D/0.9;πEnd; {DegToGrad}ππFunction RadToDeg(R: Real): Real;πBegin;π RadToDeg:=R*180/Pi;πEnd; {RadToDeg}ππFunction RadToGrad(R: Real): Real;πBegin;π RadToGrad:=R*200/Pi;πEnd;ππFunction GradToDeg(G: Real): Real;πBegin;π GradToDeg:=G*0.9;πEnd; {GradToDeg}ππFunction Tan(R: Real): Real;πBegin;π Tan:=Sin(R) / Cos(R);πEnd; {Tan}ππFunction Csc(R: Real): Real;πBegin;π Csc:=1 / Sin(R);πEnd; {Csc}ππFunction Sec(R: Real): Real;πBegin;π Sec:=1 / Cos(R);πEnd; {Sec}ππFunction Cot(R: Real): Real;πBegin;π Cot:=Cos(R) / Sin(R);πEnd; {Cot}ππFunction Hypotenuse_Equilateral_Triangle(S: Real): Real;πBegin;π Hypotenuse_Equilateral_Triangle:=( SQRT(3) * S ) / 2;πEnd;ππFunction Pythagoras(A, B: Real): Real;πBegin;π Pythagoras:=Sqrt((A*A)+(B*B));πEnd; {Pythagoras}ππFunction Triangle_Area(B, H: Real): Real;πBegin;π Triangle_Area:=0.5 * B * H;πEnd; {Triangle Area}ππFunction Equilateral_Triangle_Area(S: Real): Real;πBegin;π Equilateral_Triangle_Area:=( SQRT(3) * (S*S) ) / 4;πEnd;ππFunction Circle_Area(R: Real): Real;πBegin;π Circle_Area:=Pi*(R*R);πEnd;ππFunction Ellipse_Area(A, B: Real): Real;πBegin;π Ellipse_Area:=Pi*A*B;πEnd;ππFunction Square_Area(S: Real): Real;πBegin;π Square_Area:=(S*S);πEnd;ππFunction Rectangle_Area(X, Y: Real): Real;πBegin;π Rectangle_Area:=X*Y;πEnd;ππFunction Cube_Surface_Area(S: Real): Real;πBegin;π Cube_Surface_Area:=6*(S*S);πEnd;ππFunction Rectangular_Prism_Surface_Area(H, W, L: Real): Real;πBegin;π Rectangular_Prism_Surface_Area:=(2*H*W) + (2*H*L) + (2*L*W);πEnd;ππFunction Sphere_Surface_Area(R: Real): Real;πBegin;π Sphere_Surface_Area:=4*Pi*(R*R);πEnd;ππFunction Cylinder_Surface_Area(R, H: Real): Real;πBegin;π Cylinder_Surface_Area:=(2*Pi*R*H) + (2*Pi*(R*R));πEnd;ππFunction Cone_Surface_Area_Without_Base(R, H: Real): Real;πBegin;π Cone_Surface_Area_Without_Base:=Pi*R*SQRT((R*R) + (H*H) );πEnd;ππFunction Cone_Surface_Area_With_Base(R, H: Real): Real;πBegin;π Cone_Surface_Area_With_Base:=(Pi*R*SQRT((R*R) + (H*H)) ) + (Pi*(R*R));πEnd;ππFunction Sector_Area(R, A: Real): Real;πBegin;π Sector_Area:=0.5*(R*R)*A;πEnd;ππFunction Trapezoid_Area(A, B, H: Real): Real;πBegin;π Trapezoid_Area:=(H / 2) * (A + B);πEnd;ππFunction Circle_Circumference(R: Real): Real;πBegin;π Circle_Circumference:=2*Pi*R;πEnd;ππFunction Ellipse_Circumference(A, B: Real): Real;πBegin;π Ellipse_Circumference := (2*Pi) * ( SQRT( ( (A*A) + (B*B) ) / 2 ) );πEnd;ππFunction Cube_Volume(S: Real): Real;πBegin;π Cube_Volume:=S*S*S;πEnd;ππFunction Rectangle_Volume(X, Y, Z: Real): Real;πBegin;π Rectangle_Volume:=X*Y*Z;πEnd;ππFunction Sphere_Volume(R: Real): Real;πBegin;π Sphere_Volume:=(4/3)*Pi*(R*R*R);πEnd;ππFunction Cylinder_Volume(R, H: Real): Real;πBegin;π Cylinder_Volume:=Pi*(R*R)*H;πEnd; {Cylinder Volume}ππFunction Cone_Volume(R, H: Real): Real;πBegin;π Cone_Volume:=(Pi*(R*R)*H)/3;πEnd;ππFunction Prism_Volume(B, H: Real): Real;πBegin;π Prism_Volume:=B*H;πEnd; {Prism Volume}ππFunction Distance(X1, X2, Y1, Y2: Real): Real;πBegin;π Distance:=Sqrt(Sqr(Y2-Y1)+Sqr(X2-X1));πEnd; {Distance}ππFunction Factorial(N: LongInt): LongInt;π Var X, Y: LongInt;πBegin;π If N <> 0 then Beginπ X:=N;π For Y:=(N-1) downto 2 do X:=X*Y;π Factorial:=X;π End {If}π Else Factorial:=1;πEnd; {Factorial}ππFunction GCF(A, B: LongInt): LongInt;π {finds the Greatest Common Factor between 2 arguments}π Var X, High: LongInt;πBegin;π High:=1;π For X:=2 to A do If (A MOD X = 0) AND (B MOD X = 0) then High:=X;π GCF:=High;πEnd; {GCF}ππFunction LCM(A, B: LongInt): LongInt;π {finds the Least Common Multiple between 2 arguments}π Var Inc, Low, High: LongInt;πBegin;π If A > B then Beginπ High:=A;π Low:=B;π End {If}π Else Beginπ High:=B;π Low:=A;π End; {Else}π Inc:=High;π While High MOD Low <> 0 do High:=High+Inc;π LCM:=High;πEnd; {LCM}ππProcedure ISwap(Var X, Y: LongInt);π {swaps 2 Integer or LongInteger variables}π Var Z: LongInt;πBegin;π Z:=X;π X:=Y;π Y:=Z;πEnd;ππProcedure RSwap(Var X, Y: Real);π {swaps 2 REAL variables}π Var Z: Real;πBegin;π Z:=X;π X:=Y;π Y:=Z;πEnd;πππ 63 02-09-9411:49ALL KENT BRIGGS Latitude/Longitude IMPORT 10 ₧Ç≤ {π Any navigators out there? I need formulas or source code to calculateπ the distance between two points given the latitude and longitudeπ of each point. I'm trying to write some support software for myπ Sony Pyxis GPS (global positioning system). }πππ Procedure Dist( Var xlat1,xlon1,xlat2,xlon2,xdist,ydist,distance : Real);π {π Returns the distance ( in km ) between two points on a tangent planeπ on the earth.π }π Constπ Km = 111.19;π C1 = 0.017453292;π Varπ Xmlat,π cosm,π Adist : Real;ππ Begin { Dist }π { Calculate cos of mean latitude }π Xmlat := (xlat1+xlat2)/2;π cosm := cos(xmlat*C1);π { Calculate Y (N-S) distance }π ydist := (xlat2-xlat1)*km;π { Calculate X (E-W) distance }π xdist := (xlon2-xlon1)*km*cosm;π { Calculate total distance }π adist := xdist*xdist + ydist*ydist;π If adist >= 0 thenπ distance := sqrt(adist)π Elseπ distance := 0;π End; { Dist }ππThis is one I use in some wind calculations for an aircraft fitted withπGPS and LORAN-C.ππNote that all Latitude And Longitudes are in Degrees with minutes andπseconds converted to decimal degrees.π 64 02-15-9408:39ALL J.W. RIDER Financial Calulations IMPORT 149 ₧⌐▒ unit ufinance; { last modified 920520 }ππ{ Math Routines for Finance Calculations in Turbo Pascal }π{ Copyright 1992, J. W. Rider }π{ CIS mail: [70007,4652] }ππ{ These are pascal implementations some of the finance functionsπ available for ObjectVision and Quattro Pro. They are intended toπ work exactly as described in the Quattro Pro 3.0 @Functions manual.ππ The following are the Lotus 1-2-3 compatibility functions.ππ CTERM ( Rate, FV, PV)π DDB ( cost, salvage, life, period)π FV ( Pmt, Rate, Nper)π PMT ( PV, RATE, Nper)π PV ( Pmt, Rate, Nper)π RATE ( FV, PV, Nper)π SLN ( cost, salvage, life)π SYD ( cost, salvage, life, period)π TERM ( pmt, rate, fv)ππ Also implemented are the extended versions of the routines thatπ balance the following "cash-flow" equation:ππ pval*(1+rate)^nper + paymt*(1+rate*ptype)*((1+rate)^nper-1)/rate + fval = 0ππ IRATE ( nper, pmt, pv, fv, ptype)π NPER ( rate, pmt, pv, fv, ptype)π PAYMT ( rate, nper, pv, fv, ptype)π PPAYMT( rate, per, nper, pv, fv, ptype)π IPAYMT( rate, per, nper, pv, fv, ptype)π PVAL ( rate, nper, pmt, fv, ptype)π FVAL ( rate, nper, pmt, pv, ptype)ππ In QPro and OV, the ptype code is either 0 or 1 to indicate that theπ is made at the end or beginning of the month respectively. My preferredπ explanation is that "ptype" is the fraction of the interest rate that isπ applied to a payment in the period that it is paid. This has the sameπ effect when ptype is 0 or 1, but complicates the explanation for what isπ right when ptype=1. THE EXAMPLES IN THE QPRO AND OV MANUALS DO NOT AGREEπ FOR THE "PPAYMT" FUNCTION. Someone needs to explain these discrepancies.π UFinance follows the QPro3 style, but the formula is different than whatπ QPro3 function reference says is used for IPaymt.ππ The "block" financial functions from QPro3 are also implemented:ππ IRR ( guess, block)π NPV ( rate, block, ptype)ππ These make use of the "UBlock.BlockType" object designed especiallyπ for these functions. The BlockType object provides access to a listπ of indexed floating point numbers. See the test program FINTEST.PASπ for an example of BlockType usage.ππ Caveats: under no circumstances will I be held responsible if someoneπ misuses this code. The code is provided for the convenience of otherπ programmers. It is the someone else's responsibility to ensure thatπ these functions satisfy financial needs.ππ While this is a relatively complete set of functions, it is not possibleπ to calculate all desirved components in the compound interest equationπ directly. In particular, there is no way provided to compute directlyπ the interest rate on an annuity or loan that goes from "pv" to "fv" inπ "nper" intervals, paying "pmt" each period. The "RATE" functionπ provided only determines the rate at which a compounded amount grows.π The "IRATE" function computes a value by successive approximation andπ is inherently unstable. (The "IRR" function is subject to similarπ instability.)ππ One way in which programmers go wrong is misunderstanding theπ distinction between binary floating point representations of numbers andπ decimal floating point representation. Turbo Pascal, as well as mostπ other high speed number processing systems, uses the binary form. Whileπ such binary operations give results that are close to their decimalπ counterparts, some differences may arise. Especially, when you expectπ results to round one way versus the other.π}ππinterfaceππuses ublock; { for "blocktype" of NPV and IRR functions }ππ{ "Extended" math is used if $N+ is set. Otherwise, use "real" math.}ππ{$ifopt N-}πtype extended = real;π{$endif}ππfunction CTERM ( Rate, FV, PV: extended):extended;π { number of compounding periods for initial amount "PV" to accumulateπ into amount "FV" at interest "Rate" }ππfunction DDB ( cost, salvage, life, period:extended):extended;π { double declining balance depreciation for the "period" (should be aπ positive, whole number) interval on an item with initial "cost" andπ final "salvage" value at the end of "life" intervals }ππfunction FV ( Pmt, Rate, Nper:extended):extended;π { accumulated amount from making "nper" payments of amount "pmt" withπ interest accruing on the accumulated amount at interest "rate"π compounded per interval }ππfunction FVAL ( rate, nper, pmt, pv, ptype:extended):extended;π { extended version of the FV function }ππfunction IPAYMT(rate, per, nper, pv, fv, ptype:extended):extended;π { computes the portion of a loan payment that is interest on theπ principal }ππfunction IRATE ( nper, pmt, pv, fv, ptype:extended):extended;π { extended version of the RATE function }ππfunction IRR ( guess: extended; var block: blocktype): extended;π { returns internal rate-of-return of sequence of cashflows }ππfunction NPER ( rate, pmt, pv, fv, ptype:extended):extended;π { extended version of the CTERM and TERM functions }ππfunction NPV (π rate: extended; var block: blocktype; ptype:extended): extended;π { return net present value of sequence of cash flows }ππfunction PAYMT ( rate, nper, pv, fv, ptype:extended):extended;π { extended version of the PMT function }ππfunction PMT ( PV, RATE, Nper: extended): extended;π { payment amount per interval on loan or annuity of initial value "PV"π with payments spread out over "nper" intervals and with interestπ accruing at "rate" per interval }ππfunction PPAYMT( rate, per, nper, pv, fv, ptype:extended):extended;π { computes the portion of a loan payment that reduces the principal }ππfunction PV ( Pmt, Rate, Nper: extended): extended;π { initial value of loan or annuity that can be paid off by making "nper"π payments of "pmt" which interest on the unpaid amount accrues atπ "rate" per interval }ππfunction PVAL ( rate, nper, pmt, fv, ptype:extended):extended;π { extended version of the PV function }ππfunction RATE ( FV, PV, Nper: extended): extended;π { determines interest rate per interval when initial amount "pv"π accumulates into amount "fv" by compounding over "nper" intervals }ππfunction SLN ( cost, salvage, life: extended): extended;π { straight line depreciation per interval when item of initial valueπ "cost" has a value of "salvage" after "life" intervals }ππfunction SYD ( cost, salvage, life, period: extended): extended;π { sum-of-year-digits depreciation amount for the "period" (should be aπ positive, whole number) interval on a item with initial "cost" andπ final "salvage" value at the end of "life" intervals }ππfunction TERM ( pmt, rate, fv: extended): extended;π { number of compounding periods required to accumulate "fv" by makingπ periodic deposits of "pmt" with interest accumulating at "rate" perπ period }ππimplementationππfunction CTERM ( Rate, FV, PV: extended):extended;πbegin cterm:=ln(fv/pv)/ln(1+rate) end;ππfunction DDB ( cost, salvage, life, period:extended):extended;πvar x:extended; n:integer;πbeginπ x:=0; n:=0;π while period>n do beginπ x:=2*cost/life;π if (cost-x)<salvage then x:=cost-salvage;π if x<0 then x:=0;π cost:=cost-x; inc(n); end;π ddb:=x;πend;ππfunction FV ( Pmt, Rate, Nper:extended):extended;πbeginπ if abs(rate)>1e-6 then fv:=pmt*(exp(nper*ln(1+rate))-1)/rateπ else fv:=pmt*nper*(1+(nper-1)*rate/2); end;ππfunction FVAL ( rate, nper, pmt, pv, ptype:extended):extended;πvar f: extended;πbeginπ f:=exp(nper*ln(1+rate));π if abs(rate)<1e-6 thenπ fval :=-pmt*nper*(1+(nper-1)*rate/2)*(1+rate*ptype)-pv*fπ elseπ fval := pmt*(1-f)*(1/rate+ptype)-pv*f;πend;ππfunction IPAYMT(rate, per, nper, pv, fv, ptype:extended):extended;πbeginπ ipaymt := rateπ * fval( rate, per-ptype-1, paymt( rate, nper, pv, fv, ptype), pv, ptype);πend;ππfunction IRATE ( nper, pmt, pv, fv, ptype:extended):extended;πvar rate,x0,x1,y0,y1:extended;ππ function y:extended;π var f:extended;π beginπ if abs(rate)<1e-6 then y:=pv*(1+nper*rate)+pmt*(1+rate*ptype)*nper+fvπ else beginπ f:=exp(nper*ln(1+rate));π y:=pv*f+pmt*(1/rate+ptype)*(f-1)+fv; end; end;ππbegin {irate}ππ { JWR: There are two fundamental problems with solutions by successiveπ approximation. One is figuring out where you want to start; theπ other is figuring out where you want to stop. If you don't set themπ right, then your solution will approximate successively forever.π This is my guess, but there is no guarantee that the solution willπ even exist, much less converge. }ππ rate:=0; y0:=pv+pmt*nper+fv; x0:=rate;π rate:=exp(1/nper)-1; y1:=y; x1:=rate;π while abs(y0-y1)>1e-6 do begin { find root by secant method }π rate:=(y1*x0-y0*x1)/(y1-y0); x0:=x1; x1:=rate; y0:=y1; y1:=y; end;π irate:=rate;πend; {irate}ππfunction IRR( guess: extended; var block: blocktype): extended;πvar orate, rate: extended;ππ function drate(rate:extended):extended;π var npv,npvprime,blockvaluei:extended; i:longint;π beginπ npv:=0; npvprime:=0; rate:=1/(1+rate);π for I:=block.count downto 1 do beginπ blockvaluei:=block.value(i);π npv:=npv*rate+blockvaluei;π npvprime:=(npvprime+blockvaluei*i)*rate; end;π if abs(npvprime)<1e-6 then drate:=npv*1e-6 { a guess }π else drate:=npv/npvprime; end;ππbegin {IRR}ππ { JWR: same caveats as for IRate }ππ orate:=guess; rate:=orate+drate(orate);π while abs(rate-orate)>1e-6 do begin { find root by newton-raphson }π orate:=rate; rate:=rate+drate(rate); end;π irr:=rate;πend;ππfunction NPER ( rate, pmt, pv, fv, ptype:extended):extended;πvar f:extended;πbeginπ f:=pmt*(1+rate*ptype);π if abs(rate)>1e-6 thenπ nper:=ln((f-rate*fv)/(pv*rate+f))/ln(1+rate)π elseπ nper:=-(fv+pv)/(pv*rate+f); end;ππfunction NPV (π rate: extended; var block: blocktype; ptype:extended): extended;πvar x:extended; i:longint;πbeginπ x:=0; rate:=1/(1+rate); {note: change in meaning of "rate"!}π for I:=block.count downto 1 do x:=x*rate+block.value(i);π npv:=x*exp((1-ptype)*ln(rate)); end;ππfunction PAYMT ( rate, nper, pv, fv, ptype:extended):extended;πvar f:extended;πbeginπ f:=exp(nper*ln(1+rate));π paymt:= (fv+pv*f)*rate/((1+rate*ptype)*(1-f)); end;ππfunction PMT ( PV, RATE, Nper: extended): extended;πbegin pmt:=pv*rate/(1-exp(-nper*ln(1+rate))) end;ππfunction PPAYMT( rate, per, nper, pv, fv, ptype:extended):extended;πvar f:extended;πbeginπ f:=paymt(rate,nper,pv,fv,ptype);π ppaymt:=f-rate*fval(rate,per-ptype-1,f,pv,ptype);πend;ππfunction PV ( Pmt, Rate, Nper: extended): extended;πbeginπ if abs(rate)>1e-6 thenπ pv:=pmt*(1-exp(-nper*ln(1+rate)))/rateπ elseπ pv:=pmt*nper*(1+(nper-1)*rate/2)/(1+nper*rate)πend;ππfunction PVAL ( rate, nper, pmt, fv, ptype:extended):extended;πvar f:extended;πbeginπ if abs(rate)>1e-6 then beginπ f:=exp(nper*ln(1+rate)); pval := (pmt*(1/rate+ptype)*(1-f)-fv)/f; endπ elseπ pval:=-(pmt*(1+rate*ptype)*nper+fv)/(1+nper*rate)πend;ππfunction RATE ( FV, PV, Nper: extended): extended;πbegin rate:=exp(ln(fv/pv)/nper)-1 end;ππfunction SLN ( cost, salvage, life: extended): extended;πbegin sln:=(cost-salvage)/life end;ππfunction SYD ( cost, salvage, life, period: extended): extended;πbegin syd:=2*(cost-salvage)*(life-period+1)/(life*(life+1)) end;ππfunction TERM ( pmt, rate, fv: extended): extended;πbegin term:=ln(1+(fv/pmt)*rate)/ln(1+rate) end;ππend.ππ{ ---------------------- CUT HERE -------------------------- }ππunit ublock;ππ{ defines the "BlockType" object used for the UFinance NPV and IRR functions }π{ Copyright 1992 by J. W. Rider }π{ CIS mail: [70007,4652] }ππinterfaceππ{$ifopt N-}πtypeπ extended = real;π{$endif}ππtypeππ { the abstract "block": this is the type that is used for theπ type of "var" parameters in procedures and functions }π BlockTypePtr = ^BlockType;π BlockType = objectπ function count: longint; virtual; { number of values in "block" }π function value(n:longint):extended; virtual; { return nth value }π destructor done; virtual;π end;ππtypeπ ExtendedArrayPtr = ^ExtendedArray;π ExtendedArray = array [1..$fff8 div sizeof(extended)] of extended;ππtypeπ { a special-purpose block that extracts values from "extended" arrays.π This is the type that would be declared as "const" or "var" orπ allocated on the heap in your program. This one is very simple; youπ could easily extend the abstract block to other storage forms. }π { Note that "extended" means the same as "real" if $N-. }π ExtendedArrayBlockTypePtr = ^ExtendedArrayBlockType;π ExtendedArrayBlockType = object(BlockType)π c: word;π d: extendedarrayptr;π function count:longint; virtual;π function value(n:longint):extended; virtual;π constructor init(dim:word; var firstvalue:extended);π end;ππimplementationππfunction blocktype.count; begin count:=0 end;πfunction extendedarrayblocktype.count; begin count:=c; end;ππdestructor blocktype.done; begin end;ππconstructor extendedarrayblocktype.init; begin c:=dim; d:=@firstvalue; end;ππfunction blocktype.value; begin value:=0; end;πfunction extendedarrayblocktype.value; begin value:=d^[n] end;ππend.ππ{ ======================== DEMO ============================= }ππ{JWR: The output scrolls without stopping. You might want to replaceπ "writeln;" with "readln;" so that you can follow along in the QPROπ manual while you run the example. What I usually do for testing isπ just to redirect everything to a file from the command line and thenπ examine the file.}ππprogram fintest;πuses ufinance,ublock;ππ{ these types and consts are used for the IRR and NPV functions }ππtypeπ xray3 = array [1..3] of extended;π xray5 = array [1..5] of extended;π xray7 = array [1..7] of extended;π bt = object(extendedarrayblocktype) end;ππconstπ x1: xray3 = (-10,150,-145);π x2: xray3 = (-10,150.1,-145);π a: xray7 = (-3000,700,600,750,900,1000,1400);π b: xray7 = (-50000,-8000,2000,4000,6000,5000,4500);π c: xray7 = (-10000,1000,1000,1200,2000,3000,4000);π a2: xray5 = (-5000,2000,2000,2000,2000);π b2: xray7 = (8000,9000,8500,9500,10000,11000,10000);π c2: xray7 = (200,350,-300,600,700,1000,1200);π d2: xray7 = (3500,4000,3000,5000,4000,6500,7000);ππ block1:bt = (c:3; d:@x1);π block2:bt = (c:3; d:@x2);π block3:bt = (c:7; d:@a);π block4:bt = (c:7; d:@b);π block5:bt = (c:7; d:@c);π block6:bt = (c:5; d:@a2);π block7:bt = (c:4; d:@a2[2]);π block8:bt = (c:7; d:@b2);π block9:bt = (c:7; d:@c2);π block10:bt = (c:7; d:@d2);ππbeginππ writeln('Test of UFinance unit. Examples from');π writeln(' Quattro Pro 3.0 @Functions and Macros manual');π writeln;π writeln('page 29 (CTERM):');π writeln(cterm(0.07,5000,3000):10:2);π writeln(nper(0.07,0,-3000,5000,0):10:2,'(nper)');π writeln(cterm(0.1,5000,3000):10:6);π writeln(cterm(0.12,5000,3000):10:6);π writeln(cterm(0.12,10000,7000):10:6);π writeln;π writeln('pages 35-36 (DDB):');π writeln(ddb(4000,350,8,2):10:0);π writeln(ddb(15000,3000,10,1):10:0);π writeln(ddb(15000,3000,10,2):10:0);π writeln(ddb(15000,3000,10,3):10:0);π writeln(ddb(15000,3000,10,4):10:0);π writeln(ddb(15000,3000,10,5):10:0);π writeln;π writeln('page 48 (FV):');π writeln(fv(500,0.15,6):10:2);π writeln(fval(0.15,6,-500,0,0):10:2,'(fval)');π writeln(fv(200,0.12,5):10:2);π writeln(fv(500,0.9,4):10:2);π writeln(fv(800,0.9,3):10:2);π writeln(fv(800,0.9,6):10:2);π writeln;π writeln('page 49 (FVAL):');π writeln(fval(0.15,6,-500,0,1):10:2);π writeln(fval(0.15,6,-500,-340,1):10:2);π writeln;π writeln('page 57 (IPAYMT):');π writeln(ipaymt(0.1/12,2*12,30*12,100000,0,0):10:2);π writeln;π writeln('pages 57-58 (IRATE):');π writeln(irate(5*12,-500,15000,0,0):10:5);π writeln(irate(5,-2000,-2.38,15000,0):10:4);π writeln;π writeln('pages 60-61 (IRR):');π writeln(irr(0,block1)*100:10:2,'%');π writeln(irr(10,block1)*100:10:0,'%');π writeln(irr(0,block2)*100:10:2,'%');π writeln(irr(10,block2)*100:10:0,'%');π writeln(irr(0,block3)*100:10:2,'%');π writeln(irr(0,block4)*100:10:2,'%');π writeln(irr(0,block5)*100:10:2,'%');π writeln;π writeln('page 73 (NPER):');π writeln(nper(0.115,-2000,-633,50000,0):10:2);π writeln;π writeln('page 75 (NPV):');π writeln(npv(0.1,block6,1):10:0);π writeln(a2[1]+npv(0.1,block7,0):10:0);π writeln(npv(0.0125,block8,0):10:2);π writeln(npv(0.15/12,block9,0):10:0);π writeln(npv(0.15/12,block10,0):10:0);π writeln;π writeln('page 77 (PAYMT):');π writeln(paymt(0.175/12,12*30,175000,0,0):10:2);π writeln(paymt(0.175/12,12*30,175000,0,1):10:2);π writeln(paymt(0.175/12,12*30,175000,-80000,0):10:2);π writeln;π writeln('pages 78-79 (PMT)');π writeln(pmt(10000,0.15/12,3*12):10:2);π writeln(paymt(0.15/12,3*12,10000,0,0):10:2,'(paymt)');π writeln(pmt(1000,0.12,5):10:2);π writeln(pmt(500,0.16,12):10:2);π writeln(pmt(5000,0.16/12,12):10:2);π writeln(pmt(12000,0.11,15):10:2);π writeln;π writeln('page 79 (PPAYMT):');π writeln(ppaymt(0.1/12,2*12,30*12,100000,0,0):10:2);π writeln(ppaymt(0.15/4,24,40,10000,0,1):10:2);π writeln;π writeln('page 81 (PV)');π writeln(pv(350,0.07/12,5*12):10:2);π writeln(pval(0.07/12,5*12,-350,0,0):10:2,'(pval)');π writeln(pv(277,0.12,5):10:2);π writeln(pv(600,0.17,10):10:2);π writeln(pv(100,0.11,12):10:2);π writeln;π writeln('page 82 (PVAL)');π writeln(pval(0.1,12,2000,0,0):10:2);π writeln(pval(0.1,15,0,30000,0):10:2);π writeln;π writeln('page 84 (RATE)');π writeln(rate(4000,2000,10)*100:6:2,'%');π writeln(rate(10000,7000,6*12)*100:6:2,'%');π writeln(rate(1200,1000,3)*100:6:2,'%');π writeln(rate(500,100,25)*100:6:2,'%');π writeln;π writeln('page 89 (SLN)');π writeln(sln(4000,350,8):10:2);π writeln(sln(15000,3000,10):10:0);π writeln(sln(5000,500,5):10:0);π writeln(sln(1800,0,3):10:0);π writeln;π writeln('pages 94-95 (SYD)');π writeln(syd(4000,350,8,2):10:2);π writeln(syd(12000,1000,5,1):10:0);π writeln(syd(12000,1000,5,2):10:0);π writeln(syd(12000,1000,5,3):10:0);π writeln(syd(12000,1000,5,4):10:0);π writeln(syd(12000,1000,5,5):10:0);π writeln;π writeln(ddb(12000,1000,5,1):10:0,'(ddb)');π writeln(ddb(12000,1000,5,2):10:0,'(ddb)');π writeln(ddb(12000,1000,5,3):10:0,'(ddb)');π writeln(ddb(12000,1000,5,4):10:0,'(ddb)');π writeln(ddb(12000,1000,5,5):10:0,'(ddb)');π writeln;π writeln('page 96 (TERM)');π writeln(term(2000,0.11,50000):10:2);π writeln(nper(0.11,-2000,0,50000,0):10:2,'(nper)');π writeln(term(300,0.06,5000):10:1);π writeln(term(500,0.07,1000):10:2);π writeln(term(500,0.07,1000):10:2);π writeln(term(1000,0.10,50000):10:1);π writeln(term(100,0.05,1000):10:1);πend.π 65 02-22-9411:40ALL GLENN GROTZINGER A definite Integral IMPORT 29 ₧ program integration; uses crt;ππ { program below demonstrates Pascal code used to compute a definite }π { integral. Useful for many calculus-related functions such as }π { finding areas of irregular shapes when a functional relation is }π { known. You may freely use this code, but do please give me the }π { credits. }ππ { A negative area as an answer, is the result of incorrectly definingπ the lower and upper bounds for a function. For example, using theπ functionππ 6 - 6x^5, a perfectly justifiable lower bound would be 0, while - 5π would not be. a perfectly justifiable upper bound would be 1, whileπ 6 would not be. The non-justifiable bounds used as examples, are notπ defined in the function used, so a negative area would result in thisπ caseππ { Tutorial: this program uses Simpson's rule as a method of finding }π { the area under a graphed curve. A lower and an upper limit is set }π { where the area is calculated. The area is cut up into a number of }π { rectangles dictated by the 'number of divisions'. The more you }π { divide up this area, the more accurate an approximation becomes. }ππ varπ lower, upper, divisions, sum, width, counter, x, left, right, middle,π c: real;ππ procedure formula;ππ { procedure set apart from rest of program for ease of changing the }π { function if need be. The function is defined as: f(x) = }π { <expression>, expression being set in a Pascal-type statement }ππ beginπ c := 6 - ( 6 * x * x * x * x * x ); { current function set: 6 - 6x^5 }π end;ππ beginππ clrscr;π { read in lower bound }ππ writeln('Input lower limit.');π readln(lower);ππ { read in upper bound }ππ writeln('Input upper limit.');π readln(upper);ππ { read in the number of divisions.. The higher you make this number, }π { the more accurate the results, but the longer the calculation... }ππ Writeln('number of divisions?');π readln(divisions);ππ { set the total sum of the rectangles to zero }ππ sum := 0;ππ { determine width of each rectangle }ππ width := (upper - lower) / (2 * divisions);ππ { initalize counter for divisions loop }ππ counter := 1;ππ clrscr;π writeln('Working...');ππ { start computations }ππ repeatππ { define left, right, and middle points along each rectangle }ππ left := lower + 2 * (counter - 1) * width;π right := lower + 2 * counter * width;π middle := (left + right) / 2;ππ { compute functional values at each point }ππ x := left;π formula;π left := c;π x := middle;π formula;π middle := c;π x := right;π formula;π right := c;ππ { calculate particular rectangle area and increment the area to the }π { sum of the areas. }ππ sum := (width * (left + 4 * middle + right)) / 3 + sum;ππ { write sum to screen as a "working" status }ππ writeln;π write(sum:0:9);π gotoxy(1,2);ππ { increment counter }ππ counter := counter + 1;ππ { stop loop when all areas of rectangles are computed }ππ until counter = divisions;ππ { output results }ππ clrscr;π writeln('The area under the curve is ', sum:0:9, '.');π { ^^^^^^^^ }π end. { format code used to eliminate }π { scientific notation in answer } 66 05-25-9408:02ALL STEVE ROGERS Complex Math Unit SWAG9405 18 ₧ π{Just for grins, here's a complex number unit I wrote come time back:}ππunit complex;π(*π polar/rectangular conversions and complex mathπ Steve Rogers, ~1993π*)ππ{----------------------}πinterfaceππtypeπ tComplex=recordπ r, { real component }π x { imaginary component }π : real;π end;ππprocedure r2p(var r,p : tComplex);πprocedure p2r(var p,r : tComplex);πprocedure c_add(var c1,c2,c3 : tComplex);πprocedure c_sub(var c1,c2,c3 : tComplex);πprocedure c_mult(var c1,c2,c3 : tComplex);πprocedure c_div(var c1,c2,c3 : tComplex);ππimplementationππconstπ RADS=0.0174532; { degree to radian conversion constant }ππ{----------------------}πprocedure r2p(var r,p : tComplex);π{ returns polar in degrees in p, given rectangular in r }πbeginπ p.r:= sqrt(sqr(r.r)+sqr(r.x));π p.x:= arctan(r.x/r.r)/RADS;πend;ππ{----------------------}πprocedure p2r(var p,r : tComplex);π{ returns rectangular in r, given polar in degrees in p }πbeginπ r.r:= p.r*cos(p.x*RADS);π r.x:= p.r*sin(p.x*RADS);πend;ππ{----------------------}πprocedure c_add(var c1,c2,c3 : tComplex);π{ adds c2 to c1, places result in c3 }πbeginπ c3.r:= c1.r+c2.r;π c3.x:= c1.x+c2.x;πend;ππ{----------------------}πprocedure c_sub(var c1,c2,c3 : tComplex);π{ subtracts c2 from c1, places result in c3 }πbeginπ c3.r:= c1.r-c2.r;π c3.x:= c1.x-c2.x;πend;ππ{----------------------}πprocedure c_mult(var c1,c2,c3 : tComplex);π{ multiplies c1 by c2, places result in c3 }πbeginπ c3.r:= (c1.r*c2.r)-(c1.x*c2.x);π c3.x:= (c1.r*c2.x)+(c1.x*c2.r);πend;ππ{----------------------}πprocedure c_div(var c1,c2,c3 : tComplex);π{ divides c1 by c2, places result in c3 }πvarπ p1,p2,p3 : tComplex;ππbeginπ r2p(c1,p1); { convert c1 to polar form }π r2p(c2,p2); { convert c2 to polar form }π p3.r:= p1.r/p2.r; { divide real component }π p3.x:= p1.x-p2.x; { subtract imaginary component }π if (p3.x<0) then p3.x:= p3.x+180; { Pretty it up }π p2r(p3,c3); { convert c3 back to rectangular }πend;π 67 05-25-9408:24ALL JUHANI KAUKORANTA Trig & hyperbolic functioSWAG9405 24 ₧ {πMSGID: 2:228/406 68DEA672πHere is the unit of trigonometric and hyperbolicπreal functions:π}ππUNIT trighyp;π{ Juhani Kaukoranta, Sysop of Pooki MBBS, Finlandπ Pooki MBBS 358-82-221 782 }ππINTERFACEππFUNCTION TAN(x:Real):Real;πFUNCTION COT(x:Real): Real;πFUNCTION SEC(x:Real): Real;πFUNCTION COSEC(x:Real): Real;πFUNCTION SINH(x:Real): Real;πFUNCTION COSH(x:Real): Real;πFUNCTION TANH(x:Real): Real;πFUNCTION COTH(x:Real): Real;πFUNCTION SECH(x:Real): Real;πFUNCTION COSECH(x:Real): Real;πFUNCTION ARCSIN(x:Real):Real;πFUNCTION ARCCOS(x:Real):Real;πFUNCTION ARCCOT(x:Real): Real;πFUNCTION ARCSEC(x:Real): Real;πFUNCTION ARCCOSEC(x:Real): Real;πFUNCTION ARCSINH(x:Real): Real;πFUNCTION ARCCOSH(x:Real): Real;πFUNCTION ARCTANH(x:Real): Real;πFUNCTION ARCCOTH(x:Real): Real;ππIMPLEMENTATIONππFUNCTION TAN(x: Real): Real;π{ argument x is in radians }πBEGINπ TAN := SIN(x)/COS(x);πEND;ππFUNCTION COT(x:Real): Real;π{ cotangent, x is in radians }πBEGINπ COT := 1/TAN(x);πEND;ππFUNCTION SEC(x:Real): Real;π{ secant, x is in radians }πBEGINπ SEC := 1/COS(x);πEND;ππFUNCTION COSEC(x:Real): Real;π{ cosecant, x is in radians }πBEGINπ COSEC := 1/SIN(x);πEND;ππFUNCTION SINH(x:real):Real;π{ hyperbolic sin }πBEGINπ SINH := (EXP(x)-EXP(-x))/2;πEND;ππFUNCTION COSH(x:Real): Real;π{ hyperbolic cos }πBEGINπ COSH := (EXP(x)+EXP(-x))/2;πEND;ππFUNCTION TANH(x:Real): REAL;π{ hyperbolic tan }πBEGINπ TANH := SINH(x)/COSH(x);πEND;ππFUNCTION COTH(x: Real): Real;π{ hyperbolic cotangent }πBEGINπ COTH :=SINH(x)/COSH(x);πEND;ππFUNCTION SECH(x:Real): Real;π{ hyperbolic secant }πBEGINπ SECH := 1/COSH(x);πEND;ππFUNCTION COSECH(x:Real): Real;π{ hyperbolic cosecant }πBEGINπ COSECH := 1/SINH(x);πEND;ππFUNCTION ARCSIN(x:Real):Real;π{ inverse of sin, return value is in radians }πBEGINπ IF ABS(x)=1.0 THENπ ARCSIN := x*Pi/2π ELSEπ ARCSIN := ARCTAN(x/SQRT(-SQR(x)+1));πEND;ππFUNCTION ARCCOS(x:Real):Real;π{ inverse of cos, return value is in radians }πBEGINπ IF x = 1.0 THENπ ARCCOS := 0π ELSE IF x = -1.0 THENπ ARCCOS :=Piπ ELSEπ ARCCOS := -ARCTAN(x/SQRT(-SQR(x)+1))+Pi/2;πEND;ππFUNCTION ARCCOT(x:Real): Real;π{ inverse of cot, return value is in radians }πBEGINπ ARCCOT := ARCTAN(1/x);πEND;ππFUNCTION ARCSEC(x:Real): Real;π{ inverse of secant, return value is in radians }πBEGINπ ARCSEC := ARCCOS(1/x);πEND;ππFUNCTION ARCCOSEC(x:Real): Real;π{ inverse of cosecant, return value is in radians }πBEGINπ ARCCOSEC := ARCSIN(1/x);πEND;ππFUNCTION ARCSINH(x:Real): Real;π{ inverse of hyperbolic sin }πBEGINπ ARCSINH := LN(x + SQRT(x*x+1));πEND;ππFUNCTION ARCCOSH(x:Real): Real;π{ inverse of hyperbolic cos}πBEGINπ ARCCOSH := LN(x + SQRT(x*x-1));πEND;ππFUNCTION ARCTANH(x:Real): Real;π{ inverse of hyperbolic tan }πBEGINπ ARCTANH := LN((1+x)/(1-x))/2;πEND;ππFUNCTION ARCCOTH(x:Real): REAL;π{ inverse of hyperbolic cotangent }πBEGINπ ARCCOTH := LN((x+1)/(x-1))/2;πEND;ππEND. { of unit }π 68 05-26-9406:18ALL RUUD KUCHLER Prime Numbers IMPORT 13 ₧ {πJT>Does anyone know of anyway to code a prime number generator?? I've hadπJT>some ideas, but none so far that have worked... I am just learning PascalπJT>right now, so I do need some help... Any would be appreciated becauseπJT>this is for a class assignment!! ThankXππTry this:ππ------ take scissors and cut here :-) ------------------------ }ππprogram priem;ππ{Program creates prime numbers.ππWorking of the program:π- an array is created where found prime numbers are stored.πChecking whether a number is prime:π- the number is checked with the previously found prime numberπif it is primeπ- if it is prime it is stored in the array and printed}ππconstπmaxpriems=10000;ππtypeπpriemarrtype=array[1..maxpriems] of longint; {array to store primes}ππvarπpriemarr: priemarrtype;πnrofpriem: word;πnumber, divider: longint;πisapriemnumber: boolean;ππbegin {priem}πnumber:=1;πnrofpriem:=0; {number of prime numbers already found}πwhile(nrofpriem<maxpriems) doπbeginπinc(number);πisapriemnumber:=true;πdivider:=1;πwhile (isapriemnumber) and (divider<=nrofpriem) doπbeginπif (number mod priemarr[divider]=0)π{calculate "remains" of division}πthen isapriemnumber:=false {no prime}πelse inc(divider) {get next prime}πend; { not (isapriemnumber) or (divider>nrofpriem) }πif (isapriemnumber) thenπbegin {a prime number is found}πinc(nrofpriem);πpriemarr[nrofpriem]:=number; {store it in the array}πwriteln('prime number ',nrofpriem:5,' found is:π',priemarr[nrofpriem]:8)πendπend; { nrofpriem>=maxpriems }πend. {priem}ππ 69 05-26-9406:18ALL SCOTT STONE More Prime Numbers IMPORT 6 ₧ πFunction CheckPrime(a : integer) : boolean;πVarπ x : integer;π y : integer;πBeginπ y:=0;π for x:=1 to (a div 2) do {Only #s up to half of a can be factors}π beginπ if (a mod x)=0 then y:=(y+1)π end;π if y=2 then checkprime:=true else checkprime:=false;π if a=1 then checkprime:=true;πEnd;ππYou see, only prime numbers have exactly two factors, themselves and one.πWith the exception of One. Therefore you have a specific IF for theπnumber one. One is prime, yet its only factor is one. I think - Is oneπprime or not? Anyway, remove that line if it isn't, the function will work.π
