自编程序得到的一组大素数

ysr · 发表于 2026-5-11 10:06

170141183460469231731687303715884105729~170141183460469231731687303715884107729之间的素数有33个：（用时942.1406秒）
170141183460469231731687303715884105757  170141183460469231731687303715884105773  170141183460469231731687303715884105793  170141183460469231731687303715884105829  170141183460469231731687303715884105851  170141183460469231731687303715884105979  170141183460469231731687303715884106001  170141183460469231731687303715884106031  170141183460469231731687303715884106123  170141183460469231731687303715884106207
170141183460469231731687303715884106213  170141183460469231731687303715884106231  170141183460469231731687303715884106273  170141183460469231731687303715884106303  170141183460469231731687303715884106309  170141183460469231731687303715884106319  170141183460469231731687303715884106409  170141183460469231731687303715884106439  170141183460469231731687303715884106721  170141183460469231731687303715884106723
170141183460469231731687303715884106787  170141183460469231731687303715884107009  170141183460469231731687303715884107029  170141183460469231731687303715884107149  170141183460469231731687303715884107237  170141183460469231731687303715884107339  170141183460469231731687303715884107467  170141183460469231731687303715884107477  170141183460469231731687303715884107579  170141183460469231731687303715884107587
170141183460469231731687303715884107621  170141183460469231731687303715884107639  170141183460469231731687303715884107717

这是用我的判断程序找到的一组39位的大素数，原理就是用的欧拉原理，是确定性的，AI 说我的程序无法验证对不对，这不是胡说八道吗？

ysr · 发表于 2026-5-11 10:43

用网上的分解软件一个个判定了，都是素数，没有一个错误的。
图片中就是最后一个，判定是素数

ysr · 发表于 2026-5-11 10:46

用网上的分解软件一个个判定了，一共33个都是素数，没有一个错误的

ysr · 发表于 2026-5-13 23:36

如下就是我的判断程序，原理就是用的欧拉原理，是确定性的：

ysr · 发表于 2026-11-1 23:16

本帖最后由 ysr 于 2026-11-1 15:17 编辑

170141183460469231731687303715884105757 这是素数有39位，用时2.085938秒（几年前编的程序算的，后来编的程序代码都丢了，有机会了重新编一个吧！快速判断大素数的方法用的是欧拉原理）

楼上的分段筛选大素数的程序代码也没有保存，那个程序也是比较快的

ysr · 发表于 2026-11-1 23:25

170141183460469231731687303715884107729~170141183460469231731687303715884105729之间有2000个整数，去掉偶数还有1000个奇数，按这个慢速程序需要2*1000=2000秒，前楼的942秒显然要快得多

ysr · 发表于 2026-11-1 23:32

170141183460469231731687303715884105729 这是合数，有39位，用时 0秒（某些特殊合数的判断也是很快的）
170141183460469231731687303715884107729 *这是合数，有39位，用时2.296875秒（这个就慢了）

ysr · 发表于 2026-11-2 01:39

本帖最后由 ysr 于 2026-11-1 17:46 编辑

找到了，这个是快速判断大素数的程序，代码如下（不是判断程序，好像是产生特殊素数的程序）：
Private Function zhengchuqyushu(sa As String) As String
If InStr(sa, "/") = 0 Then
zhengchuqyushu = 0
Else
zhengchuqyushu = Mid(sa, InStr(sa, "/") + 1)
End If

End Function

Private Function zhengchuqy(sa As String) As String
If InStr(sa, "/") = 0 Then
zhengchuqy = sa
Else
zhengchuqy = Left(sa, InStr(sa, "/") - 1)
End If

End Function

Public Function MBBC(D1 As String) As String 'kai pingfang
If Len(D1) < 10 Then
jss = Int(Sqr(D1))
JW = Val(D1) - (jss) ^ 2
  If JW = 0 Then
  MBBC = jss
  Else
  MBBC = jss & "/" & JW
End If
Else
Dim X 'shuju changdu
X = Len(D1) \ 4
D2 = String(4 - Len(D1) + 4 * X, "0") & D1
Dim A() As String
ReDim A(4 To 4 * X + 4)
Dim B() As String
ReDim B(2 To 2 * X)
Dim I, J, js
  For I = 4 To 4 * X + 4 Step 4

A(I) = Mid(D2, I - 3, 4)
js = Int(Sqr(Val(A(4) & A(8))))
JW = Val(A(4) & A(8)) - (js) ^ 2
Next
J = 4
Do While J <= 2 * X

jws = MPC1(JW & "0000", A(2 * J + 4))
If MBJC(Trim(jws), MbC(Trim(js), 200)) <= 0 Then
B(J) = "00"
Else
jwc = Left(jws, Len(jws) - Len(MbC(Trim(js), 200)) + 2) \ Left(MbC(Trim(js), 200), 2)
If Len(jwc) > 2 Then
   B(J) = 99
   Else
   B(J) = jwc
   End If


   Do While MBJC(Trim(jws), MbC(MPC1(B(J), MbC(Trim(js), 200)), B(J))) = -1

   B(J) = B(J) - 1

            Loop
      End If
      JW = MPC(Trim(jws), MbC(MPC1(MbC(200, Trim(js)), B(J)), B(J)))

   js = MPC1(MbC(Trim(js), 100), Trim(B(J)))


J = J + 2
If JW = 0 Then

MBBC = js
Else
MBBC = js & "/" & JW
End If
Loop

End If
End Function

Public Function MBJC(D1 As String, D2 As String) As String ';bijiao
If Len(D1) <= 10 And Len(D2) <= 10 Then
If Val(D1) > Val(D2) Then
MBJC = 1
Else
If Val(D1) = Val(D2) Then
MBJC = 0
Else
MBJC = -1
End If
End If
Else

