{Start of file Golygon.Pas *************************************************}
Program Golygon; { Converted from Apple II+ Pascal to Turbo Pascal 5.0 }
{ and changed from SextPrime to Golygon }
{ 90/07/08 by Harry Smith, Saratoga CA }
uses Crt,
PrimeInt; { Algorithm 357 - Collected Algorithms from ACM }
{ An Efficient Prime Number Generator }
{ Driver Generates all the primes < about 2**31 }
{ and displays Sextet Primes }
const
Name = 'Golygon - Generates and Records n-Sided Golygon';
Version = 'Version 1.00, last revised: 90/09/02 0600 hours';
Author = 'Copyright (c) 1981-1990 by author: Harry J. Smith,';
Address = '19628 Via Monte Dr., Saratoga CA 95070. All rights reserved.';
{***************************************************************************}
{ Developed in Turbo Pascal 5.0 }
{ Generates and records 8-Sided Golygon Integers. See Scientific American,
July 1990, Mathematical Recreations.
}
type
SignsType = array[1..128] of Char; { Table of Signs N/S or E/W }
var
Sides : Integer;
GType : String[11]; { Integers, Primes, or Twin Primes }
SidesSt : String[3];
FileSt : String[12]; { Integers, Primes, or Twin Primes }
GTypeCh : Char; { I = Integers, P = Primes, T = Twin Primes }
Verbose : Char; { Limit output flag, L = Limit it, V = Verbose }
FoundAn : Integer; { Number of Sum Types found starting with E[1] }
FoundBn : Integer; { Number of Sum Types found starting with E[2] }
FoundABn: Integer; { Number of Sum Types found with same + and -'s` }
AnBn : LongInt; { FoundAn * FoundBn }
Total : LongInt; { Total golygons found }
TestN : Integer; { Sum Type, 1 thru MaxTest, being tested }
MaxTest : Integer; { Max Sum Type for "Sides"}
{ IP : PrimeStore; . Working storage for primes, defined in Prime4By }
Max : LongInt; { Maximum integer tested }
MaxIn : LongInt; { Maximum integer tested from command line}
I : Integer; { Utility index }
J : Integer;
K : Integer;
L : Integer;
N : Integer;
A1 : Integer; { Number of sum types in 1st set with = + and - }
A2 : Integer; { Number of sum types in 2nd set with <> + and - }
B2 : Integer; { Number of sum types in 2st set with <> + and - }
Ch : Char;
M : Integer; { Number of primes each call }
St : String;
Disk : Text;
OutP : ^Text;
Done : Boolean;
Done1 : Boolean;
TypeA : array[1..1280] of Integer;
TypeB : array[1..1280] of Integer;
TypeAB : array[1..1280] of Integer; { Ones with the same number of + and - }
E : array[1..128] of LongInt; { Elements of set with "Sides" sides }
NSEW : SignsType; { Table of Signs N/S, E/W }
FirstI : Boolean; { True if E[1] = 1 and GType = Integers }
Batch : Boolean; { True if running in batch mode, no pauses }
{--------------------------------------}
procedure CloseIt;
begin
Str(E[Sides], St); St:= ConCat('Tested all integers <= ', St);
WriteLn(St); WriteLn(Disk, St);
Close(Disk)
end; { CloseIt }
{--------------------------------------}
procedure AbortIt;
begin
St:= 'Program aborted by operator';
WriteLn(St); WriteLn(Disk, St);
CloseIt;
Halt(0); { 27 = Esc }
end; { AbortIt }
{--------------------------------------}
procedure TestIt;
begin
while Keypressed do Ch:= ReadKey;
WriteLn(E[Sides]:8);
if Ord(Ch) = 27 then AbortIt;
end; { TestIt }
{--------------------------------------}
procedure Credits;
begin
ClrScr;
WriteLn;
WriteLn( Name);
WriteLn( Version);
WriteLn( Author);
WriteLn( Address);
WriteLn;
end; { Credits }
{--------------------------------------}
procedure Init; { Initialize program }
begin
TextBackground( Black);
TextColor( Yellow);
Credits;
GTypeCh:= GType[1];
Str(Sides, SidesSt);
if Sides < 10 then SidesSt:= '0' + SidesSt;
FileSt:= 'Goly' + GTypeCh + SidesSt + '.Out';
Write('Will write file: ', FileSt);
if Verbose = 'V' then WriteLn(' (Verbose output)');
if Verbose = 'L' then WriteLn(' (Limited output)');
if Verbose = 'M' then WriteLn(' (Minimal output)');
WriteLn;
Str(MemAvail, St); St:= ConCat('MemAvail=', St);
WriteLn(St);
if not Batch then begin
WriteLn('Type any key to continue... (or Esc to quit)');
Ch:= ReadKey;
if Ord(Ch) = 27 then Halt(0);
end;
WriteLn;
Assign(Disk, FileSt);
ReWrite(Disk);
WriteLn(Disk, St);
OutP:= @OutPut;
for K:= 1 to 2 do begin
WriteLn(OutP^, 'Tests all integers <= ', Max);
WriteLn(OutP^, 'Generates ', Sides, '-Sided Golygon ', GType);
WriteLn(OutP^);
OutP:= @Disk;
end;
IP[1]:= -1;
M:= Sides - 1;
N:= NPrime(M);
for I:= 1 to M do E[I]:= IP[I];
M:= 1;
E[1]:= 1; {For odd primes}
MaxTest:= 1;
for I:= 1 to (Sides div 2 - 1) do
MaxTest:= 2 * MaxTest;
MaxTest:= MaxTest - 1;
Done:= False;
FoundABn:= 0;
Total:= 0;
FirstI:= False;
if GTypeCh = 'P' then begin
end
else if GTypeCh = 'I' then begin
FirstI:= True;
for I:= 1 to Sides do begin
E[I]:= I;
end;
end
else if GTypeCh = 'T' then begin
repeat
N:= NPrime(M);
E[Sides]:= IP[1];
Done1:= True;
J:= Sides + 1;
for I:= 1 to Sides div 2 do begin
J:= J - 2;
if E[J + 1] - E[J] <> 2 then Done1:= False;
end;
if not Done1 then begin
for I:= 1 to Sides - 1 do E[I]:= E[I + 1];
end;
if E[Sides] >= Max then Done:= True;
if KeyPressed then TestIt
until Done or Done1;
end;
end; { Init }
{--------------------------------------}
function SumIt(First, TestN : Integer) : LongInt;
var
Sum : LongInt;
I, J : Integer;
begin
if KeyPressed then TestIt;
Sum:= E[First]; J:= Sides + First;
for I:= 0 to Sides div 2 - 2 do begin
J:= J - 2;
if ((TestN ShR I) mod 2) = 0 then
Sum:= Sum + E[J]
else
Sum:= Sum - E[J];
end;
SumIt:= Sum;
end; { SumIt }
{--------------------------------------}
procedure SetSigns(TypeA, TypeB : Integer; var NSEW : SignsType);
var I, J : Integer;
begin { SetSigns }
J:= Sides + 1;
for I:= 0 to Sides div 2 - 1 do begin
J:= J - 2;
if ((TypeA ShR I) mod 2) = 0 then
NSEW[J]:= 'N'
else
NSEW[J]:= 'S';
if ((TypeB ShR I) mod 2) = 0 then
NSEW[J + 1]:= 'E'
else
NSEW[J + 1]:= 'W';
end;
end; { SetSigns }
{--------------------------------------}
procedure Goly; { Main portion of driver }
begin { Goly }
Init;
repeat
if GTypeCh = 'P' then begin
N:= NPrime(M);
E[Sides]:= IP[1];
end
else if GTypeCh = 'I' then begin
E[Sides]:= 1 + E[Sides - 1];
end
else if GTypeCh = 'T' then begin
repeat
if KeyPressed then TestIt;
N:= NPrime(M);
E[Sides]:= IP[1];
Done1:= True;
J:= Sides + 1;
for I:= 1 to Sides div 2 do begin
J:= J - 2;
if E[J + 1] - E[J] <> 2 then Done1:= False;
end;
if not Done1 then begin
for I:= 1 to Sides - 1 do E[I]:= E[I + 1];
end;
if E[Sides] >= Max then Done:= True;
until Done or Done1;
end;
{ Diagnostic
WriteLn;
for I:= 1 to Sides do
Write(E[I], ' ');
WriteLn(' <-- Primes, Sums -->');
for TestN:= 1 to MaxTest do
Write(SumIt(1, TestN), ' ');
WriteLn('<- 1st set, 2nd set ->');
for TestN:= 1 to MaxTest do
Write(SumIt(2, TestN), ' ');
WriteLn;
Ch:= ReadKey;
}
FoundAn:= 0; FoundBn:= 0;
for TestN:= 1 to MaxTest do begin { Find zero sums in the N/S set }
if SumIt(1, TestN) = 0 then begin
FoundAn:= FoundAn + 1;
TypeA[ FoundAn]:= TestN;
end;
end;
if FoundAn <> 0 then begin
for TestN:= 1 to MaxTest do begin { Find zero sums in the E/W set }
if SumIt(2, TestN) = 0 then begin
FoundBn:= FoundBn + 1;
TypeB[ FoundBn]:= TestN;
end;
end;
end;
if FirstI then begin
{ Save sum-types that are in both TypeA and TypeB, these are
the ones with the same number of + and - operations. }
FoundABn:= 0;
for I:= 1 to FoundAn do begin
for J:= 1 to FoundBn do begin
if TypeA[I] = TypeB[J] then begin
FoundABn:= FoundABn + 1;
TypeAB[ FoundABn]:= TypeA[I];
end;
end;
end;
OutP:= @OutPut;
for K:= 1 to 2 do begin
Write(OutP^, FoundABn,
' Sum type(s) found with the same number of + and - : S = [');
for I:= 1 to FoundABn do Write(OutP^, ' ', TypeAB[I]);
WriteLn(OutP^, '].');
WriteLn(OutP^);
OutP:= @Disk;
end;
end;
if FoundBn <> 0 then begin
A1:= FoundABn; { B1:= A1; }
A2:= FoundAn - A1;
B2:= FoundBn - A1;
OutP:= @OutPut;
AnBn:= LongInt(FoundAn) * FoundBn;
if not FirstI then AnBn:= AnBn - LongInt(A1) * A1;
if AnBn > 0 then begin
Total:= Total + AnBn;
for K:= 1 to 2 do begin
Write(OutP^, 'G', Sides, ',', GTypeCh, E[1], ' ');
if FirstI or (A1 = 0) then Write(OutP^, FoundAn, ' x ', FoundBn)
else
Write(OutP^, A1, ' x ', B2, ' + ',
A2, ' x ', A1, ' + ',
A2, ' x ', B2);
Write(OutP^, ' = ', AnBn, ' Total = ', Total);
if Verbose <> 'M' then begin
Write(OutP^, ' [');
if A1 <> 0 then Write(OutP^, 'S');
for I:= 1 to FoundAn do begin
L := TypeA[I];
for J:= 1 to A1 do if L = TypeAB[J] then L:= 0;
if L <> 0 then Write(OutP^, ' ', L);
end;
Write(OutP^, '] [');
if A1 <> 0 then Write(OutP^, 'S');
for I:= 1 to FoundBn do begin
L := TypeB[I];
for J:= 1 to A1 do if L = TypeAB[J] then L:= 0;
if L <> 0 then Write(OutP^, ' ', L);
end;
Write(OutP^, ']');
end;
WriteLn(OutP^);
OutP:= @Disk;
end;
end;
if Verbose = 'V' then begin
for I:= 1 to FoundAn do begin
for J:= 1 to FoundBn do begin
L := TypeA[I];
if not FirstI then begin
for K:= 1 to FoundABn do if L = TypeAB[K] then L:= 0;
if L = 0 then begin
L := TypeB[J];
for K:= 1 to FoundABn do if L = TypeAB[K] then L:= 0;
end;
end;
if L <> 0 then begin
SetSigns(TypeA[I], TypeB[J], NSEW);
OutP:= @OutPut;
for K:= 1 to 2 do begin
Write(OutP^, 'G', Sides, ',', GTypeCh, E[1], ',',
TypeA[I], ',', TypeB[J], ' = ');
for L:= 1 to Sides do begin
Write(OutP^, E[L], NSEW[L]);
if L <> Sides then Write(Outp^, ' ');
end;
WriteLn(OutP^);
OutP:= @Disk;
end;
end;
end;
end;
end;
end;
for I:= 1 to Sides - 1 do E[I]:= E[I + 1];
FirstI:= False;
{ Diagnostic
WriteLn('IQ JQ');
for I:= 1 to N do
WriteLn('I=', I, ' IQ=', IQ[I], ' JQ=', JQ[I])
}
if E[Sides] >= Max then Done:= True;
until Done;
CloseIt;
end; { Goly }
{--------------------------------------}
begin { Golygon }
if ParamCount = 0 then begin
Credits;
WriteLn('Usage: Golygon sides [I, P, T] [max_integer_to_test]',
' [V, L, M] [B]');
WriteLn(' Parameters:');
WriteLn(' 1)');
WriteLn(' 6 <= sides <= 32 and even');
WriteLn(' 2)');
WriteLn(' I -> Integers, P -> Primes, T -> Twin primes');
WriteLn(' 3)');
WriteLn(' 0 <= max_integer_to_test <= ', MaxT, ', 0 -> ', MaxT);
WriteLn(' 4)');
WriteLn(' V -> Total output, verbose');
WriteLn(' L -> Limit the output, non-verbose');
WriteLn(' M -> Minimal output');
WriteLn(' 5)');
WriteLn(' B -> Batch mode, no pauses');
WriteLn;
Halt(0);
end;
Val(ParamStr(1), Sides, I);
if I <> 0 then Sides:= 0;
Sides:= 2 * (Sides div 2);
if Sides < 6 then Sides:= 6;
if Sides > 32 then Sides:= 32;
GType:= 'I';
if ParamCount > 1 then GType:= ParamStr(2);
If UpCase(GType[1]) = 'P' then GType:= 'Primes'
else If UpCase(GType[1]) = 'T' then Gtype:= 'Twin Primes'
else GType:= 'Integers';
Max:= MaxT;
MaxIn:= 0;
if ParamCount > 2 then begin
Val(ParamStr(3), MaxIn, I);
if MaxIn > MaxT then MaxIn:= MaxT;
if MaxIn < 1 then MaxIn:= MaxT;
if I <> 0 then MaxIn:= 0
else Max := MaxIn;
end;
St:= ParamStr(4);
Verbose:= 'V';
if (ParamCount > 3) and (UpCase(St[1]) = 'L') then Verbose:= 'L';
if (ParamCount > 3) and (UpCase(St[1]) = 'M') then Verbose:= 'M';
St:= ParamStr(5);
Batch:= False;
if (ParamCount > 4) and (UpCase(St[1]) = 'B') then Batch:= True;
Goly;
end. { Golygon }
{End of file Golygon.Pas ***************************************************}
times since October 20, 2004.