use strict; use warnings; my $NUMBER_BASE = ord('a') - 1; my $aNoMagic = findUnmagicNames(['Shiela'], 26); print "no solution: @$aNoMagic\n"; #---------------------------------------------------------------------- sub findUnmagicNames { my ($aNames, $iMax) = @_; my @aNoSolutions; foreach my $sName (@$aNames) { my $aNumbers = getNumbersFromName($sName); my $aMagic = validateSeed($aNumbers, $iMax); if ($aMagic) { print sprintf("%-8s= %s", $sName, "@$aNumbers\n"); printSolution($aMagic); }else { push(@aNoSolutions, "$sName (@$aNumbers)"); } } return \@aNoSolutions; } sub printSolution { my $aNumbers = shift; my $sMatrix=''; for (my $i=0; $i < 3; $i++) { my $aRow = $aNumbers->[$i]; $sMatrix .= sprintf(" %3s%3s%3s\n" , $aRow->[0], $aRow->[1], $aRow->[2]); } $sMatrix .= "\n"; for (my $i=0; $i < 3; $i++) { my $aRow = $aNumbers->[$i]; $sMatrix .= sprintf(" %3s%3s%3s\n" , uc chr($aRow->[0] + $NUMBER_BASE) , uc chr($aRow->[1] + $NUMBER_BASE) , uc chr($aRow->[2] + $NUMBER_BASE)); } print $sMatrix; } #---------------------------------------------------------------------- # This is supposed to check whether or not a set of five can be turned # into a magic square, but it is too restrictive: it forgets about the # possibility of: # X X # X X # X sub getMagicSquare { my ($aNumbers, $iMax) = @_; my ($x11, $x12, $x13, $x21, $x31, $sum); #can these five numbers be part of a magic square? # $sum = $x11 + $x12 + $x13; # $sum = $x11 + $x21 + $x31; # $total = 2*$sum - $x11; my $bOk = 0; my $sumAll = 0; foreach (@$aNumbers) { $sumAll += $_; }; for my $i (0..$#$aNumbers) { $x11 = $aNumbers->[$i]; my $sumTwice = $sumAll + $x11; next if $sumTwice %2 ; $sum = $sumTwice/2; my @aInUse = ($i); my $j = getNotInUse(\@aInUse, $#$aNumbers); $x21 = $aNumbers->[$j]; push @aInUse, $j; $x31 = $sum - $x11 - $x21; next if ($x31 < 1) || ($x31 > $iMax); while ($j < $#$aNumbers) { $j++; last if $aNumbers->[$j] == $x31; } next if (($#$aNumbers < $j) || isDup($j, \@aInUse)); push @aInUse, $j; $j = getNotInUse(\@aInUse, $#$aNumbers); $x12 = $aNumbers->[$j]; push @aInUse, $j; $x13 = $sum - $x11 - $x12; next if ($x13 < 1) || ($x13 > $iMax); $j = getNotInUse(\@aInUse, $#$aNumbers); next if ($x13 != $aNumbers->[$j]); $bOk = 1; last; } return undef unless $bOk; #print "5 is OK <@$aNumbers>\n"; my @aSolution = ($x11, $x12, $x13, $x21, $x31); my $x22 = $sum - $x13 - $x31; return undef if (($x22 < 1) || ($x22 > $iMax) || isDup($x22, \@aSolution)); push @aSolution, $x22; #print "6 is OK <@aSolution>\n"; my $x33 = $sum - $x11 - $x22; return undef if (($x33 < 1) || ($x33 > $iMax) || isDup($x33, \@aSolution)); push @aSolution, $x33; #print "7 is OK <@aSolution>\n"; my $x23 = $sum - $x21 - $x22; return undef if ($x23 < 1) || ($x23 > $iMax) || isDup($x23, \@aSolution); push @aSolution, $x23; #print "8 is OK <@aSolution> sum=<$sum> <$x21> <$x22> <$x23>\n"; my $x32 = $sum - $x33 - $x31; return undef if ($x32 < 1) || ($x32 > $iMax) || isDup($x32, \@aSolution); push @aSolution, $x32; print "9 is OK <@aSolution> sum=<$sum>\n"; return undef if $sum != ($x13 + $x23 + $x33); return [[$x11,$x12,$x13],[$x21,$x22,$x23],[$x31,$x32,$x33]]; } #---------------------------------------------------------------------- sub getNotInUse { my ($aInUse, $iMax) = @_; pick: for (my $i=0; $i <= $iMax; $i++) { for (my $j=0; $j <= $#$aInUse; $j++) { next pick if $i == $aInUse->[$j]; } return $i; } return undef; } #---------------------------------------------------------------------- sub getNumbersFromName { my $sName = shift; return [ map { ord(lc($_)) - $NUMBER_BASE; } split(//,$sName) ]; } #---------------------------------------------------------------------- sub isDup { my ($iFind, $aNumbers) = @_; for(my $i=0; $i<$#$aNumbers; $i++) { return 1 if ($iFind == $aNumbers->[$i]); } return 0; } #---------------------------------------------------------------------- sub validateSeed { my ($aSeed, $iMax) = @_; my $iSeedCount = scalar(@$aSeed); my $iMissing = 6 - $iSeedCount; return getMagicSquare($aSeed, $iMax) unless $iMissing; #for each possible completion of $aSeed into @aSix #verify (note: this is still buggy - my brain can't do loops today) my @aSix = @$aSeed; my $iLast = $iMissing - 1; my $i = 0; my $iPick=0; my @aPick; while (1) { print "1: last=$iLast at=$i pick=$iPick <@aSix>\n"; if ($iLast < $i) { my $aMagic = getMagicSquare(\@aSix, $iMax); return $aMagic if $aMagic; $i--; } while (isDup(++$iPick, \@aSix) && ($iPick < $iMax)) {}; if ($iPick <= $iMax) { $aSix[$iSeedCount + $i ] = $iPick; $aPick[$i] = $iPick; $i++; } else { $aPick[$i] = 0; $iPick = 0; last unless $i; $i--; } die "How'd this grow so big? <@aSix>" if (scalar(@aSix) > 6); } return undef; }