If Len(D1) > Len(D2) Then
MBJC = 1
Else
If Len(D1) < Len(D2) Then
MBJC = -1
Else
If Len(D1) = Len(D2) Then
Dim X, Y
X = Len(D1) \ 4: Y = Len(D2) \ 4
Dim A() As String, B() As String
ReDim A(4 To 4 * X + 4)
ReDim B(4 To 4 * Y + 4)
If Val(Left(D1, Len(D1) - 4 * X)) > Val(Left(D2, Len(D2) - 4 * Y)) Then
  MBJC = 1
  Else
  If Val(Left(D1, Len(D1) - 4 * X)) < Val(Left(D2, Len(D2) - 4 * Y)) Then
  MBJC = -1
  Else
  For I = 4 To 4 * X Step 4
  A(I) = Mid(D1, Len(D1) - I + 1, 4)
  B(I) = Mid(D2, Len(D2) - I + 1, 4)
  Next
  J = 4 * X
  Do While A(J) = B(J) And J >= 8

  J = J - 4
   Loop


If Val(A(J)) - Val(B(J)) > 0 Then
MBJC = 1
Else
If Val(A(J)) - Val(B(J)) < 0 Then
MBJC = -1
Else
MBJC = 0
End If

  End If



End If
End If
End If
End If
End If
End If
End Function

Public Function MCC(D1 As String, D2 As String) As String ';除数少于8位的除法
If Len(D1) < Len(D2) Then
MCC = "0" & "/" & D1
Else
If Len(D1) < 9 Then
MCC = Val(D1) \ Val(D2) & "/" & Val(D1) - (Val(D1) \ Val(D2)) * Val(D2)
   If Mid(MCC, InStr(MCC, "/") + 1) = 0 Then
  MCC = Left(MCC, InStr(MCC, "/") - 1)
Else
MCC = MCC
End If

Else

Dim X ';fen duan changdu
X = Len(D1)



   Dim A() As String
   ReDim A(1 To X)  ';定义数组的储存空间
   For I = 1 To X Step 1  ';把被除数各位放在a()中
   A(I) = Mid(D1, I, 1)


   Next I
   Dim B() As String
   JW = 0
   ReDim B(1 To X)
   For J = 1 To X Step 1
B(J) = Val(JW & A(J)) \ Val(D2)
   JW = Val(JW & A(J)) - Val(B(J)) * Val(D2)
   Next J
   For r = 1 To X
   If JW = 0 Then
      MCC = MCC & B(r)
      Else
      CJ = CJ & B(r)
      MCC = CJ & "/" & JW

End If

For I = 1 To Len(MCC)
If Not Mid(MCC, I, 1) = "0" Then
   Exit For
End If
Next
strTmp = Mid(MCC, I)
If Len(strTmp) = 0 Then
MCC = "0"
Else
MCC = strTmp
End If

Next

End If

   End If

End Function

Public Function MCC1(D1 As String, D2 As String) As String ';大整数的除法
Dim ss
ss = MBJC(D1, D2)
If ss = -1 Then
MCC1 = "0" & "/" & D1
  Else
  If ss = 0 Then
MCC1 = 1
Else
If Len(D1) = Len(D2) Then
   s = Val(Left(D1, 1)) \ Val(Left(D2, 1))

Do While MBJC(MbC(Trim(s), Trim(D2)), D1) = 1
  s = s - 1
  Loop
  If MBJC(MbC(Trim(s), Trim(D2)), D1) = 0 Then
MCC1 = s
Else
MCC1 = s & "/" & MPC(Trim(D1), MbC(Trim(s), Trim(D2)))

End If
Else
If Len(D2) < 9 Then
   MCC1 = MCC(D1, D2)
   Else
Dim X, Y ';定义分段长度
X = Len(D1): Y = Len(D2)

Dim JW, jcc, jss, jcs

  Dim A() As String, B() As String

  ReDim A(1 To X)
  ReDim B(1 To Y)
  For I = 1 To X
  A(I) = Mid(D1, I, 1)
  Next
  For J = 1 To Y
  B(J) = Mid(D2, J, 1)
  Next
  jcc = Val(A(1) & A(2)) \ Val(B(1) & B(2))



  jss = MbC(Trim(jcc), D2)
For i1 = 1 To Y
jws = jws & A(i1)
   Next

   Do While MBJC(Trim(jws), Trim(jss)) = -1
   jcc = jcc - 1
   jss = MbC(Trim(jcc), D2)
   Loop
  JW = MPC(Trim(jws), Trim(jss))

z = X - Y

Dim c() As String
ReDim c(1 To z)
For s = 1 To z
   If MBJC(JW & A(s + Y), D2) = -1 Then
   c(s) = "0"
   Else
   jwc = Val(Left(JW & A(s + Y), 3)) \ Val(Left(D2, 2))
   If Len(jwc) > 1 Then
   c(s) = "9"
   Else
      c(s) = jwc
      End If

   Do While MBJC(JW & A(s + Y), MbC(Val(c(s)), D2)) = -1
c(s) = Right(10000 + Val(c(s) - 1), 1)
   Loop
   End If

   JW = MPC(JW & A(s + Y), MbC(Val(c(s)), D2))

jcc = jcc & c(s)
Next s
If JW = 0 Then
MCC1 = jcc
Else
MCC1 = jcc & "/" & JW
End If

  For I = 1 To Len(MCC1)
If Not Mid(MCC1, I, 1) = "0" Then
      Exit For
End If
Next
strTmp = Mid(MCC1, I)
  If Len(strTmp) = 0 Then
  MCC1 = "0"
  Else
MCC1 = strTmp
End If

End If


  End If
End If
End If
End Function
Public Function MbC(D1 As String, D2 As String) As String
Dim j1&, j2&, e&, d&, e1&, m, n

' 按列法计算C=A*B
m = Trim(D1): n = Trim(D2)
X = Len(m) \ 4: Y = Len(n) \ 4
m = String(4 * X + 4 - Len(m), "0") & m
n = String(4 * Y + 4 - Len(n), "0") & n
X = X + 1: Y = Y + 1
Dim A(), B()
ReDim A(1 To X): ReDim B(1 To Y)
For i1 = 1 To X
A(i1) = Val(Mid(m, i1 * 4 - 3, 4))
Next
For i2 = 1 To Y
B(i2) = Val(Mid(n, i2 * 4 - 3, 4))
Next
ma = X: mb = Y
MC = ma + mb
ReDim c(MC)
e1 = 0
j1 = ma: j2 = ma
For I = MC To 2 Step -1
      If I <= ma Then j2 = I - 1
      e = e1: e1 = 0
      For J = j1 To j2
         e = e + A(J) * B(I - J)
         If e > 2040000000 Then '减少进位次数
            e = e - 2040000000
            e1 = e1 + 204000
         End If
      Next J

      If j1 > 1 Then j1 = j1 - 1
