Golygons.Pas Program Listing




{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 ***************************************************}

Return to Golygons
Return to Harry's Home Page


This page accessed times since October 20, 2004.
Page created by: hjsmithh@sbcglobal.net
Changes last made on Saturday, 14-May-05 12:47:37 PDT

1