' Generates Semi Latin Squares of order 10
(Symmetrical Diagonals / Composed Border)
' Tested with Office 365 under Windows 10
Sub SemiLat10()
Dim a(10, 10), a1(10), d1(10), d2(10)
Dim b(10, 10), c(10, 10), c1(100)
y = MsgBox("Blocked", 0, "SemiLat10")
End
Sheets("Klad1").Select
k1 = 1: k2 = 1
''Set Diagonals
For i1 = 1 To 10
d1(i1) = i1 - 1
d2(i1) = i1 - 1
Next i1
For j1 = 7 To 7 ''253
i10 = j1: i20 = 1: GoSub 200
If fl1 = 0 Then GoTo 10
For j2 = 254 To 505
Cells(1, 2).Value = j2
i10 = j2: i20 = 2: GoSub 200
If fl1 = 0 Then GoTo 20
GoSub 350: If fl1 = 0 Then GoTo 20
For j3 = 506 To 758
Cells(2, 2).Value = j3
i10 = j3: i20 = 3: GoSub 200
If fl1 = 0 Then GoTo 30
GoSub 350: If fl1 = 0 Then GoTo 30
For j4 = 759 To 1009
i10 = j4: i20 = 4: GoSub 200
If fl1 = 0 Then GoTo 40
GoSub 350: If fl1 = 0 Then GoTo 40
For j5 = 1010 To 1261
i10 = j5: i20 = 5: GoSub 200
If fl1 = 0 Then GoTo 50
GoSub 300: If fl1 = 0 Then GoTo 50 'Check Square
GoSub 500: If fl1 = 0 Then GoTo 50 'Check Border
n9 = n9 + 1: GoSub 650 'Print Result
'' Cells(1, 1).Value = n9 'Count Only
50 Next j5
40 Next j4
30 Next j3
20 Next j2
10 Next j1
End
' Check Border
500 fl1 = 1
For i1 = 3 To 8
s4 = a(i1, 1) + a(i1, 2) + a(i1, 9) + a(i1, 10)
If s4 <> 18 Then fl1 = 0: Return
Next i1
Return
' Read, Check and Store
200 fl1 = 1
For i1 = 1 To 10
a1(i1) = Sheets("MgcLns10").Cells(i10, i1).Value
Next i1
If a1(i20) <> d1(i20) Then fl1 = 0: Return
If a1(11 - i20) <> d2(i20) Then fl1 = 0: Return
For i1 = 1 To 10 'Store
a(i20, i1) = a1(i1)
a(11 - i20, i1) = 9 - a1(i1) 'Complement
Next i1
Return
' Intermediate Check
350 fl1 = 1
For i1 = 1 To 10
For i2 = 1 To 10
b(i1, i2) = a(i2, i1)
Next i2
Next i1
i3 = 0
For i1 = 1 To 10
For i2 = 1 To 10
c(i1, i2) = a(i1, i2) + 10 * b(i1, i2) + 1
i3 = i3 + 1: c1(i3) = c(i1, i2)
Next i2
Next i1
Select Case i20
Case 2
c1(1) = c(1, 1): c1(2) = c(1, 2): c1(3) = c(1, 9): c1(4) = c(1, 10):
c1(5) = c(2, 1): c1(6) = c(2, 2): c1(7) = c(2, 9): c1(8) = c(2, 10):
c1(9) = c(9, 1): c1(10) = c(9, 2): c1(11) = c(9, 9): c1(12) = c(9, 10):
c1(13) = c(10, 1): c1(14) = c(10, 2): c1(15) = c(10, 9): c1(16) = c(10, 10):
n10 = 16
Case 3
c1(1) = c(1, 1): c1(2) = c(1, 2): c1(3) = c(1, 3):
c1(4) = c(1, 8): c1(5) = c(1, 9): c1(6) = c(1, 10):
c1(7) = c(2, 1): c1(8) = c(2, 2): c1(9) = c(2, 3):
c1(10) = c(2, 8): c1(11) = c(2, 9): c1(12) = c(2, 10):
c1(13) = c(3, 1): c1(14) = c(3, 2): c1(15) = c(3, 3):
c1(16) = c(3, 8): c1(17) = c(3, 9): c1(18) = c(3, 10):
c1(19) = c(8, 1): c1(20) = c(8, 2): c1(21) = c(8, 3):
c1(22) = c(8, 8): c1(23) = c(8, 9): c1(24) = c(8, 10):
c1(25) = c(9, 1): c1(26) = c(9, 2): c1(27) = c(9, 3):
c1(28) = c(9, 8): c1(29) = c(9, 9): c1(30) = c(9, 10):
c1(31) = c(10, 1): c1(32) = c(10, 2): c1(33) = c(10, 3):
c1(34) = c(10, 8): c1(35) = c(10, 9): c1(36) = c(10, 10):
n10 = 36
Case 4
c1(1) = c(1, 1): c1(2) = c(1, 2): c1(3) = c(1, 3): c1(4) = c(1, 4):
c1(5) = c(1, 7): c1(6) = c(1, 8): c1(7) = c(1, 9): c1(8) = c(1, 10):
c1(9) = c(2, 1): c1(10) = c(2, 2): c1(11) = c(2, 3): c1(12) = c(2, 4):
c1(13) = c(2, 7): c1(14) = c(2, 8): c1(15) = c(2, 9): c1(16) = c(2, 10):
c1(17) = c(3, 1): c1(18) = c(3, 2): c1(19) = c(3, 3): c1(20) = c(3, 4):
c1(21) = c(3, 7): c1(22) = c(3, 8): c1(23) = c(3, 9): c1(24) = c(3, 10):
c1(25) = c(4, 1): c1(26) = c(4, 2): c1(27) = c(4, 3): c1(28) = c(4, 4):
c1(29) = c(4, 7): c1(30) = c(4, 8): c1(31) = c(4, 9): c1(32) = c(4, 10):
c1(33) = c(7, 1): c1(34) = c(7, 2): c1(35) = c(7, 3): c1(36) = c(7, 4):
c1(37) = c(7, 7): c1(38) = c(7, 8): c1(39) = c(7, 9): c1(40) = c(7, 10):
c1(41) = c(8, 1): c1(42) = c(8, 2): c1(43) = c(8, 3): c1(44) = c(8, 4):
c1(45) = c(8, 7): c1(46) = c(8, 8): c1(47) = c(8, 9): c1(48) = c(8, 10):
c1(49) = c(9, 1): c1(50) = c(9, 2): c1(51) = c(9, 3): c1(52) = c(9, 4):
c1(53) = c(9, 7): c1(54) = c(9, 8): c1(55) = c(9, 9): c1(56) = c(9, 10):
c1(57) = c(10, 1): c1(58) = c(10, 2): c1(59) = c(10, 3): c1(60) = c(10, 4):
c1(61) = c(10, 7): c1(62) = c(10, 8): c1(63) = c(10, 9): c1(64) = c(10, 10):
n10 = 64
End Select
For i1 = 1 To n10
c2 = c1(i1)
For i2 = (1 + i1) To n10
If c2 = c1(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Calculate and Check Square
300 fl1 = 1
For i1 = 1 To 10
For i2 = 1 To 10
b(i1, i2) = a(i2, i1)
Next i2
Next i1
i3 = 0
For i1 = 1 To 10
For i2 = 1 To 10
c(i1, i2) = a(i1, i2) + 10 * b(i1, i2) + 1
i3 = i3 + 1: c1(i3) = c(i1, i2)
Next i2
Next i1
For i1 = 1 To 100
c2 = c1(i1)
For i2 = (1 + i1) To 100
If c2 = c1(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Print results (squares)
650 n1 = n1 + 1
If n1 = 5 Then
n1 = 1: k1 = k1 + 11: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 11
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 10
For i2 = 1 To 10
''i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = c(i1, i2) ''c(i1, i2)
Next i2
Next i1
Return
End Sub
