数学.frm

实现M5加密算法的源程序

For j = i To 126 Step 25
RSet o = p(j)
tval = tval & o & " "
Next j
tval = tval & vbCrLf
Next i
End Sub
Function w(n As Integer) As Integer
    w = (3 * n * n - n) / 2
End Function

Private Sub mnuNe_Click()
Dim n As Long, c As Long, d As Long, i As Long, s As Long
On Error GoTo err
n = ask("请输入范围N", "圆内格点问题", lng)
If n < 0 Then Exit Sub
c = Int(Sqr(n + 0.5)): d = Int(Sqr(n / 2 + 0.25))
For i = 1 To d
    s = s + Int(Sqr(n - i * i))
Next i
s = s + s + c - d * d
s = s * 4 + 1
tval = s
err:
End Sub

Private Sub mnuChu_Click()
Dim n As Long, c As Long, i As Long, s As Long
On Error GoTo err
n = ask("请输入范围N", "除数问题", lng)
If n < 0 Then Exit Sub
c = Int(Sqr(n + 0.5))
For i = 1 To c
    s = s + n \ i
Next i
s = s + s - c * c
tval = s
err:
End Sub

Private Sub mnuSqr_Click()
Dim n As Long
n = ask("请输入范围N" & vbCrLf & "(分解形如4N+1的素数为两平方数之和)", "平方数问题", lng)
If n < 0 Then Exit Sub
If n Mod 4 <> 1 Or Not Prime(n) Then
    MsgBox ("请输入形如4N+1的素数"), vbCritical
Else
    ToSqr n
End If
End Sub

Private Sub mnuThreePlus_Click()
Dim a(32767) As Integer, n As Integer, num As Integer
Start = GetTime
Dim i As Integer
a(1) = 1: a(2) = 0: a(3) = 0: a(4) = 1
n = 4
'a(43) = 9
'For i = 1 To 9
'a(24 + i) = 10 - i
'a(33 + i) = 10 - i
'Next i
'a(1) = 2: n = 43                  '此数为996步
'a(1) = 1: a(1000) = 1: n = 1000   '此数为23068步
If ThreePlusEx(a(), n, num) Then tval = "共需" & num & "步收敛至1"
MsgBox "共耗时" & Str((GetTime - Start) / freq) & "秒", vbInformation
End Sub

Private Sub mnuGolomb_Click()
Dim n As Long, max As Long, First As Long
Dim k As Long
n = ask("请输入范围N", "Golomb尺", 20)
If n < 0 Then Exit Sub
If MsgBox("要提供上限吗?", vbYesNo Or vbInformation) = vbYes Then
    max = ask("请输入上限", "Golomb尺", 32767)
End If
If max <= 0 Then max = 32767
tval = ""
Oldn = "": Newn = ""
k = Golomb(n, max)
tval = "最短尺长" & k & vbCrLf
tval = tval & Oldn
Unload Tips
MsgBox "共耗时" & Str((GetTime - Start) / freq) & "秒", vbInformation
End Sub

Private Sub mnuQueen_Click()
Dim n As Long
n = ask("请输入范围N", "八皇后问题", 20)
If n < 0 Then Exit Sub
Start = GetTime
tval = "共有" & Queen2(n) & "种解法"
MsgBox "共耗时" & Str((GetTime - Start) / freq) & "秒", vbInformation
End Sub

Private Sub mnuYouLi_Click()
Dim n As Long
n = ask("请输入棋盘大小", "骑士游历问题", lng)
If n < 0 Then Exit Sub
Start = GetTime
YouLi n, 1, 1, 1
MsgBox "共耗时" & Str((GetTime - Start) / freq) & "秒", vbInformation
End Sub

