VBA实现四阶幻方素数

vbyou126

VBA实现四阶幻方素数

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

Vicel

11        12        5        8
6        1        2        3
7        16        15        14
10        13        4        9

vbyou126

Vicel 发表于 2016-4-21 23:29
11        12        5        8
6        1        2        3
7        16        15        14

你在搞什么，输出所有

香川群子

这依然是一个遍历排列组合的问题。和圆圈素数类似，但难度要大一点。

vbyou126

vbyou126 发表于 2016-4-22 09:09
你在搞什么，输出所有

就


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

香川群子

奇数阶矩阵 无解？……按9楼代码计算也是有解的。5阶第1组：

1	2	3	4	7
6	5	8	15	22
25	18	23	14	9
16	13	24	17	20
21	10	19	12	11

6阶第1组：

1	2	3	4	7	6
10	21	16	13	24	5
19	22	25	18	23	14
12	31	36	35	8	15
29	30	17	26	33	28
32	11	20	27	34	9

7阶第1组：

1	2	3	4	7	6	5
10	9	8	15	16	13	18
19	22	21	46	37	24	23
12	49	40	43	30	29	14
35	48	31	36	17	44	39
38	41	42	11	26	45	28
33	20	47	32	27	34	25

8阶第1组：

1	2	3	4	7	6	5	8
10	9	14	15	16	13	18	11
19	22	39	28	25	34	49	12
24	37	64	33	46	55	54	17
23	60	43	40	61	42	29	44
56	41	30	31	36	47	32	27
57	26	53	48	35	62	21	52
50	63	20	59	38	45	58	51

香川群子

通用算法：

1. Dim a&(), b(), c() As Boolean, k&, m&, n&, cnt&, tms#
   
2. Sub 偶数矩阵相邻数相加为素数的递归排列计算()
   
3.     Dim i&
   
4.     [a:d] = ""
   
5.     tms = Timer
   
6.    
   
7.     m = 6
   
8.     n = m * m / 2 'm=4 实际范围为1-16
   
9.     ReDim a(3, n - 1), b(m - 1, m - 1)
   
10.     For i = 1 To n
    
11.         a(2, i - 1) = i * 2: a(3, i - 1) = i * 2 - 1
    
12.     Next
    
13.     c = GetPrime(4 * n - 1)
    
14.    
    
15.     k = 0: cnt = 0: Call dgPL2(1, 0): Call dgPL2(0, 0)
    
16.     MsgBox Format(Timer - tms, "0.000s ") & k & "/" & cnt
    
17. End Sub
    
18. Sub dgPL2(i&, t&)
    
19.     Dim i1&, j1&, j&, r&, f As Boolean
    
20.     cnt = cnt + 1: If cnt Mod 10000 = 0 Then DoEvents: Application.StatusBar = Format(Timer - tms, "0.000s ") & k & "/" & cnt
    
21.     If t = m * m Then If k > 2 Then k = k + 1 Else Cells(k * (m + 1) + 1, 1).Resize(m, m) = b: k = k + 1
    
22.     i1 = t \ m: j1 = t Mod m
    
23.     For j = 0 To n - 1
    
24.         If a(i, j) = 0 Then
    
25.             f = False: r = a(i + 2, j)
    
26.             If i1 = 0 Then f = True Else If c(b(i1 - 1, j1) + r) Then f = True
    
27.             If f Then If j1 Then f = c(b(i1, j1 - 1) + r)
    
28.             If f Then
    
29.                 a(i, j) = 1: b(i1, j1) = r
    
30.                 Call dgPL2(IIf(j1 = m - 1, i, IIf(i, 0, 1)), t + 1)
    
31.                 a(i, j) = 0: b(i1, j1) = ""
    
32.             End If
    
33.         End If
    
34.     Next
    
35. End Sub
    
36. Function GetPrime(n&) '计算素数数列
    
37.     Dim a&(), b() As Boolean, i&, j&, k&, m&, s&
    
