' Generates Simple Latin Cubes of order 4 for integers 0 thru 7
' Horizontal Pan Magic Planes (3D Compact)
' Tested with Office 365 under Windows 10
Sub SudCube42()
Dim a(64), b(4), s(8)
y = MsgBox("Locked", vbCritical, "Routine SudCube42")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 7: s1 = 14
' Generate data
Sheets("Klad1").Select
t1 = Timer
For j64 = m1 To m2 'a(64)
a(64) = j64
For j63 = m1 To m2 'a(63)
a(63) = j63
For j62 = m1 To m2 'a(62)
a(62) = j62
a(61) = s1 - a(62) - a(63) - a(64): If a(61) < m1 Or a(61) > m2 Then GoTo 620
For j60 = m1 To m2 'a(60)
a(60) = j60
a(59) = s1 - a(60) - a(63) - a(64): If a(59) < m1 Or a(59) > m2 Then GoTo 600
a(58) = a(60) - a(62) + a(64): If a(58) < m1 Or a(58) > m2 Then GoTo 600
a(57) = -a(60) + a(62) + a(63): If a(57) < m1 Or a(57) > m2 Then GoTo 600
' Complete Pan Magic Top Square
a(56) = s1 / 2 - a(62): a(55) = s1 / 2 - a(61):
a(54) = s1 / 2 - a(64): a(53) = s1 / 2 - a(63):
a(52) = s1 / 2 - a(58): a(51) = s1 / 2 - a(57):
a(50) = s1 / 2 - a(60): a(49) = s1 / 2 - a(59):
' Check Top Square
b(1) = a(49): b(2) = a(50): b(3) = a(51): b(4) = a(52): GoSub 860: If fl1 = 0 Then GoTo 600
b(1) = a(53): b(2) = a(54): b(3) = a(55): b(4) = a(56): GoSub 860: If fl1 = 0 Then GoTo 600
b(1) = a(57): b(2) = a(58): b(3) = a(59): b(4) = a(60): GoSub 860: If fl1 = 0 Then GoTo 600
b(1) = a(61): b(2) = a(62): b(3) = a(63): b(4) = a(64): GoSub 860: If fl1 = 0 Then GoTo 600
b(1) = a(49): b(2) = a(53): b(3) = a(57): b(4) = a(61): GoSub 860: If fl1 = 0 Then GoTo 600
b(1) = a(50): b(2) = a(54): b(3) = a(58): b(4) = a(62): GoSub 860: If fl1 = 0 Then GoTo 600
b(1) = a(51): b(2) = a(55): b(3) = a(59): b(4) = a(63): GoSub 860: If fl1 = 0 Then GoTo 600
b(1) = a(52): b(2) = a(56): b(3) = a(60): b(4) = a(64): GoSub 860: If fl1 = 0 Then GoTo 600
b(1) = a(49): b(2) = a(54): b(3) = a(59): b(4) = a(64): GoSub 875: If fl1 = 0 Then GoTo 600
b(1) = a(52): b(2) = a(55): b(3) = a(58): b(4) = a(61): GoSub 875: If fl1 = 0 Then GoTo 600
For j48 = m1 To m2 'a(48)
a(48) = j48
a(45) = -a(48) + a(62) + a(63): If a(45) < m1 Or a(45) > m2 Then GoTo 480
a(43) = -a(48) + a(60) + a(63): If a(43) < m1 Or a(43) > m2 Then GoTo 480
a(42) = a(48) - a(60) + a(62): If a(42) < m1 Or a(42) > m2 Then GoTo 480
For j47 = m1 To m2 'a(47)
a(47) = j47
a(46) = s1 - a(47) - a(62) - a(63): If a(46) < m1 Or a(46) > m2 Then GoTo 470
a(44) = s1 - a(47) - a(60) - a(63): If a(44) < m1 Or a(44) > m2 Then GoTo 470
a(41) = a(47) + a(60) - a(62): If a(41) < m1 Or a(41) > m2 Then GoTo 470
For j32 = m1 To m2 'a(32)
a(32) = j32
a(27) = a(32) + 2 * a(48) - a(60) - a(63):
If a(27) < m1 Or a(27) > m2 Then GoTo 320
a(16) = s1 - a(32) - a(48) - a(64): If a(16) < m1 Or a(16) > m2 Then GoTo 320
a(11) = s1 - a(27) - a(43) - a(59): If a(11) < m1 Or a(11) > m2 Then GoTo 320
For j31 = m1 To m2 'a(31)
a(31) = j31
a(28) = s1 - a(31) - 2 * a(32) + a(43) - a(48):
If a(28) < m1 Or a(28) > m2 Then GoTo 310
a(15) = s1 - a(31) - a(47) - a(63): If a(15) < m1 Or a(15) > m2 Then GoTo 310
a(12) = s1 - a(28) - a(44) - a(60): If a(12) < m1 Or a(12) > m2 Then GoTo 310
For j30 = m1 To m2 'a(30)
a(30) = j30
a(29) = s1 - a(30) - a(31) - a(32): If a(29) < m1 Or a(29) > m2 Then GoTo 300
a(26) = a(29) - 2 * a(48) + a(60) + a(63):
If a(26) < m1 Or a(26) > m2 Then GoTo 300
a(25) = s1 - a(26) - a(27) - a(28): If a(25) < m1 Or a(25) > m2 Then GoTo 300
a(14) = -a(30) + a(47) + a(63): If a(14) < m1 Or a(14) > m2 Then GoTo 300
a(13) = s1 - a(14) - a(15) - a(16): If a(13) < m1 Or a(13) > m2 Then GoTo 300
a(10) = s1 - a(26) - a(42) - a(58): If a(10) < m1 Or a(10) > m2 Then GoTo 300
a(9) = s1 - a(10) - a(11) - a(12): If a(9) < m1 Or a(9) > m2 Then GoTo 300
a(40) = s1 / 2 - a(46): a(24) = s1 / 2 - a(30): a(8) = s1 / 2 - a(14)
a(39) = s1 / 2 - a(45): a(23) = s1 / 2 - a(29): a(7) = s1 / 2 - a(13)
a(38) = s1 / 2 - a(48): a(22) = s1 / 2 - a(32): a(6) = s1 / 2 - a(16)
a(37) = s1 / 2 - a(47): a(21) = s1 / 2 - a(31): a(5) = s1 / 2 - a(15)
a(36) = s1 / 2 - a(42): a(20) = s1 / 2 - a(26): a(4) = s1 / 2 - a(10)
a(35) = s1 / 2 - a(41): a(19) = s1 / 2 - a(25): a(3) = s1 / 2 - a(9)
a(34) = s1 / 2 - a(44): a(18) = s1 / 2 - a(28): a(2) = s1 / 2 - a(12)
a(33) = s1 / 2 - a(43): a(17) = s1 / 2 - a(27): a(1) = s1 / 2 - a(11)
' Exclude solutions with identical numbers in rows, colums or pillars
GoSub 800: If fl1 = 0 Then GoTo 300 'rows, colums or pillars
GoSub 900: If fl1 = 0 Then GoTo 300 'Valid (Semi) Latin Cube
n9 = n9 + 1: GoSub 740 'Print results (selected numbers)
' n9 = n9 + 1: GoSub 750 'Print results (planes 1, 2, 3, 4)
' n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
300 Next j30
310 Next j31
320 Next j32
470 Next j47
480 Next j48
600 Next j60
620 Next j62
630 Next j63
640 Next j64
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SudCube42")
End
' Print results (selected numbers)
740 For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Cells(1, 67).Value = n9
Return
' Print results (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
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
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 = a(i3)
Next i2
Next i1
Next i0
Return
' Exclude solutions with identical numbers in rows, colums or pillars
800 fl1 = 1
' Rows
i1 = -3
For i0 = 1 To 16
i1 = i1 + 4
b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3)
GoSub 860
If fl1 = 0 Then Return
Next i0
' Columns
i1 = 0: i2 = 0
For i0 = 1 To 16
i1 = i1 + 1
b(1) = a(i1): b(2) = a(i1 + 4): b(3) = a(i1 + 8): b(4) = a(i1 + 12)
i2 = i2 + 1: If i2 = 4 Then i2 = 0: i1 = i1 + 12
GoSub 860
If fl1 = 0 Then Return
Next i0
' Pillars
i1 = 0: i2 = 0
For i0 = 1 To 16
i1 = i0
b(1) = a(i1): b(2) = a(i1 + 16): b(3) = a(i1 + 32): b(4) = a(i1 + 48)
GoSub 860
If fl1 = 0 Then Return
Next i0
' Space Diagonals
b(1) = a(1): b(2) = a(22): b(3) = a(43): b(4) = a(64): GoSub 860: If fl1 = 0 Then Return
b(1) = a(4): b(2) = a(23): b(3) = a(42): b(4) = a(61): GoSub 860: If fl1 = 0 Then Return
b(1) = a(13): b(2) = a(26): b(3) = a(39): b(4) = a(52): GoSub 860: If fl1 = 0 Then Return
b(1) = a(16): b(2) = a(27): b(3) = a(38): b(4) = a(49): GoSub 860: If fl1 = 0 Then Return
' Diagonals Hor Magic Planes
b(1) = a(1): b(2) = a(6): b(3) = a(11): b(4) = a(16): GoSub 875: If fl1 = 0 Then Return
b(1) = a(4): b(2) = a(7): b(3) = a(10): b(4) = a(13): GoSub 875: If fl1 = 0 Then Return
b(1) = a(17): b(2) = a(22): b(3) = a(27): b(4) = a(32): GoSub 875: If fl1 = 0 Then Return
b(1) = a(20): b(2) = a(23): b(3) = a(26): b(4) = a(29): GoSub 875: If fl1 = 0 Then Return
b(1) = a(33): b(2) = a(38): b(3) = a(43): b(4) = a(48): GoSub 875: If fl1 = 0 Then Return
b(1) = a(36): b(2) = a(39): b(3) = a(42): b(4) = a(45): GoSub 875: If fl1 = 0 Then Return
b(1) = a(49): b(2) = a(54): b(3) = a(59): b(4) = a(64): GoSub 875: If fl1 = 0 Then Return
b(1) = a(52): b(2) = a(55): b(3) = a(58): b(4) = a(61): GoSub 875: If fl1 = 0 Then Return
Return
860 fl1 = 1
For j1 = 1 To 4
b2 = b(j1)
For j2 = (1 + j1) To 4
If b2 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
GoSub 875 'Check suitable for Prime Numbers
Return
' Check suitable for Prime Numbers
875 fl1 = 1
Erase s
For j1 = 1 To 4
s(b(j1) + 1) = s(b(j1) + 1) + 1
Next j1
For j1 = 1 To 4
If s(j1) <> s(9 - j1) Then fl1 = 0: Return
Next j1
Return
' Valid (Semi) Latin Cube
900 fl1 = 1
Erase s
For i1 = 1 To 64
s(a(i1) + 1) = s(a(i1) + 1) + 1
Next i1
For i1 = 1 To 8
If s(i1) <> 8 Then fl1 = 0: Return
Next i1
Return
End Sub
