Zauberquadrat ermitteln

[kwhk]

In einem etwas älteren Buch "Die Wunder der Rechenkunst" von Johann Christoph Schäfer, das 1857 erstmalig erschienen ist, gibt es u.a. Aufgaben zu Zauberquadraten 3x3, 4x4, 5x5 usw.
Dabei sind z.B. in einem 3x3 Quadrat die Ziffern 1 bis 9 so in die 9 Felder einzutragen, dass die Summen der Ziffern jeder Zeile, Spalte und Diagonale jeweils gleich sind.
Die Summe der Ziffern 1 bis 9 beträgt 45, es muss also die Zeilen-, Spalten- und Diagonalen-Summe jeweils 15 sein.
Die Anzahl der Kombinationsmöglichkeiten von n Elementen betragt n!. Bei 9 Ziffern sind das 9! = 1*2*3*4*5*6*7*8*9 = 362.880 Möglichkeiten.

Mein Lösungsansatz z.B. beim 3x3 Quadrat:
a) Die 9 Ziffern in eine Reihe stellen,
b) dann jeweils die ersten drei Ziffern dieser Reihe in Zeile 1,
c) die nächsten drei in Zeile 2
d) und die letzten drei in die 3. Zeile.
e) Danach prüfen, ob die Summen der Zeilen, Spalten und Diagonalen jeweils identisch sind.
f) Wenn es (noch) nicht stimmt, dann die Ziffern in der Reihe tauschen und erneut probieren, bis man die Lösung gefunden hat.

Ausgangsreihe = 1 2 3 - 4 5 6 - 7 8 9

Durch Probieren herausgefunden = 8 3 4 - 1 5 9 - 6 7 2

Zauberquadrat 3x3 :

8 3 4
1 5 9
6 7 2

Mit welchem Algorithmus könnte man diese Elemente der Reihe so umtauschen, dass alle 382.880 Möglichkeiten durchgespielt werden können ? Es ist eine Aufgabe der Kombinatorik.

[Amateurprofi]

So vielleicht?
Ist recht langsam, scheint aber zu funktionieren.
Wenn du es laufen lässt: Nicht die Geduld verlieren, braucht ein paar Sekunden.

Meines Wissens gibt es für die Kantenlänge 3 insgesamt 8 Lösungen, eigentlich nur eine, die anderen sind Spiegelungen / Drehungen.
Für andere Kantenlängen brauchst Du nur die Konstante "Size" ändern. Aber dann dauert es richtig lange.

Delphi-Quellcode:

PROCEDURE GetMagicSquares;
const
   Size=3;
   Numbers=Size*Size;
   RowSum=(1+Numbers)*Numbers div 2 div Size;
var
   Combi:Array[0..Numbers-1] of Byte;
   Square:Array[0..Size-1,0..Size-1] of Byte absolute Combi;
FUNCTION NextCombi:Boolean;
var I,J:Integer;
begin
   for I:=High(Combi) downto 0 do
      if Combi[I]<Numbers then begin
         Inc(Combi[I]);
         for J:=I+1 to High(Combi) do Combi[J]:=1;
         Exit(True);
      end;
   Result:=False;
end;

FUNCTION CheckCombi:Boolean;
var I:Integer; Entries:Set of 1..Numbers;
begin
   Entries:=[];
   for I:=High(Combi) downto 0 do Include(Entries,Combi[I]);
   Result:=Entries=[1..Numbers];
end;

FUNCTION CheckMagic:Boolean;
var I,J,RSum,CSum,D1Sum,D2Sum:Integer;
begin
   D1Sum:=0;
   D2Sum:=0;
   for I:=0 to Size-1 do begin
      Inc(D1Sum,Square[I,I]);
      Inc(D2Sum,Square[I,Size-1-I]);
      RSum:=0;
      CSum:=0;
      for J:=0 to Size-1 do begin
         Inc(RSum,Square[I,J]);
         Inc(CSum,Square[J,I]);
      end;
      if (RSum<>RowSum) or (CSum<>RowSum) then Exit(False);
   end;
   Result:=(D1Sum=RowSum) and (D2Sum=RowSum);
