in reply to Re: magic squares
in thread magic squares

Henry Higgins: By George, she's got it, By George, she's got it. (or so I hope). I finally managed to debug the script and changed the solution strategy... and who do you think doesn't have a magic square to show the teacher?

Paul, that laggard!

The magic squares for the other students are:

John    = 10 15 8 14
     3 16  8
    14  9  4
    10  2 15

     C  P  H
     N  I  D
     J  B  O
Marty   = 13 1 18 20 25
     6 25  8
    15 13 11
    18  1 20

     F  Y  H
     O  M  K
     R  A  T
Sheila  = 19 8 5 9 12 1
     5 23  8
    15 12  9
    16  1 19

     E  W  H
     O  L  I
     P  A  S
Smack   = 19 13 1 3 11
     3 21  9
    17 11  5
    13  1 19

     C  U  I
     Q  K  E
     M  A  S
Suzy    = 19 21 26 25
    15 26 19
    24 20 16
    21 14 25

     O  Z  S
     X  T  P
     U  N  Y
Elsa    = 5 12 19 1
     3 19  8
    15 10  5
    12  1 17

     C  S  H
     O  J  E
     L  A  Q

no solution:
   Paul (16 1 21 12)

[download]

The solution was found by using a little algebra to calculate some contraints on the diagonal of the magic square. This included a maximum possible sum and some contraints on the relationship between the diagonal cell values.

With the diagonal and one other corner, it is possible to calculate the values in the remaining squares. So to find the solution, I generated all possible combinations of diagonals. And for every diagonal that fit the constraints, I searched for all possible values of a second corner. Clarification re: tilly below - "all possible combinations" until a diagonal for a valid magic square was found.

On my system the script took 0.69s between 0.40 and 0.48s to print the above output.

The code follows:

use strict;
use warnings;

use strict;
use warnings;

my $NUMBER_BASE = ord('a') - 1;
my @aNames =qw(John Marty Paul Sheila Smack Suzy Elsa);

printMagicNames(\@aNames, 26);

#==================================================================
# MAIN FUNCTION
#==================================================================

sub printMagicNames {
  my ($aNames, $iMax) = @_;

  my @aNoSolutions;
  foreach my $sName (@$aNames) {
    my $aRequired = getNumbersFromName($sName);
    my $aMagic = getMagicSquare($aRequired, $iMax);

    if ($aMagic) {
      print sprintf("%-8s= %s", $sName, "@$aRequired\n");
      printSolution($aMagic);
    }else {
      push(@aNoSolutions, "$sName (@$aRequired)");
    }
  }

  local $"="\n   ";
  print "\nno solution:\n   @aNoSolutions\n";
}

#==================================================================
# SUPPORTING FUNCTIONS
#==================================================================

#---------------------------------------------------------------------
+-

