```{ -- FLORIDA HIGH SCHOOLS COMPUTING COMPETITION '87 }
{ -- PASCAL PROGRAM SOLUTIONS }

{1.1}
program One1T87;
{ -- This program will print out the sign of a given number. }
var
Num: Real;

begin
Write ('Enter number: ');
if Num > 0 then
Writeln ('POSITIVE')
else if Num < 0 then
Writeln ('NEGATIVE')
else
Writeln ('ZERO');
end.

{1.2}
program One2T87;
{ -- This program will sum the numbers n, n+1, ... n+20. }
var
N, I, Sum: Integer;

begin
Write ('Enter n: ');  Readln (N);
Sum := 0;
for I := 0 to 20 do
Sum := Sum + N + I;
Writeln ('SUM = ', Sum);
end.

{1.3}
program One3T87;
{ -- This program will print PROBLEM THREE diagonally. }
uses Crt;
const
St = 'PROBLEM THREE';
var
Row, Col, I, L: Byte;

begin
ClrScr;
L := Length (St);
Row := (24 - L) div 2;
Col := (80 - L) div 2;
for I := 1 to L do begin
GotoXY (Col+I, Row+I);
Write (Copy (St,I,1));
end;
end.

{1.4}
program One4T87;
{ -- This program displays the numbers on the sides of a die. }
var
Top, Front, Right: Byte;

begin
Write ('Enter number on top: ');    Readln (Top);
Write ('Enter number on front: ');  Readln (Front);
Write ('Enter number on right: ');  Readln (Right);

Writeln ('TOP= ',    Top);
Writeln ('FRONT= ',  Front);
Writeln ('RIGHT= ',  Right);
Writeln ('BOTTOM= ', 7 - Top);
Writeln ('BACK= ',   7 - Front);
Writeln ('LEFT= ',   7 - Right);
end.

{1.5}
program One5T87;
{ -- This program will fill the screen with random characters. }
uses Crt;
var
Row, Col: Byte;

begin
Randomize;
for Row := 1 to 24 do
for Col := 1 to 80 do
Write( Chr (Random (96) + 33) );
repeat until KeyPressed;
ClrScr;
end.

{1.6}
program One6T87;
{ -- This program will display a rectangular array of periods. }
uses Crt;
var
Row1, Col1, Row2, Col2, I, J: Byte;

begin
Write ('Enter coordinates: ');
ClrScr;
for I := Row1 to Row2 do
for J := Col1 to Col2 do begin
GotoXY (J, I);  Write ('.');
end;
end.

{1.7}
program One7T87;
{ -- This program will generate 10 random numbers given a seed. }
var
Seed, I: Integer;

begin
Write ('Enter seed: ');  Readln (Seed);
for I := 1 to 10 do begin
Seed := (Seed * 421 + 1) mod 100;
Writeln (Seed);
end;
end.

{1.8}
program One8T87;
{ -- This program will determine the mass of a fish tank. }
var
K, L, W, H, Mass, InchCubed: Real;

begin
Write ('Enter K, L, W, H: ');  Readln (K, L, W, H);
InchCubed := 2.54 * 2.54 * 2.54;
Mass := L * 12 * W * 12 * H * 12 * InchCubed;
Mass := Mass / 1000 + K;
Writeln (Mass: 8:2, ' KILOGRAMS');
end.

{1.9}
program One9T87;
{ -- This program will display 21 rows of letters. }
uses Crt;
var
Row, I: Integer;
Ch:     Char;

begin
ClrScr;
for Row := 1 to 21 do begin
Ch := Chr(64 + Row);
if Row mod 2 = 1 then
for I := 1 to 31 do
Write (Ch)
else begin
Write (Ch);
for I := 1 to 10 do
Write ('  ', Ch);
end;
Writeln;
end;
end.

{1.10}
program One10T87;
{ -- This program will display the time needed to read a book. }
const
Title : Array [1..4] of String =
('THE HISTORY OF THE COMPUTER', 'THE RED DOG RUNS',
'EATING APPLE PIE', 'THE ART OF WINNING');
Pages : Array [1..4] of Integer = (400, 200, 150, 250);

var
BookTitle:   String;
MP, Minutes: Integer;
BookFound:   Boolean;
I, Hours:    Integer;

begin
Write ('Enter book title: ');           Readln (BookTitle);
Write ('Enter rate (minutes/page): ');  Readln (MP);

I := 0;  BookFound := False;
repeat
Inc(I);
BookFound := BookTitle = Title[I];
until (I > 4) or BookFound;

Minutes := MP * Pages[I];
Hours := Trunc(Minutes) div 60;
Minutes := Minutes - Hours * 60;
Write (Hours, ' HOURS  ', Trunc(Minutes), ' MINUTES');
end.

{2.1}
program Two1T87;
{ -- This program will rotate a string N times to the left. }
var
St:   String;
L, N: Byte;

begin
Write ('Enter string: ');  Readln (St);
Write ('Enter N: ');       Readln (N);

L := Length(St);
N := N mod L;
Write   (Copy (St, N+1, L-N));
Writeln (Copy (St, 1, N));
end.

{2.2}
program Two2T87;
{ -- This program will determine the number of diskettes bought. }
var
Vers, Maxs, Wabs: Integer;

begin
for Vers := 1 to 98 do
for Maxs := 1 to 99 - Vers do begin
Wabs := 100 - Maxs - Vers;
if (Wabs > 0) and
(Vers * 225 + Maxs * 297 + Wabs * 120 = 23607) then
begin
Writeln (Vers,' VERS  ', Maxs,' MAXS  ', WABS,' Wabs');
Exit;
end;
end;
end.

{2.3}
program Two3T87;
{ -- This program will display a subset of random numbers. }
uses Crt;
var
SetOfNum: Array [1..16] of Integer;
Nums:     Array [1..5]  of Integer;
NewNum:   Boolean;
Ch:       Char;
Num, I, NumDisplayed, LastIndex:  Integer;

begin
I := 0;
repeat
Inc(I);
Write ('Enter list item: ');  Readln (SetOfNum[I]);
until SetofNum[I] < 0;
LastIndex := I - 1;

Randomize;
repeat
NumDisplayed := 0;
repeat
repeat  { -- Get unique random number }
Num := SetOfNum[ Random(LastIndex) + 1 ];
NewNum := True;
for I := 1 to NumDisplayed do
if Num = Nums[I] then
NewNum := False;
until NewNum = True;

Writeln (Num);
Inc(NumDisplayed);
Nums[NumDisplayed] := Num;
until NumDisplayed = 5;

Writeln ('PRESS ANY KEY');
repeat until KeyPressed;
until Ch = Chr(27);
end.

{2.4}
program Two4T87;
{ -- This program will display all partitioned sum of a number. }
var
Num, I, J: Byte;

begin
Write ('Enter a number less than 20: ');  Readln (Num);
for I := Num downto 1 do
if Num mod I = 0 then begin
Write (' ': 30 - (Num div I));
Write (I);
for J := 2 to Num div I do
Write ('+', I);
Writeln;
end;
end.

{2.5}
program Two5T87;
{ -- This program will calculate the fractional value. }

var
St:          String;
A:           Array [1..3] of Integer;
Num, Den, I: Integer;

begin
Write ('Enter word: ');  Readln (St);
for I := 1 to 3 do
A[I] := Ord(St[I]) - 64;
Num := A * A + A * A + A * A;
Den := A * A * A;
for I := Den downto 1 do
if (Num mod I = 0) and (Den mod I = 0) then begin
Writeln (Num div I, '/', Den div I);  Exit;
end;
end.

{2.6}
program Two6T87;
{ -- This program will find a subset of integers. }
var
Item:             Array [1..8] of Integer;
N, S, I, J, Sum, Temp, LastIndex: Integer;

begin
I := 0;
repeat
Inc(I);
Write ('Enter set item: ');  Readln (Item[I]);
until Item[I] < 0;
LastIndex := I - 1;
Write ('Enter N: ');  Readln (N);
Write ('Enter S: ');  Readln (S);

for I := 1 to LastIndex - 1 do
for J := I + 1 to LastIndex do
if Item[I] > Item[J] then begin
Temp := Item[I];  Item[I] := Item[J];  Item[J] := Temp;
end;

Sum := 0;
for I := 1 to N do
Sum := Sum + Item[I];

If Sum <= S then
begin
Writeln ('YES');
for I := 1 to N do
Write (Item[I], '  ')
end
else
Writeln ('NO');
end.

{2.7}
program Two7T87;
{ -- This program will determine if patterns are legal/illegal. }
var
St:       String;
I, BA, A: Byte;
Legal:    Boolean;

begin
Write ('Enter pattern: ');  Readln (St);
Legal := True;
I := 1;

if Copy(St, I, 1) <> 'A' then  { -- does not start with A }
Legal := False
else begin  { -- starts with A }
Inc(I);
while Copy (St, I, 2) = 'BA' do  { -- skip valid BA's }
I := I + 2;

A := I;  { -- A = position before finding trailing A's }
while (I <= Length (St)) and Legal do begin
if Copy(St, I, 1) <> 'A' then  { -- invalid trailing letter}
Legal := False;
Inc(I);
end;
if A = I then { -- no trailing A's }
Legal := False;
end;

if not Legal then Write ('IL');
Writeln ('LEGAL PATTERN');
end.

{2.8}
program Two8T87;
{ -- This program will find integers having F factors. }
var
I, J, M, N, F, NumF: Integer;

begin
Write ('Enter M, N, F: ');  Readln (M, N, F);
for I := M to N do begin
NumF := 0;
for J := 1 to Trunc(Sqrt(I)) do
if I mod J = 0 then
NumF := NumF + 2;
if Sqrt(I) = Trunc(Sqrt(I)) then
Dec(NumF);
if NumF = F then
Writeln (I);
end;
end.

{2.9}
program Two9T87;
{ -- This program will alphabetize 5 words according to rules. }
var
Word:        Array [1..5]  of String;
Word2:       Array [1..5]  of String;
St:          Array [1..12] of String;
Temp:        String;
I, J, K, L:  Byte;

begin
for I := 1 to 5 do begin
Write ('Enter word ', I, ': ');  Readln (Word[I]);
L := Length( Word[I] );
for J := 1 to L do
St[J] := Copy(Word[I], J, 1);
{ -- Alphabetize letters within word and make WORD2. }
for J := 1 to L - 1 do
for K := J + 1 to L do
if St[J] > St[K] then begin
Temp := St[J];  St[J] := St[K];  St[K] := Temp;
end;
Word2[I] := '';
for J := 1 to L do
Word2[I] := Word2[I] + St[J];
end;

{ -- Alphabetize Words according to Word2. }
for J := 1 to 4 do
for K := J + 1 to 5 do
if Word2[J] > Word2[K] then begin
Temp := Word2[J];  Word2[J] := Word2[K];  Word2[K] := Temp;
Temp := Word[J];   Word[J]  := Word[K];   Word[K]  := Temp;
end;

for I := 1 to 5 do
Writeln (Word[I]);
end.

{2.10}
program Two10T87;
{ -- This program will produce a super-duper input routine. }
uses Crt;
var
Row, Col, Max, Tipe, InitCol: Byte;
Ch:       Char;
ValidCh:  Boolean;
Entry:    String;

begin
Write ('Enter ROW, COL: ');  Readln (Row, Col);
Write ('Enter MAX: ');       Readln (Max);
Write ('Enter TYPE: ');      Readln (Tipe);

ClrScr;  Entry := '';  InitCol := Col;
repeat
GotoXY (Col, Row);
repeat until KeyPressed;
if Ch = Chr(8) then begin  { -- Backspace pressed }
if Length(Entry) > 0 then begin
Entry := Copy (Entry, 1, Length(Entry)-1);
Dec(Col);
GotoXY (Col, Row);  Write (' ');
end
end
else begin
ValidCh := Length(Entry) < Max;
If ValidCh then
Case Tipe of
1:  if not (Ch in ['A'..'Z', ' ']) then
ValidCh := False;
2:  if not (Ch in ['0'..'9', '.']) then
ValidCh := False;
3:  begin
if Col-InitCol in [2, 5] then
if Ch <> '-' then ValidCh := False
else
else
if not (Ch in ['0'..'9']) then
ValidCh := False;
end;
end;

if ValidCh then begin
Write (Ch);
Entry := Entry + Ch;
Inc(Col);
end;
end;
until Ch = Chr(13);
GotoXY (InitCol, Row+2);  Writeln (Entry);
end.

{3.1}
program Thr1T87;
{ -- This program will determine if 2 words are closely spelled. }
type
String10 = String;
var
Word1, Word2:    String10;
Close:           Boolean;
Len1, Len2, Min: Byte;
PosDif:          Byte;

function PositionDiffer ({using} Word1, Word2: String10;
Min: Byte): {giving} Byte;
{ -- This function will find the first position that differs. }
var
I : Byte;

begin
for I := 1 to Min do
if Copy(Word1, I, 1) <> Copy(Word2, I, 1) then begin
PositionDiffer := I;  Exit;
end;
PositionDiffer := Min + 1;
end;  { -- function }

begin
Write ('Enter word 1: ');  Readln (Word1);
Write ('Enter word 2: ');  Readln (Word2);
Len1 := Length(Word1);
Len2 := Length(Word2);

Close := False;
if Word1 = Word2 then  { -- Words are the same }
Close := True
else if Abs(Len1 - Len2) < 2 then begin  { -- Could be close }
{ -- Find first character that differs. }
if Len1 < Len2 then
Min := Len1
else
Min := Len2;
PosDif := PositionDiffer (Word1, Word2, Min);
If PosDif > Min then  { -- Close (Same, or differ by add/del)}
Close := True
else
if Len1 = Len2 then  { -- Check if 1 letter changed/trans }
begin
if (PosDif < Len1) and
(Copy(Word1, PosDif+1, 1) = Copy(Word2, PosDif, 1)) and
(Copy(Word2, PosDif+1, 1) = Copy(Word1, PosDif, 1)) then
Inc(PosDif);  { -- possible skip over }
if Copy(Word1, PosDif+1, Len1 - PosDif + 1) =
Copy(Word2, PosDif+1, Len2 - PosDif + 1) then
Close := True;
end
else  { -- Lengths differ by 1, Check for insertion/delete }
if Len2 < Len1 then begin
if Copy (Word2, PosDif,   Len2 - PosDif + 1) =
Copy (Word1, PosDif+1, Len1 - PosDif) then
Close := True
end
else
if Copy (Word1, PosDif,   Len1 - PosDif + 1) =
Copy (Word2, PosDif+1, Len2 - PosDif) then
Close := True;
end;

if Close then
WriteLn ('CLOSE')
else
WriteLn ('NOT CLOSE');
end.

{3.2}
program Thr2T87;
{ -- This program will evaluate an NxN determinant for N=2,3,4. }
var
I, J, K:     Byte;
A, B:        Array [1..4, 1..6] of Integer;
Sum, Tot, N: Integer;
Power:       Integer;

procedure EvaluateDetWithout ({using} K: Integer);
{ -- This procedure evaluates a 3 x 3 determinant w/o col K }
var
I, J, S: Byte;

begin
for I := 1 to 3 do begin
S := 0;
for J := 1 to 4 do
if J <> K then begin  { -- Create an 3 row by 4 col array }
Inc(S);
B[I,S]   := A[I,J];
B[I,S+3] := A[I,J];
end;
end;
Sum := 0;
for I := 1 to 3 do
Sum := Sum + B[1,I]   * B[2,I+1] * B[3,I+2]
- B[1,I+2] * B[2,I+1] * B[3,I];
end;

begin
Write ('Enter dimension N: ');  Readln (N);
for I := 1 to N do
for J := 1 to N do begin
Write ('Enter row ', I, ', col ', J, ': ');
end;

if N = 2 then begin  { 2 x 2 determinant }
Sum := A[1,1] * A[2,2] - A[1,2] * A[2,1];
Writeln (Sum);
end
else if N = 3 then begin  { 3 x 3 determinant }
EvaluateDetWithout (4);
Writeln (Sum);
end
else begin
Tot := 0;
for K := 1 to 4 do begin
EvaluateDetWithout (K);
Power := 1;
for I := 1 to K do
Power := Power * (-1);
Tot := Tot + Sum * A[4,K] * Power;
end;
WriteLn (Tot);
end;
end.

{3.3}
program Thr3T87;
{ -- This program will display the number of word occurrences. }
type
String12 = String;
var
Lines:       String;
Word:        Array [1..20] of String12;
WordTot:     Array [1..20] of Byte;
NextWord:    String12;
NumOfWords:  Byte;
NewWord:     Boolean;
Start, I:    Byte;
WordInd:     Byte;

function GetWord ({using} var Start: Byte): {giving} String12;
{ -- This procedure get the next word in the passage at Start. }
var
I:         Byte;
NextWord:  String12;
Ch:        Char;
EndOfWord: Boolean;

begin
I := Start;  EndOfWord := False;  NextWord := '';
repeat
Ch := Lines[I];
if Ch in ['A'..'Z', ''''] then
NextWord := NextWord + Ch
else
EndOfWord := True;
Inc(I);
until (I > Length(Lines)) or EndOfWord;
Start := I;  GetWord := NextWord;
end;

begin
Write ('Enter text: ');  Readln (Lines);
Start := 1;  NumOfWords := 0;
repeat
NextWord := GetWord(Start);
if NextWord > '' then
NewWord := True
else
NewWord := False;
WordInd := 0;
while (WordInd < NumOfWords) and NewWord do begin
Inc(WordInd);
if NextWord = Word[WordInd] then NewWord := False;
end;
if NewWord then begin  { -- Add new word to list of words }
Inc(NumOfWords);
Word[NumOfWords] := NextWord;
WordTot[NumOfWords] := 1;
end
else  { -- Increment # of times this word appears }
Inc( WordTot[WordInd] );
until Start > Length(Lines);

for I := 1 to NumOfWords do
Writeln (WordTot[I], ' ', Word[I]);
end.

{3.4}
program Thr4T87;
{ -- This program will encrypt a string such that when this
-- code is entered, the string will be reproduced. }
var
St:         String;
I, NumOfCh: Byte;
Result:     Integer;
Ch, NextCh: Char;
AscSt:      String;
Asc:        Array [1..50] of Byte;
CodeNum:    Byte;

begin
Write ('Enter text: ');  Readln (St);
NumOfCh := 0;  I := 1;
while (I <= Length(St)) do begin
Ch := St[I];  Inc(NumOfCh);
if Ch = '\' then
begin  { -- Either another / or ### follows }
Inc(I);
NextCh := St[I];
if NextCh <> '\' then
begin { -- Next 3 characters are the ASC code }
AscSt := Copy (St, I, 3);
Val (AscSt, Asc[NumOfCh], Result);
I := I + 2;
end
else  { / follows }
Asc[NumOfCh] := Ord(NextCh);
end
else  { -- A regular character }
Asc[NumOfCh] := Ord(Ch);
Inc(I);
end;  { -- while I }

{ -- Encrypt code }
for I := 1 to NumOfCh do begin
CodeNum := 255 - Asc[I];
If CodeNum in [32 .. 92] then begin
Write (Char(CodeNum));
if CodeNum = Ord('\') then
Write ('\');
end
else  { -- Non printable }
begin
Str (1000 + CodeNum: 4, AscSt);
Write ('\');  Write(Copy(AscSt, 2, 3));
end;
end;
end.

{3.5}
program Thr5T87;
{ -- This program will unscramble the numbers 5132, 4735, and
-- 8014153 so that the first times the second equal the
-- third with a missing digit }
const
A : Array [1..4] of Byte = (5, 1, 3, 2);
B : Array [1..4] of Byte = (4, 7, 3, 5);
C : Array [1..7] of Byte = (8, 0, 1, 4, 1, 5, 3);
var
I, J, K, L, Perm24:       Byte;
Prod:                     LongInt;
Result:                   Byte;
ANum, BNum:               Array [1..24] of LongInt;
St:                       String;
PCh:                      Array [1..8] of Char;
Match:                    Boolean;

begin
{ -- Generate 24 permuations of 5132 and 4735 each. }
Perm24 := 0;
for I := 1 to 4 do
for J := 1 to 4 do
for K := 1 to 4 do begin
L := 4+3+2+1 -I-J-K;
if (I=J) or (J=K) or (I=K) then { -- do nothing }
else begin
Inc(Perm24);
ANum[Perm24] := A[I]*1000 + A[J]*100 + A[K]*10 + A[L];
BNum[Perm24] := B[I]*1000 + B[J]*100 + B[K]*10 + B[L];
end;
end;  { -- for K }

for I := 1 to 24 do
for J := 1 to 24 do begin
Prod := ANum[I] * BNum[J];
if not (Prod < 10E6) then begin { -- has 8 digits }
Str (Prod, St);
for K := 1 to 8 do
PCh[K] := St[K];
L := 1;
repeat
Match := False;  K := 0;
repeat
Inc(K);
if C[L] = Ord(PCh[K]) - Ord('0') then begin
PCh[K] := ' ';
Match := True;
end
until (K = 8) or Match;
Inc(L);
until (L > 7) or not Match;

if Match then
Writeln (ANum[I], '  ', BNum[J], '  ', St);
end;  { -- if }
end;  { -- for J }
end.

{3.6}
program Thr6T87;
{ -- This program will display the front colors on the Rubik's
-- Pocket Cube after a move of T or F is performed. }
const
A : Array [1..24] of Char =
('W', 'W', 'W', 'W', 'Y', 'Y', 'Y', 'Y',
'O', 'O', 'O', 'O', 'R', 'R', 'R', 'R',
'G', 'G', 'G', 'G', 'B', 'B', 'B', 'B');
var
I, J:    Byte;
Move, X: Char;

begin
repeat
Write ('Enter T, F, or Q: ');  Readln (Move);
if Move = 'T' then
begin
X    := A;  A := A;  A := A;
A := A;  A := X;
X    := A;  A := A;  A := A;
A:= A; A:= X;
X    := A;  A := A; A:= A;
A:= A; A:= X;
end
else if Move = 'F' then
begin
X    := A;  A := A;  A := A;
A := A;  A := X;
X    := A;  A := A; A:= A;
A:= A;  A := X;
X    := A;  A := A; A:= A;
A:= A; A:= X;
end;
if Move <> 'Q' then begin
Writeln (A, '  ', A);
Writeln (A, '  ', A);
end
until Move = 'Q';
end.

{3.7}
program Thr7T87;
{ -- This program will simulate a drill of Adding Roman Numerals.}
uses Crt;
const
RN:  Array[1..7] of Char= ('M', 'D', 'C', 'L', 'X', 'V', 'I');
RNV: Array[1..7] of Integer = (1000, 500, 100, 50, 10, 5, 1);
var
Option:       Byte;
Name, Dayte:  String;

procedure Do3Problems;
{ -- This procedure will allow the user to do 3 addition problems}
var
I, J, K:      Byte;
Right, Wrong: Byte;
Prob, XX:     Byte;
Num:          Array [1..3] of Byte;
RNum:         Array [1..3] of String;
Ans:          String;
X:            Real;
Miss:         Byte;
L1, L2, Col:  Byte;
Arabic:       Byte;
Ri, Wr:       Array [1..3] of String;
RiA:          Array [1..3] of Byte;

begin
Right := 0;  Wrong := 0;
for Prob := 1 to 3 do begin
ClrScr;
Randomize;
Num := Random(19) + 1;  Num := Random(19) + 1;
Num := Num + Num;  Arabic := Num;
for K := 1 to 3 do
RNum[K] := '';
for K := 1 to 3 do
for I := 1 to 7 do begin
X := Num[K] / RNV[I];
if (X < 2) and (X >= 9/5) and ((I=2) or (I=4) or (I=6))
then { null }
else begin
XX := Trunc(X);
If XX = 9 then
RNum[K] := RNum[K] + RN[I] + RN[I-2]
else if XX = 4 then
RNum[K] := RNum[K] + RN[I] + RN[I-1]
else if XX > 0 then
for J := 1 to XX do
RNum[K] := RNum[K] + RN[I];
Num[K] := Num[K] - RNV[I] * XX;
end;
end; { -- for I }

{ -- Display Problem }
GotoXY (15, 10);  Write (RNum);
L1 := Length(RNum);  L2 := Length(RNum);
Col := 15 + (L1 - L2) - 2;
GotoXY (Col, 11);  Write ('+ ', RNum);
GotoXY (Col, 12);
for I := 1 to 2 + L2 do Write ('-');
Miss := 0;
repeat

if Ans = RNum then begin
Inc(Right);  Miss := 0;  end
else  { -- Incorrect answer }
if Miss > 0 then begin  { -- Second Miss }
Miss := 0;  Sound (400); Delay (200);  NoSound;
Inc(Wrong);  Wr[Wrong] := Ans;
Ri[Wrong] := RNum;  RiA[Wrong] := Arabic;
end
else begin  { -- First Miss }
Miss := 1;  Sound (400);  Delay (200);  NoSound;
GotoXY (Col, 16);  Write (Arabic);
GotoXY (Col, 13);  ClrEol;
end;
until Miss = 0;
end;  { -- for Prob }

{ -- Progress Report }
ClrScr;  GotoXY (11,1);  Writeln ('PROGRESS REPORT');
Writeln ('DATE: ', Dayte);
Writeln ('NAME: ', Name);
Writeln ('NUMBER CORRECT: ', Right);
Writeln ('NUMBER OF EXERCISES: 3');
Writeln ('PERCENT CORRECT: ', Round(RIGHT / 3 * 100), '%');
Writeln;
if Wrong > 0 then begin
GotoXY (1, 15);
for I := 1 to Wrong do begin
GotoXY (1, 16+I);  Write (Wr[I]);
GotoXY (16, 16+I); Write (Ri[I]);
GotoXY (32, 16+I); Write (RiA[I]);
end;
repeat until KeyPressed;
end;
end;

begin
Write ('Enter name: ');  Readln (Name);
Write ('Enter date: ');  Readln (Dayte);

repeat
ClrScr;
Writeln ('1. INSTRUCTION PAGE');
Writeln ('2. PRACTICE 3 PROBLEMS');
Writeln ('3. QUIT');
if Option = 1 then  { -- Display instructions }
begin
ClrScr;
Writeln ('YOU WILL BE GIVEN 3 PROBLEMS TO');
Writeln ('WORK. A PROBLEM WILL CONSIST OF');
Writeln ('ROMAN NUMERALS LESS THAN 20.');
Writeln ('ROMAN NUMERALS AND PRESS ''RETURN.''');
repeat until KeyPressed;
end
else if Option = 2 then  { -- Practice 3 problems }
Do3Problems;
until Option = 3;
end.

{3.8}
program Thr8T87;
{ -- This program will determine the area shared w/2 rectangles. }
var
A, B, X, Y:      Array [1..4] of Integer;
AB, XY:          Array [0..20, 0..20] of Integer;
I, J, Width,
Width2, Height:  Integer;

begin
for I := 1 to 4 do begin
Write ('Enter X,Y: ');  Readln (X[I], Y[I]);
X[I] := Abs(X[I]);  Y[I] := Abs(Y[I]);
end;
Writeln;
for I := 1 to 4 do begin
Write ('Enter A,B: ');  Readln (A[I], B[I]);
A[I] := Abs(A[I]);  B[I] := Abs(B[I]);
end;

{ -- Initialize AB and XY arrays }
for I := 0 to 20 do
for J := 0 to 20 do begin
AB[I,J] := 0;  XY[I,J] := 0;  end;

{ -- Store a 1 in each occupied square }
for I := A to A do
for J := B to B do
AB[I, J] := 1;

{ -- Determine area in common (height-1 x Width-1) }
Width := 0;  Height := 0;
for I := X to X do begin
for J := Y to Y do
if (AB[I, J] = 1) then
Inc(Width);
if Width > 0 then begin
Inc(Height);  Width2 := Width;  Width := 0;
end;
end;

Writeln ((Height -1) * (Width2 -1));
end.

{3.9}
program Thr9T87;
{ -- This program will divide 2 big numbers w/at most 30 digits. }
var
ASt, BSt:            String;
A, B:                Array[1..30] of Integer;
Ch:                  Char;
LenA, LenB, Quot:    Byte;
I:                   Integer;
LastAPos, LastAInd:  Byte;
AtLeast1Divide:      Boolean;

function ALessThanB: {giving} Boolean;
{ -- This function returns true if A[..] is less than B[..] }
var
I: Byte;

begin
if LastAInd > LenB then
ALessThanB := False
else if LastAInd < LenB then
ALessThanB := True
else begin  { -- both A and B are same length }
I := LenB;
while (I > 1) and (A[I] = B[I]) do
Dec(I);
if A[I] < B[I] then  { -- Found position where A is < B }
ALessThanB := True
else
ALessThanB := False;
end;
end;

procedure AttachDigitToA;
{ -- This procedure will attach another digit at end of A[..] }
begin
for I := LastAInd downto 1 do
A[I+1] := A[I];
if A[LastAInd+1] > 0 then
Inc(LastAInd);
Inc(LastAPos);
Ch := ASt[LastAPos];
A := Ord(Ch) - Ord('0');
end;

procedure Sub_B_From_A;
{ -- This procedure will subtract B[..] from A[..] with borrowing}
var
Borrow: Byte;

begin
for I := 1 to LenB do begin
if B[I] <= A[I] then Borrow := 0
else begin
Borrow := 10;
Dec(A[I+1]);
end;
A[I] := A[I] - B[I] + Borrow;
end;
{ -- Find first non-zero of A[] for LastAInd }
while (LastAInd > 1) and (A[LastAInd] = 0) do
Dec(LastAInd);
end;

procedure DivideAbyB;
{ -- This procedure will divide A[..] by B[..] and display quot. }
begin
Quot := 1;
while not ALessThanB and (Quot < 10) do begin
Sub_B_From_A;  Inc(Quot);
end;
Write (Quot - 1);
end;
{ -- Main program routine }
begin
Write ('Enter first number: ');   Readln (ASt);
Write ('Enter second number: ');  Readln (BSt);
LenA := Length (ASt);  LenB := Length (BSt);  { -- LenA > LenB }

{ -- Store B number in Array: 456 becomes B=6,B=5,B=4 }
for I := LenB downto 1 do begin
Ch := BSt[I];
B[LenB-I+1] := Ord(Ch) - Ord('0');
end;
{ -- Store equal number of digits in A as was in B }
if LenB <= LenA then LastAPos := LenB
else LastAPos := Length(ASt);
for I := LastAPos downto 1 do begin
Ch := ASt[I];
A[LastAPos-I+1] := Ord(Ch) - Ord('0');
end;
LastAInd := LastAPos;
if ALessThanB and (LastAPos < LenA) then
{ -- Attach 1 more digit so A > B }
AttachDigitToA;
AtLeast1Divide := False;

{ -- Perform systematic division by attaching digits
-- until no more digits }
while (LastAPos < LenA) or not ALessThanB do begin
while ALessThanB and (LastAPos < LenA) do begin
end;
for I := 1 to DigitsAdded-1 do
{ -- Print 0's for each excessive digit }
Write ('0');
DivideAbyB;
AtLeast1Divide := True;
end;  { -- while }

{ -- Display Remainder }
if not AtLeast1Divide then Write ('0');  { -- No quotient, A Lnum then X := Lnum;
if Y < 0 then Y := 0;
if Y > Wnum then Y := Wnum;
until (PointUsed[X, Y] = 1) and (A[X, Y] = 0);

repeat
D := Random(4);  { -- Random direction }

SegmentDrawn := False;  NumOfTries := 0;
repeat
NumOfTries := NumOfTries + 1;
Inc(D);  If D > 4 then D := D - 4;
Case D of
1: begin  { -- Up }
if (Y > 0) and not (PointUsed[X, Y-1] = 1) then
begin
for J := 0 to Winc - 1 do begin
GotoXY (X*Linc+1, Y*Winc-J);  Write ('*');
end;
X2 := X;  Y2 := Y - 1;
SegmentDrawn := True;
end;
end;

2: begin  { -- Right }
if (X < LNum) and not (PointUsed[X+1, Y] = 1) then
begin
for J := 0 to Linc - 1 do begin
GotoXY (X*Linc+2+J, Y*Winc+1);  Write ('*');
end;
X2 := X + 1;  Y2 := Y;
SegmentDrawn := True;
end;
end;

3: begin  { -- Down }
if (Y < Wnum) and not (PointUsed[X, Y+1] = 1) then
begin
for J := 0 to Winc - 1 do begin
GotoXY (X*Linc+1, Y*Winc+2+J);  Write ('*');
end;
X2 := X;  Y2 := Y + 1;
SegmentDrawn := True;
end;
end;

4: begin  { -- Left }
if (X > 0) and not (PointUsed[X-1, Y] = 1) then
begin
for J := 0 to Linc - 1 do begin
GotoXY (X*Linc-J, Y*Winc+1);  Write ('*');
end;
X2 := X - 1;  Y2 := Y;
SegmentDrawn := True;
end;
end;
end;  { -- case }
until SegmentDrawn or (NumofTries = 4);

if SegmentDrawn then begin
PointUsed[X2, Y2] := 1;
Inc(LinesDrawn);
X := X2;  Y := Y2;
end
else  { -- No more segments can be drawn from this point }
A[X, Y] := 1;
until (LinesDrawn = NumOfLines) or not SegmentDrawn;
until (LinesDrawn = NumOfLines);  { -- Get new point of
-- Segment not drawn }
{ -- Open doors }
X := Random(Wnum) + 1;  Y := Random (Wnum) + 1;
for J := 0 to Winc - 2 do begin
GotoXY (1,  X * Winc - J);  Write (' ');
GotoXY (33, Y * Winc - J);  Write (' ');
end;
GotoXY (1, 23);

end.

```