base = 10000
      d = e \ base
      c(I) = e - d * base
      If Len(c(I)) < 4 Then
      c(I) = String(4 - Len(c(I)), "0") & c(I)
      Else
      c(I) = c(I)
      End If
jc = c(I) & jc
      e1 = e1 + d
Next I
jc = d & jc
MbC = qqdl(Trim(jc))
End Function

'该程序已经做了修改，不是去掉前导0的问题，是补够前导0的问题。

Public Function MPC(D1 As String, D2 As String) As String ';jianfaqi
  Dim X, Y ';两数长度
  If qqdl(D2) = "0" Then
  MPC = D1
  Else
If Len(D1) >= Len(D2) Then
  D4 = String(Len(D1) - Len(D2), "0") & D2
  D3 = D1
  Else
  D4 = D2
  D3 = String(Len(D2) - Len(D1), "0") & D1
  End If
  X = Len(D3) \ 8: Y = Len(D4) \ 8
  D3 = String(8 * X + 8 - Len(D3), "0") & D3
  D4 = String(8 * Y + 8 - Len(D4), "0") & D4
  X = X + 1: Y = Y + 1

  Dim A() As String, B1() As String, C1() As String, e1() As String
  ReDim A(1 To X)
  ReDim B1(1 To Y)
  ReDim C1(1 To X)
  ReDim e1(1 To X)
  Dim I, J, C2, CJ, JW
  For J = Y To 1 Step -1 ';D2
  JW = 1 ';yu jie weichuzhi
  B1(J) = Mid(D4, J * 8 - 7, 8) ';每位数
For I = X To 1 Step -1  ';D1
   A(I) = Mid(D3, I * 8 - 7, 8) ';每位数
C1(I) = Val(1 & A(I)) - Val(B1(I)) - Val(1) + Val(JW) ';计算jia
If Len(C1(I)) <= 8 Then
JW = 0
C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
Else
   JW = Left(C1(I), Len(C1(I)) - 8)
   End If
   e1(I) = Right(C1(I), 8)
   If Len(e1(I)) < 8 Then
   e1(I) = String(8 - Len(e1(I)), "0") & e1(I)
   Else
   e1(I) = e1(I)
   End If

Next
Next
For r = 1 To X
MPC = MPC & e1(r)
If Len(MPC) > Len(D1) Then
MPC = Mid(MPC, Len(MPC) - Len(D1) + 1)
Else
MPC = MPC
End If
For I = 1 To Len(MPC)
   If Not Mid(MPC, I, 1) = "0" Then
      Exit For
   End If
  Next
  strTmp = Mid(MPC, I)
If Len(strTmp) = 0 Then
MPC = "0"
Else
  MPC = strTmp
  End If
Next
End If

  End Function

Public Function MPC1(D1 As String, D2 As String) As String 'jiafa
  Dim X, Y, JW '两数长度

If Len(D1) >= Len(D2) Then
  D4 = String(Len(D1) - Len(D2), "0") & D2
  D3 = D1
  Else
  D4 = D2
  D3 = String(Len(D2) - Len(D1), "0") & D1
  End If
  X = Len(D3) \ 8: Y = Len(D4) \ 8
  If 8 * X < Len(D3) Then
  D3 = String(8 * X + 8 - Len(D3), "0") & D3
  D4 = String(8 * Y + 8 - Len(D4), "0") & D4
  X = X + 1: Y = Y + 1
  Else
  X = X: Y = Y
  D3 = D3: D4 = D4
  End If
  Dim A() As String, B1() As String, C1() As String, e1() As String
  ReDim A(1 To X)
  ReDim B1(1 To Y)
  ReDim C1(1 To X)
  ReDim e1(1 To X)
  Dim I, J, C2, CJ
  For J = Y To 1 Step -1 'D2
  JW = 0 '进位清0
  B1(J) = Mid$(D4, J * 8 - 7, 8) '每位数
For I = X To 1 Step -1  'D1
   A(I) = Mid$(D3, I * 8 - 7, 8) '每位数
C1(I) = Val(A(I)) + Val(B1(I)) + Val(JW) '计算jia
If Len(C1(I)) < 8 Then
C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
Else
C1(I) = C1(I)
End If
   JW = Left(C1(I), Len(C1(I)) - 8)
   e1(I) = Right(C1(I), 8)
Next
Next
For r = 1 To X
If JW = 0 Then
MPC1 = MPC1 & e1(r)
Else
jc = jc & e1(r)
MPC1 = JW & jc
End If
Next
MPC1 = qqdl(Trim(MPC1))
  End Function

  Private Function qqdl(sa As String) As String


  For I = 1 To Len(sa)
If Not Mid(sa, I, 1) = "0" Then
      Exit For
End If
Next
strTmp = Mid(sa, I)
  If Len(strTmp) = 0 Then
  qqdl = "0"
  Else
qqdl = strTmp
End If
End Function

Private Function zzxc(sa As String, sb As String) As String
Dim A, B, c, d, r
  A = Trim(sa)
  B = Trim(sb)
  If Len(A) < 10 And Len(B) < 10 Then

  If Val(A) > Val(B) Then
   c = A
   d = B
  Else
   c = B
   d = A
  End If
Do Until Val(c) Mod Val(d) = 0
   r = c Mod d
   c = d
   d = r
  Loop

  Else

  If MBJC(Trim(A), Trim(B)) >= 1 Then
  c = A
  d = B
  Else
  c = B
  d = A
  End If
  Do Until zhengchuqyushu(MCC1(Trim(c), Trim(d))) = 0
  r = zhengchuqyushu(MCC1(Trim(c), Trim(d)))
  c = d
  d = r
  Loop
  End If


  zzxc = d

End Function

Private Function qniyuan(sa As String, sb As String) As String
Dim n, p, A, B, c, d, r
  n = Trim(sa)
  p = Trim(sb)
  A = 1
  B = 0
  c = 0
  d = 1
  If Len(n) < 10 And Len(p) < 10 Then

  If Val(n) > Val(p) Then
   m = n
   q = p
   s1 = 1
  Else
   m = p
   q = n
   s1 = 0
  End If