Private Sub mnuPell_Click()
Dim x As Long, y As Long, z As Long, t As Long, m As Long, k As Long
Dim al As Integer, n As Integer, a As Integer, b As Integer, c As Integer, q As Integer
On Error GoTo err
n = ask("请输入系数N(非平方数)", "Pell方程", lng)
If n < 0 Then Exit Sub
If Int(Sqr(n)) = Sqr(n) Then MsgBox "请输入非平方数", vbCritical, "Pell方程": Exit Sub
a = Int(Sqr(n + 0.5)): b = a: c = n - a * a: q = a
x = 1: z = a: t = 1: al = -1
a = 2 * a \ c
Do
k = x: m = y: x = z: y = t: z = a * z + k: t = a * t + m
b = c * a - b
c = (n - b * b) / c
a = (q + b) \ c
al = -al
Loop Until c = 1
tval = "不定方程x*x-" & n & "*y*y=" & al & "的最小解为x=" & z & " y=" & t
Exit Sub
err:
    MsgBox "无法计算", vbCritical
End Sub

Private Sub mnuDis_Click(Index As Integer)
Dim a() As Long, n As Long, i As Long
Start = GetTime
If Index = 1 Then n = 10000 Else n = 100
ReDim a(n)
For i = 1 To n
    a(i) = Int(Rnd * 32767)
Next i
QSort a(), n
If Index = 0 Then
    tval = a(1)
    For i = 2 To n
        tval = tval & "," & a(i)
    Next i
End If
MsgBox "共耗时" & Str((GetTime - Start) / freq) & "秒", vbInformation
End Sub

Private Sub mnuTwo_Click()
Dim i As Long, d As Long, j As Long, a() As Long, b As Long, n As Long, m As Long
Dim c As Long
c = 1000000000
On Error GoTo err
n = ask("请输入N", "2^N", lng)
If n < 0 Then Exit Sub
Start = GetTime
ReDim a((n * 0.31) \ 9 + 1)
d = 1: a(1) = 1
For j = 1 To n
    b = 0
    For i = 1 To d
        a(i) = a(i) + a(i) + b
        If a(i) >= c Then
            b = 1: a(i) = a(i) - c
        Else
            b = 0
        End If
Next i
    If b = 1 Then d = d + 1: a(d) = 1
Next j
Dim HResult() As Byte
ConvertToString a(), 9, "2^" & n & "=", d, HResult()
tval = HResult
Erase HResult
MsgBox "共耗时" & Str((GetTime - Start) / freq) & "秒", vbInformation
err:
End Sub

Private Sub mnuChen_Click()
Dim i As Long, d As Long, j As Long, b As Long, n As Long, o As Long, m As Long
Dim c, q As Long
Dim a() As Long, f As Long
c = 1000000000
On Error GoTo err
n = ask("请输入N", "N!", lng)
If n < 0 Then Exit Sub
Start = GetTime
q = 2147483647: o = 9
Do While c * n > q
c = c \ 10
o = o - 1
Loop
ReDim a((Log(n) * n) / Log(10) \ o + 2)
d = 1: a(1) = 1
For j = 2 To n
    b = 0
    For i = 1 To d
        a(i) = a(i) * j + b
        If a(i) >= c Then
            b = a(i) \ c: a(i) = a(i) Mod c
        Else
            b = 0
        End If
    Next i
    If b > 0 Then d = d + 1: a(d) = b
Next j
Dim HResult() As Byte
ConvertToString a(), o, n & "!=", d, HResult()
tval = HResult
Erase HResult
MsgBox "共耗时" & Str((GetTime - Start) / freq) & "秒", vbInformation
err:
End Sub

Private Sub mnuPI_Click()
Dim i As Long, j As Long, n As Long
Dim q As Long, temp As Long, nold As Long
Dim r() As Long, a As String
n = ask("请输入N", "Pi", 32767)
If n < 0 Then Exit Sub
Start = GetTime
nold = n
n = n * 10 \ 3
ReDim r(n)
    For i = 0 To n
        r(i) = 2
    Next i
    For i = 1 To nold
        q = 0
        For j = 0 To n
            r(j) = r(j) * 10
        Next j
        For j = n To 1 Step -1
            temp = r(j) + q * (j + 1)
            r(j) = temp Mod (j + j + 1)
            q = temp \ (j + j + 1)
        Next j
        temp = r(0) + q
        r(0) = temp Mod 10
        a = a & (temp Mod 100) \ 10
    Next i
    tval = a
MsgBox "共耗时" & Str((GetTime - Start) / freq) & "秒", vbInformation
End Sub

