{ -- 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: ');
Readln (Num);
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: ');
Readln (Row1, Col1, Row2, Col2);
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[30] =
('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[30];
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[10];
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;
Ch := ReadKey;
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[3];
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[1] * A[2] + A[2] * A[3] + A[3] * A[1];
Den := A[1] * A[2] * A[3];
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[20];
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[12];
Word2: Array [1..5] of String[12];
St: Array [1..12] of String[1];
Temp: String[12];
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[20];
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;
Ch := ReadKey;
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[10];
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, ': ');
Readln (A[I,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[12];
var
Lines: String[255];
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[50];
I, NumOfCh: Byte;
Result: Integer;
Ch, NextCh: Char;
AscSt: String[4];
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[8];
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[1]; A[1] := A[3]; A[3] := A[4];
A[4] := A[2]; A[2] := X;
X := A[5]; A[5] := A[9]; A[9] := A[13];
A[13]:= A[17]; A[17]:= X;
X := A[6]; A[6] := A[10]; A[10]:= A[14];
A[14]:= A[18]; A[18]:= X;
end
else if Move = 'F' then
begin
X := A[5]; A[5] := A[7]; A[7] := A[8];
A[8] := A[6]; A[6] := X;
X := A[3]; A[3] := A[20]; A[20]:= A[22];
A[22]:= A[9]; A[9] := X;
X := A[4]; A[4] := A[18]; A[18]:= A[21];
A[21]:= A[11]; A[11]:= X;
end;
if Move <> 'Q' then begin
Writeln (A[5], ' ', A[6]);
Writeln (A[7], ' ', A[8]);
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[8];
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[12];
Ans: String[12];
X: Real;
Miss: Byte;
L1, L2, Col: Byte;
Arabic: Byte;
Ri, Wr: Array [1..3] of String[12];
RiA: Array [1..3] of Byte;
begin
Right := 0; Wrong := 0;
for Prob := 1 to 3 do begin
ClrScr;
Randomize;
Num[1] := Random(19) + 1; Num[2] := Random(19) + 1;
Num[3] := Num[1] + Num[2]; Arabic := Num[3];
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[1]);
L1 := Length(RNum[1]); L2 := Length(RNum[2]);
Col := 15 + (L1 - L2) - 2;
GotoXY (Col, 11); Write ('+ ', RNum[2]);
GotoXY (Col, 12);
for I := 1 to 2 + L2 do Write ('-');
Miss := 0;
repeat
GotoXY (Col, 13); Readln (Ans);
{ -- Evaluate Answer }
if Ans = RNum[3] 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[3]; 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);
Writeln ('WRONG ANSWER CORRECT ANSWER ARABIC');
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;
GotoXY (1, 23); Writeln ('PRESS ANY KEY TO RETURN TO MENU.');
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');
Readln (Option);
if Option = 1 then { -- Display instructions }
begin
ClrScr;
Writeln ('YOU WILL BE GIVEN 3 PROBLEMS TO');
Writeln ('WORK. A PROBLEM WILL CONSIST OF');
Writeln ('ADDING TWO RANDOMLY GENERATED');
Writeln ('ROMAN NUMERALS LESS THAN 20.');
Writeln ('YOU WILL TYPE YOUR ANSWER IN');
Writeln ('ROMAN NUMERALS AND PRESS ''RETURN.''');
Writeln ('(PRESS ANY KEY TO RETURN TO MENU.)');
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[1] to A[2] do
for J := B[4] to B[1] do
AB[I, J] := 1;
{ -- Determine area in common (height-1 x Width-1) }
Width := 0; Height := 0;
for I := X[1] to X[2] do begin
for J := Y[4] to Y[1] 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[30];
A, B: Array[1..30] of Integer;
Ch: Char;
LenA, LenB, Quot: Byte;
I: Integer;
LastAPos, LastAInd: Byte;
DigitsAdded: 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[1] := 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[3]=6,B[2]=5,B[1]=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
DigitsAdded := 0;
while ALessThanB and (LastAPos < LenA) do begin
AttachDigitToA; Inc(DigitsAdded);
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.