Program MagQuad;

{ Aufgabe : Erstellen magischer Quadrate unter DOS
  Autor   : Jan Theofel, jan@theofel.de
  Version : 1.01
  Stand   : 20.11.1998

  Dieses Programm ist "PUBLIC DOMAIN", d.h. Sie duerfen den Sourcecode beliebig
  veraendern, kopieren und in eigene Programme Uebernehmen.

  Chronik :
    v1.0 (26.11.1997):
    - Erstellt magische Quadrate der Ordnung 3 bis 20
    v1.01 (20.11.1998):
    - Korrektur der Umlaute, so dass sie immer lesbar sind (ae, ...)
  }

uses
  Crt; { wird zur Bildschirmausgabe benoetigt }

var
  order  : byte; { ordnung des magischen Quadrats }
  square : array[1..20,1..20] of word;
                 { magisches Quadrat (zweidimensionales Array }


{ ------------------------------------------------------------------------- }
{               Proceduren zum Fuellen des Quadrats                         }
{ ------------------------------------------------------------------------- }

{ ----- EmptySquare: Leer das magische Quadrat ---------------------------- }
procedure EmptySquare;
var x, y : Byte;
begin
  for x:=1 to 20 do   { jedes Feld mit zwei For-Schleifen auf 0 setzten }
    for y:=1 to 20 do
      square[x,y]:=0;
end;

{ --------- FillOdd: Faellt ein magisches Quadrat ungerader Ordnung -------- }
procedure FillOdd;
var
  x, y : byte; { Koordinaten des naechsten Kaestchens }
  z    : byte; { Zaehlervariable }
begin
  x:=order div 2 + 1;
  y:=1; { -> Feld in der Mitte oben }
  for z:=1 to order*order do
    begin
    { Zahl setzen ... }
    square[x,y]:=z;
    { ... und Platz fuer die naechste ermitteln: }
    if (z mod order)=0
      then begin { naechstes Feld belegt -> breakmove }
      y:=y+1;
      if y>order then y:=1; { wenn y ausserhalb, y wieder auf 1 setzten }
      end
      else begin { normal weiter }
      x:=x+1;
      y:=y-1;
      if x>order then x:=1; { wenn x ausserhalb, x wieder auf 1 setzten }
      if y=0 then y:=order; { wenn y ausserhalb, y wieder auf order setzten }
      end;
    end;
end;

{ --------- FillOddlyEven: Fuellt ein mag. Quadrat einfach gerader Ordnung - }
procedure FillOddlyEven;

  procedure Change(x, y : Byte);
  { tauscht zwei Zahlen aus der oberen und unteren Haelfe aus }
  var i : integer;
  begin
    i:=square[x,y];
    square[x,y]:=square[x,y+order div 2];
    square[x,y+order div 2]:=i;
  end;

  procedure FillUngerade(_x,_y,o:Byte; add:integer);
  { f�llt ein Viertel des magischen Quadrats }
  var x, y, nx, ny : Byte;
      z            : integer;
  begin
    x:=_x + o div 2;
    y:=_y; { -> Feld in der Mitte oben }
    for z:=1 to o*o do
      begin
      { Zahl setzen ... }
      square[x,y]:=z+add;
      { ... und Position fuer die naechsten ermitteln }
      if (z mod o)=0
        then begin { naechstes Feld belegt breakmove }
        y:=y+1;
        if y>_y+o-1 then y:=_y;
        end
        else begin { normal weiter }
        x:=x+1;
        y:=y-1;
        if x>_x+o-1 then x:=_x;
        if y<_y then y:=_y+o-1;
        end;
      end;
  end;

var
  x, y, cr, cl : byte;
  order_h      : byte; { =order div 2 (wird haeufiger benoetigt!) }
begin
  order_h:=order div 2;
  FillUngerade(1,1,order_h,0); { oben links fuellen }
  FillUngerade(order_h+1, order_h+1, order_h, sqr(order_h)); { unten rechts }
  FillUngerade(order_h+1, 1, order_h, 2*sqr(order_h)); { oben rechts }
  FillUngerade(1, order_h+1, order_h, 3*sqr(order_h)); { unten rechts }

  cl:=order div 4; { Anzahl, die links je Reihe getauscht wird }
  cr:=cl-1; { Anzahl, die rechts je Reihe getauscht wird }
  if cr<>0 then { wenn rechts getauscht werden muss ... }
    for x:=order-cr+1 to order do { ... rechten Rand tauschen }
      for y:=1 to order div 2 do
        Change(x,y);
  for x:=1 to cl do { links wird mindestens 1 getauscht! }
    begin
    for y:=1 to order div 2 do
      if y<>(order div 2) div 2 + 1
        then Change(x,y) { normal tauschen }
        else Change(x+1,y); { in der Mitte um 1 versetzt }
    end;
end;

{ --------- FillEven: Fuellt ein mag. Quadrat einfach- gerader Ordnung ----- }
procedure FillEven;

  procedure Change(x, y : Byte);
  { tauscht zwei Zahlen punktsymetrisch zum Ursprung }
  var i : integer;
  begin
    i:=square[x,y];
    square[x,y]:=square[order+1-x, order+1-y];
    square[order+1-x,order+1-y]:=i;
  end;

var
  x, y : Byte;
begin { fillvier }
  for x:=1 to order do { ganz "normal" fuellen }
    for y:=1 to order do
      square[x,y]:=(y-1)*order+x;
  for y:=1 to order div 2 do { nur obere Haelfte! }
    for x:=1 to order do { wenn auf der Diagonalen eines 4x4 Quadrats... }
      if (((x mod 4 = 1) or (x mod 4 = 0)) and
          ((y mod 4 = 1) or (y mod 4 = 0))) or
         (((x mod 4 = 2) or (x mod 4 = 3)) and
          ((y mod 4 = 2) or (y mod 4 = 3))) then
        Change(x,y); { ... dann austauschen }
end;

{ ---------- FillMagic: Fuellt ein magisches Quadrat beliebiger Ordnung ---- }
procedure FillMagic;
begin
  Emptysquare; { erst mal leeren }
  if Odd(order) { Auswahl der richtigen Bildungsmethode: }
    then FillOdd { fuer ungerade }
    else if Odd(order div 2)
      then FillOddlyEven { fuer einfach-gerade }
      else FillEven; { fuer doppelt-gerade }
end;

{---------------------------------------------------------------------------}
{                        H A U P T P R O G R A M M                          }
{---------------------------------------------------------------------------}

var
  key     : Char;         { zum Einlesen einer Taste }
  y, x    : byte;         { zum Sichern der Cursorposition }
  z       : byte;         { Zaehler bei der Ausgabe }
  s       : String;       { String, der Eingaben aufnimmt }
  error   : integer;      { Fehlerrueckmeldung von "val" }
  oldattr : byte;         { sichert die Farbe }

begin
  oldattr:=textattr; { Farbe sichern }
  Textmode(CO80+Font8x8); { Textmodus auf 80x50 }
  textbackground(lightgray); textcolor(red);
  { Kopf anzeigen: }
  clrscr;
  WriteLn;
  WriteLn('Magische Quadrate mit MAGQUAD fuer DOS - Version 1.01':60);
  writeln;
  writeln('Erstellt von Jan Theofel (1997-98)':53);
  WriteLn;
  textcolor(black);
  writeln('  Public domain - Sie duerfen dieses Programm beliebig veraendern und kopieren!');
  writeln;
  { Im unteren Bereich magische Quadrate anzeigen: }
  Window(1,8,80,50);
  textcolor(yellow); textbackground(blue);
  clrscr;
  key:='J';
  while key='J' do
    begin
    Write(' Welche ordnung? (3-20) ');
    x:=WhereX; y:=WhereY;
    repeat { Ordnung einlesen, mit Fehlerabfrage }
      GotoXY(x,y);
      ClrEol;
      ReadLn(s);
      VAL(s, order, error);
      if (error<>0) or (order<3) or (order>20) { wenn Fehleingabe ... }
        then write(#7); { ... dann beepen }
    until (error=0) and (order in [3..20]);
    FillMagic; { magisches Quadrat erzeugen }
    WriteLn;
    { Ordnung und magische Summe ausgeben: }
    WriteLn(' Ihr magisches Quadrat: (ordnung: ',order,
      '; Magische Summe: ',(order*order*order+order) div 2,')');
    { magisches Quadrat ausgeben: }
    Write('ÚÄÄÄ');
    for z:=1 to order-2 do
      Write('ÂÄÄÄ');
    if order<>20
      then WriteLn('ÂÄÄÄ¿')
      else Write('ÂÄÄÄ');
    for y:=1 to order do
      begin
      Write('³');
      for x:=1 to order-1 do
        Write(square[x,y]:3,'³');
      if order<>20
        then WriteLn(square[order,y]:3,'³')
        else Write(square[20,y]:3);
      if y<>order
        then begin
        Write('Ã');
        for z:=1 to order-1 do
          Write('ÄÄÄÅ');
        if order<>20
          then WriteLn('ÄÄÄ´')
          else Write('ÄÄÄ');
        end
        else begin
        Write('À');
        for z:=1 to order-1 do
          Write('ÄÄÄÁ');
        if order<>20
          then WriteLn('ÄÄÄÙ')
          else Write('ÄÄÄ');
        end;
      end;
    { weiter machen? }
    Write(' Wollen Sie noch ein magisches Quadrat erstellen? (j/n) ');
    while KeyPressed do { Tastaturpuffer leeren }
      key:=ReadKey;
    repeat { Taste einlesen ... }
      key:=Upcase(ReadKey);
      if not (key in ['J','N']) then write(#7);
    until key in ['J','N']; { ... bis Taste J oder N }
    WriteLn(key);
    end;
  Textmode(CO80);    { Textmodus auf 80x25 setzten }
  textattr:=oldattr; { Farben wiederherstellen }
  clrscr;            { Bildschirm loeschen }
  writeln('Bis zum naechsten Mal mit MAGQUAD fuer DOS v1.0!');
  writeln;
end.