'未验证正确性
Private Sub mnuPIQuick_Click()
Dim PIValue As String
'Dim n As Long
'n = ask("请输入N", "Pi", lng)
'If n < 0 Then Exit Sub
Start = GetTime
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f(2801) As Long, g As Long, k As Long
a = 10000: c = 2800
While b <> c
    f(b) = a / 5
    b = b + 1
Wend
d = 0: g = c + c
While g > 0
    b = c: d = d + f(b) * a: g = g - 1: f(b) = d Mod g: d = d \ g: g = g - 1: b = b - 1
    While b > 0
        d = d * b: d = d + f(b) * a: g = g - 1: f(b) = d Mod g: d = d \ g: g = g - 1: b = b - 1
    Wend
    c = c - 14
    k = e + d \ a
    PIValue = PIValue & Format(k, "0###")
    e = d Mod a: d = 0: g = c + c
Wend
tval = PIValue
MsgBox "共耗时" & Str((GetTime - Start) / freq) & "秒", vbInformation
End Sub

Private Sub mnuGen_Click(Index As Integer)
Dim a As Double
Select Case Index
Case 0
    a = TwoEq(-1, 0, 1E-16)
    'GetGen (InputBox("n"))
Case 1
    a = Newton(0.4, 3E-16)
Case 2
    a = GenQieBi(0.4, 0.000000000000001)
Case 3
    a = Stevensen(0.4, 0.000000000000001)
End Select
If a <> 0 Then tval = a Else tval = ""
End Sub

Private Sub mnuXiao_Click(Index As Integer)
Dim a() As Double, x() As Double, y() As Double
Dim n As Integer
n = 3
ReDim a(n, n), x(n), y(n)
FillArray 3, 3, a(), 9, 3, 4, 1, 5, 3, 1, 2, -6
FillArray 1, 3, y(), 1, 12, -3
Select Case Index
    Case 0
        EquGaussEx a(), y(), x(), n
    Case 1
        FillArray 1, 3, x(), 1, 1, 1
        Seidel a(), y(), x(), n, 25
    Case 2
        FillArray 1, 3, x(), 1, 1, 1
        GongEx a(), y(), x(), n, 5
End Select
tval = OutPutArray(x(), n)
End Sub

Private Sub mnuNi_Click(Index As Integer)
Dim a() As Double, b() As Double, n As Integer
n = 3
ReDim a(n, n), b(n, n)
FillArray n, n, a(), 1, 1, 1, 1, 2, 3, 2, 1, -1
Select Case Index
    Case 0
        GetEquNiEx a(), b(), n
    Case 1
        GetEquNiEx2 a(), b(), n
End Select
tval = OutPutMatrix(b(), n)
End Sub

Private Sub mnuEigen_Click(Index As Integer)
Dim a() As Double
Dim n As Integer, i As Integer, result As String
Select Case Index
    Case 0
        'n = 4
        'ReDim a(n, n)
        'FillArray n, n, a(), 2, -1, 0, 0, -1, 2, -1, 0, 0, -1, 2, -1, 0, 0, -1, 2
        n = 3
        ReDim a(n, n)
        FillArray n, n, a(), 7, 4, -4, 4, 7, -4, -4, -4, 4
        Jaccobi a(), n, 10
    Case 1
        Dim y() As Double
        n = 3: ReDim y(n)
        ReDim a(n, n)
        FillArray n, n, a(), 7, 4, -4, 4, 7, -4, -4, -4, 4
        'FillArray 4, 4, a(), 2, -1, 0, 0, -1, 2, -1, 0, 0, -1, 2, -1, 0, 0, -1, 2
        HouseHolder a(), y(), n, 0.000000000000005
    Case 2
        n = 3
        ReDim a(n, n)
        FillArray n, n, a(), 7, 4, -1, 4, 7, -1, -4, -4, 4
        'FillArray 3, 3, a(), 2, 4, 6, 3, 9, 15, 4, 16, 36
        'FillArray 3, 3, a(), 8, 0, -8, 18, 0, -17, 18, 1, -18
        'FillArray 3, 3, a(), 5, 1, -4, -2, 2, 2, 1, 1, 0
        QR a(), n, 10
