' Generates Symmetric Semi-Latin Squares of order 6
' Almost Associated
' Tested with Office 2007 under Windows 7
Sub AssLat6()
Dim a1(81), a(36), b1(81), b(81), c(36), n62(6)
y = MsgBox("Locked", vbCritical, "Routine AssLat6")
End
n2 = 0: n3 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 6: s1 = 15: p6 = s1 / 3
a1(1) = 0: a1(2) = 1: a1(3) = 2: a1(4) = 3: a1(5) = 4: a1(6) = 5:
Sheets("Klad1").Select
t1 = Timer
' Generate Squares
For j36 = m1 To m2 'a(36)
a(36) = a1(j36)
a(1) = p6 - a(36)
For j35 = m1 To m2 'a(35)
a(35) = a1(j35)
a(5) = p6 - a(35)
For j34 = m1 To m2 'a(34)
a(34) = a1(j34)
a(3) = p6 - a(34)
For j33 = m1 To m2 'a(33)
a(33) = a1(j33)
a(4) = p6 - a(33)
For j32 = m1 To m2 'a(32)
a(32) = a1(j32)
a(2) = p6 - a(32)
a(31) = s1 - a(32) - a(33) - a(34) - a(35) - a(36)
If a(31) < a1(m1) Or a(31) > a1(m2) Then GoTo 320
a(6) = p6 - a(31):
' Check Row 1/6
b(1) = a(31): b(2) = a(32): b(3) = a(33): b(4) = a(34): b(5) = a(35): b(6) = a(36):
GoSub 860: If fl1 = 0 Then GoTo 320
For j30 = m1 To m2 'a(30)
a(30) = a1(j30)
a(25) = p6 - a(30)
For j29 = m1 To m2 'a(29)
a(29) = a1(j29)
a(8) = p6 - a(29)
For j28 = m1 To m2 'a(28)
a(28) = a1(j28)
a(9) = p6 - a(28)
For j27 = m1 To m2 'a(27)
a(27) = a1(j27)
a(26) = 4 * s1 / 6 - a(27) - a(28) - a(29)
If a(26) < a1(m1) Or a(26) > a1(m2) Then GoTo 270
a(10) = p6 - a(27): a(11) = p6 - a(26)
' Check Row 2
b(1) = a(25): b(2) = a(26): b(3) = a(27): b(4) = a(28): b(5) = a(29): b(6) = a(30):
GoSub 860: If fl1 = 0 Then GoTo 270
For j24 = m1 To m2 'a(24)
a(24) = a1(j24)
a(13) = p6 - a(24)
For j23 = m1 To m2 'a(23)
a(23) = a1(j23)
a(20) = -4 * s1 / 6 + a(23) + a(27) + a(28) + 2 * a(29)
If a(20) < a1(m1) Or a(20) > a1(m2) Then GoTo 230
a(14) = p6 - a(23): a(17) = p6 - a(20)
For j22 = m1 To m2 'a(22)
a(22) = a1(j22)
a(15) = p6 - a(22):
' Check Diagonal 1
b(1) = a(1): b(2) = a(8): b(3) = a(15): b(4) = a(22): b(5) = a(29): b(6) = a(36):
GoSub 860: If fl1 = 0 Then GoTo 220
a(21) = a(22) - a(27) + a(28) - a(33) + a(34)
If a(21) < a1(m1) Or a(21) > a1(m2) Then GoTo 220
a(16) = p6 - a(21)
' Check Diagonal 2
b(1) = a(6): b(2) = a(11): b(3) = a(16): b(4) = a(21): b(5) = a(26): b(6) = a(31):
GoSub 860: If fl1 = 0 Then GoTo 220
a(19) = 10 * s1 / 6 - 2 * a(22) - 2 * a(23) - a(24) - 2 * a(28) - 2 * a(29) + a(33) - a(34)
If a(19) < a1(m1) Or a(19) > a1(m2) Then GoTo 220
a(12) = p6 + a(19) - a(24) - a(30) + a(31) - a(36)
If a(12) < a1(m1) Or a(12) > a1(m2) Then GoTo 220
a(18) = p6 - a(19): a(7) = p6 - a(12)
' Check Row 5
b(1) = a(7): b(2) = a(8): b(3) = a(9): b(4) = a(10): b(5) = a(11): b(6) = a(12):
GoSub 860: If fl1 = 0 Then GoTo 220
' Check Row 3/4
b(1) = a(19): b(2) = a(20): b(3) = a(21): b(4) = a(22): b(5) = a(23): b(6) = a(24):
GoSub 860: If fl1 = 0 Then GoTo 220
' Check Columns 1 ... 6
i6 = 0
For i0 = 1 To 6
i6 = i6 + 1
b(1) = a(i6): b(2) = a(i6 + 6): b(3) = a(i6 + 12): b(4) = a(i6 + 18): b(5) = a(i6 + 24): b(6) = a(i6 + 30)
GoSub 2500: If fl1 = 0 Then GoTo 220
Next i0
n9 = n9 + 1: GoSub 2650 'Print results (squares)
' n9 = n9 + 1: GoSub 2645 'Print results (selected numbers)
' n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
''End
220 Next j22
230 Next j23
240 Next j24
270 Next j27
280 Next j28
290 Next j29
300 Next j30
320 Next j32
330 Next j33
340 Next j34
350 Next j35
360 Next j36
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SunLat6")
End
' Check Latin Rows and Diagonals
860 fl1 = 1
For i1 = 1 To 6
b22 = b(i1)
For i2 = (1 + i1) To 6
If b22 = b(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Check Semi Latin Columns
2500 fl1 = 0
' Count 1, 2, 3, 4, 5, 6
Erase n62
For i1 = 1 To 6
n62(b(i1) + 1) = n62(b(i1) + 1) + 1
Next i1
' Check Valid Combinations
If n62(1) = 1 And n62(2) = 1 And n62(3) = 1 And n62(4) = 1 And n62(5) = 1 And n62(6) = 1 Then fl1 = 1: Return
If n62(1) = 1 And n62(2) = 2 And n62(5) = 2 And n62(6) = 1 Then fl1 = 1: Return
If n62(1) = 1 And n62(3) = 2 And n62(4) = 2 And n62(6) = 1 Then fl1 = 1: Return
If n62(1) = 2 And n62(2) = 1 And n62(5) = 1 And n62(6) = 2 Then fl1 = 1: Return
If n62(1) = 2 And n62(3) = 1 And n62(4) = 1 And n62(6) = 2 Then fl1 = 1: Return
If n62(1) = 3 And n62(6) = 3 Then fl1 = 1: Return
If n62(2) = 1 And n62(3) = 2 And n62(4) = 2 And n62(5) = 1 Then fl1 = 1: Return
If n62(2) = 2 And n62(3) = 1 And n62(4) = 1 And n62(5) = 2 Then fl1 = 1: Return
If n62(2) = 3 And n62(5) = 3 Then fl1 = 1: Return
If n62(3) = 3 And n62(4) = 3 Then fl1 = 1: Return
Return
' Print results (selected numbers)
2645 For i1 = 1 To 36
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 37).Value = n9
Cells(1, 38).Value = n9
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 7: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 7
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 6
For i2 = 1 To 6
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