end;

PROCEDURE WriteSquare(var F:TextFile; Count:Integer);
var R,C:Integer; S:String;
begin
   S:=IntToStr(Count)+') ';
   for R:=0 to Size-1 do begin
      for C:=0 to Size-1 do S:=S+IntToStr(Square[R,C])+' ';
      if R<Size-1 then S:=S+'- ';
   end;
   Writeln(F,S);
end;

var I,Count:Integer; F:TextFile; Dsn:String;
begin
   Dsn:=ExtractFilePath(ParamStr(0))+'MagicalSquares_'+IntToStr(Size)+'.txt';
   AssignFile(F,Dsn);
   Rewrite(F);
   Count:=0;
   for I:=0 to High(Combi) do Combi[I]:=I+1;
   while NextCombi do
      if CheckCombi then
         if CheckMagic then begin
            Inc(Count);
            WriteSquare(F,Count);
         end;
   CloseFile(F);
   ShowMessage('Datei "'+Dsn+'" erstellt, '+IntToStr(Count)+' Lösungen.');
end;

[Schokohase]

Das nennt sich Permutation und eben nicht Kombination (Kombinatorik).

Statt alles irgendwie zu durchlaufen und dann auf eine gültige Permutation zu prüfen, kann man auch direkt die Permutationen erzeugen lassen, was erheblich schneller geht.

Ein Beipiel:

Delphi-Quellcode:

program Project1;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  System.SysUtils, System.Generics.Collections;

type
  TArray = class abstract( System.Generics.Collections.TArray )
  private
    class procedure InternalPermute<T>( const Values: TArray<T>; const Current: TArray<T>; const Callback: TProc < TArray < T >> );
  public
    class procedure Permute<T>( const Values: TArray<T>; const Callback: TProc < TArray < T >> );
  end;

  { TArray }

class procedure TArray.InternalPermute<T>( const Values: TArray<T>; const Current: TArray<T>; const Callback: TProc < TArray < T >> );
var
  validx:                  Integer;
  nextValues, nextCurrent: TArray<T>;
begin
  if Length( Values ) = 0
  then
    Callback( Current )
  else
    begin
      for validx := Low( Values ) to High( Values ) do
        begin
          SetLength( nextValues, Length( Values ) );
          TArray.Copy<T>( Values, nextValues, Length( Values ) );
          Delete( nextValues, validx, 1 );
          nextCurrent := Current + [Values[validx]];

          InternalPermute( nextValues, nextCurrent, Callback );
        end;
    end;
end;

class procedure TArray.Permute<T>( const Values: TArray<T>; const Callback: TProc < TArray < T >> );
begin
  InternalPermute<T>( Values, [], Callback );
end;

function IsMagicSquare( const Values: TArray<Integer> ): Boolean;
var
  v:     Integer;
  size:  Integer;
  row:   Integer;
  col:   Integer;
  csums: TArray<Integer>;
  rsums: TArray<Integer>;
  dsums: TArray<Integer>;
begin
  size := Round( Sqrt( Length( Values ) ) );
  if size * size <> Length( Values )
  then
    raise Exception.Create( 'Fehlermeldung' );

  SetLength( rsums, size );
  SetLength( csums, size );
  SetLength( dsums, 2 );

  dsums[0] := 0;
  dsums[1] := 0;

  for row := 0 to size - 1 do
    begin
      v := Values[row * size + row];
      Inc( dsums[0], v );
      v := Values[row * size + size - 1 - row];
      Inc( dsums[1], v );
      rsums[row] := 0;
      csums[row] := 0;
      for col    := 0 to size - 1 do
        begin
          v := Values[row * size + col];
          Inc( rsums[row], v );
          v := Values[col * size + row];
          Inc( csums[row], v );
        end;
    end;

  if dsums[0] <> dsums[1]
  then
    Exit( false );

  for row := 0 to size - 1 do
    if ( rsums[row] <> dsums[0] ) or ( csums[row] <> dsums[0] )
    then
      Exit( false );

  Result := True;