Do Until Val(m) Mod Val(q) = 0
s = m \ q
   r = m Mod q
   s1 = s1 + 1
   If s1 Mod 2 = 1 Then
   A = A
   B = A * s + B
   c = c
   d = c * s + d
   Else
   B = B
   A = A + B * s
   d = d
   c = c + d * s
   End If
   m = q
   q = r
  Loop
  If Val(A + B * m) = p Then
  B = B
  A = A + B * (m - 1)
  d = d
  c = c + d * (m - 1)
  Else
  If Val(B + A * m) = p Then
  A = A
  B = B + A * m
  c = c
  d = d + c * m
  Else
  B = B
  A = A + B * (m - 1)
  d = d
  c = c + d * (m - 1)
  End If
  End If
X = (A + B) Mod p
  Y = (c + d) Mod n


  Else

  If MBJC(Trim(n), Trim(p)) >= 1 Then
  m = n
  q = p
  s1 = 1
  Else
  m = p
  q = n
  s1 = 0
  End If
  Do Until zhengchuqyushu(MCC1(Trim(m), Trim(q))) = 0
  s = zhengchuqy(MCC1(Trim(m), Trim(q)))
  r = zhengchuqyushu(MCC1(Trim(m), Trim(q)))
  s1 = s1 + 1
  If s1 Mod 2 = 1 Then
  A = A
  B = MPC1(MbC(Trim(A), Trim(s)), Trim(B))
  c = c
  d = MPC1(MbC(Trim(c), Trim(s)), Trim(d))
  Else
  B = B
  A = MPC1(Trim(A), MbC(Trim(B), Trim(s)))
  d = d
  c = MPC1(Trim(c), MbC(Trim(d), Trim(s)))
  End If

  m = q
  q = r
  Loop

  If MPC1(Trim(A), MbC(Trim(B), Trim(m))) = p Then
  B = B
  A = MPC1(Trim(A), MbC(Trim(B), MPC(Trim(m), 1)))
  d = d
  c = MPC1(Trim(c), MbC(Trim(d), MPC(Trim(m), 1)))
  Else
  If MPC1(Trim(B), MbC(Trim(A), Trim(m))) = p Then
  A = A
  B = MPC1(Trim(B), MbC(Trim(A), Trim(m)))
  c = c
  d = MPC1(Trim(d), MbC(Trim(c), Trim(m)))
  Else
  B = B
  A = MPC1(Trim(A), MbC(Trim(B), MPC(Trim(m), 1)))
  d = d
  c = MPC1(Trim(c), MbC(Trim(d), MPC(Trim(m), 1)))
  End If
  End If
Do While Left(A, 1) = "0"
A = Mid(A, 2)
Loop

  End If

  qniyuan = A
End Function

Private Function qksmimo(sa As String, sb As String, sc As String) As String
Dim c, e, n, d
c = Trim(sa)
e = Trim(sb)
n = Trim(sc)
d = 1
If Len(c) < 5 And Len(e) < 5 And Len(n) < 5 Then
c = Val(c): n = Val(n)
Do While e > 0
If Right(e, 1) Mod 2 = 0 Then
c = c * c Mod n
e = e / 2

Else
d = d * c Mod n
e = e - 1
End If
Loop
Else
c = c
Do While MBJC(Trim(e), 1) >= 0
If Right(e, 1) Mod 2 = 0 Then
c = zhengchuqyushu(MCC1(MbC(Trim(c), Trim(c)), Trim(n)))
e = zhengchuqy(MCC1(Trim(e), 2))
Else
d = zhengchuqyushu(MCC1(MbC(Trim(c), Trim(d)), Trim(n)))
e = MPC(Trim(e), 1)
End If
Loop
End If

qksmimo = d
End Function

Private Function fenjieyinzi(sa As String) As String
Dim X, A, B
X = sa
B = Int(Sqr(Val(X)) / 2)
If X = 3 Or X = 2 Then
A = True
Else
If X Mod 2 = 0 Then
A = False
Else

For I = 3 To 2 * B + 1 Step 2
If X Mod I = 0 Then
A = False
Exit For

Else: A = True

End If
Next
End If
End If
If A = True Then
fenjieyinzi = "这是个素数"
Else
fenjieyinzi = "2*2"
End If

End Function

Private Sub Command1_Click() '判断素数的程序
Dim A, B, k
k = Val(Text1)
ts = Timer
A = ksm2(Val(7), Val(k)): B = ksm2("9999999999", Trim(A))
s = MbC(Trim(B), Val(18)): s2 = MPC(Trim(s), Val(1))
s1 = zhengchuqy(MCC1(Trim(s2), Val(6517)))
t1 = fenjieyinzi0(Trim(s1))
If InStr(t1, "*") = 0 Then
t = "这是素数"
Else
t = "这是合数"
End If
Text2 = s2
Combo1 = "该整数有" & Len(s1) & "位，判断结果为" & t & " (用时" & Timer - ts & "秒）,被除数" & vbCrLf & Text2

End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""

Combo1 = ""
Form1.Cls
End Sub

Private Function fenjieyinzi0(sa As String) As String
Dim A, n
n = Trim(sa)
If Len(n) < 6 Then
fenjieyinzi0 = fenjieyinzi(Trim(n))
Else
n1 = MPC(Trim(n), 1)
A = 123
'a为明文
a1 = zzxc(Trim(n), Trim(A))
If Val(a1) > 1 Then
fenjieyinzi0 = a1 & "*"
Else
c = 999
'c为公约
Do While zzxc(Trim(n1), Trim(c)) > 1
c = Val(c - 1)
Loop
d = qniyuan(Trim(c), Trim(n1))
'd为逆元为私钥
a2 = qksmimo(Trim(A), Trim(c), Trim(n))
'a2为密文
a3 = qksmimo(Trim(a2), Trim(d), Trim(n))
If MBJC(Trim(a3), Trim(A)) = 0 Then
fenjieyinzi0 = "这是素数有"
Else
fenjieyinzi0 = "2*2"
End If
End If
End If

End Function

