```{ -- 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;
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: ');
Write ('Enter end of year deposit: ');
Write ('Enter annual rate of interest: ');
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;
Word:          String;
End1, End2:    String;
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;
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;
Word:            Array [1..20] of String;
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;
TotalXD, Row:   Integer;
NumX, Rows, I:  Integer;

begin
Write ('Enter total number of X''s and -''s: ');
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;
Message:   String;
Ch:        Char;

begin
St1 := 'ZXCVBNMASDFGHJKLQWERTYUIOP ';
St2 := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ ';
repeat
Writeln;
Writeln ('1) ENCODE');
Writeln ('2) DECODE');
Writeln ('3) END');
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: ');
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;
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 =
('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 =
('CENTIMETERS', 'METERS', 'KILOMETERS', 'GRAMS',
'KILOGRAMS', 'LITERS');
var
Option, I: Integer;
X, Y:      Real;
St:        String;

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],': ');
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], ': ');
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: ');

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;
end;
end;

if Month <> 1 then begin
Writeln;
Writeln ('YEAR''S INTEREST', '  \$', YI: 8:2);
TI := TI + YI;
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 = 'MDCLXVI';
RV: Array [1..7] of Integer = (1000, 500, 100, 50, 10, 5, 1);
var
RomNum:        String;
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 = ('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;
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: ');
{ -- 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 = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
var
A, B, I, J, Ex, X: Integer;
N, Pow:            Real;
NumSt:             String;

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;
N:     Array[1..6] of String;
A:     Array[1..6] of String;
B:     Array[1..6] of Real;
SSN:   String;
Temp:  String;
I,J,L: Integer;
Ch:    Char;
Trans: Real;
P1,P2: Integer;

begin
SS := '234567890'; N := 'JOHN SMITH  ';
SS := '564783219'; N := 'GAIL HUSTON ';
SS := '873421765'; N := 'TIM JONES   ';
SS := '543876543'; N := 'JILL RUPERTS';
SS := '345212342'; N := 'AL BROWN    ';
SS := '565656565'; N := 'KERMIT TEU  ';
A  := '1234 ANYWHERE LANE, EXIST, KANSAS 66754  ';
A  := '543 SOUTH THIRD, BIG TOWN, TEXAS 88642   ';
A  := '2387 PALM PLACE, NOME, ALASKA 77643      ';
A  := '4536 123RD STREET, TINY TOWN, MAINE 76765';
A  := 'PO BOX 234, TINSEL TOWN, CALIFORNIA 77654';
A  := '1234 LOST LANE, WIMPLE, WISCONSIN 66543  ';
B  :=  345.78;
B  := 2365.89;
B  := 6754.76;
B  :=   45.18;
B  := 3456.09;
B  :=   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;
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;

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, ': ');
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;
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 = 2!, F = 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 := 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 := D1;
for D2 := D1+1 to 3 do begin
D := D2;
for D3 := D2+1 to 4 do begin
D := D3;  C := 3;  CheckCondition;
end;
end;
end;  { -- for D1}
D3 := 0;
if P <> 1 then begin
for D1 := 1 to 2 do begin
D := D1;
for D2 := D1+1 to 3 do begin
D := D2;  C := 2;  CheckCondition;
end;
end;
D2 := 0;
if P <> 1 then begin
for D1 := 1 to 6 do begin
D := 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.

```