' Perfect Diagonal Magic Cubes (m >= 18, m Mod 3 = 0)
' Tested with Office 2007 under Windows 7
Sub Perfect18()
y = MsgBox("Locked", vbCritical, "Routine Perfect18")
End
Sheets("Klad1").Select
m = 18: N = 8
For k = 0 To m - 1
If k < m - 1 - k Then k1 = k Else k1 = m - 1 - k
For i = 0 To m - 1
i11 = i11 + 1
If i < m - 1 - i Then i1 = i Else i1 = m - 1 - i
For j = 0 To m - 1
j11 = j11 + 1: j12 = j12 + 1
If j < m - 1 - j Then j1 = j Else j1 = m - 1 - j
v = 4*Int(2*i/m) + 2*Int(2*j/m) + ((Int(2*i/m) + Int(2*j/m) + Int(2*k/m)) Mod 2) ' (0 <= v <= 7),
z1 = (i1 + j1 - 2 * k1)
While z1 < 0
z1 = z1 + m / 2
Wend
z = z1 Mod (m / 2)
cijk = (2 * i1 + j1 + k1) Mod (m / 2) ' 0 <= bijk < m/2
dijk = (i1 + 2 * j1 + k1) Mod (m / 2) ' 0 <= cijk < m/2
eijk = (i1 + j1 + 2 * k1) Mod (m / 2) ' 0 <= dijk < m/2
x = F8(v, z, N)
bijk = D8(x, i1, j1, k1, i, j, k, m)
' Print Cube
If j11 = m + 1 Then j11 = 1
If j12 = m ^ 2 + 1 Then j12 = 1: i11 = i11 + 1
aijk = bijk * (m / 2) ^ 3 + S93(cijk) * (m / 2) ^ 2 + S93(dijk) * (m / 2) + S93(eijk) + 1
Cells(i11 + 1, j11 + 1).Value = aijk
Next j
Next i
Next k
End
End Sub
Function S93(x)
S93 = Q33(Int(x / 3), x Mod 3)
End Function
Function Q33(x, y)
p = 3: q = 3
If 0 < x And x < p - 1 Then
If Int(x / 2) = x / 2 Then 'x is even
Q33 = q * x + y
Else 'x is odd
Q33 = q * x + (q - 1 - y)
End If
ElseIf x = 0 Then
If Int(y / 2) = y / 2 Then 'y is even
Q33 = y / 2 + (q - 1) / 2
Else 'y is odd
Q33 = (y - 1) / 2
End If
ElseIf x = p - 1 Then
If Int(y / 2) = y / 2 Then 'y is even
Q33 = y / 2 + (p - 1) * q
Else 'y is odd
Q33 = (y - 1) / 2 + p * q - (q - 1) / 2
End If
End If
End Function
Function F8(v, z, N)
If Int(v / 2) = v / 2 Then 'v is even
Select Case z
Case 0: F8 = v
Case 1: F8 = v + 1
Case 2: F8 = N / 2 - 1 - v / 2
Case 3: F8 = N - 1 - v / 2
Case 4, 6, 8: F8 = N - 1 - v
Case 5, 7: F8 = v
End Select
Else 'v is odd
Select Case z
Case 0: F8 = v
Case 1: F8 = v - 1
Case 2: F8 = N - 1 - (v - 1) / 2
Case 3: F8 = N / 2 - 1 - (v - 1) / 2
Case 4, 6, 8: F8 = N - 1 - v
Case 5, 7: F8 = v
End Select
End If
End Function
Function D8(x, i1, j1, k1, i, j, k, m)
fl1 = 0: fl2 = 0
If j1 = (k1 + 1) Mod (m / 2) And i >= m / 2 And i1 = k1 Then fl1 = 1: GoTo 10
If i1 = (k1 + 1) Mod (m / 2) And j >= m / 2 And j1 = k1 Then fl1 = 1: GoTo 10
If j1 = (k1 + (m + 2) / 4) Mod (m / 2) And i >= m / 2 And i1 = j1 Then fl1 = 1: GoTo 10
k2 = (k1 - 1) Mod (m / 2)
If k2 < 0 Then k2 = (k1 - 1 + m / 2) Mod (m / 2)
If j1 = (k1 + 1) Mod (m / 2) And i >= m / 2 And i1 = k2 Then fl1 = 1: GoTo 10
If i1 = (k1 + 1) Mod (m / 2) And j >= m / 2 And j1 = k2 Then fl1 = 1: GoTo 10
i2 = (j1 - 1) Mod (m / 2)
If i2 < 0 Then i2 = (j1 - 1 + m / 2) Mod (m / 2)
If j1 = (k1 + (m + 2) / 4) Mod (m / 2) And i >= m / 2 And i1 = i2 Then fl1 = 1: GoTo 10
10
If fl1 = 1 Then
D8 = x + (-1) ^ x
Else
D8 = x
End If
End Function
