Vorige Pagina Volgende Pagina About the Author

' Generates Bordered Magic Cubes of order 6 (Prime Numbers)
' Magic Top and Bottom Squares
' Part I: Semi Magic Anti Symmetric Squares (3 x 3)

' Tested with Office 2007 under Windows 7

Sub PrimeCubes6c()

Dim a1(1200), b1(21803), a(9), b(21803), c(9), c6(216)
Dim a2(9), b2(21803), c2(9)

y = MsgBox("Locked", vbCritical, "Routine Priem3c")
End
    
    n1 = 0: n9 = 0: n10 = 0: k1 = 1: k2 = 1
    ShtNm1 = "Pairs63"

    Sheets("Klad1").Select
    t1 = Timer

For j100 = 56 To 87

    GoSub 3100                                  'Read Prime Numbers From Sheet ShtNm1
''    If nVar < 216 Then GoTo 1000
    If nSemi3 < 16 Then GoTo 1000

'   Generate Squares (7 Magic Lines)

For j9 = m1 To m2                                                     'a(9)
If b1(a1(j9)) = 0 Then GoTo 2090
If b(a1(j9)) = 0 Then b(a1(j9)) = a1(j9): c(9) = a1(j9) Else GoTo 2090
a(9) = a1(j9)

For j8 = m1 To m2                                                     'a(8)
If b1(a1(j8)) = 0 Then GoTo 2080
If b(a1(j8)) = 0 Then b(a1(j8)) = a1(j8): c(8) = a1(j8) Else GoTo 2080
a(8) = a1(j8)

    a(7) = s1 - a(8) - a(9):
    If a(7) < a1(m1) Or a(7) > a1(m2) Then GoTo 2070
    If b1(a(7)) = 0 Then GoTo 2070
    If b(a(7)) = 0 Then b(a(7)) = a(7): c(7) = a(7) Else GoTo 2070
    
For j6 = m1 To m2                                                     'a(6)
If b1(a1(j6)) = 0 Then GoTo 2060
If b(a1(j6)) = 0 Then b(a1(j6)) = a1(j6): c(6) = a1(j6) Else GoTo 2060
a(6) = a1(j6)

    a(5) = -s1 + a(6) + a(8) + 2 * a(9)
    If a(5) < a1(m1) Or a(5) > a1(m2) Then GoTo 2050:
    If b1(a(5)) = 0 Then GoTo 2050
    If b(a(5)) = 0 Then b(a(5)) = a(5): c(5) = a(5) Else GoTo 2050
    
    a(4) = 2 * s1 - 2 * a(6) - a(8) - 2 * a(9)
    If a(4) < a1(m1) Or a(4) > a1(m2) Then GoTo 2040:
    If b1(a(4)) = 0 Then GoTo 2040
    If b(a(4)) = 0 Then b(a(4)) = a(4): c(4) = a(4) Else GoTo 2040
    
    a(3) = s1 - a(6) - a(9)
    If a(3) < a1(m1) Or a(3) > a1(m2) Then GoTo 2030:
    If b1(a(3)) = 0 Then GoTo 2030
    If b(a(3)) = 0 Then b(a(3)) = a(3): c(3) = a(3) Else GoTo 2030
    
    a(2) = 2 * s1 - a(6) - 2 * a(8) - 2 * a(9)
    If a(2) < a1(m1) Or a(2) > a1(m2) Then GoTo 2020:
    If b1(a(2)) = 0 Then GoTo 2020
    If b(a(2)) = 0 Then b(a(2)) = a(2): c(2) = a(2) Else GoTo 2020
    
    a(1) = -2 * s1 + 2 * a(6) + 2 * a(8) + 3 * a(9)
    If a(1) < a1(m1) Or a(1) > a1(m2) Then GoTo 2010:
    If b1(a(1)) = 0 Then GoTo 2010
    If b(a(1)) = 0 Then b(a(1)) = a(1): c(1) = a(1) Else GoTo 2010

                 GoSub 950: If fl1 = 0 Then GoTo 2005    ' Anti Symmetric

                 n10 = n10 + 1
                 If n10 <= 4 Then
                        
                        GoSub 3000                       ' Determine Adjacent Back Square
                        
                        If fl2 = 0 Then
                            GoSub 905                    ' Restore a(1) ... a(6) in b1()
                            n10 = n10 - 1: GoTo 2005
                        Else

                            GoSub 750                    ' Transform and Assign Sub Squares to c6()
                            GoSub 910                    ' Remove used primes a2() from  b1()
                        End If
                        
                        Erase b, c: GoTo 2090
                 Else
                        Erase b, c: GoTo 1000
                 End If
                          
