[已解决]VBA实现四阶幻方素数

vbyou127 · 发表于 2016-4-20 16:50

VBA实现四阶幻方素数

用1到16构成一个四阶幻方，要求任意相邻两个方格中的数字之和均为素数

最佳答案

月排行榜 / 总排行榜

香川群子

2016-4-23 16:21

我的递归算法比你至少快1倍。

是在上次圆圈素数的基础上改的。

Dim a&(), b(), c() As Boolean, k&, n&, cnt&
Sub 矩阵相邻数相加为素数的排列计算()
Dim i&, tms#
[a:d] = ""
tms = Timer
n = 8 '实际范围为1-16
ReDim a(3, n - 1), b(3, 3)
For i = 1 To n
a(2, i - 1) = i * 2: a(3, i - 1) = i * 2 - 1
Next
c = GetPrime(4 * n - 1)
k = 0: cnt = 0: Call dgPL2(1, 0): Call dgPL2(0, 0)
MsgBox Format(Timer - tms, "0.000s ") & k & "/" & cnt
End Sub
Sub dgPL2(i&, t&)
Dim i1&, j1&, j&, r&, f As Boolean
cnt = cnt + 1
If t = 2 * n Then Cells(k * 5 + 1, 1).Resize(4, 4) = b: k = k + 1
i1 = t \ 4: j1 = t Mod 4
For j = 0 To n - 1
If a(i, j) = 0 Then
f = False: r = a(i + 2, j)
If i1 = 0 Then f = True Else If c(b(i1 - 1, j1) + r) Then f = True
If f Then If j1 Then f = c(b(i1, j1 - 1) + r)
If f Then
a(i, j) = 1: b(i1, j1) = r
Call dgPL2(IIf(j1 = 3, i, IIf(i, 0, 1)), t + 1)
a(i, j) = 0: b(i1, j1) = ""
End If
End If
Next
End Sub
Function GetPrime(n&) '计算素数数列
Dim a&(), b() As Boolean, i&, j&, k&, m&, s&
m = n \ 2: ReDim a&(m), b(3 To n) As Boolean
For i = 1 To Sqr(n) \ 2
If a(i) = 0 Then
s = i * 2 + 1: b(s) = True: k = k + 1: a(k) = s
For j = (i * 3 + 1) To m Step s
a(j) = 1
Next
End If
Next
For i = (a(k) + 1) / 2 To m
If a(i) = 0 Then s = i * 2 + 1: b(s) = True ': k = k + 1: a(k) = s
Next
GetPrime = b
End Function

复制代码

跳转到最佳答案楼层

vbyou127 · 发表于 2016-4-21 08:41

来一个

Dim arr%(3, 3)
Sub s()
Dim brr(15)
For i = 1 To 16
      brr(i - 1) = i
Next
p brr, 0, 0
End Sub
Function ss(ByVal n%) As Boolean
Select Case n
      Case 3, 5, 7, 11, 13, 17, 19, 23, 29, 31
         ss = True
      Case Else
         ss = False
End Select
End Function
Sub p(brr, x, y)
If x = 3 And y = 3 Then
      arr(3, 3) = brr(0)
      If ss(arr(2, 3) + arr(3, 3)) And ss(arr(3, 2) + arr(3, 3)) Then o
Else
      x1 = (x + 1) Mod 4
      y1 = y
      If x1 = 0 Then y1 = y1 + 1
      k = UBound(brr) - 1
      ReDim crr(k)
      For i = 0 To k
      crr(i) = brr(i + 1)
      Next
      For i = 0 To k + 1
         arr(x, y) = brr(i)
         If i > 0 Then crr(i - 1) = brr(i - 1)
         If x > 0 Then
            If Not ss(arr(x, y) + arr(x - 1, y)) Then GoTo 1
         End If
         If y > 0 Then
            If Not ss(arr(x, y) + arr(x, y - 1)) Then GoTo 1
         End If
         p crr, x1, y1
1:    Next
End If
End Sub
Sub o()
Static x&
x = x + 5
Cells(x, 1).Resize(4, 4) = arr
End Sub

香川群子 · 发表于 2016-4-23 16:21

我的递归算法比你至少快1倍。

是在上次圆圈素数的基础上改的。

Dim a&(), b(), c() As Boolean, k&, n&, cnt&
Sub 矩阵相邻数相加为素数的排列计算()
Dim i&, tms#
[a:d] = ""
tms = Timer
n = 8 '实际范围为1-16
ReDim a(3, n - 1), b(3, 3)
For i = 1 To n
a(2, i - 1) = i * 2: a(3, i - 1) = i * 2 - 1
Next
c = GetPrime(4 * n - 1)
k = 0: cnt = 0: Call dgPL2(1, 0): Call dgPL2(0, 0)
MsgBox Format(Timer - tms, "0.000s ") & k & "/" & cnt
End Sub
Sub dgPL2(i&, t&)
Dim i1&, j1&, j&, r&, f As Boolean
cnt = cnt + 1
If t = 2 * n Then Cells(k * 5 + 1, 1).Resize(4, 4) = b: k = k + 1
i1 = t \ 4: j1 = t Mod 4
For j = 0 To n - 1
If a(i, j) = 0 Then
f = False: r = a(i + 2, j)
If i1 = 0 Then f = True Else If c(b(i1 - 1, j1) + r) Then f = True
If f Then If j1 Then f = c(b(i1, j1 - 1) + r)
If f Then
a(i, j) = 1: b(i1, j1) = r
Call dgPL2(IIf(j1 = 3, i, IIf(i, 0, 1)), t + 1)
a(i, j) = 0: b(i1, j1) = ""
End If
End If
Next
End Sub
Function GetPrime(n&) '计算素数数列
Dim a&(), b() As Boolean, i&, j&, k&, m&, s&
m = n \ 2: ReDim a&(m), b(3 To n) As Boolean
For i = 1 To Sqr(n) \ 2
If a(i) = 0 Then
s = i * 2 + 1: b(s) = True: k = k + 1: a(k) = s
For j = (i * 3 + 1) To m Step s
a(j) = 1
Next
End If
Next
For i = (a(k) + 1) / 2 To m
If a(i) = 0 Then s = i * 2 + 1: b(s) = True ': k = k + 1: a(k) = s
Next
GetPrime = b
End Function

复制代码

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

[已解决]VBA实现四阶幻方素数

评分