' Generates Latin (Diagonal) Squares of order 4
' Tested with Office 2007 under Windows 7
Sub LatSqr4()
Dim a(16), a1(4), b(4), s10(8)
y = MsgBox("Locked", vbExclamation, "Routine LatSqr4")
End
n1 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 4: s1 = 6
a1(1) = 0: a1(2) = 1: a1(3) = 2: a1(4) = 3
Sheets("Klad1").Select
t1 = Timer
For j16 = m1 To m2 'a(16)
a(16) = a1(j16)
For j15 = m1 To m2 'a(15)
a(15) = a1(j15)
If a(15) = a(16) Then GoTo 150
For j14 = m1 To m2 'a(14)
a(14) = a1(j14)
If a(14) = a(15) Or a(14) = a(16) Then GoTo 140
a(13) = s1 - a(14) - a(15) - a(16)
For j12 = m1 To m2 'a(12)
a(12) = a1(j12)
If a(12) = a(16) Then GoTo 120
For j11 = m1 To m2 'a(11)
a(11) = a1(j11)
If a(11) = a(12) Then GoTo 110
If a(11) = a(15) Then GoTo 110
For j10 = m1 To m2 'a(10)
a(10) = a1(j10)
If a(10) = a(11) Or a(10) = a(12) Then GoTo 100
If a(10) = a(14) Then GoTo 100
a(9) = s1 - a(10) - a(11) - a(12)
If a(9) = a(13) Then GoTo 100
For j8 = m1 To m2 'a(8)
a(8) = a1(j8)
If a(8) = a(12) Or a(8) = a(16) Then GoTo 80
For j7 = m1 To m2 'a(7)
a(7) = a1(j7)
If a(7) = a(8) Then GoTo 70
If a(7) = a(11) Or a(7) = a(15) Then GoTo 70
For j6 = m1 To m2 'a(6)
a(6) = a1(j6)
If a(6) = a(7) Or a(6) = a(8) Then GoTo 60
If a(6) = a(10) Or a(6) = a(14) Then GoTo 60
a(5) = s1 - a(6) - a(7) - a(8)
If a(5) = a(9) Or a(5) = a(13) Then GoTo 60
a(1) = s1 - a(5) - a(9) - a(13)
a(2) = s1 - a(6) - a(10) - a(14)
a(3) = s1 - a(7) - a(11) - a(15)
a(4) = s1 - a(8) - a(12) - a(16)
' Check Latin Diagonals (Option)
' GoSub 200: If fl1 = 0 Then GoTo 60
' Check Pan Diagonals (Option)
' GoSub 850: If fl1 = 0 Then GoTo 60
' Check Associated (Option)
GoSub 400: If fl1 = 0 Then GoTo 60
' n9 = n9 + 1: GoSub 640 'Print results (selected numbers)
n9 = n9 + 1: GoSub 650 'Print results (squares)
60 Next j6
70 Next j7
80 Next j8
100 Next j10
110 Next j11
120 Next j12
140 Next j14
150 Next j15
160 Next j16
t2 = Timer
t10 = Str(t2 - t1) + " sec, " + Str(n9) + " Solutions"
y = MsgBox(t10, vbInformation, "Routine LatSqr4")
End
' Check Diagonals (Option)
200 fl1 = 1
b(1) = a(1): b(2) = a(6): b(3) = a(11): b(4) = a(16):
GoSub 300: If fl1 = 0 Then Return
b(1) = a(4): b(2) = a(7): b(3) = a(10): b(4) = a(13):
GoSub 300: If fl1 = 0 Then Return
Return
300 fl1 = 1
For i1 = 1 To 4
b2 = b(i1)
For i2 = (1 + i1) To 4
If b2 = b(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Check Associated Pairs
400 fl1 = 1
s10(1) = a(1) + a(16)
s10(2) = a(2) + a(15)
s10(3) = a(3) + a(14)
s10(4) = a(4) + a(13)
s10(5) = a(5) + a(12)
s10(6) = a(6) + a(11)
s10(7) = a(7) + a(10)
s10(8) = a(8) + a(9)
For j1 = 1 To 8
If s10(j1) <> 3 Then fl1 = 0: Return
Next j1
Return
' Check Pan Diagonals
850 fl1 = 1
s10(1) = a(1) + a(6) + a(11) + a(16)
s10(2) = a(2) + a(7) + a(12) + a(13)
s10(3) = a(3) + a(8) + a(9) + a(14)
s10(4) = a(4) + a(5) + a(10) + a(15)
s10(5) = a(4) + a(7) + a(10) + a(13)
s10(6) = a(3) + a(6) + a(9) + a(16)
s10(7) = a(2) + a(5) + a(12) + a(15)
s10(8) = a(1) + a(8) + a(11) + a(14)
For j1 = 1 To 8
If s10(j1) <> 6 Then fl1 = 0: Return
Next j1
Return
' Print results (selected numbers)
640 Cells(n9, 17).Select
For i1 = 1 To 16
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 17).Value = n9
Return
' Print results (squares)
650 n1 = n1 + 1
If n1 = 5 Then
n1 = 1: k1 = k1 + 5: 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 = n9
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
End Sub