2005  b(c(1)) = 0: c(1) = 0
2010  b(c(2)) = 0: c(2) = 0
2020  b(c(3)) = 0: c(3) = 0
2030  b(c(4)) = 0: c(4) = 0
2040  b(c(5)) = 0: c(5) = 0
2050 b(c(6)) = 0: c(6) = 0
2060 Next j6
   
     b(c(7)) = 0: c(7) = 0
2070 b(c(8)) = 0: c(8) = 0
2080 Next j8
    
     b(c(9)) = 0: c(9) = 0
2090 Next j9
    

1000  n10 = 0
      Next j100

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

End

'   Determine Adjacent Back Square

3000 fl2 = 1
     Erase b2, c2: GoSub 900   ' Remove a(1) ... a(6)  from  b1()

     a2(9) = a(9): a2(8) = a(8): a2(7) = a(7)
     b2(a2(9)) = a2(9): b2(a2(8)) = a2(8): b2(a2(7)) = a2(7):

For jj6 = m1 To m2                                                     'a2(6)
If b1(a1(jj6)) = 0 Then GoTo 3060
If b2(a1(jj6)) = 0 Then b2(a1(jj6)) = a1(jj6): c2(6) = a1(jj6) Else GoTo 3060
a2(6) = a1(jj6)

    a2(3) = s1 - a2(6) - a2(9)
    If a2(3) < a1(m1) Or a2(3) > a1(m2) Then GoTo 3030:
    If b1(a2(3)) = 0 Then GoTo 3030
    If b2(a2(3)) = 0 Then b2(a2(3)) = a2(3): c2(3) = a2(3) Else GoTo 3030

For jj5 = m1 To m2                                                     'a2(5)
If b1(a1(jj5)) = 0 Then GoTo 3050
If b2(a1(jj5)) = 0 Then b2(a1(jj5)) = a1(jj5): c2(5) = a1(jj5) Else GoTo 3050
a2(5) = a1(jj5)
    
    a2(4) = s1 - a2(5) - a2(6)
    If a2(4) < a1(m1) Or a2(4) > a1(m2) Then GoTo 3040:
    If b1(a2(4)) = 0 Then GoTo 3040
    If b2(a2(4)) = 0 Then b2(a2(4)) = a2(4): c2(4) = a2(4) Else GoTo 3040
    
    a2(2) = s1 - a2(5) - a2(8)
    If a2(2) < a1(m1) Or a2(2) > a1(m2) Then GoTo 3020:
    If b1(a2(2)) = 0 Then GoTo 3020
    If b2(a2(2)) = 0 Then b2(a2(2)) = a2(2): c2(2) = a2(2) Else GoTo 3020
    
    a2(1) = -s1 + a2(5) + a2(6) + a2(8) + a2(9)
    If a2(1) < a1(m1) Or a2(1) > a1(m2) Then GoTo 3010:
    If b1(a2(1)) = 0 Then GoTo 3010
    If b2(a2(1)) = 0 Then b2(a2(1)) = a2(1): c2(1) = a2(1) Else GoTo 3010

                      GoSub 960: If fl1 = 0 Then GoTo 3005    ' Anti Symmetric
                      Return

3005  b2(c2(1)) = 0: c2(1) = 0
3010  b2(c2(2)) = 0: c2(2) = 0
3020  b2(c2(4)) = 0: c2(4) = 0
3040  b2(c2(5)) = 0: c2(5) = 0
3050  Next jj5
   
     b2(c2(3)) = 0: c2(3) = 0
3030 b2(c2(6)) = 0: c2(6) = 0
3060 Next jj6
    
    fl2 = 0
    Return
    
'   Transform and Assign Sub Squares to c6()

750

