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.