program.bas

实现M5加密算法的源程序

Attribute VB_Name = "Program"
Option Explicit
Private n As Long
Private x() As Long
Private t As Long
Public Oldn As String, Newn As String

Sub tprint()
Dim i As Long
With Maths
    .tval = .tval & "解" & t & ":"
    For i = 1 To n
        .tval = .tval & x(i) & " "
    Next i
    .tval = .tval & vbCrLf
End With
End Sub

Sub place(k As Long)
Dim i As Long
If k > n Then
    t = t + 1
    'tprint
Else
    For i = 1 To n
        If try(i, k) Then
            x(k) = i
            place k + 1
        End If
    Next i
End If
End Sub

Function try(i As Long, k As Long) As Boolean
Dim j As Long
For j = 1 To k - 1
    If x(j) = i Then Exit Function
    If Abs(x(j) - i) = Abs(j - k) Then Exit Function
Next j
try = True
End Function
 
'N皇后问题(t为解数)
'递归算法 queen1(10):1.23s
Function Queen1(num As Long) As Long
n = num
t = 0
ReDim x(num)
place 1
Queen1 = t
End Function

'回溯算法 queen2(10):1.32s
Function Queen2(n As Long) As Long
Dim i As Long, total As Long
ReDim x(n)
For i = 1 To n \ 2
    total = total + queenMain(n, i)
Next i
total = total + total
If n Mod 2 Then
    total = total + queenMain(n, n \ 2 + 1)
End If
Queen2 = total
End Function
Function queenMain(ByVal n As Long, ByVal i As Long) As Long
Dim total As Long
Dim k As Long, m As Long, j As Long
k = 2: m = 1: x(1) = i
Do While k > 1
    For j = m To n
        If try(j, k) Then Exit For
    Next j
    If j <= n Then
        x(k) = j
        If k < n Then
            k = k + 1: m = 1
        Else
            'tprint
            total = total + 1: k = k - 1: m = x(k) + 1
        End If
    Else
        k = k - 1: m = x(k) + 1
    End If
Loop
queenMain = total
End Function

'骑士游历问题
'total:至多输出的解数
Sub YouLi(n As Long, ByVal x As Long, ByVal y As Long, total As Long)
Dim dx(8) As Long, dy(8) As Long, a() As Long, b() As Long
Dim k As Long, m As Long, i As Long, j As Long, cx As Long, cy As Long
Dim res As String, temp As Long, ts As String
Dim tt As Long
ReDim a(-1 To n + 2, -1 To n + 2), b(n * n)
FillArraySpe 1, 8, dx(), 1, 2, 2, 1, -1, -2, -2, -1
FillArraySpe 1, 8, dy(), -2, -1, 1, 2, 2, 1, -1, -2
temp = n * n - 2: ts = Space(Len(CStr(temp + 2)) + 1)
For i = -1 To n + 2
    For j = -1 To n + 2
        a(i, j) = -1
    Next j
Next i
For i = 1 To n
    For j = 1 To n
        a(i, j) = 0
    Next j
Next i
a(x, y) = 1
Do
    If k > 7 Then
        a(x, y) = 0: k = b(m): m = m - 1: x = x - dx(k): y = y - dy(k)
    Else
        k = k + 1: cx = x + dx(k): cy = y + dy(k)
        If a(cx, cy) = 0 Then
            If m = temp Then
                a(cx, cy) = n * n
                For j = 1 To n
                    For i = 1 To n
                        RSet ts = a(i, j)
                        res = res & ts
                    Next i
                    res = res & vbCrLf
                    'Maths.tval = res
                Next j
                res = res & vbCrLf
                a(cx, cy) = 0
                k = 8
                tt = tt + 1: If tt = total Then Exit Do
            Else
                x = cx: y = cy
                m = m + 1: a(x, y) = m + 1: b(m) = k: k = 0
            End If
        End If
    End If
Loop Until m < 0
Maths.tval = res
End Sub