Private Function ksm2(sb As String, sa As String) As String '2的快速幂程序
Dim A, B
A = Trim(sb): B = sa
If B = 1 Then
ksm2 = A
ElseIf B = 0 Then
ksm2 = 1
Else
a1 = A
Do While B > 1
s = Int(Log(B) / Log(2))
s1 = 0
Do While s1 < s
A = MbC(Trim(A), Trim(A))
s1 = s1 + 1
Loop
a2 = A
B = B - 2 ^ s
A = a1
If s2 > 0 Then
a3 = MbC(Trim(a3), Trim(a2))
Else
a3 = a2
End If
s2 = s2 + 1
Loop
If B = 1 Then
ksm2 = MbC(Trim(a3), Trim(a1))
Else
ksm2 = a3
End If
s3 = Len(ksm2)
ksm2 = ksm2
End If

End Function

ysr · 发表于 2026-11-2 01:51

170141183460469231731687303715884107729 这是合数*，有39位，用时 1.60498秒（稍微快些，也不是太快）

ysr · 发表于 2026-11-2 01:52

代码如下：
Private Function zhengchuqyushu(sa As String) As String
If InStr(sa, "/") = 0 Then
zhengchuqyushu = 0
Else
zhengchuqyushu = Mid(sa, InStr(sa, "/") + 1)
End If

End Function

Private Function zhengchuqy(sa As String) As String
If InStr(sa, "/") = 0 Then
zhengchuqy = sa
Else
zhengchuqy = Left(sa, InStr(sa, "/") - 1)
End If

End Function

Public Function MBBC(D1 As String) As String 'kai pingfang
If Len(D1) < 10 Then
jss = Int(Sqr(D1))
JW = Val(D1) - (jss) ^ 2
  If JW = 0 Then
  MBBC = jss
  Else
  MBBC = jss & "/" & JW
End If
Else
Dim X 'shuju changdu
X = Len(D1) \ 4
D2 = String(4 - Len(D1) + 4 * X, "0") & D1
Dim A() As String
ReDim A(4 To 4 * X + 4)
Dim B() As String
ReDim B(2 To 2 * X)
Dim I, J, js
  For I = 4 To 4 * X + 4 Step 4

A(I) = Mid(D2, I - 3, 4)
js = Int(Sqr(Val(A(4) & A(8))))
JW = Val(A(4) & A(8)) - (js) ^ 2
Next
J = 4
Do While J <= 2 * X

jws = MPC1(JW & "0000", A(2 * J + 4))
If MBJC(Trim(jws), MbC(Trim(js), 200)) <= 0 Then
B(J) = "00"
Else
jwc = Left(jws, Len(jws) - Len(MbC(Trim(js), 200)) + 2) \ Left(MbC(Trim(js), 200), 2)
If Len(jwc) > 2 Then
   B(J) = 99
   Else
   B(J) = jwc
   End If


   Do While MBJC(Trim(jws), MbC(MPC1(B(J), MbC(Trim(js), 200)), B(J))) = -1

   B(J) = B(J) - 1

            Loop
      End If
      JW = MPC(Trim(jws), MbC(MPC1(MbC(200, Trim(js)), B(J)), B(J)))

   js = MPC1(MbC(Trim(js), 100), Trim(B(J)))


J = J + 2
If JW = 0 Then

MBBC = js
Else
MBBC = js & "/" & JW
End If
Loop

End If
End Function

Public Function MBJC(D1 As String, D2 As String) As String ';bijiao
If Len(D1) <= 10 And Len(D2) <= 10 Then
If Val(D1) > Val(D2) Then
MBJC = 1
Else
If Val(D1) = Val(D2) Then
MBJC = 0
Else
MBJC = -1
End If
End If
Else

If Len(D1) > Len(D2) Then
MBJC = 1
Else
If Len(D1) < Len(D2) Then
MBJC = -1
Else
If Len(D1) = Len(D2) Then
Dim X, Y
X = Len(D1) \ 4: Y = Len(D2) \ 4
Dim A() As String, B() As String
ReDim A(4 To 4 * X + 4)
ReDim B(4 To 4 * Y + 4)
If Val(Left(D1, Len(D1) - 4 * X)) > Val(Left(D2, Len(D2) - 4 * Y)) Then
  MBJC = 1
  Else
  If Val(Left(D1, Len(D1) - 4 * X)) < Val(Left(D2, Len(D2) - 4 * Y)) Then
  MBJC = -1
  Else
  For I = 4 To 4 * X Step 4
  A(I) = Mid(D1, Len(D1) - I + 1, 4)
  B(I) = Mid(D2, Len(D2) - I + 1, 4)
  Next
  J = 4 * X
  Do While A(J) = B(J) And J >= 8

  J = J - 4
   Loop


If Val(A(J)) - Val(B(J)) > 0 Then
MBJC = 1
Else
If Val(A(J)) - Val(B(J)) < 0 Then
MBJC = -1
Else
MBJC = 0
End If

  End If



End If
End If
End If
End If
End If
End If
End Function

Public Function MCC(D1 As String, D2 As String) As String ';除数少于8位的除法
If Len(D1) < Len(D2) Then
MCC = "0" & "/" & D1
Else
If Len(D1) < 9 Then
MCC = Val(D1) \ Val(D2) & "/" & Val(D1) - (Val(D1) \ Val(D2)) * Val(D2)
   If Mid(MCC, InStr(MCC, "/") + 1) = 0 Then
  MCC = Left(MCC, InStr(MCC, "/") - 1)
Else
MCC = MCC
End If

Else

Dim X ';fen duan changdu
X = Len(D1)



   Dim A() As String
   ReDim A(1 To X)  ';定义数组的储存空间
   For I = 1 To X Step 1  ';把被除数各位放在a()中
   A(I) = Mid(D1, I, 1)


   Next I
   Dim B() As String
   JW = 0
   ReDim B(1 To X)
   For J = 1 To X Step 1
B(J) = Val(JW & A(J)) \ Val(D2)
   JW = Val(JW & A(J)) - Val(B(J)) * Val(D2)
   Next J
   For r = 1 To X
   If JW = 0 Then
      MCC = MCC & B(r)
      Else
      CJ = CJ & B(r)
      MCC = CJ & "/" & JW

End If

For I = 1 To Len(MCC)
If Not Mid(MCC, I, 1) = "0" Then
   Exit For
End If
Next
strTmp = Mid(MCC, I)
If Len(strTmp) = 0 Then
MCC = "0"
Else
MCC = strTmp
End If

