Vorige Pagina About the Author

' Generates Simple Latin Cubes

' Tested with Office 365 under Windows 10

Sub LtnCbs4b()

Dim a(64), b(4)

y = MsgBox("Locked", vbCritical, "Routine LtnCbs4a")
End

n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 3: s1 = 6

ShtNm1 = "LtnLns4b"

'   Generate data
    
    Sheets("Klad1").Select
    
    t1 = Timer

For j100 = 2 To 577

    For i1 = 1 To 16
        a(i1 + 48) = Sheets(ShtNm1).Cells(j100, i1).Value
    Next i1
    Cells(2, 1).Value = j100

For j200 = 2 To 577
If j200 = j100 Then GoTo 2000

    For i1 = 1 To 16
        a(i1 + 32) = Sheets(ShtNm1).Cells(j200, i1).Value
    Next i1
    Cells(3, 1).Value = j200

'   Check Identical Integers

    For i1 = 1 To 16
        If a(i1 + 48) = a(i1 + 32) Then GoTo 2000
    Next i1

    If a(49) = a(38) Then GoTo 2000
    If a(52) = a(39) Then GoTo 2000
    If a(61) = a(42) Then GoTo 2000
    If a(64) = a(43) Then GoTo 2000

For j32 = m1 To m2                                                   'a(32)
    a(32) = j32
    If a(32) = a(48) Or a(32) = a(64) Then GoTo 320
    
    a(27) = a(32) - a(38) + a(48) + a(53) + a(57) - a(62) - a(63)
    If a(27) < 0 Or a(27) > 3 Then GoTo 320:
    If a(27) = a(43) Or a(27) = a(59) Then GoTo 320
    
For j31 = m1 To m2                                                   'a(31)
    a(31) = j31
    If a(31) = a(47) Or a(31) = a(63) Then GoTo 310
    If a(31) = a(27) Then GoTo 310

For j30 = m1 To m2                                                   'a(30)
    a(30) = j30
    If a(30) = a(46) Or a(30) = a(62) Then GoTo 300

    a(29) = s1 - a(30) - a(31) - a(32)
    If a(29) < 0 Or a(29) > 3 Then GoTo 300                          'a(29)
    If a(29) = a(45) Or a(29) = a(61) Then GoTo 300
    
    b(1) = a(32):  b(2) = a(31): b(3) = a(30): b(4) = a(29): GoSub 860: If fl1 = 0 Then GoTo 300
    
    a(26) = a(29) - a(39) + a(45) + a(56) + a(60) - a(62) - a(63)
    If a(26) < 0 Or a(26) > 3 Then GoTo 300:
    If a(26) = a(42) Or a(26) = a(58) Then GoTo 300
    If a(26) = a(30) Then GoTo 300
    If a(26) = a(27) Then GoTo 300
    
For j28 = m1 To m2                                                   'a(28)
    a(28) = j28
    If a(28) = a(44) Or a(28) = a(60) Then GoTo 280
    If a(28) = a(32) Then GoTo 280

    a(25) = s1 - a(26) - a(27) - a(28):
    If a(25) < 0 Or a(25) > 3 Then GoTo 280:
    If a(25) = a(41) Or a(25) = a(57) Then GoTo 280
    If a(25) = a(29) Then GoTo 280
   
    b(1) = a(25):  b(2) = a(26): b(3) = a(27): b(4) = a(28): GoSub 860: If fl1 = 0 Then GoTo 280
   
For j24 = m1 To m2                                                   'a(24)
    a(24) = j24
    If a(24) = a(40) Or a(24) = a(56) Then GoTo 240
    If a(24) = a(28) Or a(24) = a(32) Then GoTo 240
    
    a(23) = s1 - a(24) - a(28) - a(32) + a(36) - a(42) - a(56) - a(60) + a(62) + a(63)
    If a(23) < 0 Or a(23) > 3 Then GoTo 240:
    If a(23) = a(39) Or a(23) = a(55) Then GoTo 240
    If a(23) = a(27) Or a(23) = a(31) Then GoTo 240
    If a(23) = a(24) Then GoTo 240
    
