数论问题巅峰对决

ysr

额，明白了，我试试40000内的如何？

ysr

程序改进完成，下面是对1~40000之间的收索结果：
13与39998之间有4组6生素数对:
/13/17/11/19/7/23
/103/107/101/109/97/113
/16063/16067/16061/16069/16057/16073
/19423/19427/19421/19429/19417/19433

ysr

其中在1~100内仅一组。

ysr

下面是对1~80000之间的搜索结果：
7与80003之间有5组6生素数对:
/13/17/11/19/7/23
/103/107/101/109/97/113
/16063/16067/16061/16069/16057/16073
/19423/19427/19421/19429/19417/19433
/43783/43787/43781/43789/43777/43793

代码如下：（仅发主程序）
Private Sub Command1_Click()
Dim a, b
a = Val(15) - 8
a1 = a
q1 = Int(Val(Text2) / 15)
q = q1 * 15 + 8
m = Sqr(q)
If Right(a, 1) Mod 2 = 0 Then
a = a + 1
Else
a = a
End If
s = 0
a2 = 1
Do While a <= m
B1 = a2 * 15 - 2
b2 = a2 * 15 + 2
b3 = a2 * 15 - 4
b4 = a2 * 15 + 4
b5 = a2 * 15 - 8
b6 = a2 * 15 + 8
c1 = fenjieyinzi0(Val(B1))
C2 = fenjieyinzi0(Val(b3))
c3 = fenjieyinzi0(Val(b5))
D1 = fenjieyinzi0(Val(b2))
D2 = fenjieyinzi0(Val(b4))
d3 = fenjieyinzi0(Val(b6))
If InStr(c1, "*") = 0 And InStr(D1, "*") = 0 And InStr(C2, "*") = 0 And InStr(D2, "*") = 0 And InStr(c3, "*") = 0 And InStr(d3, "*") = 0 Then
s = s + 1
Print B1, b2, b3, b4
Text3 = Text3 & "/" & B1 & "/" & b2 & "/" & b3 & "/" & b4 & "/" & b5 & "/" & b6 & vbCrLf
Else
s = s
End If
a2 = a2 + 2
a = a2 * 15 + 8
Loop
a2 = a2
s1 = s
Do While a2 * 15 + 8 <= q
B1 = a2 * 15 - 2
b2 = a2 * 15 + 2
b3 = a2 * 15 - 4
b4 = a2 * 15 + 4
b5 = a2 * 15 - 8
b6 = a2 * 15 + 8
c1 = fenjieyinzi0(Val(B1))
C2 = fenjieyinzi0(Val(b3))
c3 = fenjieyinzi0(Val(b5))
D1 = fenjieyinzi0(Val(b2))
D2 = fenjieyinzi0(Val(b4))
d3 = fenjieyinzi0(Val(b6))
If InStr(c1, "*") = 0 And InStr(D1, "*") = 0 And InStr(C2, "*") = 0 And InStr(D2, "*") = 0 And InStr(c3, "*") = 0 And InStr(d3, "*") = 0 Then
s1 = s1 + 1
Print B1, b2, b3, b4
Text3 = Text3 & "/" & B1 & "/" & b2 & "/" & b3 & "/" & b4 & "/" & b5 & "/" & b6 & vbCrLf
Else
s1 = s1
End If
a2 = a2 + 2

Loop
Combo1 = a1 & "与" & q & "之间有" & s1 & "组6生素数对:" & vbCrLf & Text3
s103 = DeleteSpace1(Text3)
s103 = Mid(s103, 1)
Dim i As Integer
Dim ak(), s105, cr(), f
Set f = CreateObject("Scripting.Dictionary")
s105 = Split(s103, "/")
   j1 = UBound(s105)
   Print j1
   For k = 1 To j1
      n1 = n1 + 1
       ReDim Preserve ak(1 To n1)
      ak(n1) = s105(n1)
    Next
    Print ak(1)
     n = 0
        For k = 1 To j1
           For i = 1 To j1
             n = n + 1
             ReDim Preserve cr(1 To n)
            m = Val(ak(k)) + Val(ak(i))
            f(m) = ""
      Next
    Next
      n = 0
      m = f.Keys
      For i = 0 To f.Count - 1
          ReDim Preserve cr(1 To i + 1)
          cr(i + 1) = m(i)
      Next
     For i = 1 To UBound(cr) - 1
        For j = i + 1 To UBound(cr)
            If cr(i) > cr(j) Then
                temp = cr(j)
                cr(j) = cr(i)
                cr(i) = temp  'c数组是排序好的
            End If
        Next j
        
       ' If i Mod 20 = 0 Then
       ' s104 = s104 & temp & "/" & vbCrLf
       ' Else
       ' s104 = s104 & temp & "/"
       ' End If
    Next i
   
      For i = 1 To UBound(cr)
        If i Mod 20 = 0 Then
          s104 = s104 & cr(i) & "/" & vbCrLf
        Else
          s104 = s104 & cr(i) & "/"
        End If
     Next
         Print temp
         MsgBox "ok"
     MsgBox s104  '显示数组
Text4 = s104
End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
Combo1 = ""
Form1.Cls
End Sub

蔡家雄

13与39998之间有4组6生素数对:
/13/17/11/19/7/23
/103/107/101/109/97/113
/16063/16067/16061/16069/16057/16073
/19423/19427/19421/19429/19417/19433

最好：从小到大依次排列

ysr

额，好的，改进一下吧！

ysr

改进了一下，每一组都从小到大排序，下面是对1~60000之间的搜索结果：
7与60008之间有5组6生素数对:
/7/11/13/17/19/23
/97/101/103/107/109/113
/16057/16061/16063/16067/16069/16073
/19417/19421/19423/19427/19429/19433
/43777/43781/43783/43787/43789/43793

