' Generates Semi-Latin Squares of order 8
' Pan Magic Corner Squares, Magic Middle - and Center Squares
' Tested with Office 2007 under Windows 7
Sub CompLat8b()
Dim a(64), a1(8), b(8)
y = MsgBox("Locked", vbCritical, "Routine CompLat8b")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 8: s1 = 28
For i1 = 1 To 8: a1(i1) = i1 - 1: Next i1
' Generate data
Sheets("Klad1").Select
t1 = Timer
For j64 = m1 To m2 'a(64)
a(64) = a1(j64)
For j63 = m1 To m2 'a(63)
a(63) = a1(j63)
For j62 = m1 To m2 'a(62)
a(62) = a1(j62)
a(61) = 0.5 * s1 - a(62) - a(63) - a(64)
If a(61) < a1(m1) Or a(61) > a1(m2) Then GoTo 620
For j60 = m1 To m2 'a(60)
a(60) = a1(j60)
a(59) = -a(60) + a(63) + a(64):
If a(59) < a1(m1) Or a(59) > a1(m2) Then GoTo 600:
a(58) = a(60) + a(62) - a(64):
If a(58) < a1(m1) Or a(58) > a1(m2) Then GoTo 600:
a(57) = 0.5 * s1 - a(60) - a(62) - a(63):
If a(57) < a1(m1) Or a(57) > a1(m2) Then GoTo 600:
' Check Row 1
For i1 = 1 To 8: b(i1) = a(i1 + 56): Next i1
GoSub 800: If fl1 = 0 Then GoTo 600
For j56 = m1 To m2 'a(56)
a(56) = a1(j56)
a(55) = 0.5 * s1 - a(56) - a(63) - a(64): If a(55) < a1(m1) Or a(55) > a1(m2) Then GoTo 560:
a(54) = a(56) - a(62) + a(64): If a(54) < a1(m1) Or a(54) > a1(m2) Then GoTo 560:
a(53) = -a(56) + a(62) + a(63): If a(53) < a1(m1) Or a(53) > a1(m2) Then GoTo 560:
a(52) = a(56) + a(60) - a(64): If a(52) < a1(m1) Or a(52) > a1(m2) Then GoTo 560:
a(51) = 0.5 * s1 - a(56) - a(60) - a(63): If a(51) < a1(m1) Or a(51) > a1(m2) Then GoTo 560:
a(50) = a(56) + a(60) - a(62): If a(50) < a1(m1) Or a(50) > a1(m2) Then GoTo 560:
a(49) = -a(56) - a(60) + a(62) + a(63) + a(64): If a(49) < a1(m1) Or a(49) > a1(m2) Then GoTo 560:
'Check Row 2
For i1 = 1 To 8: b(i1) = a(i1 + 48): Next i1
GoSub 800: If fl1 = 0 Then GoTo 560
a(48) = 0.25 * s1 - a(62): If a(48) < a1(m1) Or a(48) > a1(m2) Then GoTo 560:
a(47) = -0.25 * s1 + a(62) + a(63) + a(64): If a(47) < a1(m1) Or a(47) > a1(m2) Then GoTo 560:
a(46) = 0.25 * s1 - a(64): If a(46) < a1(m1) Or a(46) > a1(m2) Then GoTo 560:
a(45) = 0.25 * s1 - a(63): If a(45) < a1(m1) Or a(45) > a1(m2) Then GoTo 560:
a(44) = 0.25 * s1 - a(60) - a(62) + a(64): If a(44) < a1(m1) Or a(44) > a1(m2) Then GoTo 560:
a(43) = -0.25 * s1 + a(60) + a(62) + a(63): If a(43) < a1(m1) Or a(43) > a1(m2) Then GoTo 560:
a(42) = 0.25 * s1 - a(60): If a(42) < a1(m1) Or a(42) > a1(m2) Then GoTo 560:
a(41) = 0.25 * s1 + a(60) - a(63) - a(64): If a(41) < a1(m1) Or a(41) > a1(m2) Then GoTo 560:
'Check Row 3
For i1 = 1 To 8: b(i1) = a(i1 + 40): Next i1
GoSub 800: If fl1 = 0 Then GoTo 560
a(40) = 0.25 * s1 - a(56) + a(62) - a(64): If a(40) < a1(m1) Or a(40) > a1(m2) Then GoTo 560:
a(39) = 0.25 * s1 + a(56) - a(62) - a(63): If a(39) < a1(m1) Or a(39) > a1(m2) Then GoTo 560:
a(38) = 0.25 * s1 - a(56): If a(38) < a1(m1) Or a(38) > a1(m2) Then GoTo 560:
a(37) = -0.25 * s1 + a(56) + a(63) + a(64): If a(37) < a1(m1) Or a(37) > a1(m2) Then GoTo 560:
a(36) = 0.25 * s1 - a(56) - a(60) + a(62): If a(36) < a1(m1) Or a(36) > a1(m2) Then GoTo 560:
a(35) = 0.25 * s1 + a(56) + a(60) - a(62) - a(63) - a(64): If a(35) < a1(m1) Or a(35) > a1(m2) Then GoTo 560:
a(34) = 0.25 * s1 - a(56) - a(60) + a(64): If a(34) < a1(m1) Or a(34) > a1(m2) Then GoTo 560:
a(33) = -0.25 * s1 + a(56) + a(60) + a(63): If a(33) < a1(m1) Or a(33) > a1(m2) Then GoTo 560:
'Check Row 4
For i1 = 1 To 8: b(i1) = a(i1 + 32): Next i1
GoSub 800: If fl1 = 0 Then GoTo 560
For j32 = m1 To m2 'a(32)
a(32) = a1(j32)
a(31) = a(32) + a(63) - a(64): If a(31) < a1(m1) Or a(31) > a1(m2) Then GoTo 320:
a(30) = -a(32) + a(62) + a(64): If a(30) < a1(m1) Or a(30) > a1(m2) Then GoTo 320:
a(29) = 0.5 * s1 - a(32) - a(62) - a(63): If a(29) < a1(m1) Or a(29) > a1(m2) Then GoTo 320:
a(28) = a(32) + a(60) - a(64): If a(28) < a1(m1) Or a(28) > a1(m2) Then GoTo 320:
a(27) = a(32) - a(60) + a(63): If a(27) < a1(m1) Or a(27) > a1(m2) Then GoTo 320:
a(26) = -a(32) + a(60) + a(62): If a(26) < a1(m1) Or a(26) > a1(m2) Then GoTo 320:
a(25) = 0.5 * s1 - a(32) - a(60) - a(62) - a(63) + a(64): If a(25) < a1(m1) Or a(25) > a1(m2) Then GoTo 320:
'Check Row 5
For i1 = 1 To 8: b(i1) = a(i1 + 24): Next i1
GoSub 800: If fl1 = 0 Then GoTo 320
a(24) = -a(32) + a(56) + a(64): If a(24) < a1(m1) Or a(24) > a1(m2) Then GoTo 320:
a(23) = 0.5 * s1 - a(32) - a(56) - a(63): If a(23) < a1(m1) Or a(23) > a1(m2) Then GoTo 320:
a(22) = a(32) + a(56) - a(62): If a(22) < a1(m1) Or a(22) > a1(m2) Then GoTo 320:
a(21) = a(32) - a(56) + a(62) + a(63) - a(64): If a(21) < a1(m1) Or a(21) > a1(m2) Then GoTo 320:
a(20) = -a(32) + a(56) + a(60): If a(20) < a1(m1) Or a(20) > a1(m2) Then GoTo 320:
a(19) = 0.5 * s1 - a(32) - a(56) - a(60) - a(63) + a(64): If a(19) < a1(m1) Or a(19) > a1(m2) Then GoTo 320:
a(18) = a(32) + a(56) + a(60) - a(62) - a(64): If a(18) < a1(m1) Or a(18) > a1(m2) Then GoTo 320:
a(17) = a(32) - a(56) - a(60) + a(62) + a(63): If a(17) < a1(m1) Or a(17) > a1(m2) Then GoTo 320:
'Check Row 6
For i1 = 1 To 8: b(i1) = a(i1 + 16): Next i1
GoSub 800: If fl1 = 0 Then GoTo 320
a(16) = 0.25 * s1 + a(32) - a(62) - a(64): If a(16) < a1(m1) Or a(16) > a1(m2) Then GoTo 320:
a(15) = -0.25 * s1 + a(32) + a(62) + a(63): If a(15) < a1(m1) Or a(15) > a1(m2) Then GoTo 320:
a(14) = 0.25 * s1 - a(32): If a(14) < a1(m1) Or a(14) > a1(m2) Then GoTo 320:
a(13) = 0.25 * s1 - a(32) - a(63) + a(64): If a(13) < a1(m1) Or a(13) > a1(m2) Then GoTo 320:
a(12) = 0.25 * s1 + a(32) - a(60) - a(62): If a(12) < a1(m1) Or a(12) > a1(m2) Then GoTo 320:
a(11) = -0.25 * s1 + a(32) + a(60) + a(62) + a(63) - a(64): If a(11) < a1(m1) Or a(11) > a1(m2) Then GoTo 320:
a(10) = 0.25 * s1 - a(32) - a(60) + a(64): If a(10) < a1(m1) Or a(10) > a1(m2) Then GoTo 320:
a(9) = 0.25 * s1 - a(32) + a(60) - a(63): If a(9) < a1(m1) Or a(9) > a1(m2) Then GoTo 320:
'Check Row 7
For i1 = 1 To 8: b(i1) = a(i1 + 8): Next i1
GoSub 800: If fl1 = 0 Then GoTo 320
a(8) = 0.25 * s1 - a(32) - a(56) + a(62): If a(8) < a1(m1) Or a(8) > a1(m2) Then GoTo 320:
a(7) = 0.25 * s1 - a(32) + a(56) - a(62) - a(63) + a(64): If a(7) < a1(m1) Or a(7) > a1(m2) Then GoTo 320:
a(6) = 0.25 * s1 + a(32) - a(56) - a(64): If a(6) < a1(m1) Or a(6) > a1(m2) Then GoTo 320:
a(5) = -0.25 * s1 + a(32) + a(56) + a(63): If a(5) < a1(m1) Or a(5) > a1(m2) Then GoTo 320:
a(4) = 0.25 * s1 - a(32) - a(56) - a(60) + a(62) + a(64): If a(4) < a1(m1) Or a(4) > a1(m2) Then GoTo 320:
a(3) = 0.25 * s1 - a(32) + a(56) + a(60) - a(62) - a(63): If a(3) < a1(m1) Or a(3) > a1(m2) Then GoTo 320:
a(2) = 0.25 * s1 + a(32) - a(56) - a(60): If a(2) < a1(m1) Or a(2) > a1(m2) Then GoTo 320:
a(1) = -0.25 * s1 + a(32) + a(56) + a(60) + a(63) - a(64): If a(1) < a1(m1) Or a(1) > a1(m2) Then GoTo 320:
'Check Row 8
For i1 = 1 To 8: b(i1) = a(i1): Next i1
GoSub 800: If fl1 = 0 Then GoTo 320
'Check Diagonal 1
i2 = 1
For i1 = 1 To 8:
b(i1) = a(i2): i2 = i2 + 9
Next i1
GoSub 800: If fl1 = 0 Then GoTo 320
'Check Diagonal 2
i2 = 8
For i1 = 1 To 8:
b(i1) = a(i2): i2 = i2 + 7
Next i1
GoSub 800: If fl1 = 0 Then GoTo 320
n9 = n9 + 1
GoSub 650 'Print results (squares)
'' GoSub 645 'Print results (selected numbers)
320 Next j32
560 Next j56
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 CompLat8b")
End
' Check Identical nNumbers in Row
800 fl1 = 1
For j1 = 1 To 8
b2 = b(j1)
For j2 = (1 + j1) To 8
If b2 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Print results (selected numbers)
645 For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 65).Value = n9
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
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 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