Next

End If

   End If

End Function

Public Function MCC1(D1 As String, D2 As String) As String ';大整数的除法
'可能还有优化和提高速度的空间

Dim ss
ss = MBJC(D1, D2)
If ss = -1 Then
MCC1 = "0" & "/" & D1
  Else
  If ss = 0 Then
MCC1 = 1
Else
If Len(D1) = Len(D2) Then
Do While MBJC(D1, D2) >= 0
S1 = S1 + 1
D1 = MPC(D1, D2)
Loop
If D1 = 0 Then
MCC1 = S1
Else
MCC1 = S1 & "/" & D1
End If
Else
If Len(D2) < 9 Then
   MCC1 = MCC(D1, D2)
   Else
Dim X, Y ';定义分段长度

X = Len(D1) \ 4: Y = Len(D2) \ 4
If Len(D1) > 4 * X Then
X = X + 1
D1 = String(4 * X - Len(D1), "0") & D1
ElseIf Len(D2) > 4 * Y Then
Y = Y + 1
D2 = String(4 * Y - Len(D2), "0") & D2
Else
D1 = String(4 * X - Len(D1), "0") & D1
D2 = String(4 * Y - Len(D2), "0") & D2
End If
  X = Len(D1) \ 4: Y = Len(D2) \ 4
Dim JW, jcc, jss, jcs

  Dim A() As String, B() As String

  ReDim A(1 To X)
  ReDim B(1 To Y)
  For I = 1 To X
  A(I) = Mid(D1, I * 4 - 3, 4)
  Next
  For J = 1 To Y
  B(J) = Mid(D2, J * 4 - 3, 4)
  jws = jws & A(J)
  Next
If Len(qqdl(Trim(jws))) <= Len(qqdl(D2)) Then
  jcc = Val(Left(qqdl(A(1) & A(2)), 2)) \ Val(Left(qqdl(B(1) & B(2)), 2))
  Else
  jcc = Val(Left(qqdl(A(1) & A(2)), 2 + Len(qqdl(Trim(jws))) - Len(qqdl(D2)))) \ Val(Left(qqdl(B(1) & B(2)), 2))
  End If

  jss = MbC(Trim(jcc), D2)


   Do While MBJC(Trim(jws), Trim(jss)) = -1
   jcc = jcc - 1
   jss = MbC(Trim(jcc), D2)
   Loop
  JW = MPC(Trim(jws), Trim(jss))

z = X - Y

Dim c() As String
ReDim c(1 To z)
For s = 1 To z
   If MBJC(JW & A(s + Y), D2) = -1 Then
   c(s) = "0000"
   Else
   If Len(qqdl(JW & A(s + Y))) = Len(qqdl(D2)) Then
  jwc = Val(Left(qqdl(JW & A(s + Y)), 4)) \ Val(Left(qqdl(B(1) & B(2)), 4))
  Else
  If Len(qqdl(JW & A(s + Y))) <= Len(qqdl(D2)) Then
  jwc = Val(Left(qqdl(JW & A(s + Y)), 4)) \ Val(Left(qqdl(B(1) & B(2)), 4))
  Else
  jwc = Val(Left(qqdl(JW & A(s + Y)), 4 + Len(qqdl(JW & A(s + Y))) - Len(qqdl(D2)))) / Val(Left(qqdl(B(1) & B(2)), 4))
  jwc = Format(Val(jwc), "0.000000")
  If InStr(jwc, ".") = 0 Then
  jwc = jwc
  Else
  jwc = Left(jwc, InStr(jwc, ".") - 1)
  End If
  End If
  End If
   c(s) = jwc
      End If
   jsw = MbC(Trim(c(s)), Trim(D2))
   Do While MBJC(JW & A(s + Y), Trim(jsw)) = -1
   c(s) = c(s) - 1
   jsw = MbC(Trim(c(s)), D2)
   Loop
   JW = MPC(JW & A(s + Y), MbC(Val(c(s)), D2))
   Do While MBJC(Trim(JW), Trim(D2)) >= 0
   jwc1 = jwc1 + 1
   JW = MPC(Trim(JW), Trim(D2))
   Loop
   c(s) = Val(c(s) + jwc1)
c(s) = Right(100000000 + Val(c(s)), 4)

jcc = jcc & c(s)
Next s
If JW = 0 Then
MCC1 = jcc
Else
MCC1 = jcc & "/" & JW
End If

  For I = 1 To Len(MCC1)
If Not Mid(MCC1, I, 1) = "0" Then
      Exit For
End If
Next
strTmp = Mid(MCC1, I)
  If Len(strTmp) = 0 Then
  MCC1 = "0"
  Else
MCC1 = strTmp
End If

End If

  End If
End If
End If
End Function
Public Function MbC(D1 As String, D2 As String) As String
Dim j1&, j2&, e&, d&, e1&, m, n

' 按列法计算C=A*B
m = Trim(D1): n = Trim(D2)
X = Len(m) \ 4: Y = Len(n) \ 4
m = String(4 * X + 4 - Len(m), "0") & m
n = String(4 * Y + 4 - Len(n), "0") & n
X = X + 1: Y = Y + 1
Dim A(), B()
ReDim A(1 To X): ReDim B(1 To Y)
For i1 = 1 To X
A(i1) = Val(Mid(m, i1 * 4 - 3, 4))
Next
For i2 = 1 To Y
B(i2) = Val(Mid(n, i2 * 4 - 3, 4))
Next
ma = X: mb = Y
MC = ma + mb
ReDim c(MC)
e1 = 0
j1 = ma: j2 = ma
For I = MC To 2 Step -1
      If I <= ma Then j2 = I - 1
      e = e1: e1 = 0
      For J = j1 To j2
         e = e + A(J) * B(I - J)
         If e > 2040000000 Then '减少进位次数
            e = e - 2040000000
            e1 = e1 + 204000
         End If
      Next J

      If j1 > 1 Then j1 = j1 - 1
base = 10000
      d = e \ base
      c(I) = e - d * base
      If Len(c(I)) < 4 Then
      c(I) = String(4 - Len(c(I)), "0") & c(I)
      Else
      c(I) = c(I)
      End If
jc = c(I) & jc
      e1 = e1 + d
