Category : Pascal Source Code
Archive   : ALLSWAGS.ZIP
Filename : MATH.SWG

SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00065 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 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 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 ) );ããã==============================================================================ã 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) 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 ž{ô {ã[email protected] (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' ');ã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')')ã 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)) )0)ã THENã BEGINã {----Underflow Protected}ã IF (value<>0)ã THENã IF (ABS( LN(ABS(value))-LN(ABS(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' : 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 (fiesiz0) 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)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]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))) )=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.ãã-------------------------------------------------------------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)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 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 }