End Select
For i = 1 To n
    If Index = 1 Then
        result = result & y(i) & vbCrLf
    Else
        result = result & a(i, i) & vbCrLf
    End If
Next i
tval = result
End Sub

Private Sub mnuCha_Click(Index As Integer)
Dim a As Double, b As Double, q As Double
a = -2: b = 0
Select Case Index
    Case 0
        q = Alpha(-1, 0.0000001)
    Case 1
        q = FenShu(-1, 0.0000001)
    Case 2
        q = Three(a, b, 0.001)
    Case 3
        '
End Select
tval = q
End Sub

Private Sub mnuDiff_Click(Index As Integer)
Dim i As Integer
If Index = 0 Then Exit Sub
tval = ""
Select Case Index
Case 0
    'tval = LarrangeS(1.2, 0.01, 10)
Case 1
    WeiOut 1.2, 0.5
Case 2
    Dim f(5) As Double, y(5) As Double, t As Double
    For i = 0 To 5
        f(i) = Sqr(100 + i)
    Next i
    Simpson f(), y(), 0.05, 1 / (2 * Sqr(105)), 1, 5
    For i = 1 To 4
    tval = tval & y(i) & vbCrLf
    Next i
End Select
End Sub

Private Sub mnuLarrange_Click(Index As Integer)
Select Case Index
Case 0
    tval = LarrangeS(1.2, 0.01, 10)
Case 1
    tval = LarrangeD(1.2, 0.01, 10)
End Select
End Sub

Private Sub mnuCotes_Click(Index As Integer)
Select Case Index
Case 0
    tval = Cotes(2, 3, 10000)
Case 1
    tval = QieBiJi(2, 3, 5000)
End Select
End Sub

Private Sub mnuGauss_Click(Index As Integer)
Dim a As Double, b As Double
Dim i As Integer
tval = ""
a = 100: b = 1000
If Index < 2 Then
    Call Romberg(a, b, Index)
Else
    For i = 2 To 8
        tval = tval & Gauss(a, b, i) & vbCrLf
    Next i
    For i = 10 To 18 Step 2
        tval = tval & Gauss(a, b, i) & vbCrLf
    Next i
End If
End Sub

Private Sub mnuEXP_Click()
'使用前应先改f(x)=x*x
Dim a As Double
a = 1
tval = ExpSimpleD(a, 1, 1000)
End Sub

'未完成
Private Sub mnuWeiChu_Click(Index As Integer)
Select Case Index
    Case 0
        tval = Euler(0, 1, 1, 100)
    Case 1
        tval = EulerEx(0, 1, 1, 100, 10)
    Case 2
        tval = Runge(0, 1, 1, 100)
    Case 3
        'tval = Adams(0, 1, 1, 100, 10)
    Case 4
        'tval = Milne(0, 1, 1, 100, 10)
    Case 5
        'tval = HaMing(0, 1, 1, 100, 10)
    Case 6
        
End Select
End Sub

Private Sub mnuFFT_Click()
Dim i As Long, res As String
Dim n As Long
Dim ur() As Double, ui() As Double, t As Double
n = 1024: t = 0.01
ReDim ur(n), ui(n)
'For i = 0 To 7
    'ur(i) = i + 1
'Next i
'FFT ur(), ui(), 8
For i = 0 To n - 1
    ur(i) = (Exp(-i * t) + Exp(-t * (n - i))) * t
Next i
FFT ur(), ui(), n
'FFTNi ur(), ui(), n
For i = 0 To 7
    res = res & ur(i) & "," & ui(i) & vbCrLf
Next i
tval = res
End Sub

Private Sub mnuBaoTu_Click()
Dim x() As Double, y() As Double
Dim n As Long, i As Long
n = 100
ReDim x(n), y(n)
For i = 0 To n
    x(i) = i / 50
    y(i) = Cos(x(i))
Next i
FunDraw x(), y(), Simple, 1, -1, n
Simple.Show
End Sub

Private Sub tval_Click()
Dim i As Long
End Sub