end;

procedure WriteSquare( const Values: TArray<Integer> );
var
  size:     Integer;
  row, col: Integer;
begin
  size := Round( Sqrt( Length( Values ) ) );
  if size * size <> Length( Values )
  then
    raise Exception.Create( 'Fehlermeldung' );

  for row := 0 to size - 1 do
    begin
      for col := 0 to size - 1 do
        begin
          Write( Values[row * size + col], ' ' );
        end;
      WriteLn;
    end;
end;

var
  counter, cmagic: Integer;

begin
  try
    counter := 0;
    cmagic  := 0;
    TArray.Permute<Integer>( [1, 2, 3, 4, 5, 6, 7, 8, 9],
        procedure( v: TArray<Integer> )
      begin
        Inc( counter );

        if IsMagicSquare( v )
        then
          begin
            Inc( cmagic );
            WriteSquare( v );
            WriteLn;
          end;
      end );
    WriteLn( counter, ' - ', cmagic );
  except
    on E: Exception do
      WriteLn( E.ClassName, ': ', E.Message );
  end;
  ReadLn;

end.

Eine Zeitmessung ist quasi überflüssig, denn das Ergebnis ist quasi sofort da.

Code:

2 7 6
9 5 1
4 3 8

2 9 4
7 5 3
6 1 8

4 3 8
9 5 1
2 7 6

4 9 2
3 5 7
8 1 6

6 1 8
7 5 3
2 9 4

6 7 2
1 5 9
8 3 4

8 1 6
3 5 7
4 9 2

8 3 4
1 5 9
6 7 2

362880 - 8

[kwhk]

Hallo Klaus,
vielen Dank für Deinen Code, er funktioniert !

NextCombi ändert die Belegung des Arrays, dabei entstehen doppelte Ziffern dafür fehlen welche.

CheckCombi prüft, ob von NxtCombi zulässige Belegungen erzeugt wurden, wen ja, dann result=TRUE.

CheckMagic prüft, ob die Bedingungen für das Zauberquadrat erfüllt sind.

Wenn Du mir noch ein paar Hinweise zu CheckCombi geben könntest, den dort benutzten Code habe ich bisher noch nie benutzt oder gesehen.

Delphi-Quellcode:

const
    Size=3;
    Numbers=Size*Size;
    RowSum=(1+Numbers)*Numbers div 2 div Size;
var
    Combi:Array[0..Numbers-1] of Byte;
    Square:Array[0..Size-1,0..Size-1] of Byte absolute Combi;

FUNCTION CheckCombi:Boolean;
var I:Integer; Entries:Set of 1..Numbers;
begin
    Entries:=[];
    for I:=High(Combi) downto 0 do Include(Entries,Combi[I]);
    Result:=Entries=[1..Numbers];
end;

Die Anweisung Include(Entries,Combi[I]); fügt offenbar die Zahl Combi[I] in Entries ein.
Mit Entries=[1..Numbers] wird geprüft, ob tatsächlich nur die Ziffern z.B. 1..9 in Combi enthalten sind.
Gibt es doppelte oder fehlende Ziffern, ist das Ergebnis FALSE.

@Schokohase,
Deine Version werde ich prüfen, wenn sie schneller ist, dann wäre das ein Vorteil.

Noch eine Anmerkung
Die Permutation ist ein Teil der Kombinatorik
https://www.mathebibel.de/kombinatorik
https://www.mathebibel.de/permutation-ohne-wiederholung

Danke für Euere Hinweise

[kwhk]

@Schokohase

Delphi-Quellcode:

//   TArray.Permute<Integer>( [1, 2, 3, 4, 5, 6, 7, 8, 9],
   TArray.Permute<Integer>( [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16],

]
Ich habe diese Anweisung geändert, um ein 4x4 Quadrat zu berechnen.
Da bleibt das Programm hängen.
Was mache ich falsch ?

[Schokohase]

Bei 9 Zahlen haben wir 9! = 362.880 Permutationen.
Bei 16 Zahlen haben wir 16! = 20.922.789.888.000 Permutationen.

Das sind mal eben so 57.657.600 mal mehr Permutationen als bei 9 Zahlen.
Davon ausgehend, dass wir für diese 9 Zahlen ungefähr eine viertel Sekunde zum Berechnen brauchen, würde ich das Ergebnis in frühestens 166,8 Tagen erwarten.

Was du falsch machst: Du bist zu ungeduldig.

[Amateurprofi]

@kwhk:

Zu CheckCombi:

Delphi-Quellcode:

const
     Size=3;
     Numbers=Size*Size;
     RowSum=(1+Numbers)*Numbers div 2 div Size;
var
     Combi:Array[0..Numbers-1] of Byte;
     Square:Array[0..Size-1,0..Size-1] of Byte absolute Combi;

FUNCTION CheckCombi:Boolean;
var I:Integer; Entries:Set of 1..Numbers;
begin
     Entries:=[];
     for I:=High(Combi) downto 0 do Include(Entries,Combi[I]);
     Result:=Entries=[1..Numbers];
end;

Das in der Prozedur deklarierte "Entries" ist ein Set, das die Elemente 1 bis Numbers enthalten kann.
Wenn du einem Set ein Element mehrfach hinzufügst, ist es im Set trotzdem nur einmal enthalten.
Erste Zeile:
"Entries" wird = [] gesetzt, das Set enthält dann nichts.
Zweite Zeile:
Alle Werte aus "Combi" werden zu "Entries" hinzugefügt.
Dritte Zeile:
Prüft, ob "Entries" = [1,2,3, ...,Numbers] ist, anders ausgedrückt ob "Entries" alle Werte von 1 bis Numbers enthält.
Wenn das der Fall ist, sind in "Combi" die Werte von 1 bis Numbers, die Combi (korrekterweise die Permutation, wie Schokohase anmerkte) ist dann wirklich eine Permutatation der Werte 1..Numbers.
Sorry, bin nicht so gut im Erklären.

[kwhk]

Hallo Klaus,
es ist eine gute Erklärung.
Wahrscheinlich werden die einzelnen Elemente eines SETs auch noch sortiert.
Ansonsten wäre [1,2,3] <> [1,3,2], obwohl beide Sets die gleichen Elemente enthalten.

Man könnte das Programm beenden, wenn die erste Lösung gefunden wird, da die anderen Lösungen ja nur Spiegelungen sind, die man viel schneller anders ermitteln könnte, falls man das will.
Eigentlich wollte ich ja nur EINE Lösung, das kann ich aber ins Programm einbauen, dann geht es evtl. auch bei 4x4 und größer schneller.

[Schokohase]

Das wage ich zu bezweifeln. Bei 4x4 und größer wirst du ein anderes Verfahren benötigen als das mit den Permutationen.

Backtracking wie man bei Sudoku verwendet wäre z.B. eine Möglichkeit um wesentlich schneller ans Ziel zu gelangen

[KodeZwerg]

Im Anhang noch etwas aus meinem Fundus, die original Webseite existiert nicht mehr.
Dieses Demo ist für 3x3 ausgelegt, auch Graphiken dazu werden eingeblendet.

Ich hoffe es ist ne Berreicherung für diesen Thread,

viel Spass damit.

Ps: Der Anhang ist der Source only release, mit D2010 und Tokyo ließ es sich problemlos kompilieren, habe aber nicht auf Warnungen (falls vorhanden) geachtet, nur obs funktioniert.