Next I
jc = d & jc
MbC = qqdl(Trim(jc))
End Function

'该程序已经做了修改，不是去掉前导0的问题，是补够前导0的问题。

Public Function MPC(D1 As String, D2 As String) As String ';jianfaqi
  Dim X, Y ';两数长度
  If qqdl(D2) = "0" Then
  MPC = D1
  Else
If Len(D1) >= Len(D2) Then
  D4 = String(Len(D1) - Len(D2), "0") & D2
  D3 = D1
  Else
  D4 = D2
  D3 = String(Len(D2) - Len(D1), "0") & D1
  End If
  X = Len(D3) \ 8: Y = Len(D4) \ 8
  D3 = String(8 * X + 8 - Len(D3), "0") & D3
  D4 = String(8 * Y + 8 - Len(D4), "0") & D4
  X = X + 1: Y = Y + 1

  Dim A() As String, B1() As String, C1() As String, e1() As String
  ReDim A(1 To X)
  ReDim B1(1 To Y)
  ReDim C1(1 To X)
  ReDim e1(1 To X)
  Dim I, J, C2, CJ, JW
  For J = Y To 1 Step -1 ';D2
  JW = 1 ';yu jie weichuzhi
  B1(J) = Mid(D4, J * 8 - 7, 8) ';每位数
For I = X To 1 Step -1  ';D1
   A(I) = Mid(D3, I * 8 - 7, 8) ';每位数
C1(I) = Val(1 & A(I)) - Val(B1(I)) - Val(1) + Val(JW) ';计算jia
If Len(C1(I)) <= 8 Then
JW = 0
C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
Else
   JW = Left(C1(I), Len(C1(I)) - 8)
   End If
   e1(I) = Right(C1(I), 8)
   If Len(e1(I)) < 8 Then
   e1(I) = String(8 - Len(e1(I)), "0") & e1(I)
   Else
   e1(I) = e1(I)
   End If

Next
Next
For r = 1 To X
MPC = MPC & e1(r)
If Len(MPC) > Len(D1) Then
MPC = Mid(MPC, Len(MPC) - Len(D1) + 1)
Else
MPC = MPC
End If
For I = 1 To Len(MPC)
   If Not Mid(MPC, I, 1) = "0" Then
      Exit For
   End If
  Next
  strTmp = Mid(MPC, I)
If Len(strTmp) = 0 Then
MPC = "0"
Else
  MPC = strTmp
  End If
Next
End If

  End Function

Public Function MPC1(D1 As String, D2 As String) As String 'jiafa
  Dim X, Y, JW '两数长度

If Len(D1) >= Len(D2) Then
  D4 = String(Len(D1) - Len(D2), "0") & D2
  D3 = D1
  Else
  D4 = D2
  D3 = String(Len(D2) - Len(D1), "0") & D1
  End If
  X = Len(D3) \ 8: Y = Len(D4) \ 8
  If 8 * X < Len(D3) Then
  D3 = String(8 * X + 8 - Len(D3), "0") & D3
  D4 = String(8 * Y + 8 - Len(D4), "0") & D4
  X = X + 1: Y = Y + 1
  Else
  X = X: Y = Y
  D3 = D3: D4 = D4
  End If
  Dim A() As String, B1() As String, C1() As String, e1() As String
  ReDim A(1 To X)
  ReDim B1(1 To Y)
  ReDim C1(1 To X)
  ReDim e1(1 To X)
  Dim I, J, C2, CJ
  For J = Y To 1 Step -1 'D2
  JW = 0 '进位清0
  B1(J) = Mid$(D4, J * 8 - 7, 8) '每位数
For I = X To 1 Step -1  'D1
   A(I) = Mid$(D3, I * 8 - 7, 8) '每位数
C1(I) = Val(A(I)) + Val(B1(I)) + Val(JW) '计算jia
If Len(C1(I)) < 8 Then
C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
Else
C1(I) = C1(I)
End If
   JW = Left(C1(I), Len(C1(I)) - 8)
   e1(I) = Right(C1(I), 8)
Next
Next
For r = 1 To X
If JW = 0 Then
MPC1 = MPC1 & e1(r)
Else
jc = jc & e1(r)
MPC1 = JW & jc
End If
Next
MPC1 = qqdl(Trim(MPC1))
  End Function

  Private Function qqdl(sa As String) As String


  For I = 1 To Len(sa)
If Not Mid(sa, I, 1) = "0" Then
      Exit For
End If
Next
strTmp = Mid(sa, I)
  If Len(strTmp) = 0 Then
  qqdl = "0"
  Else
qqdl = strTmp
End If
End Function

Private Function zzxc(sa As String, sb As String) As String
Dim A, B, c, d, r
  A = Trim(sa)
  B = Trim(sb)
  If Len(A) < 10 And Len(B) < 10 Then

  If Val(A) > Val(B) Then
   c = A
   d = B
  Else
   c = B
   d = A
  End If
Do Until Val(c) Mod Val(d) = 0
   r = c Mod d
   c = d
   d = r
  Loop

  Else

  If MBJC(Trim(A), Trim(B)) >= 1 Then
  c = A
  d = B
  Else
  c = B
  d = A
  End If
  Do Until zhengchuqyushu(MCC1(Trim(c), Trim(d))) = 0
  r = zhengchuqyushu(MCC1(Trim(c), Trim(d)))
  c = d
  d = r
  Loop
  End If


  zzxc = d

End Function

Private Function qniyuan(sa As String, sb As String) As String
Dim n, p, A, B, c, d, r
  n = Trim(sa)
  p = Trim(sb)
  A = 1
  B = 0
  c = 0
  d = 1
  If Len(n) < 10 And Len(p) < 10 Then

  If Val(n) > Val(p) Then
   m = n
   q = p
   S1 = 1
  Else
   m = p
   q = n
   S1 = 0
  End If
Do Until Val(m) Mod Val(q) = 0
s = m \ q
   r = m Mod q
   S1 = S1 + 1
   If S1 Mod 2 = 1 Then
   A = A
   B = A * s + B
   c = c
   d = c * s + d
   Else
   B = B
   A = A + B * s
   d = d
   c = c + d * s
   End If
   m = q
   q = r
  Loop
  If Val(A + B * m) = p Then
  B = B
  A = A + B * (m - 1)
  d = d
  c = c + d * (m - 1)
  Else
  If Val(B + A * m) = p Then
  A = A
  B = B + A * m
  c = c
  d = d + c * m
  Else
  B = B
  A = A + B * (m - 1)
  d = d
  c = c + d * (m - 1)
  End If
  End If
