' Generates Almost Perfect Magic Cubes of order 4 for integers 1 thru 64, based on 4 x 4 Pan Magic Squares
' Tested with Office 2007 under Windows 7
Sub MgcCube4b()
Dim a(16), b(16), c(16), A1(64), B1(64), C1(64)
y = MsgBox("Locked", vbCritical, "Routine MgcCube4b")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 16: s1 = 34
Sheets("Klad1").Select
' Select Sudoku Cube
i10 = 3: GoSub 1000 'i10 = 1 ... 8
' Generate data
t1 = Timer
For j16 = m1 To m2 'a(16)
If b(j16) = 0 Then b(j16) = j16: c(16) = j16 Else GoTo 160
a(16) = j16
For j15 = m1 To m2 'a(15)
If b(j15) = 0 Then b(j15) = j15: c(15) = j15 Else GoTo 150
a(15) = j15
For j14 = m1 To m2 'a(14)
If b(j14) = 0 Then b(j14) = j14: c(14) = j14 Else GoTo 140
j13 = s1 - j14 - j15 - j16
If j13 <= 0 Or j13 > 16 Then GoTo 130 'a(13)
If b(j13) = 0 Then b(j13) = j13: c(13) = j13 Else GoTo 130
a(14) = j14
a(13) = j13
For j12 = m1 To m2 'a(12)
If b(j12) = 0 Then b(j12) = j12: c(12) = j12 Else GoTo 120
a(12) = j12
a(11) = s1 - a(12) - a(15) - a(16): If a(11) <= 0 Or a(11) > 16 Then GoTo 110
a(10) = a(12) - a(14) + a(16): If a(10) <= 0 Or a(10) > 16 Then GoTo 110
a(9) = -a(12) + a(14) + a(15): If a(9) <= 0 Or a(9) > 16 Then GoTo 110
a(8) = 0.5 * s1 - a(14): If a(8) <= 0 Or a(8) > 16 Then GoTo 110
a(7) = -0.5 * s1 + a(14) + a(15) + a(16): If a(7) <= 0 Or a(7) > 16 Then GoTo 110
a(6) = 0.5 * s1 - a(16): If a(6) <= 0 Or a(6) > 16 Then GoTo 110
a(5) = 0.5 * s1 - a(15): If a(5) <= 0 Or a(5) > 16 Then GoTo 110
a(4) = 0.5 * s1 - a(12) + a(14) - a(16): If a(4) <= 0 Or a(4) > 16 Then GoTo 110
a(3) = 0.5 * s1 + a(12) - a(14) - a(15): If a(3) <= 0 Or a(3) > 16 Then GoTo 110
a(2) = 0.5 * s1 - a(12): If a(2) <= 0 Or a(2) > 16 Then GoTo 110
a(1) = -0.5 * s1 + a(12) + a(15) + a(16): If a(1) <= 0 Or a(1) > 16 Then GoTo 110
' Exclude solutions with identical numbers
GoSub 800: If fl1 = 0 Then GoTo 110
n9 = n9 + 1:
' GoSub 640 'Print results (Pan Magic Squares: selected numbers)
' GoSub 650 'Print results (Pan Magic Squares: squares)
GoSub 1050 'Construct Cube B1 and Calculate Cube A1 = B1 + 16 * C1
' GoSub 740 'Print results (Cubes: selected numbers)
GoSub 750 'Print results (Cubes: planes 11, 12, 13 and 14)
' GoSub 760 'Print results (Cubes: 3d)
110 b(c(12)) = 0: c(12) = 0
120 Next j12
b(c(13)) = 0: c(13) = 0
130 b(c(14)) = 0: c(14) = 0
140 Next j14
b(c(15)) = 0: c(15) = 0
150 Next j15
b(c(16)) = 0: c(16) = 0
160 Next j16
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine MgcCube4b")
End
' Print results (Pan Magic Squares: selected numbers)
640 For i1 = 1 To 16
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (Pan Magic Squares: squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 5: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 5
End If
Cells(k1 + 1, k2 + 1).Select
i3 = 0
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
' Print results (Cubes: selected numbers)
740 For i1 = 1 To 64
Cells(n9, i1).Value = A1(i1)
Next i1
Return
' Print results (Cubes: planes 11, 12, 13 and 14)
750 n2 = n2 + 1
If n2 = 9 Then
n2 = 1: k1 = k1 + 20: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 5
End If
For i0 = 1 To 4
i3 = (4 - i0) * 16
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
Cells(k1 + i1 + (i0 - 1) * 5, k2 + i2).Value = A1(i3)
Next i2
Next i1
If i0 = 1 Then
Cells(k1 + (i0 - 1) * 5, k2 + 1).Value = "Plane 1" + CStr(i0) + ", C" + CStr(n9)
Else
Cells(k1 + (i0 - 1) * 5, k2 + 1).Value = "Plane 1" + CStr(i0)
End If
Next i0
Return
' Print results (Cubes: 3d)
760 n2 = n2 + 1
If n2 = 3 Then
n2 = 1: k1 = k1 + 29: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 17
End If
For i0 = 1 To 4
i3 = (4 - i0) * 16
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
Cells(k1 + 1 + (i1 - 1) * 2 + (i0 - 1) * 7, k2 + 7 + (i2 - 1) * 3 - (i1 - 1) * 2).Value = A1(i3)
Next i2
Next i1
Next i0
Return
' Exclude solutions with identical numbers (Pan Magic Square)
800 fl1 = 1
For j1 = 1 To 16
a2 = a(j1)
For j2 = (1 + j1) To 16
If a2 = a(j2) Then fl1 = 0: GoTo 850
Next j2
Next j1
850 Return
' Select Sudoku Cube C1
1000 Select Case i10
Case 1
C1(1) = 3: C1(2) = 2: C1(3) = 1: C1(4) = 0: C1(5) = 2: C1(6) = 0: C1(7) = 3: C1(8) = 1
C1(9) = 1: C1(10) = 3: C1(11) = 0: C1(12) = 2: C1(13) = 0: C1(14) = 1: C1(15) = 2: C1(16) = 3
C1(17) = 2: C1(18) = 0: C1(19) = 3: C1(20) = 1: C1(21) = 0: C1(22) = 1: C1(23) = 2: C1(24) = 3
C1(25) = 3: C1(26) = 2: C1(27) = 1: C1(28) = 0: C1(29) = 1: C1(30) = 3: C1(31) = 0: C1(32) = 2
C1(33) = 1: C1(34) = 3: C1(35) = 0: C1(36) = 2: C1(37) = 3: C1(38) = 2: C1(39) = 1: C1(40) = 0
C1(41) = 0: C1(42) = 1: C1(43) = 2: C1(44) = 3: C1(45) = 2: C1(46) = 0: C1(47) = 3: C1(48) = 1
C1(49) = 0: C1(50) = 1: C1(51) = 2: C1(52) = 3: C1(53) = 1: C1(54) = 3: C1(55) = 0: C1(56) = 2
C1(57) = 2: C1(58) = 0: C1(59) = 3: C1(60) = 1: C1(61) = 3: C1(62) = 2: C1(63) = 1: C1(64) = 0:
Case 2
C1(1) = 3: C1(2) = 1: C1(3) = 2: C1(4) = 0: C1(5) = 1: C1(6) = 0: C1(7) = 3: C1(8) = 2
C1(9) = 2: C1(10) = 3: C1(11) = 0: C1(12) = 1: C1(13) = 0: C1(14) = 2: C1(15) = 1: C1(16) = 3
C1(17) = 1: C1(18) = 0: C1(19) = 3: C1(20) = 2: C1(21) = 0: C1(22) = 2: C1(23) = 1: C1(24) = 3
C1(25) = 3: C1(26) = 1: C1(27) = 2: C1(28) = 0: C1(29) = 2: C1(30) = 3: C1(31) = 0: C1(32) = 1
C1(33) = 2: C1(34) = 3: C1(35) = 0: C1(36) = 1: C1(37) = 3: C1(38) = 1: C1(39) = 2: C1(40) = 0
C1(41) = 0: C1(42) = 2: C1(43) = 1: C1(44) = 3: C1(45) = 1: C1(46) = 0: C1(47) = 3: C1(48) = 2
C1(49) = 0: C1(50) = 2: C1(51) = 1: C1(52) = 3: C1(53) = 2: C1(54) = 3: C1(55) = 0: C1(56) = 1
C1(57) = 1: C1(58) = 0: C1(59) = 3: C1(60) = 2: C1(61) = 3: C1(62) = 1: C1(63) = 2: C1(64) = 0
Case 3
C1(1) = 2: C1(2) = 3: C1(3) = 0: C1(4) = 1: C1(5) = 3: C1(6) = 1: C1(7) = 2: C1(8) = 0
C1(9) = 0: C1(10) = 2: C1(11) = 1: C1(12) = 3: C1(13) = 1: C1(14) = 0: C1(15) = 3: C1(16) = 2
C1(17) = 3: C1(18) = 1: C1(19) = 2: C1(20) = 0: C1(21) = 1: C1(22) = 0: C1(23) = 3: C1(24) = 2
C1(25) = 2: C1(26) = 3: C1(27) = 0: C1(28) = 1: C1(29) = 0: C1(30) = 2: C1(31) = 1: C1(32) = 3
C1(33) = 0: C1(34) = 2: C1(35) = 1: C1(36) = 3: C1(37) = 2: C1(38) = 3: C1(39) = 0: C1(40) = 1
C1(41) = 1: C1(42) = 0: C1(43) = 3: C1(44) = 2: C1(45) = 3: C1(46) = 1: C1(47) = 2: C1(48) = 0
C1(49) = 1: C1(50) = 0: C1(51) = 3: C1(52) = 2: C1(53) = 0: C1(54) = 2: C1(55) = 1: C1(56) = 3
C1(57) = 3: C1(58) = 1: C1(59) = 2: C1(60) = 0: C1(61) = 2: C1(62) = 3: C1(63) = 0: C1(64) = 1
Case 4
C1(1) = 2: C1(2) = 0: C1(3) = 3: C1(4) = 1: C1(5) = 0: C1(6) = 1: C1(7) = 2: C1(8) = 3
C1(9) = 3: C1(10) = 2: C1(11) = 1: C1(12) = 0: C1(13) = 1: C1(14) = 3: C1(15) = 0: C1(16) = 2
C1(17) = 0: C1(18) = 1: C1(19) = 2: C1(20) = 3: C1(21) = 1: C1(22) = 3: C1(23) = 0: C1(24) = 2
C1(25) = 2: C1(26) = 0: C1(27) = 3: C1(28) = 1: C1(29) = 3: C1(30) = 2: C1(31) = 1: C1(32) = 0
C1(33) = 3: C1(34) = 2: C1(35) = 1: C1(36) = 0: C1(37) = 2: C1(38) = 0: C1(39) = 3: C1(40) = 1
C1(41) = 1: C1(42) = 3: C1(43) = 0: C1(44) = 2: C1(45) = 0: C1(46) = 1: C1(47) = 2: C1(48) = 3
C1(49) = 1: C1(50) = 3: C1(51) = 0: C1(52) = 2: C1(53) = 3: C1(54) = 2: C1(55) = 1: C1(56) = 0
C1(57) = 0: C1(58) = 1: C1(59) = 2: C1(60) = 3: C1(61) = 2: C1(62) = 0: C1(63) = 3: C1(64) = 1
Case 5
C1(1) = 1: C1(2) = 3: C1(3) = 0: C1(4) = 2: C1(5) = 3: C1(6) = 2: C1(7) = 1: C1(8) = 0
C1(9) = 0: C1(10) = 1: C1(11) = 2: C1(12) = 3: C1(13) = 2: C1(14) = 0: C1(15) = 3: C1(16) = 1
C1(17) = 3: C1(18) = 2: C1(19) = 1: C1(20) = 0: C1(21) = 2: C1(22) = 0: C1(23) = 3: C1(24) = 1
C1(25) = 1: C1(26) = 3: C1(27) = 0: C1(28) = 2: C1(29) = 0: C1(30) = 1: C1(31) = 2: C1(32) = 3
C1(33) = 0: C1(34) = 1: C1(35) = 2: C1(36) = 3: C1(37) = 1: C1(38) = 3: C1(39) = 0: C1(40) = 2
C1(41) = 2: C1(42) = 0: C1(43) = 3: C1(44) = 1: C1(45) = 3: C1(46) = 2: C1(47) = 1: C1(48) = 0
C1(49) = 2: C1(50) = 0: C1(51) = 3: C1(52) = 1: C1(53) = 0: C1(54) = 1: C1(55) = 2: C1(56) = 3
C1(57) = 3: C1(58) = 2: C1(59) = 1: C1(60) = 0: C1(61) = 1: C1(62) = 3: C1(63) = 0: C1(64) = 2
Case 6
C1(1) = 1: C1(2) = 0: C1(3) = 3: C1(4) = 2: C1(5) = 0: C1(6) = 2: C1(7) = 1: C1(8) = 3
C1(9) = 3: C1(10) = 1: C1(11) = 2: C1(12) = 0: C1(13) = 2: C1(14) = 3: C1(15) = 0: C1(16) = 1
C1(17) = 0: C1(18) = 2: C1(19) = 1: C1(20) = 3: C1(21) = 2: C1(22) = 3: C1(23) = 0: C1(24) = 1
C1(25) = 1: C1(26) = 0: C1(27) = 3: C1(28) = 2: C1(29) = 3: C1(30) = 1: C1(31) = 2: C1(32) = 0
C1(33) = 3: C1(34) = 1: C1(35) = 2: C1(36) = 0: C1(37) = 1: C1(38) = 0: C1(39) = 3: C1(40) = 2
C1(41) = 2: C1(42) = 3: C1(43) = 0: C1(44) = 1: C1(45) = 0: C1(46) = 2: C1(47) = 1: C1(48) = 3
C1(49) = 2: C1(50) = 3: C1(51) = 0: C1(52) = 1: C1(53) = 3: C1(54) = 1: C1(55) = 2: C1(56) = 0
C1(57) = 0: C1(58) = 2: C1(59) = 1: C1(60) = 3: C1(61) = 1: C1(62) = 0: C1(63) = 3: C1(64) = 2
Case 7
C1(1) = 0: C1(2) = 2: C1(3) = 1: C1(4) = 3: C1(5) = 2: C1(6) = 3: C1(7) = 0: C1(8) = 1
C1(9) = 1: C1(10) = 0: C1(11) = 3: C1(12) = 2: C1(13) = 3: C1(14) = 1: C1(15) = 2: C1(16) = 0
C1(17) = 2: C1(18) = 3: C1(19) = 0: C1(20) = 1: C1(21) = 3: C1(22) = 1: C1(23) = 2: C1(24) = 0
C1(25) = 0: C1(26) = 2: C1(27) = 1: C1(28) = 3: C1(29) = 1: C1(30) = 0: C1(31) = 3: C1(32) = 2
C1(33) = 1: C1(34) = 0: C1(35) = 3: C1(36) = 2: C1(37) = 0: C1(38) = 2: C1(39) = 1: C1(40) = 3
C1(41) = 3: C1(42) = 1: C1(43) = 2: C1(44) = 0: C1(45) = 2: C1(46) = 3: C1(47) = 0: C1(48) = 1
C1(49) = 3: C1(50) = 1: C1(51) = 2: C1(52) = 0: C1(53) = 1: C1(54) = 0: C1(55) = 3: C1(56) = 2
C1(57) = 2: C1(58) = 3: C1(59) = 0: C1(60) = 1: C1(61) = 0: C1(62) = 2: C1(63) = 1: C1(64) = 3
Case 8
C1(1) = 0: C1(2) = 1: C1(3) = 2: C1(4) = 3: C1(5) = 1: C1(6) = 3: C1(7) = 0: C1(8) = 2
C1(9) = 2: C1(10) = 0: C1(11) = 3: C1(12) = 1: C1(13) = 3: C1(14) = 2: C1(15) = 1: C1(16) = 0
C1(17) = 1: C1(18) = 3: C1(19) = 0: C1(20) = 2: C1(21) = 3: C1(22) = 2: C1(23) = 1: C1(24) = 0
C1(25) = 0: C1(26) = 1: C1(27) = 2: C1(28) = 3: C1(29) = 2: C1(30) = 0: C1(31) = 3: C1(32) = 1
C1(33) = 2: C1(34) = 0: C1(35) = 3: C1(36) = 1: C1(37) = 0: C1(38) = 1: C1(39) = 2: C1(40) = 3
C1(41) = 3: C1(42) = 2: C1(43) = 1: C1(44) = 0: C1(45) = 1: C1(46) = 3: C1(47) = 0: C1(48) = 2
C1(49) = 3: C1(50) = 2: C1(51) = 1: C1(52) = 0: C1(53) = 2: C1(54) = 0: C1(55) = 3: C1(56) = 1
C1(57) = 1: C1(58) = 3: C1(59) = 0: C1(60) = 2: C1(61) = 0: C1(62) = 1: C1(63) = 2: C1(64) = 3
End Select
Return
' Construct Cube B1 and Calculate Cube A1
1050
' Square B1
For i1 = 1 To 16: B1(i1 + 48) = a(i1): Next i1
' Square B2
B1(33) = B1(54): B1(34) = B1(53): B1(35) = B1(56): B1(36) = B1(55)
B1(37) = B1(50): B1(38) = B1(49): B1(39) = B1(52): B1(40) = B1(51)
B1(41) = B1(62): B1(42) = B1(61): B1(43) = B1(64): B1(44) = B1(63)
B1(45) = B1(58): B1(46) = B1(57): B1(47) = B1(60): B1(48) = B1(59)
' Square B3
B1(17) = B1(59): B1(18) = B1(60): B1(19) = B1(57): B1(20) = B1(58)
B1(21) = B1(63): B1(22) = B1(64): B1(23) = B1(61): B1(24) = B1(62)
B1(25) = B1(51): B1(26) = B1(52): B1(27) = B1(49): B1(28) = B1(50)
B1(29) = B1(55): B1(30) = B1(56): B1(31) = B1(53): B1(32) = B1(54)
' Square B4
B1(1) = B1(64): B1(2) = B1(63): B1(3) = B1(62): B1(4) = B1(61)
B1(5) = B1(60): B1(6) = B1(59): B1(7) = B1(58): B1(8) = B1(57)
B1(9) = B1(56): B1(10) = B1(55): B1(11) = B1(54): B1(12) = B1(53)
B1(13) = B1(52): B1(14) = B1(51): B1(15) = B1(50): B1(16) = B1(49)
' A1 = B1 + 16 * C1
For i1 = 1 To 64
A1(i1) = B1(i1) + 16 * C1(i1)
Next i1
Return
End Sub
