{ -- FLORIDA HIGH SCHOOLS COMPUTING COMPETITION '86 }
{ -- PASCAL PROGRAM SOLUTIONS }
{1.1}
program One1T86;
{ -- This program will print "THIS IS THE EASIEST PROGRAM!". }
uses Crt;
begin
ClrScr;
GotoXY (25, 12); Writeln ('THIS IS THE EASIEST PROGRAM!');
end.
{1.2}
program One2T86;
{ -- This program will display the sum, difference, and product. }
var
Num1, Num2: Integer;
begin
Write ('Enter two numbers: '); Readln (Num1, Num2);
Writeln ('SUM = ', Num1 + Num2);
Writeln ('DIFFERENCE = ', Num1 - Num2);
Writeln ('PRODUCT = ', Num1 * Num2);
end.
{1.3}
program One3T86;
{ -- This program will sum 1 + (1/2)^2 + (1/3)^3 + (1/4)^4 + ...
-- until difference between it and the next term is within E. }
var
Sum, LastSum, E, Term, Prod: Real;
I, J: Integer;
begin
Write ('Enter test value E: '); Readln (E);
I := 1;
Sum := 1; LastSum := 0;
while (Sum - LastSum) >= E do begin
Inc(I);
Term := 1.0 / I; Prod := 1;
for J := 1 to I do
Prod := Prod * Term;
LastSum := Sum;
Sum := Sum + Prod;
end;
Writeln (LastSum :8:6);
end.
{1.4}
program One4T86;
{ -- This program will print a check given name and amount. }
uses Crt;
var
First, Last, Middle, Init, Amount: String[10];
I: Integer;
begin
ClrScr;
Write ('Enter first name: '); Readln (First);
Write ('Enter middle name: '); Readln (Middle);
Write ('Enter last name: '); Readln (Last);
Init := Copy(Middle, 1, 1);
Write ('Enter amount: '); Readln (Amount);
{ -- Display border }
GotoXY (1, 6);
for I := 1 to 39 do
Write ('*');
for I := 1 to 9 do begin
GotoXY (1, 6+I); Write ('*');
GotoXY (39, 6+I); Write ('*');
end;
GotoXY (1, 6+10);
for I := 1 to 39 do
Write ('*');
GotoXY (3, 8); Write ('BEN''S TOWING SERVICE');
GotoXY (3, 9); Write ('4563 WRECKER AVENUE');
GotoXY (3, 10); Write ('WAVERLY, ARKANSAS 45632');
GotoXY (4, 12); Write ('PAY TO THE ORDER OF ');
Write (First, ' ', Init, '. ', Last);
GotoXY (4, 14); Write ('THE SUM OF $', Amount);
GotoXY (1, 22);
end.
{1.5}
program One5T86;
{ -- This program will determine which prisoners may be released.}
var
Cell: Array [1..100] of 0..1;
I, J: Integer;
begin
for I := 1 to 100 do
Cell[I] := 1; { -- Initialize all cells open }
for I := 2 to 100 do begin
J := 1;
while J <= 100 do begin
Cell[J] := 1 - Cell[J];
Inc(J,I);
end;
end;
for I := 1 to 100 do
if Cell[I] = 1 then
Writeln ('CELL ', I);
end.
{1.6}
program One6T86;
{ -- This program will determine how much money accumulates. }
var
Month, Deposit, Rate, Sum: Real;
Year, J: Integer;
begin
Write ('Enter monthly investment: ');
Readln (Month);
Write ('Enter end of year deposit: ');
Readln (Deposit);
Write ('Enter annual rate of interest: ');
Readln (Rate);
Writeln;
Rate := Rate / (12*100); { -- Rate per month in yr in percent }
Sum := 0;
for Year := 1 to 20 do begin
for J := 1 to 12 do begin
Sum := Sum + Month;
Sum := Sum + Rate*Sum;
end;
Sum := Sum + Deposit;
end;
Writeln ('AMOUNT AT END OF YEAR 20 IS $', Sum: 4:2);
end.
{1.7}
program One7T86;
{ -- This program will drop g in words ending with ing or ings. }
var
I, L, LenWord: Integer;
Sentence: String[80];
Word: String[20];
End1, End2: String[4];
Ch: Char;
begin
Write ('Enter sentence: '); Readln (Sentence);
Sentence := Sentence + ' ';
L := Length(Sentence);
I := 1; Word := '';
while I <= L do begin
Ch := Sentence[I];
if Ch <> ' ' then
Word := Word + Ch
else begin
LenWord := Length(Word);
if LenWord >= 4 then begin
End1 := Copy(Word, LenWord-2, 3);
End2 := Copy(Word, LenWord-3, 4);
if End1 = 'ING' then
Word := Copy(Word, 1, LenWord-1);
if End2 = 'INGS' then
Word := Copy(Word, 1, LenWord-2) + 'S';
end;
Write (Word, ' ');
Word := '';
end;
Inc(I);
end;
end.
{1.8}
program One8T86;
{ -- This program simulates the population growth of rabbits. }
var
Init, OverPop: Integer;
Month, I: Integer;
Pop: Real;
Dieing: Boolean;
begin
Write ('Enter initial population: '); Readln (Init);
Write ('Enter point of over population: '); Readln (OverPop);
Writeln;
Pop := Init;
Dieing := (Pop >= OverPop);
for Month := 1 to 23 do begin
If Dieing then
If (Pop < 2/3 * Init) then
begin
Dieing := False;
Pop := Pop + Pop * 0.2;
end
else
Pop := Pop - Pop * 0.15
else
if (Pop >= OverPop) then
begin
Dieing := True;
Init := Trunc(Pop);
Pop := Pop - Pop * 0.15;
end
else
Pop := Pop + Pop * 0.2;
Writeln ('POPULATION FOR MONTH ', Month, ' IS ', Pop :2:0);
end;
end.
{1.9}
program One9T86;
{ -- This program doubles every e that appears as a single e. }
var
Sentence: String[200];
LastCh, Ch, NextCh: Char;
I: Integer;
begin
Write ('Enter sentence: '); Readln (Sentence);
I := 1; LastCh := ' ';
repeat
Ch := Sentence[I];
NextCh := Sentence[I+1];
if (Ch = 'E') and (LastCh <> 'E') and (NextCh <> 'E') then
Write ('E');
Write (Ch);
Inc(I);
LastCh := Ch;
until I = Length(Sentence);
if (NextCh = 'E') and (LastCh <> 'E') then
Write ('E');
Write (NextCh);
end.
{1.10}
program One10T86;
{ -- This program will display common elements of two lists. }
var
I, J: Integer;
A, B, C: Array [1..12] of Integer;
begin
for I := 1 to 12 do begin
Write ('Enter ', I, ' of 12: '); Readln (A[I]);
end;
Writeln;
for I := 1 to 11 do begin
Write ('Enter ', I, ' of 11: '); Readln (B[I]);
end;
for I := 1 to 12 do C[I] := 0;
for I := 1 to 12 do
for J := 1 to 11 do
if A[I] = B[J] then C[I] := 1;
for I := 1 to 12 do
for J := I + 1 to 12 do
if (A[I] = A[J]) and (C[J] > 0) then
Inc(C[J]);
for I := 1 to 12 do
if C[I] = 1 then
Write (A[I], ' ');
end.
{2.1}
program Two1T86;
{ -- This program will right justify sentence within 65 columns. }
const
Col: Integer = 65;
var
Sentence, Just: String[65];
Word: Array [1..20] of String[12];
Ch: Char;
I, L, Extra, Ex: Integer;
WordNum: Integer;
TotalCh, SpAve: Integer;
begin
Write ('Enter Sentence: '); Readln (Sentence);
Sentence := Sentence + ' ';
L := Length(Sentence);
I := 1; WordNum := 1; Word[WordNum] := '';
TotalCh := 0;
{ -- Parse Words and calculate Total # of Characters in words }
while (I <= L) do begin
Ch := Sentence[I];
if Ch <> ' ' then
Word[WordNum] := Word[WordNum] + Ch
else
if Word[WordNum] > '' then begin
TotalCh := TotalCh + Length(Word[WordNum]);
Inc(WordNum);
Word[WordNum] := '';
end;
Inc(I);
end;
Dec(WordNum);
{ -- Display words with SpAve spaces between each one. }
SpAve := (Col - TotalCh) div (WordNum - 1);
Extra := (Col - TotalCh) - (SpAve * (WordNum-1));
for I := 1 to WordNum do begin
If I <= Extra then Ex := 1
else Ex := 0;
Write (Word[I], ' ': SpAve + Ex);
end;
end.
{2.2}
program Two2T86;
{ -- This program will produce a repeating pattern with XXX -- }
var
X1, X2, D1, D2: String[7];
TotalXD, Row: Integer;
NumX, Rows, I: Integer;
begin
Write ('Enter total number of X''s and -''s: ');
Readln (TotalXD);
Write ('Enter number of X''s: '); Readln (NumX);
Write ('Enter number of rows: '); Readln (Rows);
X1 := ''; X2 := ''; D1 := ''; D2 := '';
for I := 1 to NumX do begin
X1 := X1 + 'X';
D2 := D2 + '-';
end;
for I := 1 to TotalXD - NumX do begin
X2 := X2 + 'X';
D1 := D1 + '-';
end;
for Row := 1 to Rows do begin
if Row mod 2 = 1 then
for I := 1 to 4 do
Write (X1, D1)
else
for I := 1 to 4 do
Write (D2, X2);
Writeln;
end;
end.
{2.3}
program Two3T86;
{ -- This program will code or decode a message. }
var
Option, I: Integer;
St1, St2: String[27];
Message: String[80];
Ch: Char;
begin
St1 := 'ZXCVBNMASDFGHJKLQWERTYUIOP ';
St2 := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ ';
repeat
Writeln;
Writeln ('1) ENCODE');
Writeln ('2) DECODE');
Writeln ('3) END');
Write ('Choose: '); Readln (Option);
if Option < 3 then begin
Write ('Enter message: '); Readln (Message);
for I := 1 to Length(Message) do begin
Ch := Message[I];
if Ch <> ' ' then
if Option = 1 then { -- Code message }
Ch := St1[Ord(Ch) - 64]
else { -- Decode message }
Ch := St2[Pos(Ch, St1)];
Write (Ch);
end;
Writeln;
end;
until Option = 3;
end.
{2.4}
program Two4T86;
{ -- This program finds the unique mode of a set of 15 numbers. }
var
A, C: Array [1..15] of Integer;
I, J, K, Max: Integer;
Mode: Integer;
ModeExist: Boolean;
begin
for I := 1 to 15 do begin
Write ('Enter number ', I, ': '); Readln (A[I]);
end;
Max := 1;
for I := 1 to 14 do begin
C[I] := 1;
for J := I + 1 to 15 do
if A[I] = A[J] then begin
Inc(C[I]); { -- Has # of duplicates of elements }
if C[I] > Max then
Max := C[I];
end;
end;
{ -- Mode exists if only one element occurs Max # of times. }
ModeExist := False;
for I := 1 to 14 do
if (C[I] = Max) then
if not ModeExist then
begin
Mode := A[I]; ModeExist := True;
end
else begin
Writeln ('NO UNIQUE MODE'); Exit; end;
if ModeExist then
Writeln ('MODE IS ', Mode)
else
Writeln ('NO UNIQUE MODE');
end.
{2.5}
program Two5T86;
{ -- This program simulates transactions to a savings accounts. }
const
Rate: Real = 0.07;
var
Option: Integer;
Balance, Deposit, Withdrawal, Credit: Real;
begin
Write ('Enter original balance: '); Readln (Balance);
Writeln;
repeat
Writeln ('1. MAKE A DEPOSIT');
Writeln ('2. MAKE A WITHDRAWAL');
Writeln ('3. CREDIT INTEREST');
Writeln ('4. END');
Write ('Enter option: '); Readln (Option); Writeln;
case Option of
1: begin
Write ('Enter amount to deposit: '); Readln (Deposit);
Writeln ('BALANCE BEFORE TRANSACTION $', Balance: 7:2);
Balance := Balance + Deposit;
Writeln ('MAKE A DEPOSIT');
end;
2: begin
Write ('Enter amount to withdraw: ');
Readln (Withdrawal);
Writeln ('BALANCE BEFORE TRANSACTION $', Balance: 7:2);
Balance := Balance - Withdrawal;
Writeln ('MAKE A WITHDRAWAL');
end;
3: begin
Writeln ('BALANCE BEFORE TRANSACTION $', Balance: 7:2);
Credit := Balance * Rate/12;
Writeln ('CREDIT INTEREST OF $', Credit: 4:2);
Balance := Balance + Credit;
end;
end;
if Option < 4 then Write ('NEW ')
else Write ('FINAL ');
Writeln ('BALANCE $', Balance: 7:2);
Writeln;
until Option = 4;
end.
{2.6}
program Two6T86;
{ -- This program will sum two positive big numbers. }
var
St1, St2: String[38];
A, B, C: Array [1..39] of Integer;
I, L1, L2,
MaxL, Carry: Integer;
Ch: Char;
begin
Write ('Enter first number: '); Readln (St1);
Write ('Enter second number: '); Readln (St2);
for I := 1 to 39 do begin
A[I] := 0; B[I] := 0;
end;
L1 := Length(St1); L2 := Length(St2);
{ -- Put 1st number in A[1..L1], 2nd number in B[1..L2] }
for I := 1 to L1 do begin
Ch := St1[ L1-I+1 ];
A[I] := Ord(Ch) - Ord('0');
end;
for I := 1 to L2 do begin
Ch := St2[ L2-I+1 ];
B[I] := Ord(Ch) - Ord('0');
end;
if L1 > L2 then MaxL := L1
else MaxL := L2;
Carry := 0;
{ -- Calculate sum in C[1..MaxL] }
for I := 1 to MaxL do begin
C[I] := A[I] + B[I] + Carry;
if C[I] > 9 then begin
C[I] := C[I] - 10;
Carry := 1;
end
else Carry := 0;
end;
if Carry = 1 then begin
MaxL := MaxL + 1;
C[MaxL] := 1;
end;
Write ('SUM IS ');
for I := MaxL downto 1 do
Write (C[I]);
end.
{2.7}
program Two7T86;
{ -- This program will perform conversions. }
const
Dec: Array [1..6] of String[11] =
('INCHES', 'FEET', 'MILES', 'OUNCES', 'POUNDS', 'GALLONS');
Con: Array [1..6] of Real =
(2.54, 0.3048, 1.6093, 28.35, 0.4536, 3.7854);
Met: Array [1..6] of String[11] =
('CENTIMETERS', 'METERS', 'KILOMETERS', 'GRAMS',
'KILOGRAMS', 'LITERS');
var
Option, I: Integer;
X, Y: Real;
St: String[30];
begin
repeat
Writeln;
{ -- Display menu options }
for I := 1 to 6 do begin
Write (I: 2, ' ');
if I mod 2 = 1 then
begin
St := Met[(I+1) div 2] + ' TO ' + Dec[(I+1) div 2];
Write (St, ' ': 23 - Length(St));
Write (I+6: 2, ' ');
St := Met[(I+7) div 2] + ' TO ' + Dec[(I+7) div 2];
end
else
begin
St := Dec[I div 2] + ' TO ' + Met[I div 2];
Write (St, ' ': 23 - Length(St));
Write (I+6: 2, ' ');
St := Dec[(I+6) div 2] + ' TO ' + Met[(I+6) div 2];
end;
Writeln (St);
end;
Writeln ('13 END' :32);
Write ('Enter option: '); Readln (Option);
if Option < 13 then
if Option mod 2 = 1 then { -- Convert Metric to English }
begin
Write ('Enter number of ', Met[(Option + 1) div 2],': ');
Readln (X);
Y := X / Con[(Option + 1) div 2];
Write ('THIS IS EQUIVALENT TO ', Y:7:3, ' ');
Writeln (Dec[(Option+1) div 2]);
end
else { -- Convert English to Metric }
begin
Write ('Enter number of ', Dec[Option div 2], ': ');
Readln (X);
Y := X * Con[Option div 2];
Write ('THIS IS EQUIVALENT TO ', Y:7:3, ' ');
Writeln (Met[Option div 2]);
end;
until Option = 13;
end.
{2.8}
program Two8T86;
{ -- This program will generate a mortgate amortization. }
uses Crt;
var
Rate, Principal, Payment: Real;
Years, I, C, Month: Integer;
YI, TI, MI, MP, OldP: Real;
Ch: Char;
function Power({using} X: Real; {raised to the} Y: Integer):
{giving} Real;
{ -- This function simulates the ^ (power) symbol (X to the Y) }
var
I: Integer;
P: Real;
begin
P := X;
for I := 1 to Y-1 do
P := P * X;
Power := P;
end;
begin
Write ('Enter principal: '); Readln (Principal);
Write ('Enter % rate of interest: '); Readln (Rate);
Write ('Enter term in years: '); Readln (Years);
Write ('Enter # of month in year for first payment: ');
Readln (Month);
Rate := Rate / (12 * 100);
Payment := (Rate * Power((1+Rate),(Years*12)))/
(Power((1+Rate),(12*Years)) -1) * Principal;
C := Month - 1; OldP := Principal;
Rate := Rate * 12; YI := 0; TI := 0;
Writeln ('INTEREST PRINCIPAL');
for I := 1 to Years*12 do begin
MI := OldP * Rate/12;
MP := Payment - MI;
OldP := OldP - MP;
Writeln ('$', MI: 6:2, ' ':10, '$', OldP :8:2);
C := C + 1; YI := YI + MI;
if C mod 12 = 0 then begin
Writeln;
Writeln ('YEAR''S INTEREST', ' $', YI: 8:2);
TI := TI + YI; YI := 0;
Ch := ReadKey;
end;
end;
if Month <> 1 then begin
Writeln;
Writeln ('YEAR''S INTEREST', ' $', YI: 8:2);
TI := TI + YI;
Ch := ReadKey;
end;
Writeln ('TOTAL INTEREST $', TI: 8:2);
Writeln ('MONTHLY PAYMENT $', Payment: 8:2);
end.
{2.9}
program Two9T86;
{ -- This program calculates the value of sine(x) by a series. }
var
N, X, Sum, Factorial, Term: Real;
I, J, Power: Integer;
begin
Write ('Enter N degrees: '); Readln (N);
Sum := 0;
if N > 180 then
X := Pi * ((360-N)/180)
else
X := Pi * (N/180);
Power := -1;
for I := 1 to 6 do begin
Power := Power + 2;
Factorial := 1;
for J := 1 to Power do
Factorial := Factorial * J;
Term := 1;
for J := 1 to Power do
Term := Term * X;
Term := Term / Factorial;
if I mod 2 = 1 then
Sum := Sum + Term
else
Sum := Sum - Term;
end;
if N > 180 then begin
Sum := -1 * Sum; X := Pi * (N/180);
end;
Writeln ('PARTIAL SUM = ', Sum :9:7);
Writeln ('ACTUAL SINE = ', Sin(X) :8:7);
end.
{2.10}
program Two10T86;
{ -- This program will convert a Roman Numeral to Arabic form. }
const
RN: String[7] = 'MDCLXVI';
RV: Array [1..7] of Integer = (1000, 500, 100, 50, 10, 5, 1);
var
RomNum: String[12];
I, Ind1, Ind2: Integer;
L, Arabic: Integer;
Ch, NextCh: Char;
begin
Write ('Enter Roman Numeral: '); Readln (RomNum);
L := Length (RomNum); I := 1; Arabic := 0;
while (I < L) do begin
Ch := RomNum[I]; Ind1 := Pos(Ch, RN);
NextCh := RomNum[I+1]; Ind2 := Pos(NextCh, RN);
if Ind1 <= Ind2 then { -- value of first is greater or equal}
Arabic := Arabic + RV[Ind1]
else begin { -- value of first is less than second }
Arabic := Arabic + RV[Ind2] - RV[Ind1];
Inc(I);
end;
Inc(I);
end;
if I = L then begin { -- Last numeral was not done }
Ch := RomNum[I]; Ind1 := Pos(Ch, RN);
Arabic := Arabic + RV[Ind1];
end;
Writeln ('ARABIC = ', Arabic);
end.
{3.1}
program Thr1T86;
{ -- This program produces monthly calendars for the year 1986. }
uses Crt;
const
Mo: Array[1..12] of String[9] = ('JANUARY','FEBRUARY',
'MARCH','APRIL','MAY','JUNE','JULY','AUGUST','SEPTEMBER',
'OCTOBER','NOVEMBER','DECEMBER');
Days: Array[1..12] of Integer =
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
D: Array[1..7] of Char = ('S', 'M', 'T', 'W', 'T', 'F', 'S');
var
I, M, Col, Day: Integer;
Ch: Char;
begin
ClrScr;
Writeln (' ':14, '1986'); Writeln;
for M := 1 to 12 do begin
{ -- Display Month name and Day initials. }
if M > 1 then ClrScr;
Writeln (' ':12, Mo[M]); Writeln;
for I := 1 to 7 do
Write (D[I]: 4);
Writeln;
{ -- Display Day numbers in proper column. }
if M = 1 then Col := 4;
if Col > 1 then
Write (' ': (Col-1)*4);
for Day := 1 to Days[M] do begin
Write (Day: 4);
if Col < 7 then
Col := Col + 1
else begin
Col := 1; Writeln;
end;
end;
Ch := ReadKey;
end;
end.
{3.2}
program Thr2T86;
{ -- This program finds the root of a 5th degree polynomial }
{ -- of the form Ax^5 + Bx^4 + Cx^3 + Dx^2 + Ex + F = 0. }
var
A, B, C, D, E, F: Real;
X, X1, X2: Real;
function Y(X,A,B,C,D,E,F: Real):Real;
{ -- This function returns value of Y given coefficients and X. }
begin
Y := A*X*X*X*X*X + B*X*X*X*X + C*X*X*X + D*X*X + E*X + F;
end;
begin
Write ('Enter coefficients A,B,C,D,E,F: ');
Readln (A,B,C,D,E,F);
{ -- This algorithm finds 1 and only 1 root (closest to x=0) }
X1 := -1.0; X2 := 1.0;
{ -- Find sign change between X1 and X2. }
while Y(X1,A,B,C,D,E,F) * Y(X2,A,B,C,D,E,F) > 0 do begin
X1 := X1 - 1; X2 := X2 + 1;
end;
{ -- Use binary search to find root. }
while X2 - X1 > 0.000005 do begin
X := (X1 + X2) / 2;
if Y(X,A,B,C,D,E,F) * Y(X1,A,B,C,D,E,F) > 0 then X1 := X
else X2 := X;
end;
Writeln ('ROOT = ', X: 7:5);
end.
{3.3}
program Thr3T86;
{ -- This program changes a number from one base to another. }
const
D: String[36] = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
var
A, B, I, J, Ex, X: Integer;
N, Pow: Real;
NumSt: String[10];
begin
Write ('Enter base A: '); Readln (A);
Write ('Enter base B: '); Readln (B);
Write ('Enter original number: '); Readln (NumSt);
Writeln; Write (NumSt, ' BASE ', A, ' EQUALS ');
{ -- Convert Num to Base 10 from base A. }
N := 0;
for I := 1 to Length(NumSt) do begin
Pow := 1;
for J := 1 to Length(NumSt)-I do Pow := Pow * A;
N := N + (Pos(Copy(NumSt,I,1),D) - 1) * Pow;
end;
Ex := 0; Pow := 1;
while Pow <= N do begin
Inc(Ex); Pow := Pow * B;
end;
Dec(Ex);
{ -- Convert Num to Base B from Base 10. }
for I := Ex downto 0 do begin
Pow := Pow / B;
X := Trunc(N / Pow + 0.01);
Write (D[X+1]);
N := N - X*Pow;
end;
Write (' BASE ', B);
end.
{3.4}
program Thr4T86;
{ -- This program will update customers account by SSN's. }
var
SS: Array[1..6] of String[9];
N: Array[1..6] of String[12];
A: Array[1..6] of String[41];
B: Array[1..6] of Real;
SSN: String[10];
Temp: String[41];
I,J,L: Integer;
Ch: Char;
Trans: Real;
P1,P2: Integer;
begin
SS[1] := '234567890'; N[1] := 'JOHN SMITH ';
SS[2] := '564783219'; N[2] := 'GAIL HUSTON ';
SS[3] := '873421765'; N[3] := 'TIM JONES ';
SS[4] := '543876543'; N[4] := 'JILL RUPERTS';
SS[5] := '345212342'; N[5] := 'AL BROWN ';
SS[6] := '565656565'; N[6] := 'KERMIT TEU ';
A[1] := '1234 ANYWHERE LANE, EXIST, KANSAS 66754 ';
A[2] := '543 SOUTH THIRD, BIG TOWN, TEXAS 88642 ';
A[3] := '2387 PALM PLACE, NOME, ALASKA 77643 ';
A[4] := '4536 123RD STREET, TINY TOWN, MAINE 76765';
A[5] := 'PO BOX 234, TINSEL TOWN, CALIFORNIA 77654';
A[6] := '1234 LOST LANE, WIMPLE, WISCONSIN 66543 ';
B[1] := 345.78;
B[2] := 2365.89;
B[3] := 6754.76;
B[4] := 45.18;
B[5] := 3456.09;
B[6] := 78.36;
Write ('Enter SSN: '); Readln (SSN);
while SSN <> '000000000' do begin
I := 1;
while (SS[I] <> SSN) and (I < 6) do I := I + 1;
Write ('Enter C for Charge or P for Payment: '); Readln(Ch);
Write ('Enter amount of transaction: '); Readln(Trans);
if Ch = 'C' then
B[I] := B[I] - Trans
else
B[I] := B[I] + Trans;
Writeln;
Writeln ('NEW BALANCE IS $', B[I]: 5:2);
Writeln;
Write ('Enter SSN: '); Readln (SSN);
end;
{ -- Sort customers in decreasing order according to balance. }
for I := 1 to 5 do
for J := I + 1 to 6 do
if B[I] < B[J] then begin
Temp := SS[I]; SS[I] := SS[J]; SS[J] := Temp;
Temp := N[I]; N[I] := N[J]; N[J] := Temp;
Temp := A[I]; A[I] := A[J]; A[J] := Temp;
Trans := B[I]; B[I] := B[J]; B[J] := Trans;
end;
{ -- Display report }
Writeln;
Write ('SSN', ' ':8, 'NAME', ' ': 10, 'ADDRESS', ' ':2);
Writeln ('BALANCE': 18); Writeln;
for I := 1 to 6 do begin
Temp := SS[I] + ' ' + N[I] + ' ';
Write (Temp);
L := Length(Temp) - 1;
P1 := Pos(',', A[I]); Delete(A[I], P1, 1);
P2 := Pos(',', A[I]);
Write (Copy(A[I], 1, P1 - 1));
Writeln ('$': 22 - P1, B[I]:7:2);
Writeln (' ': L, Copy(A[I], P1, P2 - P1));
Writeln (' ': L, Copy(A[I], P2+1, Length(A[I]) - P2 - 1));
end;
Writeln;
end.
{3.5}
program Thr5T86;
{ -- This program will print the product of 2 large decimals. }
var
AStr, BStr: String[31];
LenA, LenB, ADec, BDec, RDigits: Integer;
A, B, Prod: Array[1..61] of Integer;
I, J, S, Carry, Base: Integer;
Sign: -1..1;
begin
Write ('Enter first number: '); Readln (AStr);
Write ('Enter second number: '); Readln (BStr);
{ -- Determine # of Digits to the right of decimal in product }
ADec := Pos ('.', AStr); BDec := Pos ('.', BStr);
Delete (AStr, ADec, 1); Delete (BStr, BDec, 1);
LenA := Length(AStr); LenB := Length(BStr);
RDigits := LenA - ADec + LenB - BDec + 2;
{ -- Store String digits into numerical arrays. }
for I := LenA downto 1 do
A[LenA-I+1] := Ord(AStr[I]) - 48;
for I := LenB downto 1 do
B[LenB-I+1] := Ord(BStr[I]) - 48;
for I := 1 to 61 do Prod[I] := 0;
{ -- Multiply 2 numbers as a person would with carries. }
for I := 1 to LenB do begin
Carry := 0;
for J := 1 to LenA do begin
S := I + J - 1;
Prod[S] := Prod[S] + B[I]*A[J] + Carry;
Carry := Prod[S] div 10;
Prod[S] := Prod[S] - Carry*10;
end;
If Carry > 0 then Prod[S+1] := Carry;
end;
{ -- Display digits of product before decimal }
Write ('PRODUCT = ');
if Carry > 0 then Inc(S);
if S > RDigits then
for I := S downto RDigits+1 do
Write (Prod[I])
else
Write ('0');
Write ('.');
{ -- Display digits after decimal. }
for I := RDigits downto 1 do
Write (Prod[I]);
end.
{3.6}
program Thr6T86;
{ -- This program will determine if a # can become palindrome. }
var
B, Rev: Array[1..50] of Integer;
I, L, Try, Carry: Integer;
Pal: Boolean;
NumSt: String[10];
begin
Write ('Enter number: '); Readln (NumSt);
L := Length(NumSt);
for I := 1 to L do
B[L-I+1] := Ord(NumSt[I]) - 48;
Try := 0;
repeat
{ -- Test for Palindrome }
Pal := True;
for I := 1 to (L div 2) do
if B[I] <> B[L-I+1] then Pal := False;
{ -- Add reverse of number to itself. }
if not Pal then begin
for I := 1 to L do Rev[I] := B[L-I+1];
Carry := 0;
for I := 1 to L do begin
B[I] := B[I] + Rev[I] + Carry;
Carry := B[I] div 10;
B[I] := B[I] - Carry*10;
end;
if Carry = 1 then begin
Inc(L); B[L] := 1;
end;
Inc(Try);
end;
until Pal or (Try > 23);
{ -- Display # if Palindrome else say it is not. }
if Pal then begin
for I := L downto 1 do Write (B[I]);
Writeln (' IS A PALINDROME');
end
else
Writeln ('CANNOT GENERATE A PALINDROME');
end.
{3.7}
program Thr7T86;
{ -- This program will solve an N x N system of equations. }
var
C: Array[1..5,1..6] of Real;
N, Row, Col, R: Integer;
Den, X: Real;
begin
{ -- Enter values in C array }
Write ('Enter N: '); Readln (N);
for Row := 1 to N do begin
Writeln ('Enter coefficients for Row ', Row);
for Col := 1 to N do begin
Write ('Co', Col, ': ');
Readln (C[Row,Col]);
end;
Write ('Enter constant: '); Readln (C[Row, N+1]);
end;
{ -- Make main diagonals all 1s with 0s to the left. }
for Row := 1 to N do begin
Den := C[Row, Row];
for Col := Row to N+1 do
C[Row, Col] := C[Row, Col] / Den;
for R := Row+1 to N do begin
X := C[R, Row];
for Col := Row to N+1 do
C[R,Col] := C[R,Col] - X * C[Row,Col];
end;
end;
{ -- Make 0s on right of 1s on main diagonal, (not constants).}
for Row := N downto 1 do
for R := Row-1 downto 1 do begin
X := C[R, Row];
for Col := Row to N+1 do
C[R,Col] := C[R,Col] - X * C[Row,Col];
end;
{ -- Display solution }
Write ('(', C[1,N+1]: 1:0);
for Row := 2 to N do
Write (', ', C[Row,N+1]: 1:0);
Writeln (')');
end.
{3.8}
program Thr8T86;
{ -- This program prints Kth, 2*Kth, and 3*Kth permutations. }
var
F, I, J, K,
L, KK, T, X, S: Integer;
AStr: String[7];
A: Array[1..7] of Char;
B: Array[1..7] of 0..1;
Temp: Char;
Fact: Array[1..7] of Integer;
Quit: Boolean;
begin
Write ('Enter word: '); Readln (AStr);
Write ('Enter K: '); Readln (K);
L := Length (AStr);
{ -- Store and alphabetize letters. }
for I := 1 to L do A[I] := AStr[I];
for I := 1 to L-1 do
for J := I+1 to L do
if A[I] > A[J] then begin
Temp := A[I]; A[I] := A[J]; A[J] := Temp;
end;
{ -- Compute Factorials F[3] = 2!, F[4] = 3!... }
for I := 1 to L do begin
F := 1;
for J := 1 to I-1 do F := F * J;
Fact[I] := F;
end;
{ -- Generate permutations in order. }
for T := 1 to 3 do begin
KK := K*T-1;
for I := 1 to 7 do B[I] := 0;
for I := L downto 1 do begin
X := KK div Fact[I]; S := 0;
J := 1; Quit := False;
repeat
if B[J] = 0 then begin
Inc(S);
if S > X then begin
B[J] := 1;
Write (A[J]);
Quit := True;
end;
end;
Inc(J);
until (J > L) or Quit;
KK := KK - Fact[I]*X;
end; { -- for I }
Write(' ');
end; { -- for T }
end.
{3.9}
program Thr9T86;
{ -- This program will solve cryptarithm puzzle ABB - CB = DEF. }
{ -- F = 0 since B-B=0. A=D+1 or A=D since CB is 2 digits,
but A<>D. D>B, otherwise D=A. Since B E=10+B-C. }
var
A, B, C, D, E, F, Tot: Integer;
begin
Tot := 0;
for B := 1 to 8 do
for C := B+1 to 9 do
for D := 1 to 8 do begin
F := 0;
A := D + 1;
E := 10 + B - C;
if not ((A=B) or (A=C) or (A=D) or (A=E) or (A=F) or
(B=C) or (B=D) or (B=E) or (B=F) or (C=D) or
(C=E) or (C=F) or (D=E) or (D=F)) then begin
Tot := Tot + 1;
Writeln (A,B,B,' - ',C,B,' = ',D,E,F,' NUMBER ',Tot);
end;
end; { -- for D }
Writeln;
Writeln ('TOTAL NUMBER OF SOLUTIONS = ',Tot);
end.
{3.10}
program Thr10T86;
{ -- This program will find all 2-digit integers equal to the sum
of integers in which each digit 0-9 is used exactly once. }
{ -- Array D is array of digits to appear in Ten's position.
-- C is count of how many digits are in array D.
-- S is sum of digits not in array D
-- F is flag array showing which digits are not in array D. }
var
I, J, K, C, DD, N, S, D1, D2, D3, P: Integer;
F, D: Array[0..9] of Integer;
procedure CheckCondition;
{ -- This procedure will Check the condition. }
begin
S := 0; F[0] := 1;
for I := 1 to 9 do F[I] := 0;
for I := 1 to 9 do
if not ((C=1) and (I=D1) or (C=2) and ((I=D1) or (I=D2)) or
(C=3) and ((I=D1) or (I=D2) or (I=D3))) then begin
S := S + I; F[I] := 1;
end;
if C = 1 then DD := D1;
if C = 2 then DD := D1 + D2;
if C = 3 then DD := D1 + D2 + D3;
if DD * 10 + S = N then begin
Write (N, ' = ');
K := 0;
for J := 1 to C do begin
while F[K] = 0 do K := K + 1;
Write (D[J], K, ' + ');
Inc(K);
end;
for I := K to 9 do begin
if F[I] = 1 then begin
Write (I);
if I < 9 then Write (' + ');
end;
end;
Writeln;
P := 1;
end;
end;
begin
for N := 45 to 99 do begin
for D1 := 1 to 2 do begin
D[1] := D1;
for D2 := D1+1 to 3 do begin
D[2] := D2;
for D3 := D2+1 to 4 do begin
D[3] := D3; C := 3; CheckCondition;
end;
end;
end; { -- for D1}
D3 := 0;
if P <> 1 then begin
for D1 := 1 to 2 do begin
D[1] := D1;
for D2 := D1+1 to 3 do begin
D[2] := D2; C := 2; CheckCondition;
end;
end;
D2 := 0;
if P <> 1 then begin
for D1 := 1 to 6 do begin
D[1] := D1; C := 1; CheckCondition;
end;
if N = 45 then begin
Write (N, ' = ');
K := 0;
for I := K to 9 do begin
if F[I] = 1 then begin
Write (I);
if I < 9 then Write (' + ');
end;
end;
Writeln;
P := 1;
end;
end; { -- if P<>1 }
end; { -- if P<>1 }
P := 0;
end; { -- for N }
end.