X = (A + B) Mod p
  Y = (c + d) Mod n


  Else

  If MBJC(Trim(n), Trim(p)) >= 1 Then
  m = n
  q = p
  S1 = 1
  Else
  m = p
  q = n
  S1 = 0
  End If
  Do Until zhengchuqyushu(MCC1(Trim(m), Trim(q))) = 0
  s = zhengchuqy(MCC1(Trim(m), Trim(q)))
  r = zhengchuqyushu(MCC1(Trim(m), Trim(q)))
  S1 = S1 + 1
  If S1 Mod 2 = 1 Then
  A = A
  B = MPC1(MbC(Trim(A), Trim(s)), Trim(B))
  c = c
  d = MPC1(MbC(Trim(c), Trim(s)), Trim(d))
  Else
  B = B
  A = MPC1(Trim(A), MbC(Trim(B), Trim(s)))
  d = d
  c = MPC1(Trim(c), MbC(Trim(d), Trim(s)))
  End If

  m = q
  q = r
  Loop

  If MPC1(Trim(A), MbC(Trim(B), Trim(m))) = p Then
  B = B
  A = MPC1(Trim(A), MbC(Trim(B), MPC(Trim(m), 1)))
  d = d
  c = MPC1(Trim(c), MbC(Trim(d), MPC(Trim(m), 1)))
  Else
  If MPC1(Trim(B), MbC(Trim(A), Trim(m))) = p Then
  A = A
  B = MPC1(Trim(B), MbC(Trim(A), Trim(m)))
  c = c
  d = MPC1(Trim(d), MbC(Trim(c), Trim(m)))
  Else
  B = B
  A = MPC1(Trim(A), MbC(Trim(B), MPC(Trim(m), 1)))
  d = d
  c = MPC1(Trim(c), MbC(Trim(d), MPC(Trim(m), 1)))
  End If
  End If
Do While Left(A, 1) = "0"
A = Mid(A, 2)
Loop

  End If

  qniyuan = A
End Function

Private Function qksmimo(sa As String, sb As String, sc As String) As String
Dim c, e, n, d
c = Trim(sa)
e = Trim(sb)
n = Trim(sc)
d = 1
If Len(c) < 5 And Len(e) < 5 And Len(n) < 5 Then
c = Val(c): n = Val(n)
Do While e > 0
If Right(e, 1) Mod 2 = 0 Then
c = c * c Mod n
e = e / 2

Else
d = d * c Mod n
e = e - 1
End If
Loop
Else
c = c
Do While MBJC(Trim(e), 1) >= 0
If Right(e, 1) Mod 2 = 0 Then
c = zhengchuqyushu(MCC1(MbC(Trim(c), Trim(c)), Trim(n)))
e = zhengchuqy(MCC1(Trim(e), 2))
Else
d = zhengchuqyushu(MCC1(MbC(Trim(c), Trim(d)), Trim(n)))
e = MPC(Trim(e), 1)
End If
Loop
End If

qksmimo = d
End Function

Private Function fenjieyinzi(sa As String) As String
Dim X, A, B
X = sa
B = Int(Sqr(Val(X)) / 2)
If X = 3 Or X = 2 Then
A = True
Else
If X Mod 2 = 0 Then
A = False
Else

For I = 3 To 2 * B + 1 Step 2
If X Mod I = 0 Then
A = False
Exit For

Else: A = True

End If
Next
End If
End If
If A = True Then
fenjieyinzi = "这是个素数"
Else
fenjieyinzi = "2*2"
End If

End Function

Private Function fenjieyinzi0(sa As String) As String
Dim A, n
n = Trim(sa)
If Len(n) < 6 Then
fenjieyinzi0 = fenjieyinzi(Trim(n))
Else
n1 = MPC(Trim(n), 1)
A = 123
'a为明文
a1 = zzxc(Trim(n), Trim(A))
If Val(a1) > 1 Then
fenjieyinzi0 = a1 & "*"
Else
c = 999
'c为公约
Do While zzxc(Trim(n1), Trim(c)) > 1
c = Val(c - 1)
Loop
d = qniyuan(Trim(c), Trim(n1))
'd为逆元为私钥
a2 = qksmimo(Trim(A), Trim(c), Trim(n))
'a2为密文
a3 = qksmimo(Trim(a2), Trim(d), Trim(n))
If MBJC(Trim(a3), Trim(A)) = 0 Then
fenjieyinzi0 = "这是素数有"
Else
fenjieyinzi0 = "2*2"
End If
End If
End If

End Function

Private Function ksm2(sb As String, sa As String) As String '2的快速幂程序
Dim A, B
A = Trim(sb): B = sa
If B = 1 Then
ksm2 = A
ElseIf B = 0 Then
ksm2 = 1
Else
a1 = A
Do While B > 1
s = Int(Log(B) / Log(2))
S1 = 0
Do While S1 < s
A = MbC(Trim(A), Trim(A))
S1 = S1 + 1
Loop
a2 = A
B = B - 2 ^ s
A = a1
If s2 > 0 Then
a3 = MbC(Trim(a3), Trim(a2))
Else
a3 = a2
End If
s2 = s2 + 1
Loop
If B = 1 Then
ksm2 = MbC(Trim(a3), Trim(a1))
Else
ksm2 = a3
End If
s3 = Len(ksm2)
ksm2 = ksm2
End If

End Function
Private Sub Command1_Click()
Dim X, m
t = Timer
X = Trim(Text1)
m = fenjieyinzi0(Trim(X))
s = Len(X)

If InStr(m, "*") = 0 Then
Text2 = "这是素数，有" & s & "位，用时 " & Timer - t & "秒"
Else
Text2 = "这是合数*，有" & s & "位，用时 " & Timer - t & "秒"
End If

End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""

End Sub

		自动登录	找回密码
密码			注册

自编程序得到的一组大素数

本帖子中包含更多资源

本帖子中包含更多资源