sub getNumbersFromName {
  my $sName = shift;
  return [ map { ord(lc($_)) - $NUMBER_BASE; } split(//,$sName) ];
}

#---------------------------------------------------------------------
+-

sub getMagicSquare {
  my ($aRequired, $iMax) = @_;

  # $sumAll=3*$sumDiag
  my $iLimitI=$iMax-2;
  my $sumMax=0; $sumMax+=$_ for (($iMax-8)..$iMax);
  $sumMax = int($sumMax/3);

  #get all possible diagonals ($i,$j,$k)
  for my $i (1..$iLimitI) {
    for my $j ($i+1..($iLimitI+1)) {
      my $iLimitK = $sumMax - $i - $j;
      $iLimitK = $iMax if ($iLimitK > $iMax);
      for my $k ($j+1..$iLimitK) {

        my $aMagic = getMagicSquareFromDiagonal
          ([$i,$j,$k], $aRequired, $iMax);
        return $aMagic if $aMagic;
      }
    }
  }
  return undef;
}

sub getMagicSquareFromDiagonal {
  my ($aDiagonal, $aRequired, $iMax) = @_;
  my @aDiagonal = @$aDiagonal;

  # 3*$sum=($x11+$x12+$x13+$x21+$x22+$x23+$x31+$x32+$x33);
  # 0 = $x11+$x33-$x31-$x13;
  # 3*$sum=2*($x11+$x33) + $x12+$x21+$x22+$x23+$x32
  # 3*$sum=2*($x11+$x33) + $x22 + $sumMiddleEdge

  # 2*$sum= $sumMiddleEdge + 2*$x22;
  # $sumMiddleEdge = 2*$sum - 2*$x22;
  # 3*$sum=2*($x11+$x33) + $x22 + 2*$sum - 2*$x22;
  # $sum=2*($x11+$x33) - $x22;

  # $x11+$x22+$x33=2*($x11+$x33) - $x22
  # 2*$x22=$x1+$x33

  my $sum = 0; $sum += $aDiagonal->[$_] for 0..2;
  for my $i (0..2) {
    # prescreen the diagonal using the above
    # calculated constraints

    my $x11 = $aDiagonal->[$i];
    my $x22 = $aDiagonal->[($i+1)%3];
    my $x33 = $aDiagonal->[($i+2)%3];

    #the uncommented test may be marginally faster
    # - but timing results are not consistent
    #next unless $sum == 2*($x11+$x33)-$x22;
    next unless ($x11+$x33) == (2*$x22);

    # get another corner: if we have one more corner
    # we can calculate the remaining cell values

    # Another speed improvement - good for about 30% increase
    # Note: we only need to search half of the range 1..$iMax
    # * if $x is not valid, then $sum - $x is also not valid
    # * if $x is valid, then $sum - $x is just the mirror image

    my $sumCattyCorners = $x11+$x33;
    my $iLimit = $sumCattyCorners%2
      ? ($sumCattyCorners+1)/2 : $sumCattyCorners/2;

    for my $x13 (1 .. $iLimit) {
    #for my $x13 (1 .. $iMax) {
      my $aSolution = [$x11,$x22,$x33];
      next if isInSolution($aSolution, $x13);
      push @$aSolution, $x13;

      my $x31 = $sumCattyCorners - $x13;
      next unless addToSolution($aSolution, $x31, $iMax);

      my $x12 = $sum - $x11 - $x13;
      next unless addToSolution($aSolution, $x12, $iMax);

      my $x21 = $sum - $x11 - $x31;
      next unless addToSolution($aSolution, $x21, $iMax);

      my $x32 = $sum - $x31 - $x33;
      #print "Diagonal: <$x11 $x22 $x33> <$x32> <@$aSolution>\n";
      next unless addToSolution($aSolution, $x32, $iMax);

      my $x23 = $sum - $x22 - $x21;
      next unless addToSolution($aSolution, $x23, $iMax);

      next unless $sum == ($x12+$x22+$x32);
      next unless $sum == ($x13+$x23+$x33);

      my $bFound=1;
      for (@$aRequired) {
        next if isInSolution($aSolution, $_);
        $bFound = 0;
        last;
      }
      next unless $bFound;

      return [$x11,$x12,$x13,$x21,$x22,$x23,$x31,$x32,$x33];
    }
  }
  return undef;
}

sub addToSolution {
  my ($aSolution, $iAdd, $iMax) = @_;
  return 0 if ($iAdd < 1) || ($iAdd > $iMax)
    || isInSolution($aSolution, $iAdd);
  push @$aSolution, $iAdd;
  return 1;
}

sub isInSolution {
  my ($aSolution, $iFind) = @_;
  foreach (@$aSolution) {
    return 1 if ($_ == $iFind);
  }
  return 0;
}

#---------------------------------------------------------------------
+-

sub printSolution {
  my $aNumbers = shift;
  my $sMatrix='';
  for (my $i=0; $i < 3; $i++) {
    $sMatrix .= sprintf("   %3s%3s%3s\n"
                        , $aNumbers->[3*$i]
                        , $aNumbers->[3*$i+1]
                        , $aNumbers->[3*$i+2]);
  }
  $sMatrix .= "\n";
  for (my $i=0; $i < 3; $i++) {
    my $aRow = $aNumbers->[$i];
    $sMatrix .= sprintf("   %3s%3s%3s\n"
                        , uc chr($aNumbers->[3*$i] + $NUMBER_BASE)
                        , uc chr($aNumbers->[3*$i+1] + $NUMBER_BASE)
                        , uc chr($aNumbers->[3*$i+2] + $NUMBER_BASE));
  }
  print $sMatrix;
}

[download]

Update: moved end of spoiler section.

Update: made two small changes to increase speed by 30-40%

Replies are listed 'Best First'.
Re^3: magic squares
by tilly (Archbishop) on Apr 05, 2009 at 17:56 UTC
    There is still a bug in your logic. There are over 70 magic squares with all of the letters J O H N and you didn't find most of them.

    Update: I misread the format that ELISHEVA printed her results in. My bad.

[reply]

      On purpose, but I reread the explanatory portion of my post and I can see how one might have thought otherwise. The algorithm isn't intended to find all of them. Finding one is all that is needed for the stated problem: which student doesn't have a magic square with their name written on it.

      Best, beth

[reply]
        That's brilliant, thanks! My permutation checker is still running... :-(

        SSF

[reply]

In Section Seekers of Perl Wisdom