38.     m = n \ 2: ReDim a&(m), b(3 To n) As Boolean
    
39.     For i = 1 To Sqr(n) \ 2
    
40.         If a(i) = 0 Then
    
41.             s = i * 2 + 1: b(s) = True: k = k + 1: a(k) = s
    
42.             For j = (i * 3 + 1) To m Step s
    
43.                 a(j) = 1
    
44.             Next
    
45.         End If
    
46.     Next
    
47.     For i = (a(k) + 1) / 2 To m
    
48.         If a(i) = 0 Then s = i * 2 + 1: b(s) = True ': k = k + 1: a(k) = s
    
49.     Next
    
50.     GetPrime = b
    
51. End Function

复制代码

香川群子

我7楼的算法，每次下一个数是区分奇、偶的，而你的算法不分奇偶数……显然计算时间要多不少。
但是7楼的算法只能计算偶数阶的、奇数的不能算。奇数的算法要用9楼的代码。

香川群子

意外的是，直接循环检查1-16的排列，而无需检查奇偶性，速度反而更快一些。

原因可能是：奇偶性不符时，马上就能检查出来。几乎不浪费时间。
而区分奇偶性就需要多做一些计算和判断、反而麻烦了。

代码如下：

1. Dim a() As Boolean, b%(), c() As Boolean, k&, m%, n%, cnt&
   
2. Sub 矩阵相邻数和为素数的递归排列检查2() ' m*m prime
   
3.     Dim i%, tms#
   
4. '    [a:z] = ""
   
5.     tms = Timer
   
6.    
   
7.     m = 4
   
8.     n = m * m
   
9.     ReDim a(1 To n), b(m - 1, m - 1)
   
10.     c = GetPrime(2 * n - 1)
    
11.    
    
12.     k = 0: cnt = 0: Call dgPL1(0)
    
13.     MsgBox Format(Timer - tms, "0.000s ") & k & "/" & cnt
    
14. End Sub
    
15. Sub dgPL1(t%)
    
16.     Dim i%, i1%, j1%, f As Boolean
    
17.     cnt = cnt + 1
    
18.     If t = n Then Cells(k * (m + 1) + 1, 1).Resize(m, m) = b: k = k + 1
    
19. '    If t = n Then k = k + 1: Exit Sub
    
20.    
    
21.     i1 = t \ m: j1 = t Mod m
    
22.     For i = 1 To n
    
23.         If Not a(i) Then
    
24.             f = False
    
25.             If i1 = 0 Then f = True Else If c(b(i1 - 1, j1) + i) Then f = True
    
26.             If f Then If j1 Then f = c(b(i1, j1 - 1) + i)
    
27.             If f Then a(i) = True: b(i1, j1) = i: Call dgPL1(t + 1): a(i) = False
    
28.         End If
    
29.     Next
    
30. End Sub
    
31. Function GetPrime(n&)
    
32.     Dim a&(), b() As Boolean, i&, j&, k&, m&, s&
    
33.     m = n \ 2: ReDim a&(m), b(3 To n) As Boolean
    
34.     For i = 1 To Sqr(n) \ 2
    
35.         If a(i) = 0 Then
    
36.             s = i * 2 + 1: b(s) = True: k = k + 1: a(k) = s
    
37.             For j = s + i To m Step s
    
38.                 a(j) = 1
    
39.             Next
    
40.         End If
    
41.     Next
    
42.     For i = (a(k) + 1) / 2 To m
    
43.         If a(i) = 0 Then s = i * 2 + 1: b(s) = True ': k = k + 1: a(k) = s
    
44.     Next
    
45.     GetPrime = b
    
46. End Function
    

复制代码

vbyou126

香川群子 发表于 2016-4-25 12:27
意外的是，直接循环检查1-16的排列，而无需检查奇偶性，速度反而更快一些。

原因可能是：奇偶性不符时， ...

对一个问题如此认真，