{ -- FLORIDA HIGH SCHOOLS COMPUTING COMPETITION '96 }
{ -- PASCAL PROGRAM SOLUTIONS }
{1.1}
program One1T96;
{ -- This program displays a phrase of the form FHSCC '##. }
var
Year: String[4];
begin
Write ('Enter year: '); Readln (Year);
Writeln ('FHSCC ''', Copy(Year,3,2));
end.
{1.2}
program One2T96;
{ -- This program tallies number of frequent flier miles. }
var
X, Y: Integer;
begin
Write ('Enter X: '); Readln (X);
Write ('Enter Y: '); Readln (Y);
Writeln (X * (1300 + 1300 + 500) + (Y * 5));
end.
{1.3}
program One3T96;
{ -- This program displays middle letter(s) of a word. }
var
Word: String[20];
L, M: Integer;
begin
Write ('Enter word: '); Readln (Word);
L := Length(Word); M := L div 2;
If (L mod 2) = 0 then Write (Copy(Word, M, 1));
Writeln (Copy(Word, M+1, 1));
end.
{1.4}
program One4T96;
{ -- This program displays area and perimeter of a rectangle. }
var
X1, Y1, X2, Y2, Area, Perim: Integer;
begin
Write ('Enter coordinate 1: '); Readln (X1, Y1);
Write ('Enter coordinate 2: '); Readln (X2, Y2);
Area := Abs((X1 - X2) * (Y1 - Y2));
Perim := (Abs(X1 - X2) + Abs(Y1 - Y2)) * 2;
Writeln ('AREA = ', Area);
Writeln ('PERIMETER = ', Perim);
end.
{1.5}
program One5T96;
{ -- This program code-breaks an encrypted secret message. }
var
E: String[40];
M: Char;
I: Integer;
begin
Write ('Enter encryption: '); Readln (E);
for I := 1 to Length(E) do begin
M := E[I];
if M = ' ' then
Write(M)
else
Write (Chr( Ord('Z') - Ord(M) + Ord('A') ));
end;
Writeln;
end.
{1.6}
program One6T96;
{ -- This program displays number of floors elevator touches. }
var
Floor, Total, Max, LastFloor: Integer;
begin
repeat
Write ('Enter floor: '); Readln (Floor);
Total := Total + Abs(Floor - LastFloor);
if Floor > Max then Max := Floor;
LastFloor := Floor;
until (Floor = 0);
{ -- 1 is added for the starting ground floor }
Writeln ('TOTAL FLOORS TOUCHED = ', Total + 1);
Writeln ('UNIQUE FLOORS TOUCHED = ', Max + 1);
end.
{1.7}
program One7T96;
{ -- This program displays a person's ratios for buying a house.}
var
Loan, Debts, Income, Ratio1, Ratio2: Real;
begin
Write ('Enter amount of loan: '); Readln (Loan);
Write ('Enter amount of debts: '); Readln (Debts);
Write ('Enter amount of income: '); Readln (Income);
Ratio1 := (Loan / Income) * 100;
Ratio2 := ((Loan + Debts) / Income) * 100;
Writeln ('RATIOS = ', Ratio1: 4:1, '% / ', Ratio2: 4:1, '%');
Write ('DOES ');
if (Ratio1 > 33) or (Ratio2 > 38) then Write ('NOT ');
Writeln ('QUALIFY');
end.
{1.8}
program One8T96;
{ -- This program will convert numbers to English or Spanish.}
const
N: Array [1..20] of String[6] = ('ONE','TWO','THREE',
'FOUR','FIVE','SIX','SEVEN','EIGHT','NINE','TEN',
'UNO','DOS','TRES','CUATRO','CINCO','SEIS','SIETE',
'OCHO','NUEVE','DIEZ');
var
Lang: Char;
Num, I: Byte;
begin
Write ('Enter E or S: '); Readln (Lang);
Write ('Enter number: ' ); Readln (Num);
if Lang = 'S' then I := 10 else I := 0;
Writeln (N[I + Num]);
end.
{1.9}
program One9T96;
{ -- This program forms a cross from word(s). }
var
W: String[20];
I, L, M: Byte;
begin
Write ('Enter word(s): '); Readln (W);
L := Length(W); M := (L div 2) + 1;
for I := 1 to L do
If I <> M then
Writeln (' ': M - 1, Copy(W, I, 1))
else
Writeln (W);
end.
{1.10}
program One10T96;
{ -- This program simulates the PRICE IS RIGHT game. }
var
Price, Min, I, Dif, Index: Integer;
A: Array[1..4] of Integer;
begin
Write ('Enter actual price: '); Readln (Price);
Write ('Enter guesses A, B, C, D: ');
Readln (A[1], A[2], A[3], A[4]);
Min := 32000;
for I := 1 to 4 do
if A[I] <= Price then begin
Dif := Price - A[I];
if Dif < Min then begin
Min := Dif; Index := I;
end;
end;
if Index > 0 then
Writeln ('PERSON ', Copy ('ABCD', Index, 1))
else
Writeln ('EVERYONE IS OVER');
end.
{2.1}
program Two1T96;
{ -- This program will emulate random dart throws. }
const
S: Array[1..7] of Byte = (0,2,4,5,10,20,50);
var
X, Throw, Total: Byte;
begin
Randomize; Throw := 0;
repeat
X := Random(7) + 1; Inc(Throw);
Write(S[X]);
Inc(Total, S[X]);
If Total < 100 then Write (',');
until (Total >= 100);
Writeln;
Writeln (Throw, ' THROWS ACHIEVED A SCORE OF ', Total);
Writeln;
end.
{2.2}
program Two2T96;
{ -- This program compresses information to save space. }
var
S: String[80];
I, Ast: Byte;
Md: Char;
begin
Write ('Enter string: '); Readln (S);
Ast := 0;
for I := 1 to Length(S) do begin
Md := S[I];
if Md <> '*' then
begin
if Ast > 0 then
begin
if Ast = 1 then
Write ('*')
else
Write (Ast);
Ast := 0;
end;
Write(Md);
end
else
Inc(Ast)
end; { -- for I }
Writeln;
end.
{2.3}
program Two3T96;
{ -- This program finds 2 numbers to add to the set 1,3,8. }
var
A: Array[1..5] of Integer;
I, J, Num, N: Integer;
Found: Boolean;
begin
A[1] := 1; A[2] := 3; A[3] := 8; N := 3; I := 0;
for I := 0 to 999 do begin
Found := True;
for J := 1 to N do begin
Num := A[J] * I + 1;
if Sqrt(Num) - Trunc(Sqrt(Num + 0.0001)) > 0.0001 then
Found := False;
end;
if Found then begin
Writeln (I); Inc(N); A[N] := I; if N = 5 then Exit;
end;
end;
end.
{2.4}
program Two4T96;
{ -- This program displays the LCM of the first N integers. }
var
A: Array[1..31] of Integer;
I, J, N: Integer;
Prod: Real;
begin
Write ('Enter N: '); Readln (N);
for I := 2 to N do A[I] := I;
{ -- Produce all the necessary prime factors. }
for I := 2 to N do
for J := I + 1 to N do
if (A[J] Mod A[I]) = 0 then A[J] := A[J] div A[I];
Prod := 1;
For I := 2 to N do
Prod := Prod * A[I];
Writeln (Prod: 13:0);
end.
{2.5}
program Two5T96;
{ -- This program will calculate the fractional value. }
var
Word: String[3];
A: Array[1..3] of Integer;
I, N, D: Integer;
begin
Write ('Enter word: '); Readln (Word);
for I := 1 to 3 do
A[I] := Ord(Word[I]) - Ord('A') + 1;
N := A[1] * A[2] + A[2] * A[3] + A[1] * A[3];
D := A[1] * A[2] * A[3];
for I := D downto 1 do
if (N mod I = 0) and (D mod I = 0) then begin
Writeln (N div I, '/', D div I); Exit
end;
end.
{2.6}
program Two6T96;
{ -- This program displays the Nth prime in Fibonacci sequence. }
var
F: Array[1..99] of LongInt;
I, N, J, PNum: Integer;
Prime: Boolean;
begin
F[1] := 1; F[2] := 1; F[3] := 2; PNum := 1; I := 3;
Write ('Enter N: '); Readln (N);
while (PNum < N) do begin
Inc(I);
F[I] := F[I-1] + F[I-2]; Prime := True;
{ -- Check if Fibonacci # is prime (not divis by 2 or odd#) }
if (F[I] Mod 2 = 0) then Prime := False;
if Prime then begin
for J := 3 to Trunc(Sqrt(F[I])) do
if (F[I] mod J = 0) then Prime := False;
if Prime then Inc(PNum);
end;
end;
Writeln(F[I]);
end.
{2.7}
program Two7T96;
{ -- This program sorts phone bills by zip code and phone #. }
var
P, Z, PZ: Array[1..8] of LongInt;
X: LongInt;
N, I, J: Integer;
begin
N := 0;
repeat
Inc(N);
Write ('Enter phone #, zip: '); Readln (P[N], Z[N]);
PZ[N] := Z[N] * 10000 + P[N];
until (P[N] = 0) and (Z[N] = 0);
Dec(N);
for I := 1 to N - 1 do
for J := I + 1 to N do
if PZ[I] > PZ[J] then begin
X := PZ[I]; PZ[I] := PZ[J]; PZ[J] := X;
X := P[I]; P[I] := P[J]; P[J] := X;
X := Z[I]; Z[I] := Z[J]; Z[J] := X;
end;
for I := 1 to N do Writeln (P[I]);
end.
{2.8}
program Two8T96;
{ -- This program will display number of runs of letters. }
var
Let: String[80];
Ch: Char;
I, H1, H2: Integer;
Half1, Half2: Boolean;
begin
Write ('Enter letters: '); Readln (Let);
Half1 := False; Half2 := False;
for I := 1 to Length(Let) do begin
Ch := Let[I];
if Pos(Ch, 'ABCDEFGHIJKLM') > 0 then begin
if Half2 then begin
Inc(H2); Half2 := False;
end;
Half1 := True;
end
else begin
if Half1 then begin
Inc(H1); Half1 := False;
end;
Half2 := True;
end;
end;
if Half1 then Inc(H1);
if Half2 then Inc(H2);
Writeln ('RUNS IN 1ST HALF = ', H1);
Writeln ('RUNS IN 2ND HALF = ', H2);
end.
{2.9}
program Two9T96;
{ -- This program reverses the order of letters in each word. }
var
S: String[80];
Md: Char;
I, J, L: Integer;
W: String[20];
Pal: Boolean;
begin
Write ('Enter string: '); Readln (S); S := S + ' ';
for I := 1 to Length(S) do begin
Md := S[I];
if Md = ' ' then begin
L := Length(W); Pal := True;
for J := 1 to L div 2 do
if Copy(W, J, 1) <> Copy (W, L-J+1, 1) then Pal := False;
if Pal then
for J := 1 to Length(W) do Write('?')
else
for J := L downto 1 do Write(Copy(W,J,1));
Write (' '); W := '';
end
else
W := W + Md;
end;
Writeln;
end.
{2.10}
program Two10T96;
{ -- This program determines day of week for a given date. }
const
MonNum: Array[1..12] of Byte = (1,4,4,0,2,5,0,3,6,1,4,6);
D: Array[1..7] of String[9] = ('SATURDAY',
'SUNDAY', 'MONDAY', 'TUESDAY', 'WEDNESDAY',
'THURSDAY', 'FRIDAY');
var
Month, Day, Year, Last2, Sum, R: Integer;
LeapYear: Boolean;
begin
Write ('Enter month, day, year: '); Readln (Month, Day, Year);
Last2 := Year mod 100;
Sum := Last2 + (Last2 div 4);
LeapYear := (Year Mod 4 = 0) and (Year mod 100 > 0);
LeapYear := LeapYear or (Year mod 400 = 0);
if (Month < 3) and LeapYear then
if (Month = 2) then Inc(Sum,3) else {-- New Month Number }
else
Inc(Sum, MonNum[Month]);
Inc(Sum, Day);
Case Year of
1753..1799: Inc(Sum, 4);
1800..1899: Inc(Sum, 2);
2000..2099: Inc(Sum, 6);
2100..2199: Inc(Sum, 4);
end;
R := Sum mod 7;
Writeln (D[R+1]);
end.
{3.1}
program Thr1T96;
{ -- This program displays the appearance of 3-dimensional book.}
uses Crt;
const
Spaces: String[16] = ' ';
var
T1, T2: String[17];
Max, Dif, Row: Byte;
begin
Write ('Enter title 1: '); Readln (T1);
Write ('Enter title 2: '); Readln (T2);
if Length(T1) > Length(T2) then
begin
Max := Length(T1); Dif := (Max - Length(T2)) div 2;
T2 := Copy(Spaces, 1, Dif) + T2 + Copy(Spaces, 1, Dif + 1);
end
else
begin
Max := Length(T2); Dif := (Max - Length(T1)) div 2;
T1 := Copy(Spaces, 1, Dif) + T1 + Copy(Spaces, 1, Dif + 1);
end;
ClrScr;
Writeln (' /---/!');
Writeln (' / / !');
Writeln (' / / !');
Writeln (' / / !');
Writeln ('!---! !');
for Row := 1 to Max do begin
Write ('!');
Write (Copy (T2, Row, 1), ' ');
Write (Copy (T1, Row, 1), '!');
if Row < Max - 3 then
Writeln (' ':4, '!')
else
Writeln (' ': Max - Row + 1, '/');
end;
Writeln ('!---!/');
end.
{3.2}
program Thr2T96;
{ -- This program produces a prime factors tree. }
uses Crt;
var
P: Array[1..100] of Integer;
Num, Left, Right, Row, Pr, Dividend, L, R: Integer;
begin
Write ('Enter number: '); Readln (NUM);
ClrScr; Row := 1; Writeln (' ':5, Num);
{-- Position of / and \, determine length of Num }
Left := 5; Right := Left + Trunc(Ln(Num) / Ln(10)) + 2;
repeat
{ -- Find smallest prime that divides number }
if Num mod 2 = 0 then
Pr := 2
else begin
Pr := 1;
repeat
Inc(Pr, 2);
until (Num mod Pr = 0);
end;
Dividend := Num div Pr;
if Dividend > 1 then begin
Inc(Row);
GotoXY (Left, Row); Write ('/');
GotoXY (Right, Row); Writeln ('\');
L := Trunc(Ln(Pr) / Ln(10));
R := Trunc(Ln(Dividend) / Ln(10));
Inc(Row);
GotoXY (Left - L - 1, Row); Write (Pr);
GotoXY (Right + 1, Row); Writeln (Dividend);
Left := Right; Right := Right + R + 2;
end;
Num := Dividend;
until Num = 1;
end.
{3.3}
program Thr3T96;
{ -- This program simulates a "base four" calculator. }
var
Num: Array[1..10] of String[6];
Sym: Array[1..10] of Char;
Ch: Char;
N: String[6];
E: String[40];
I, J, K, L, Dig, X: Byte;
B10, Total, Pow: LongInt;
begin
Write ('Enter base 4 expression: '); Readln (E);
E := E + '+'; Sym[1] := '+';
for I := 1 to Length(E) do begin
Ch := E[I];
if (Ch = '+') or (Ch = '-') then
begin
Inc(J); Num[J] := N; Sym[J+1] := Ch; N := '';
end
else
N := N + Ch;
end;
{ -- Convert base 4 numbers to base 10 and perform arithmetic }
for I := 1 to J do begin
L := Length(Num[I]); B10 := 0;
for J := 1 to L do begin
Dig := Ord(Num[I,J]) - Ord('0');
Pow := 1;
for K := 1 to (L - J) do Pow := Pow * 4;
B10 := B10 + Dig * Pow;
end;
if (Sym[I] = '-') then B10 := (-B10);
Inc(Total, B10);
end;
{ -- Convert base 10 number to base 4 }
if Total < 0 then begin
Write ('-'); Total := (-Total);
end;
J := Trunc(Ln(Total) / Ln(4) + 0.001);
for I := J downto 0 do begin
Pow := 1;
for K := 1 to I do Pow := Pow * 4;
X := Total div Pow;
Write (X);
Total := Total - X * Pow;
end;
Writeln;
end.
{3.4}
program Thr4T96;
{ -- This program calculates contractor's pay=time * rate. }
var
Rate, Time: Real;
St, Fi: String[7];
FiHour, StHour, StMin, FiMin, Code: Integer;
begin
Write ('Enter pay/hour: '); Readln (Rate);
Write ('Enter start time: '); Readln (St);
Write ('Enter finish time: '); Readln (Fi);
Val(Copy(St,1,2), StHour, Code);
Val(Copy(Fi,1,2), FiHour, Code);
Val(Copy(St,4,2), StMin, Code);
Val(Copy(Fi,4,2), FiMin, Code);
{ -- Adjust for 12AM and times from 1PM - 11PM }
if StHour = 12 then
if Copy(St, 6, 2) = 'AM' then Dec(StHour, 12) else
else
if Copy(St, 6, 2) = 'PM' then Inc(StHour, 12);
if FiHour = 12 then
if Copy(Fi, 6, 2) = 'AM' then Dec(FiHour, 12) else
else
if Copy(Fi, 6, 2) = 'PM' then Inc(FiHour, 12);
{-- Adjust for a late starting time and early morning finish.}
if StHour > FiHour then Inc(FiHour, 24);
{-- Compute difference in time (finish - start) }
Time := (FiHour - StHour) + (FiMin - StMin) / 60;
{-- If more than half of time is outside normal hours (7AM-5PM)
-- then add a shift differential of 10% to rate. }
if ((7 - StHour) + (0 - StMin) / 60) >= (Time / 2) then
{ -- More than half of time is worked before 7AM }
Rate := Rate * 1.1;
if ((FiHour - 17) + (FiMin) / 60) >= (Time / 2) then
{ -- More than half of time is worked after 5PM }
Rate := Rate * 1.1;
Writeln ('$', Time * Rate: 6:2);
end.
{3.5}
program Thr5T96;
{ -- This program displays the button that leads to the others. }
var
I, J, K, L, R, C, Press: Byte;
N: Array[1..4, 1..4] of Byte;
D: Array[1..4, 1..4] of Char;
A: Array[1..4, 1..4] of Boolean;
Row: String[12];
Code: Integer;
Good: Boolean;
begin
for I := 1 to 4 do begin
Write ('Enter row: '); Readln (Row);
for J := 1 to 4 do begin
Val(Row[J*3-2], N[I,J], Code);
D[I,J] := Row[J*3-1];
end;
end;
for I := 1 to 4 do
for J := 1 to 4 do begin
for K := 1 to 4 do
for L := 1 to 4 do A[K, L] := False;
R := I; C := J; A[R, C] := True;
Press := 1; Good := True;
repeat
Case D[R,C] of
'D': Inc(R, N[R,C]);
'U': Dec(R, N[R,C]);
'L': Dec(C, N[R,C]);
'R': Inc(C, N[R,C]);
end;
if A[R, C] then
Good := False
else begin
A[R,C] := True; Inc(Press);
end;
until (not Good) or (Press = 16);
if Press = 16 then begin
Writeln ('FIRST BUTTON = ', N[I,J], D[I,J]);
Writeln ('AT ROW = ', I, ', COL = ', J);
Exit
end;
end; { -- for J }
end.
{3.6}
program Thr6T96;
{ -- This program will generate odd size magic squares. }
var
N, First, Incr, X, Y, I, J, MagicNum: Integer;
A: Array[1..13, 1..13] of Integer;
begin
Write ('Enter order, first number, increment: ');
Readln (N, First, Incr);
X := 1; Y := (N + 1) div 2; A[X,Y] := First;
for I := 2 to N * N do begin
Dec(X); Inc(Y);
if X = 0 then X := N;
if Y > N then Y := 1;
if A[X,Y] = 0 then
A[X,Y] := First + Incr * (I - 1)
else begin
Inc(X,2); Dec(Y);
if X > N then Dec(X, N);
if Y = 0 then Y := N;
A[X,Y] := First + Incr * (I - 1);
end;
end;
{ -- Display Magic Number and Square }
MagicNum := 0;
for I := 1 to N do Inc(MagicNum, A[I,1]);
Writeln ('MAGIC NUMBER = ', MagicNum);
for I := 1 to N do begin
for J := 1 to N do
Write (A[I,J]: 4);
Writeln;
end;
end.
{3.7}
program Thr7T96;
{ -- This program will generate 6x6 magic squares. }
const
R: Array[1..4] of Byte = (0, 1, 0, 1);
C: Array[1..4] of Byte = (0, 1, 1, 0);
var
N, First, Incr, X, Y, I, J: Integer;
FirstN, MagicNum, Sq, Temp: Integer;
A: Array[1..3, 1..3] of Integer;
B: Array[1..6, 1..6] of Integer;
procedure Generate3x3;
{ -- Generate a 3x3 magic square in A[1..3,1..3] }
begin
for I := 1 to 3 do
for J := 1 to 3 do A[I,J] := 0;
N := 3;
X := 1; Y := (N + 1) div 2; A[X,Y] := First;
for I := 2 to N * N do begin
Dec(X); Inc(Y);
if X = 0 then X := N;
if Y > N then Y := 1;
if A[X,Y] = 0 then
A[X,Y] := First + Incr * (I - 1)
else begin
Inc(X,2); Dec(Y);
if X > N then Dec(X, N);
if Y = 0 then Y := N;
A[X,Y] := First + Incr * (I - 1);
end;
end;
end;
begin
Write ('Enter first number, increment: ');
Readln (FirstN, Incr);
{ -- Four 3x3 squares are made for the 6x6 matrix B[]
-- upper-left, bottom-right, upper-right, bottom-left. }
for Sq := 0 to 3 do begin
First := FirstN + Sq * 9 * Incr;
Generate3x3;
for I := 1 to 3 do
for J := 1 to 3 do
B[R[Sq+1] * 3 + I, C[Sq+1] * 3 + J] := A[I,J];
end;
{ -- Transpose three cells }
Temp := B[1,1]; B[1,1] := B[4,1]; B[4,1] := Temp;
Temp := B[2,2]; B[2,2] := B[5,2]; B[5,2] := Temp;
Temp := B[3,1]; B[3,1] := B[6,1]; B[6,1] := Temp;
{ -- Display Magic Number and 6x6 matrix }
MagicNum := 0;
for I := 1 to 6 do Inc(MagicNum, B[I,1]);
Writeln ('MAGIC NUMBER = ', MagicNum);
for I := 1 to 6 do begin
for J := 1 to 6 do
Write (B[I,J]: 4);
Writeln;
end;
end.
{3.8}
program Thr8T96;
{ -- This program will display a pie graph. }
uses Crt;
const
L: Array [1..3] of Char = ('A', 'D', 'N');
PI: Real = 3.1415926;
var
A: Array[1..21, 1..21] of Byte;
P: Array[1..3] of Byte;
I: Real;
Ch: Char;
J, K, R, X, Y, S, Sum, LSum: Integer;
begin
Write ('Enter 3 percentages: '); Readln (P[1], P[2], P[3]);
ClrScr;
for J := 1 to 21 do
for K := 1 to 21 do
A[J, K] := 0;
{ -- Draw Circle }
I := -PI / 2.0;
while I < 3 / 2 * PI do begin
X := Trunc(Cos(I) * 10); Y := Trunc(Sin(I) * 10);
GotoXY (11 + X, 11 + Y); Write ('*');
A[11 + X, 11 + Y] := 1; I := I + 0.1;
end;
{ -- Draw 3 line segments from center }
Sum := 0;
for S := 0 to 2 do begin
Sum := Sum + P[S];
I := -PI / 2 + 2 * PI * Sum / 100.0;
for R := 0 to 10 do begin
X := Trunc(Cos(I) * R); Y := Trunc(Sin(I) * R);
GotoXY (11 + X, 11 + Y); Write ('*');
A[11 + X, 11 + Y] := 1;
end;
end;
Ch := ReadKey; Sum := 0;
{ -- fill regions with letters }
for S := 1 to 3 do begin
LSum := Sum; Sum := Sum + P[S]; J := LSum;
while J < Sum do begin
I := -PI / 2 + 2 * PI * J / 100.0;
for R := 1 to 9 do begin
X := Trunc(Cos(I) * R); Y := Trunc(Sin(I) * R);
if A[11 + X, 11 + Y] = 0 then begin
GotoXY (11 + X, 11 + Y); Write (L[S]);
end;
end;
Inc(J);
end;
end;
end.
{3.9}
program Thr9T96;
{ -- This program produces a precedence of jobs to run. }
var
Num, I, J, K, L, DepLeft, UNum, P, St: Byte;
Job: String[3];
Dep: String[6];
U, U2, Jobs, NewU2: String[24];
A, B: Array[1..8] of String[3];
Marked: Array[1..8] of Boolean;
NoJob, ValidJob: Boolean;
begin
Write ('Enter number of dependencies: '); Readln (Num);
U := '';
for I := 1 to Num do begin
Write ('Enter dependency: '); Readln (Dep);
Dep := Dep + ' ';
A[I] := Copy(Dep, 1, 3);
B[I] := Copy(Dep, 4, 3);
{ -- Store unique jobs in string }
if Pos(A[I], U) = 0 then U := U + A[I];
if Pos(B[I], U) = 0 then U := U + B[I];
end;
{ -- Since there is a unique order for all the jobs,
-- every job will have its successor somewhere in B[].
-- 1) search all B[] for the only job missing.
-- 2) exclude all dependencies with this job in it.
-- 3) search all B[] for the next only job missing.
-- 4) repeat steps 2 and 3 until the final dependency is left.}
L := Length(U); UNum := L div 3; U2 := U;
DepLeft := Num; Jobs := '';
while DepLeft > 1 do begin
for I := 1 to Num do Marked[I] := False;
for I := 1 to Num do begin
P := Pos(B[I], U2);
if P > 0 then Marked[ (P+2) div 3 ] := True;
end;
NoJob := True; I := 0;
while NoJob and (I < UNum) do begin
Inc(I); St := I * 3 - 2;
Job := Copy(U2, St, 3);
ValidJob := (Pos(Job, Jobs) = 0) and (Job <> ' ');
if ValidJob and not Marked[I] then begin
Jobs := Jobs + Job;
for K := 1 to Num do
if A[K] = Job then begin
A[K] := '*'; B[K] := '*';
Dec(DepLeft);
end;
NewU2 := Copy(U2, 1, St-1) + ' ';
U2 := NewU2 + Copy(U2, St + 3, L - St - 2);
NoJob := False;
end;
end; { -- while }
end; { -- while }
{ -- Last dependency is concatenated }
for I := 1 to Num do
if A[I] <> '*' then Jobs := Jobs + A[I] + B[I];
Writeln ('JOBS MUST BE RUN IN THIS ORDER: ', Jobs);
end.
{3.10}
program Thr10T96;
{ -- This program finds a perfect square with digits 1-9. }
var
A, N, Num, Min, NumMin, NumMin2: LongInt;
I, B, Z, L, Code: Integer;
Digits: String[9];
Good: Boolean;
Count: Byte;
procedure CheckDigits;
{ -- Determine number of swaps made and store in count }
var
D: Array[1..9] of Byte;
I, J, Temp: Byte;
begin
for I := 1 to 9 do Val(Digits[I], D[I], Code);
Count := 0;
for I := 1 to 9 do
if D[I] <> I then begin
J := I + 1;
While (J < 9) and (D[J] <> I) do Inc(J);
Temp := D[I]; D[I] := D[J]; D[J] := Temp;
Inc(Count);
end;
end;
{ -- Main program }
begin
Min := 9;
for Num := 10001 to Trunc(Sqrt(987654321)) do begin
A := Num * Num;
Str(A, Digits);
Good := True; L := 1;
while (L <= 9) and Good do begin
if Pos(Chr(48+L), Digits) = 0 then Good := False;
Inc(L);
end;
if Good then begin {-- Found perfect square w/unique digits}
CheckDigits;
if Count < Min then begin
Min := Count; NumMin := A; NumMin2 := Num;
end;
end;
end;
{ -- Display the perfect square needing least num of swaps. }
Str(NumMin, Digits);
Writeln (Digits, ' IS THE SQUARE OF ', NumMin2);
Write ('AND WAS FORMED BY EXCHANGING ', Min);
Writeln (' PAIRS OF DIGITS');
end.