home *** CD-ROM | disk | FTP | other *** search
/ Carousel Volume 2 #1 / carousel.iso / mactosh / lang / mod2.hqx / m2-2.pit / Magic.MOD < prev    next >
Encoding:
Text File  |  1985-04-18  |  5.2 KB  |  194 lines
  1. MODULE MagischePrimzahlenQuadrate;
  2.  
  3. (* Marcello Merkle , 18.4.85 *)
  4. (* Dieses Programm berechnet alle moeglichen Magischen-Primzahlen-Quadrate
  5.    (3*3)bis zu einer vorgegebener Primzahl. Loesungen die Spiegel- oder 
  6.    Rotationssymmetrisch sind werden dabei nicht angegeben.
  7.    Bsp:
  8.          17  89  71     Dies ist die kleinste Loesung.
  9.     113  59   5     Ihre Zeilen-/Kolonnen-/Diagonalensumme betraegt
  10.      47  29 101     177.
  11.      
  12.    Es wurde im Rahmen des VISionen Wettbewerb (Feb. 85) geschrieben.
  13.  *)
  14.      
  15. FROM Terminal IMPORT
  16.   Write, WriteString, WriteLn, Read, ReadString, ClearTerminal, BusyRead;
  17.   
  18. FROM InTerminal IMPORT
  19.   ReadI;
  20.   
  21. FROM Conversions IMPORT
  22.   ConvertInteger;
  23.  
  24. FROM M2Files IMPORT
  25.   File, eolc, Create, Close, WriteChar, SetTypeandCreator;
  26.  
  27. FROM OutFile IMPORT FWriteI, FWriteT, FWriteLn;
  28.  
  29.  
  30. CONST
  31.   maxim = 5000; (* maxim erhoehen fuer noch mehr Loesungen *)
  32.   maxi = (maxim-1) DIV 2; (* das Erathostenessieb ist ohne geraden Zahlen *)
  33.   sf = 15; (* Sicherheitsfaktor*2 >= MAX{1<=i<╣(maxim)}(Prim[i]-Prim[i+1]) *)
  34.   ESC = 33c;
  35.   
  36. VAR
  37.   sieb           : ARRAY[-sf..maxi+sf] OF BOOLEAN;
  38.   x,a,b,c,d, max,
  39.   anzLoes, viceC : INTEGER;
  40.   ch             : CHAR;
  41.   toFile,done,
  42.   quitFlag       : BOOLEAN;
  43.   fname          : ARRAY[0..30] OF CHAR;
  44.   str            : ARRAY[0..99] OF CHAR;
  45.   FType, FCreator: ARRAY[0..3] OF CHAR;
  46.   f              : File;
  47.   
  48.   PROCEDURE Erathostenes;
  49.   VAR
  50.     i,j,k : INTEGER;
  51.   BEGIN
  52.     FOR i:= -sf TO maxi+sf DO sieb[i]:= TRUE; END;
  53.     i:= 1; j:= 3; k:= 4;
  54.     REPEAT
  55.       REPEAT
  56.         sieb[k]:= FALSE; INC(k,j)
  57.       UNTIL k>maxi;
  58.       REPEAT INC(i) UNTIL sieb[i];
  59.       k:= 2*i*(i+1); j:= 2*i+1;
  60.     UNTIL k>maxi
  61.   END Erathostenes;
  62.  
  63.   PROCEDURE Suche(VAR offset:INTEGER);
  64.   BEGIN
  65.     REPEAT
  66.       INC(offset)
  67.     UNTIL sieb[x+offset] AND sieb[x-offset]
  68.   END Suche;
  69.   
  70.   PROCEDURE Overflow(offset:INTEGER): BOOLEAN;
  71.   BEGIN
  72.     RETURN (x+offset > max) OR (x-offset <= 1);
  73.   END Overflow;
  74.   
  75.   PROCEDURE SymPrim(offset:INTEGER):BOOLEAN;
  76.   BEGIN
  77.     RETURN sieb[x+offset] AND sieb[x-offset];
  78.   END SymPrim;
  79.  
  80.   PROCEDURE WriteInt(i,len:INTEGER);
  81.   VAR str: ARRAY [0..6] OF CHAR;
  82.   BEGIN
  83.     ConvertInteger(i,len,str);
  84.     WriteString(str);
  85.   END WriteInt;
  86.   
  87.   
  88.   
  89.   PROCEDURE Print(x,a,b,c,d: INTEGER);
  90.   VAR str: ARRAY [0..20] OF CHAR;
  91.   BEGIN
  92.     x:= 2*x+1;
  93.     a:= 2*a; b:= 2*b; c:= 2*c; d:= 2*d;
  94.     INC(anzLoes);WriteInt(anzLoes,3);
  95.     WriteString(". Loesung: ");
  96.     WriteInt(3*x,5); WriteLn;
  97.     WriteInt(x-a,5); WriteInt(x+d,5); WriteInt(x+c,5); WriteLn;
  98.     WriteInt(x+b,5); WriteInt(x  ,5); WriteInt(x-b,5); WriteLn;
  99.     WriteInt(x-c,5); WriteInt(x-d,5); WriteInt(x+a,5); WriteLn;
  100.     WriteLn;
  101.     IF toFile THEN
  102.       FWriteI(f, anzLoes,3); str:= ". Loesung: ";
  103.       FWriteT(f, str,11);
  104.       FWriteI(f, 3*x,5); FWriteLn(f);
  105.       FWriteI(f, x-a,5); FWriteI(f, x+d,5); FWriteI(f, x+c,5); FWriteLn(f);
  106.       FWriteI(f, x+b,5); FWriteI(f, x  ,5); FWriteI(f, x-b,5); FWriteLn(f);
  107.       FWriteI(f, x-c,5); FWriteI(f, x-d,5); FWriteI(f, x+a,5); FWriteLn(f);
  108.       FWriteLn(f);
  109.     END;
  110.     IF NOT(toFile) AND (anzLoes MOD 5 = 0) THEN
  111.       WriteString("...");
  112.       Read(ch); WriteLn; ClearTerminal;
  113.     ELSE BusyRead(ch);
  114.     END;
  115.     IF ch=ESC THEN quitFlag:= TRUE; END;
  116.   END Print;
  117.   
  118. BEGIN (*MagischePrimzahlenQuadrate*)
  119.  REPEAT
  120.   anzLoes:= 0; quitFlag:= FALSE;
  121.   WriteString
  122.    ("++++++++++++++ Alle  Magischen  Primzahlenquadrate 3*3 ++++++++++++++mam85");
  123.   WriteLn; WriteLn;
  124.   WriteString("Bis zu welcher Primzahl (nicht groesser als ");
  125.   WriteInt(maxim,4); WriteString(", exit=0) : ? ");
  126.   ReadI(max);
  127.   WHILE (max<0) OR (max>maxim) DO ReadI(max); END;
  128.   max:= (max-1) DIV 2; WriteLn;
  129.   WriteString("Loesungen auf Terminal ofer File (t/f): ");
  130.   Read(ch); WriteLn;
  131.   IF (ch = 'f') OR (ch = 'F') THEN
  132.     toFile:= TRUE ELSE toFile:= FALSE
  133.   END;
  134.   IF toFile THEN
  135.     WriteLn;
  136.     WriteString("Gib einen Namen fuer das File an :");
  137.     ReadString(fname); WriteLn;
  138.     Create(f,fname,done);
  139.     IF NOT done THEN
  140.       WriteString("Nicht geoeffnet, normaler Terminaloutput.");
  141.       toFile:= FALSE;
  142.     ELSE
  143.       str:= "+++ Alle Magischen Primzahlenquadrate bis";
  144.       FWriteT(f,str,41);
  145.       ConvertInteger(2*(max+1),5,str);
  146.       FWriteT(f,str,5);
  147.       str:= " +++";
  148.       FWriteT(f,str,4);
  149.       FWriteLn(f); FWriteLn(f);
  150.     END;
  151.   ELSE
  152.     ClearTerminal;
  153.   END;
  154.   Erathostenes;
  155.   x:= 59 DIV 2;(* erste Loesung *)
  156.   REPEAT
  157.     c:= 0;
  158.     Suche(c);
  159.     REPEAT
  160.       d:= c;
  161.       Suche(d); viceC:= d;
  162.       LOOP
  163.         a:= c+d;
  164.     b:= a+c;
  165.     IF Overflow(b) THEN EXIT END;
  166.     IF SymPrim(a) THEN
  167.       IF SymPrim(b)  THEN Print(x,a,b,c,d) END;
  168.       b:= a+d;
  169.       IF NOT(Overflow(b)) AND SymPrim(b) THEN
  170.         Print(x,a,b,d,c);
  171.         IF quitFlag THEN EXIT; END
  172.       END;
  173.     END;
  174.     Suche(d);
  175.       END;(*LOOP*)
  176.       c:= viceC;
  177.     UNTIL (c=d) OR quitFlag;
  178.     REPEAT INC(x) UNTIL sieb[x];
  179.   UNTIL (x>max) OR quitFlag;
  180.   IF toFile THEN 
  181.     IF quitFlag THEN
  182.       FWriteLn(f);
  183.       str:= "mit ESC abgebrochen...";
  184.       FWriteT(f, str, 22); FWriteLn(f);
  185.     END;
  186.     FType:= "TEXT"; FCreator:= "EDIT";
  187.     SetTypeandCreator(f,FType, FCreator, done);
  188.     Close(f,done);
  189.     IF NOT done THEN WriteString('ERROR: File not closed'); END;
  190.   END;
  191.   WriteString("Das war's."); WriteLn;
  192.   WriteString("..."); Read(ch); ClearTerminal;
  193.  UNTIL max=0;
  194. END MagischePrimzahlenQuadrate.(c)MaM85