''n9 = n9 + 1: GoSub 650  'Print Semi Magic Square a()
''n9 = n9 + 1: GoSub 660  'Print Semi Magic Square a2()
''Return
     
     Select Case n10
    
        Case 1:
             
            c6(1) = a(7):   c6(2) = a(8):   c6(3) = a(9):   'Top
            c6(7) = a(4):   c6(8) = a(5):   c6(9) = a(6):
            c6(13) = a(1):  c6(14) = a(2):  c6(15) = a(3):
            c6(37) = a2(4): c6(38) = a2(5): c6(39) = a2(6): 'Back
            c6(73) = a2(1): c6(74) = a2(2): c6(75) = a2(3):
        
        Case 2:
            
            c6(4) = a(9):   c6(5) = a(8):   c6(6) = a(7):   'Top
            c6(10) = a(6):  c6(11) = a(5):  c6(12) = a(4):
            c6(16) = a(3):  c6(17) = a(2):  c6(18) = a(1):
            c6(40) = a2(6): c6(41) = a2(5): c6(42) = a2(4): 'Back
            c6(76) = a2(3): c6(77) = a2(2): c6(78) = a2(1):

        Case 3:
            
            c6(19) = a(1):  c6(20) = a(2):  c6(21) = a(3):  'Top
            c6(25) = a(4):  c6(26) = a(5):  c6(27) = a(6):
            c6(31) = a(7):  c6(32) = a(8):  c6(33) = a(9):
        
            c6(114) = Pr3 - a2(1):  c6(110) = Pr3 - a2(2):  c6(111) = Pr3 - a2(3):  'Back
            c6(150) = Pr3 - a2(4):  c6(146) = Pr3 - a2(5):  c6(147) = Pr3 - a2(6):
       
        Case 4:
            
            c6(22) = a(3):  c6(23) = a(2):  c6(24) = a(1):  'Top
            c6(28) = a(6):  c6(29) = a(5):  c6(30) = a(4):
            c6(34) = a(9):  c6(35) = a(8):  c6(36) = a(7):

            c6(112) = Pr3 - a2(3):  c6(113) = Pr3 - a2(2):  c6(109) = Pr3 - a2(1):  'Back
            c6(148) = Pr3 - a2(6):  c6(149) = Pr3 - a2(5):  c6(145) = Pr3 - a2(4):
                        
            'Bottom
            
            c6(181) = Pr3 - c6(36): c6(182) = Pr3 - c6(32): c6(183) = Pr3 - c6(33): 
            c6(184) = Pr3 - c6(34): c6(185) = Pr3 - c6(35): c6(186) = Pr3 - c6(31):
            c6(187) = Pr3 - c6(12): c6(188) = Pr3 - c6(8):  c6(189) = Pr3 - c6(9):  
            c6(190) = Pr3 - c6(10): c6(191) = Pr3 - c6(11): c6(192) = Pr3 - c6(7):
            c6(193) = Pr3 - c6(18): c6(194) = Pr3 - c6(14): c6(195) = Pr3 - c6(15): 
            c6(196) = Pr3 - c6(16): c6(197) = Pr3 - c6(17): c6(198) = Pr3 - c6(13):
            c6(199) = Pr3 - c6(24): c6(200) = Pr3 - c6(20): c6(201) = Pr3 - c6(21): 
            c6(202) = Pr3 - c6(22): c6(203) = Pr3 - c6(23): c6(204) = Pr3 - c6(19):
            c6(205) = Pr3 - c6(30): c6(206) = Pr3 - c6(26): c6(207) = Pr3 - c6(27): 
            c6(208) = Pr3 - c6(28): c6(209) = Pr3 - c6(29): c6(210) = Pr3 - c6(25):
            c6(211) = Pr3 - c6(6):  c6(212) = Pr3 - c6(2):  c6(213) = Pr3 - c6(3):  
            c6(214) = Pr3 - c6(4):  c6(215) = Pr3 - c6(5):  c6(216) = Pr3 - c6(1):
     
            'Front
     
            c6(67) =  Pr3 - c6(42):  c6(68) =  Pr3 - c6(38):  c6(69) =  Pr3 - c6(39):   
            c6(70) =  Pr3 - c6(40):  c6(71) =  Pr3 - c6(41):  c6(72) =  Pr3 - c6(37):
            c6(103) = Pr3 - c6(78):  c6(104) = Pr3 - c6(74):  c6(105) = Pr3 - c6(75):  
            c6(106) = Pr3 - c6(76):  c6(107) = Pr3 - c6(77):  c6(108) = Pr3 - c6(73):
            c6(139) = Pr3 - c6(114): c6(140) = Pr3 - c6(110): c6(141) = Pr3 - c6(111): 
            c6(142) = Pr3 - c6(112): c6(143) = Pr3 - c6(113): c6(144) = Pr3 - c6(109):
            c6(175) = Pr3 - c6(150): c6(176) = Pr3 - c6(146): c6(177) = Pr3 - c6(147): 
            c6(178) = Pr3 - c6(148): c6(179) = Pr3 - c6(149): c6(180) = Pr3 - c6(145):
     
            GoSub 850                    'Back Check Identical Numbers
            If fl1 = 1 Then
