' Generates Bimagic Squares of order 8, Magic Sum 260, Aale de Winkel
' Based on Sudoku Comparable Squares
' Tested with Office 2007 under Windows 7
Sub CnstrSqrs10()
Dim b(3, 64), a(64), s(20), B1(8, 8), B2(8, 8), i10(8)
Sheets("Klad1").Select
y = MsgBox("Locked", vbCritical, "Routine CnstrSqrs10")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
s1 = 260
t1 = Timer
' Example 1 Example 2
For j1 = 2019 To 8065 ''2 To 8065 615 663
Cells(k1, 1).Select: Cells(k1, 1).Value = j1
For j2 = 615 To 615 ''2 To 8065 615 7369
Cells(k1 + 1, 1).Select: Cells(k1 + 1, 1).Value = j2
j10 = j1: j20 = 1: sht1 = "SudLns8": GoSub 100 'Read Sudoku Comparable Square A
j10 = j2: j20 = 2: sht1 = "SudLns8": GoSub 100 'Read Sudoku Comparable Square B (Base)
For j5 = 1 To 2
Select Case j5
Case 1 'Create Scratch Square B1
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
B1(i1, i2) = b(2, i3)
Next i2
Next i1
Case 2 'Create Transposed Scratch Square B1
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
B1(i2, i1) = b(2, i3)
Next i2
Next i1
End Select
GoSub 500 'Determine Permutations
Next j5
20 Next j2
10 Next j1
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CnstrSqrs10")
End
' Read Sudoku Comparable Squares (Line Format)
100 For i1 = 1 To 64
b(j20, i1) = Sheets(sht1).Cells(j10, i1).Value
Next i1
Return
' Define Permutations
500
For i11 = 1 To 8
For i12 = 1 To 8
If i12 = i11 Then GoTo 112
For i13 = 1 To 8
If i13 = i12 Or i13 = i11 Then GoTo 113
For i14 = 1 To 8
If i14 = i13 Or i14 = i12 Or i14 = i11 Then GoTo 114
For i15 = 1 To 8
If i15 = i14 Or i15 = i13 Or i15 = i12 Or i15 = i11 Then GoTo 115
For i16 = 1 To 8
If i16 = i15 Or i16 = i14 Or i16 = i13 Or i16 = i12 Or i16 = i11 Then GoTo 116
For i17 = 1 To 8
If i17 = i16 Or i17 = i15 Or i17 = i14 Or i17 = i13 Or i17 = i12 Or i17 = i11 Then GoTo 117
For i18 = 1 To 8
If i18 = i17 Or i18 = i16 Or i18 = i15 Or i18 = i14 Or i18 = i13 Or i18 = i12 Or i18 = i11 Then GoTo 118
i10(1) = i11: i10(2) = i12: i10(3) = i13: i10(4) = i14: i10(5) = i15: i10(6) = i16: i10(7) = i17: i10(8) = i18:
' Permutate Columns
For i1 = 1 To 8
For i2 = 1 To 8
B2(i1, i2) = B1(i1, i10(i2))
Next i2
Next i1
' Permutate Rows
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
b(3, i3) = B2(i10(i1), i2)
Next i2
Next i1
For j4 = 1 To 64
a(j4) = 8 * b(1, j4) + b(3, j4) + 1
Next j4
GoSub 800: If fl1 = 0 Then GoTo 118 'Check identical numbers
GoSub 900: If fl1 = 0 Then GoTo 118 'Check Magic Lines (Back Check)
GoSub 950: If fl1 = 0 Then GoTo 118 'Check Bimagic Lines
' n9 = n9 + 1: GoSub 740 'Print results (selected numbers)
n9 = n9 + 1: GoSub 750 'Print results (squares)
118 Next i18
117 Next i17
116 Next i16
115 Next i15
114 Next i14
113 Next i13
112 Next i12
111 Next i11
Return
' Check identical numbers
800 fl1 = 1
For i1 = 1 To 64
a2 = a(i1)
For i2 = (1 + i1) To 64
If a2 = a(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Check Magic Properties (Back Check)
900 fl1 = 1: s2 = 260
Erase s
s(1) = a(1) + a(2) + a(3) + a(4) + a(5) + a(6) + a(7) + a(8)
s(2) = a(9) + a(10) + a(11) + a(12) + a(13) + a(14) + a(15) + a(16)
s(3) = a(17) + a(18) + a(19) + a(20) + a(21) + a(22) + a(23) + a(24)
s(4) = a(25) + a(26) + a(27) + a(28) + a(29) + a(30) + a(31) + a(32)
s(5) = a(33) + a(34) + a(35) + a(36) + a(37) + a(38) + a(39) + a(40)
s(6) = a(41) + a(42) + a(43) + a(44) + a(45) + a(46) + a(47) + a(48)
s(7) = a(49) + a(50) + a(51) + a(52) + a(53) + a(54) + a(55) + a(56)
s(8) = a(57) + a(58) + a(59) + a(60) + a(61) + a(62) + a(63) + a(64)
s(9) = a(1) + a(9) + a(17) + a(25) + a(33) + a(41) + a(49) + a(57)
s(10) = a(2) + a(10) + a(18) + a(26) + a(34) + a(42) + a(50) + a(58)
s(11) = a(3) + a(11) + a(19) + a(27) + a(35) + a(43) + a(51) + a(59)
s(12) = a(4) + a(12) + a(20) + a(28) + a(36) + a(44) + a(52) + a(60)
s(13) = a(5) + a(13) + a(21) + a(29) + a(37) + a(45) + a(53) + a(61)
s(14) = a(6) + a(14) + a(22) + a(30) + a(38) + a(46) + a(54) + a(62)
s(15) = a(7) + a(15) + a(23) + a(31) + a(39) + a(47) + a(55) + a(63)
s(16) = a(8) + a(16) + a(24) + a(32) + a(40) + a(48) + a(56) + a(64)
s(17) = a(1) + a(10) + a(19) + a(28) + a(37) + a(46) + a(55) + a(64)
s(18) = a(8) + a(15) + a(22) + a(29) + a(36) + a(43) + a(50) + a(57)
' Check Simple Magic
For j20 = 1 To 18
If s(j20) <> s2 Then fl1 = 0: Exit For
Next j20
Return
' Check Bimagic Properties
950 fl1 = 1: s2 = 11180
Erase s
s(1) = a(1) ^ 2 + a(2) ^ 2 + a(3) ^ 2 + a(4) ^ 2 + a(5) ^ 2 + a(6) ^ 2 + a(7) ^ 2 + a(8) ^ 2
s(2) = a(9) ^ 2 + a(10) ^ 2 + a(11) ^ 2 + a(12) ^ 2 + a(13) ^ 2 + a(14) ^ 2 + a(15) ^ 2 + a(16) ^ 2
s(3) = a(17) ^ 2 + a(18) ^ 2 + a(19) ^ 2 + a(20) ^ 2 + a(21) ^ 2 + a(22) ^ 2 + a(23) ^ 2 + a(24) ^ 2
s(4) = a(25) ^ 2 + a(26) ^ 2 + a(27) ^ 2 + a(28) ^ 2 + a(29) ^ 2 + a(30) ^ 2 + a(31) ^ 2 + a(32) ^ 2
s(5) = a(33) ^ 2 + a(34) ^ 2 + a(35) ^ 2 + a(36) ^ 2 + a(37) ^ 2 + a(38) ^ 2 + a(39) ^ 2 + a(40) ^ 2
s(6) = a(41) ^ 2 + a(42) ^ 2 + a(43) ^ 2 + a(44) ^ 2 + a(45) ^ 2 + a(46) ^ 2 + a(47) ^ 2 + a(48) ^ 2
s(7) = a(49) ^ 2 + a(50) ^ 2 + a(51) ^ 2 + a(52) ^ 2 + a(53) ^ 2 + a(54) ^ 2 + a(55) ^ 2 + a(56) ^ 2
s(8) = a(57) ^ 2 + a(58) ^ 2 + a(59) ^ 2 + a(60) ^ 2 + a(61) ^ 2 + a(62) ^ 2 + a(63) ^ 2 + a(64) ^ 2
s(9) = a(1) ^ 2 + a(9) ^ 2 + a(17) ^ 2 + a(25) ^ 2 + a(33) ^ 2 + a(41) ^ 2 + a(49) ^ 2 + a(57) ^ 2
s(10) = a(2) ^ 2 + a(10) ^ 2 + a(18) ^ 2 + a(26) ^ 2 + a(34) ^ 2 + a(42) ^ 2 + a(50) ^ 2 + a(58) ^ 2
s(11) = a(3) ^ 2 + a(11) ^ 2 + a(19) ^ 2 + a(27) ^ 2 + a(35) ^ 2 + a(43) ^ 2 + a(51) ^ 2 + a(59) ^ 2
s(12) = a(4) ^ 2 + a(12) ^ 2 + a(20) ^ 2 + a(28) ^ 2 + a(36) ^ 2 + a(44) ^ 2 + a(52) ^ 2 + a(60) ^ 2
s(13) = a(5) ^ 2 + a(13) ^ 2 + a(21) ^ 2 + a(29) ^ 2 + a(37) ^ 2 + a(45) ^ 2 + a(53) ^ 2 + a(61) ^ 2
s(14) = a(6) ^ 2 + a(14) ^ 2 + a(22) ^ 2 + a(30) ^ 2 + a(38) ^ 2 + a(46) ^ 2 + a(54) ^ 2 + a(62) ^ 2
s(15) = a(7) ^ 2 + a(15) ^ 2 + a(23) ^ 2 + a(31) ^ 2 + a(39) ^ 2 + a(47) ^ 2 + a(55) ^ 2 + a(63) ^ 2
s(16) = a(8) ^ 2 + a(16) ^ 2 + a(24) ^ 2 + a(32) ^ 2 + a(40) ^ 2 + a(48) ^ 2 + a(56) ^ 2 + a(64) ^ 2
s(17) = a(1) ^ 2 + a(10) ^ 2 + a(19) ^ 2 + a(28) ^ 2 + a(37) ^ 2 + a(46) ^ 2 + a(55) ^ 2 + a(64) ^ 2
s(18) = a(8) ^ 2 + a(15) ^ 2 + a(22) ^ 2 + a(29) ^ 2 + a(36) ^ 2 + a(43) ^ 2 + a(50) ^ 2 + a(57) ^ 2
' Check Simple Bimagic
n8 = 0
For j20 = 1 To 18
If s(j20) <> s2 Then fl1 = 0: Exit For
Next j20
Return
' Print results (selected numbers)
740 Cells(n9, 64).Select
For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 65).Value = j1
Cells(n9, 66).Value = j2
Return
' Print results (squares)
750 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