代码如下：（仅发主程序）
Private Sub Command1_Click()
Dim a, b
a = Val(15) - 8
a1 = a
q1 = Int(Val(Text2) / 15)
q = q1 * 15 + 8
m = Sqr(q)
If Right(a, 1) Mod 2 = 0 Then
a = a + 1
Else
a = a
End If
s = 0
a2 = 1
Do While a <= m
B1 = a2 * 15 - 2
b2 = a2 * 15 + 2
b3 = a2 * 15 - 4
b4 = a2 * 15 + 4
B5 = a2 * 15 - 8
b6 = a2 * 15 + 8
c1 = fenjieyinzi0(Val(B1))
C2 = fenjieyinzi0(Val(b3))
c3 = fenjieyinzi0(Val(B5))
D1 = fenjieyinzi0(Val(b2))
D2 = fenjieyinzi0(Val(b4))
d3 = fenjieyinzi0(Val(b6))
If InStr(c1, "*") = 0 And InStr(D1, "*") = 0 And InStr(C2, "*") = 0 And InStr(D2, "*") = 0 And InStr(c3, "*") = 0 And InStr(d3, "*") = 0 Then
s = s + 1
Print B1, b2, b3, b4
Text3 = Text3 & "/" & B5 & "/" & b3 & "/" & B1 & "/" & b2 & "/" & b4 & "/" & b6 & vbCrLf
Else
s = s
End If
a2 = a2 + 2
a = a2 * 15 + 8
Loop
a2 = a2
s1 = s
Do While a2 * 15 + 8 <= q
B1 = a2 * 15 - 2
b2 = a2 * 15 + 2
b3 = a2 * 15 - 4
b4 = a2 * 15 + 4
B5 = a2 * 15 - 8
b6 = a2 * 15 + 8
c1 = fenjieyinzi0(Val(B1))
C2 = fenjieyinzi0(Val(b3))
c3 = fenjieyinzi0(Val(B5))
D1 = fenjieyinzi0(Val(b2))
D2 = fenjieyinzi0(Val(b4))
d3 = fenjieyinzi0(Val(b6))
If InStr(c1, "*") = 0 And InStr(D1, "*") = 0 And InStr(C2, "*") = 0 And InStr(D2, "*") = 0 And InStr(c3, "*") = 0 And InStr(d3, "*") = 0 Then
s1 = s1 + 1
Print B1, b2, b3, b4
Text3 = Text3 & "/" & B5 & "/" & b3 & "/" & B1 & "/" & b2 & "/" & b4 & "/" & b6 & vbCrLf
Else
s1 = s1
End If
a2 = a2 + 2

Loop
Combo1 = a1 & "与" & q & "之间有" & s1 & "组6生素数对:" & vbCrLf & Text3
s103 = DeleteSpace1(Text3)
s103 = Mid(s103, 1)
Dim i As Integer
Dim ak(), s105, cr(), f
Set f = CreateObject("Scripting.Dictionary")
s105 = Split(s103, "/")
   j1 = UBound(s105)
   Print j1
   For k = 1 To j1
      n1 = n1 + 1
       ReDim Preserve ak(1 To n1)
      ak(n1) = s105(n1)
    Next
    Print ak(1)
     n = 0
        For k = 1 To j1
           For i = 1 To j1
             n = n + 1
             ReDim Preserve cr(1 To n)
            m = Val(ak(k)) + Val(ak(i))
            f(m) = ""
      Next
    Next
      n = 0
      m = f.Keys
      For i = 0 To f.Count - 1
          ReDim Preserve cr(1 To i + 1)
          cr(i + 1) = m(i)
      Next
     For i = 1 To UBound(cr) - 1
        For j = i + 1 To UBound(cr)
            If cr(i) > cr(j) Then
                temp = cr(j)
                cr(j) = cr(i)
                cr(i) = temp  'c数组是排序好的
            End If
        Next j
        
       ' If i Mod 20 = 0 Then
       ' s104 = s104 & temp & "/" & vbCrLf
       ' Else
       ' s104 = s104 & temp & "/"
       ' End If
    Next i
   
      For i = 1 To UBound(cr)
        If i Mod 20 = 0 Then
          s104 = s104 & cr(i) & "/" & vbCrLf
        Else
          s104 = s104 & cr(i) & "/"
        End If
     Next
         Print temp
         MsgBox "ok"
     MsgBox s104  '显示数组
Text4 = s104
End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
Combo1 = ""
Form1.Cls
End Sub

ysr

搜索1~1000000之间仍然只有五组：
7与999998之间有5组6生素数对:
/7/11/13/17/19/23
/97/101/103/107/109/113
/16057/16061/16063/16067/16069/16073
/19417/19421/19423/19427/19429/19433
/43777/43781/43783/43787/43789/43793

ysr

搜索1~3000000之间居然有10组：
7与3000008之间有10组6生素数对:
/7/11/13/17/19/23
/97/101/103/107/109/113
/16057/16061/16063/16067/16069/16073
/19417/19421/19423/19427/19429/19433
/43777/43781/43783/43787/43789/43793
/1091257/1091261/1091263/1091267/1091269/1091273
/1615837/1615841/1615843/1615847/1615849/1615853
/1954357/1954361/1954363/1954367/1954369/1954373
/2822707/2822711/2822713/2822717/2822719/2822723
/2839927/2839931/2839933/2839937/2839939/2839943

看来不是有限组，可能是有无穷多组。

蔡家雄

我因为新电脑，没有安装数学计算软件，

—— 6生素数有：无限多组 ！！！