'               n9 = n9 + 1: GoSub 1750  'Print Cube
                n9 = n9 + 1: GoSub 1740  'Print Selected Numbers
            End If
           
     End Select

     Return

'   Print Semi Magic Square a()

650 n1 = n1 + 1
    If n1 = 5 Then
        n1 = 1: k1 = k1 + 4: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 4
    End If
    
    Cells(k1, k2 + 1).Select
    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = s1
    
    i3 = 0
    For i1 = 1 To 3
        For i2 = 1 To 3
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a(i3)
        Next i2
    Next i1
    Return
    
'   Print Semi Magic Square a2()

660 n1 = n1 + 1
    If n1 = 5 Then
        n1 = 1: k1 = k1 + 4: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 4
    End If
    
    Cells(k1, k2 + 1).Select
    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = s1
    
    i3 = 0
    For i1 = 1 To 3
        For i2 = 1 To 3
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a2(i3)
        Next i2
    Next i1
    Return

'    Exclude solutions with identical numbers c6()

850  fl1 = 1
     For j1 = 1 To 216
        a20 = c6(j1): If a20 = 0 Then GoTo 855
        For j2 = (1 + j1) To 216
            If a20 = c6(j2) Then fl1 = 0: Return
        Next j2
855  Next j1
     Return

'   Remove primes a(1) ... a(6) from primes b1()

900 For i1 = 1 To 6
        b1(a(i1)) = 0: b1(Pr3 - a(i1)) = 0
    Next i1
    Return
     
'   Restore primes a(1) ... a(6) in b1()

905 For i1 = 1 To 6
        b1(a(i1)) = a(i1): b1(Pr3 - a(i1)) = Pr3 - a(i1)
    Next i1
    Return
     
'    Remove used primes a2() from available primes b1()

910  For i1 = 1 To 9
         b1(a2(i1)) = 0: b1(Pr3 - a2(i1)) = 0
     Next i1
     Return
    
'   Check Pairs a()

950 fl1 = 1: n25 = 0
    For j1 = 1 To 9
       a20 = Pr3 - a(j1)          'Complement
       For j2 = (1 + j1) To 9
            If a20 = a(j2) Then fl1 = 0: Return
       Next j2
    Next j1
    Return
     
'   Check Pairs a2()

960 fl1 = 1: n25 = 0
    For j1 = 1 To 9
       a20 = Pr3 - a2(j1)          'Complement
       For j2 = (1 + j1) To 9
            If a20 = a2(j2) Then fl1 = 0: Return
       Next j2
    Next j1
    Return
    
'    Print Intrmediate Results
    
1740 For i1 = 1 To 216
         Cells(n9, i1).Value = c6(i1)
     Next i1
     Cells(n9, 217).Value = s2
     Cells(n9, 218).Value = j100
     Return
     
'    Print results (6 plane format)

1750 n2 = n2 + 1
     If n2 = 4 Then
         n2 = 1: k1 = k1 + 42: 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 = "MC = " + CStr(s2)
       
     For i0 = 1 To 6
         i3 = (6 - i0) * 36
         For i1 = 1 To 6
             For i2 = 1 To 6
                 i3 = i3 + 1
                 Cells(k1 + i1 + (i0 - 1) * 7, k2 + i2).Value = c6(i3)
             Next i2
         Next i1
     Next i0
    
     Return
     
'    Read Prime Numbers From Sheet ShtNm1

3100 Pr3 = Sheets(ShtNm1).Cells(j100, 1).Value    'Pair Sum
     s1 = 3 * Pr3 / 2                             'MC3
     s2 = 3 * Pr3                                 'MC6
     nVar = Sheets(ShtNm1).Cells(j100, 5).Value
     
     nSemi3 = Sheets(ShtNm1).Cells(j100, 6).Value 'Expected Nmbr Semi Magic Squares
    
     m1 = 1: m2 = nVar
    
     For i1 = m1 To m2
         a1(i1) = Sheets(ShtNm1).Cells(j100, i1 + 10).Value
     Next i1
     If a1(1) = 1 Then m1 = 2
    
     Erase b1
     For i1 = m1 To m2
         b1(a1(i1)) = a1(i1)
     Next i1
   
     Return

End Sub

Vorige Pagina Volgende Pagina About the Author