For j22 = m1 To m2                                                   'a(22)
    a(22) = j22
    If a(22) = a(38) Or a(22) = a(54) Then GoTo 220
    If a(22) = a(23) Or a(22) = a(24) Then GoTo 220
    If a(22) = a(26) Or a(22) = a(30) Then GoTo 220
    
    a(21) = s1 - a(22) - a(23) - a(24): If a(21) < 0 Or a(21) > 3 Then GoTo 220:
    a(20) = s1 - a(24) - a(28) - a(32): If a(20) < 0 Or a(20) > 3 Then GoTo 220:
    a(19) = s1 - a(23) - a(27) - a(31): If a(19) < 0 Or a(19) > 3 Then GoTo 220:
    a(18) = s1 - a(22) - a(26) - a(30): If a(18) < 0 Or a(18) > 3 Then GoTo 220:
    a(17) = s1 - a(18) - a(19) - a(20): If a(17) < 0 Or a(17) > 3 Then GoTo 220:
    
    a(16) = s1 - a(32) - a(48) - a(64): If a(16) < 0 Or a(16) > 3 Then GoTo 220:
    a(15) = s1 - a(31) - a(47) - a(63): If a(15) < 0 Or a(15) > 3 Then GoTo 220:
    a(14) = s1 - a(30) - a(46) - a(62): If a(14) < 0 Or a(14) > 3 Then GoTo 220:
    a(13) = s1 - a(29) - a(45) - a(61): If a(13) < 0 Or a(13) > 3 Then GoTo 220:
    a(12) = s1 - a(28) - a(44) - a(60): If a(12) < 0 Or a(12) > 3 Then GoTo 220:
    a(11) = s1 - a(27) - a(43) - a(59): If a(11) < 0 Or a(11) > 3 Then GoTo 220:
    a(10) = s1 - a(26) - a(42) - a(58): If a(10) < 0 Or a(10) > 3 Then GoTo 220:
    a(9) = s1 - a(25) - a(41) - a(57):  If a(9) < 0 Or a(9) > 3 Then GoTo 220:
    a(8) = s1 - a(24) - a(40) - a(56):  If a(8) < 0 Or a(8) > 3 Then GoTo 220:
    a(7) = s1 - a(23) - a(39) - a(55):  If a(7) < 0 Or a(7) > 3 Then GoTo 220:
    a(6) = s1 - a(22) - a(38) - a(54):  If a(6) < 0 Or a(6) > 3 Then GoTo 220:
    a(5) = s1 - a(21) - a(37) - a(53):  If a(5) < 0 Or a(5) > 3 Then GoTo 220:
    a(4) = s1 - a(20) - a(36) - a(52):  If a(4) < 0 Or a(4) > 3 Then GoTo 220:
    a(3) = s1 - a(19) - a(35) - a(51):  If a(3) < 0 Or a(3) > 3 Then GoTo 220:
    a(2) = s1 - a(18) - a(34) - a(50):  If a(2) < 0 Or a(2) > 3 Then GoTo 220:
    a(1) = s1 - a(17) - a(33) - a(49):  If a(1) < 0 Or a(1) > 3 Then GoTo 220:
    
'           Exclude solutions with identical numbers in rows, colums or pillars
        
            GoSub 800: If fl1 = 0 Then GoTo 220     'rows, colums or pillars
                                                    'Space Diagonals, Diagonals Hor Magic Planes
                           
''          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
    
220 Next j22
240 Next j24
280 Next j28

300 Next j30
310 Next j31
320 Next j32
    
2000 Next j200
1000 Next j100

    t2 = Timer
    
    t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
    y = MsgBox(t10, 0, "Routine LtnCbs4a")

End

'   Print results (selected numbers)

740 For i1 = 1 To 64
        Cells(n9, i1).Value = a(i1)
    Next i1
    Cells(n9, 65).Value = j100
    Cells(n9, 66).Value = j200
    Cells(n9, 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(1, 1).Value = n9
    
    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = CStr(n9)
    Cells(k1, k2 + 2).Value = j100
    Cells(k1, k2 + 3).Value = j200
       
    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
'   Space Diagonals, Diagonals Hor. Magic Planes

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

    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
    Return

End Sub

Vorige Pagina About the Author