'求最短Golomb尺
Function Golomb(n As Long, max As Long) As Long
Dim First As String
Dim en As Boolean
Dim i As Long, j As Long, cs As Long, ss As Long
Dim k As Long, m As Long, s As Long, le As Long, l As Long, d As Long
Dim a() As Long
ReDim a(n)
Dim b() As Long, c(24) As Long, diff() As Long
ReDim b(n), diff(max)
FillArraySpe 1, 23, c(), 0, 1, 3, 6, 11, 17, 25, 34, 44, 55, 72, 85, 106, 114, 133, 154, 177, 201, 227, 254, 283, 314, 346, 380
If n = 1 Then Exit Function
If n = 2 Then Golomb = 1: Exit Function
'获取起始数列
If MsgBox("要提供起始数列吗?", vbYesNo Or vbInformation) = vbYes Then
    First = InputBox("请输入起始数列", "Golomb尺")
    If First <> "" Then
        k = 1
        m = InStr(m + 1, First, ",")
        Do Until m = 0
            le = le + 1
            a(le) = Val(Mid$(First, k, m - k))
            k = m + 1
            m = InStr(k, First, ",")
        Loop
        le = le + 1
        a(le) = Val(Mid$(First, k))
        l = ask("请输入固定长度", "Golomb尺", le + 1)
        If l < 0 Then l = 0
    End If
End If
Start = GetTime
en = True
'作固定差
For i = 1 To l
    For j = 0 To i - 1
        diff(a(i) - a(j)) = 1
    Next j
Next i
'定ss,cs
i = 1
Do
    If diff(i) = 0 Then ss = i - 1: Exit Do
    i = i + 1
Loop While True
If l > 0 Then
    If a(1) < 3 Then cs = 2
    For i = 1 To l
        If a(l) < a(i) + a(i) - ss - 1 Then cs = i: Exit For
    Next i
    If i = l + 1 Then cs = l + 1
End If
'生成b()
i = 1: j = 1
Do Until j > n - l - 2
    If diff(i) = 0 Then
        b(j) = b(j - 1) + i: j = j + 1
    End If
    i = i + 1
Loop
If l > 0 Then
    i = 1: j = 2: m = a(1) + 1: b(1) = m
    Do Until j > n - l - 2
        If diff(i) = 0 Then
            m = m + i
            If m > b(j) Then b(j) = m
            j = j + 1
        End If
        i = i + 1
    Loop
End If
'改进b()
For i = 1 To n - l - 2
    If c(i) > b(i) Then b(i) = c(i)
Next i
If l > 0 Then
    For i = 2 To n - l - 2
        m = c(i - 1) + a(1) + 1
        If m > b(i) Then b(i) = m
    Next i
End If
'作余下的差
For i = l + 1 To le
    For j = 0 To i - 1
        diff(a(i) - a(j)) = 1
    Next j
Next i
cs = 1
'主过程
Tips.Show
Tips.Refresh
If l < le Then
    m = a(l + 1)
    GolombEx n, max, l + 1, le, a()
    For j = l + 1 To n
        a(j) = 0
    Next j
End If
If l < le Then s = m - a(l) Else s = ss
m = a(l)
i = l + 1: d = b(n - 1 - i) + m
Do While s + d < max
    s = s + 1
    If diff(s) = 0 Then
        k = m + s
        For j = i - 2 To cs Step -1
            If diff(k - a(j)) Then en = False: Exit For
        Next j
        If en Then
            a(i) = k
            Tips.Caption = max & "(" & k & ")"
            GolombEx n, max, i, i, a()
            For j = l + 1 To n
                a(j) = 0
            Next j
        Else
            en = True
        End If
    End If
Loop
Golomb = max
End Function
Sub GolombEx(ByVal n As Long, max As Long, l As Long, le As Long, a() As Long)
Dim i As Long, j As Long, s As Long, k As Long
Dim d As Long, m As Long
Dim cs As Long, ss As Long
Dim need As Boolean, en As Boolean
Dim b() As Long, c(24) As Long, diff() As Long
ReDim b(n), diff(max)
need = True: en = True
FillArraySpe 1, 23, c(), 0, 1, 3, 6, 11, 17, 25, 34, 44, 55, 72, 85, 106, 114, 133, 154, 177, 201, 227, 254, 283, 314, 346, 380
'作固定差
For i = 1 To l
    For j = 0 To i - 1
        diff(a(i) - a(j)) = 1
    Next j
Next i
'定ss,cs
i = 1
Do
    If diff(i) = 0 Then ss = i - 1: Exit Do
    i = i + 1
Loop While True
If l > 0 Then
    If a(1) < 3 Then cs = 2
    For i = 1 To l
        If a(l) < a(i) + a(i) - ss - 1 Then cs = i: Exit For
    Next i
    If i = l + 1 Then cs = l + 1
End If
'生成b()
i = 1: j = 1
Do Until j > n - l - 2
    If diff(i) = 0 Then
        b(j) = b(j - 1) + i: j = j + 1
    End If
    i = i + 1
Loop
If l > 0 Then
    i = 1: j = 2: m = a(1) + 1: b(1) = m
    Do Until j > n - l - 2
        If diff(i) = 0 Then
            m = m + i
            If m > b(j) Then b(j) = m
            j = j + 1
        End If
        i = i + 1
    Loop
End If
'改进b()
For i = 1 To n - l - 2
    If c(i) > b(i) Then b(i) = c(i)
Next i
If l > 0 Then
    For i = 2 To n - l - 2
        m = c(i - 1) + a(1) + 1
        If m > b(i) Then b(i) = m
    Next i
End If
'作余下的差
For i = l + 1 To le
    For j = 0 To i - 1
        diff(a(i) - a(j)) = 1
    Next j
Next i
cs = 1
'主循环过程
n = n - 1: i = le + 1
Do
    m = a(i - 1)
    If need Then
        s = ss: need = False
    Else
        k = a(i)
        For j = 1 To i - 2
            diff(k - a(j)) = 0
        Next j
        diff(k) = 0
        s = k - m: diff(s) = 0
    End If
    d = b(n - i) + m
    Do While s + d < max
        s = s + 1
        If diff(s) = 0 Then
            k = m + s
            For j = i - 2 To cs Step -1
                If diff(k - a(j)) Then en = False: Exit For
            Next j
            If en Then
                If i < n Then
                    a(i) = k: diff(s) = 1
                    For j = 1 To i - 2
                        diff(k - a(j)) = 1
                    Next j
                    diff(k) = 1
                    i = i + 1
                    need = True: Exit Do
                Else
                    Newn = "0"
                    For j = 1 To n - 1
                        Newn = Newn & "," & a(j)
                    Next j
                    Newn = Newn & "," & k
                    If k = max Then
                        Oldn = Oldn & Newn & vbCrLf
                    Else
                        Oldn = Newn & vbCrLf
                        max = k
                    End If
                    Tips.Caption = max & "(" & a(l) & ")"
                    Tips.Label1.Caption = Oldn
                    Tips.Refresh
                End If
            Else
                en = True
            End If
        End If
    Loop
    If need = False Then i = i - 1
Loop Until i = l
End Sub

'未优化
Function Mersern(n As Long) As Boolean
Dim i As Long, j As Long, z As Long, min As Long, max As Long, x As Long
Dim a() As Long, b() As Long, s As Long, e As Long, total As Long, k As Long
ReDim a(n + n), b(n + n)
If n Mod 4 = 3 Then
    If Prime(n + n + 1) Then Exit Function
End If
a(2) = 1: max = 2: min = 2
For total = 1 To n - 2
    j = min + min: z = max + max: b(j) = 1
    t = j + 1: j = t + 1: b(t) = 0: e = j / 2
    Do Until j > z
        s = t - max
        If s > min Then x = s Else x = min
        s = 0
        For i = x To e - 1
            If a(i) Then s = s + a(t - i)
        Next i
        If j And 1 Then
            e = e + 1
        Else
            s = s + a(e)
        End If
        b(j) = s
        t = j: j = j + 1
    Loop
    z = max + max
    For i = 0 To min + min - 1
        a(i) = 0
    Next i
    x = n - 1
    If x > z Then x = z
    For i = min + min To x
        a(i) = b(i)
    Next i
    j = 0: x = n
    If min + min > n Then x = min + min: j = x - n
    For i = x To z
        a(j) = a(j) + b(i)
        j = j + 1
    Next i
    Do
        e = 0
        For i = 0 To n - 1
            s = a(i) + e
            a(i) = s Mod 2
            e = s \ 2
        Next i
        a(0) = a(0) + e
    Loop Until e < 2
    If e Then
        e = 0
        If a(0) = 2 Then
            Do
                e = e + 1
                a(e) = a(e) + 1
                a(e - 1) = 0
            Loop Until a(e) = 1
        End If
    End If
    k = 0
    For i = 1 To n - 1
        If a(i) Then k = i: Exit For
    Next i
    If k <> 0 Then
        a(k) = 0
        For i = 1 To k - 1
            a(i) = 1
        Next i
    Else
        If a(0) = 0 Then a(1) = 1
    End If
    min = -1
    For i = 0 To n - 1
        If a(i) Then min = i: Exit For
    Next i
    If min = -1 Then
        If total = n - 2 Then Mersern = True
        Exit Function
    End If
    i = n - 1
    Do While a(i) = 0
        i = i - 1
    Loop
    max = i
Next total
End Function