|
#52
ysr28572021-05-10 22:18
Option Explicit
Private Sub Form_Load() Call init Text1(0).Text = "1234567812345678" Text1(1).Text = "1234567812345678" End Sub Private Sub Command1_Click(Index As Integer) 'Open "d:\1.txt" For Output As #1 Dim D1$, D2$, i&, tt For i = 0 To 2 Text1(i).Text = Trim(Text1(i).Text) Text1(i).Text = Replace(Text1(i).Text, vbCrLf, "") Next D1 = Text1(0).Text D2 = Text1(1).Text Call big32(D1, Big1) '字符串转数组【4位一个分组，数组首位的长度，减少运算是数组长度判断】 Call big32(D2, Big2) Label1.Caption = Format(Now(), "hh:mm:ss") tt = Timer Select Case Index Case 0: Call BigAdd(Big1, Big2, p1p2): Text1(2).Text = B2D(p1p2) '【加法】 Case 1: Call BigSub(Big1, Big2, p1p2): Text1(2).Text = B2D(p1p2) '【减法】 Case 2: Call BigMult(Big1, Big2, p1p2): Text1(2).Text = B2D(p1p2) '【乘法】 Case 3: Call BIgDiv(Big1, Big2, p1p2): Text1(2).Text = B2D(p1p2) '【除法】 End Select tt = Timer - tt Label2.Caption = Format(tt, "0.0000") ' Close #1 End Sub Private Sub init() Dim i& For i = 0 To 2: Text1(i).Width = Screen.Width - 100: Next ReDim C2D(3, 48 To 57) As Double '字符映射引用，减少字符转数字时间 For i = 0 To 9: C2D(0, i + 48) = i: Next For i = 0 To 9: C2D(1, i + 48) = i * 10: Next For i = 0 To 9: C2D(2, i + 48) = i * 100: Next For i = 0 To 9: C2D(3, i + 48) = i * 1000: Next End Sub Option Explicit '////////////////////////////////////////////////////////////////////////////// '// '// 公有声明 '// '////////////////////////////////////////////////////////////////////////////// Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, source As Any, ByVal Length As Long) '------------------------------------------------------------------------------ ' 公有变量 '------------------------------------------------------------------------------ Public C2D, Big1() As Double, Big2() As Double, p1p2() As Double '========================================================================= '求(a,b)最大值 '========================================================================= Public Function max(a, b) As Variant max = IIf(a >= b, a, b) End Function '========================================================================= '======================================================================================= '【大数加法】【4字节】-模拟竖式加法【输入:数组、输出:长度+数组】【调用函数：Nzero】 '======================================================================================== Public Function BigAdd(D1() As Double, D2() As Double, sum() As Double) Dim i&, j& i = max(D1(0), D2(0)) '数组最大长度 j = Abs(D1(0) - D2(0)) '数组长度差 ReDim sum(i + 1) sum(0) = i + 1 If i >= D1(0) Then '【A>=B】利用一次判断，减少不同位数的加法运算 For i = 1 To j: sum(i + 1) = D1(i): Next '【差异部分】【直接赋值】 For i = 1 To D2(0) sum(i + j + 1) = D1(i + j) + D2(i) '【相同部分】【求和】 If sum(i + j + 1) > 10000 Then '【进位处理】 sum(i + j) = sum(i + j) + 1 sum(i + j + 1) = sum(i + j + 1) - 10000 End If Next Else '【A<B】 For i = 1 To j: sum(i + 1) = D2(i): Next '大数末位对齐 For i = 1 To D1(0) sum(i + j + 1) = D2(i + j) + D1(i) If sum(i + j + 1) > 10000 Then '进位处理 sum(i + j) = sum(i + j) + 1 sum(i + j + 1) = sum(i + j + 1) - 10000 End If Next End If If sum(1) = 0 Then Call NZero(sum) '【去前缀0】 End Function '======================================================================================= '【大数加法】【4字节】-模拟竖式加法【输入:数组、输出:长度+数组】【调用函数：nzero】 '======================================================================================== Public Function BigSub(D1() As Double, D2() As Double, sum() As Double) Dim i&, j& i = max(D1(0), D2(0)) '数组最大长度 j = Abs(D1(0) - D2(0)) '数组长度差 ReDim sum(i) sum(0) = i If i >= D1(0) Then For i = 1 To j: sum(i) = D1(i): Next '【差异部分】【直接赋值】 For i = 1 To D2(0) sum(i + j) = D1(i + j) - D2(i) '【相同部分】【求差】 If sum(i + j) < 0 Then '进位处理 sum(i + j - 1) = sum(i + j - 1) - 1 sum(i + j) = sum(i + j) + 10000 End If Next Else MsgBox "被减数溢出": End End If If sum(1) = 0 Then Call NZero(sum) End Function '====================================================================================== '【大数乘法】【4字节】-模拟竖式加法【输入:数组、输出:长度+数组】【调用函数：nzero】 '====================================================================================== Public Function BigMult(D1() As Double, D2() As Double, p1p2() As Double) Dim d3#, i&, j&, maxc& maxc = D1(0) + D2(0) ReDim p1p2(maxc + 1) '保存积 p1p2(0) = maxc For i = 1 To D1(0) '不考虑进位的竖式乘法运算 For j = 1 To D2(0) 'p1p2位D1的i位与D2的j位相乘结果 p1p2(i + j) = p1p2(i + j) + D1(i) * D2(j) Next Next For i = maxc To 2 Step -1 '单独处理进位，减少每次加法的进位词素 If p1p2(i) >= 10000 Then d3 = Int(p1p2(i) / 10000) p1p2(i - 1) = p1p2(i - 1) + d3 p1p2(i) = p1p2(i) - d3 * 10000 End If Next If p1p2(1) = 0 Then Call NZero(p1p2) End Function '====================================================================================================== '【大数除法】【4字节数组】-补位、试商除法【输入:数组、输出:数组】【调用函数：bigmult、bigsub、bigcomp】 '====================================================================================================== Public Function BIgDiv(D1() As Double, D2() As Double, p1p2() As Double) Dim i&, k&, j&, r0, top(1) As Double, temp() As Double, len1&, num1() As Double ReDim r0(D1(0) - D2(0) + 1) '除法的商（临时） ReDim p1p2(D1(0) - D2(0) + 1) '除法的商（结果） p1p2(0) = D1(0) - D2(0) + 1 top(0) = 1 '保留商 len1 = 0 '缩位控制 If D1(0) > D2(0) Then '【同位减法】位数不等，D2补位，首位小少补1位 len1 = IIf(D1(1) < D2(1), D1(0) - D2(0) - 1, D1(0) - D2(0)) ReDim Preserve D2(D2(0) + len1) '补位，扩大10^len1倍，d1>=d2 D2(0) = D2(0) + len1 '数组首位：数组数据长度 End If st1: k = BigComp(D1, D2) '比较数组大小 If D1(1) < 0 Then End If k = 0 Then r0(len1) = r0(len1) + 1: GoTo st2 '【N倍整除】-【返回】 If k >= 1 Then '【够除】【k=1：位数不等】【k=2：位数相等】 If k = 1 Then top(1) = Int((D1(1) * 10000 + D1(2)) / (D2(1) + 1)) '试商结果0-9999 If k = 2 Then top(1) = Int(D1(1) / (D2(1) + 1)) ''试商结果0-9999 If top(1) > 1 Then '【试商后结果：2-9999】【先乘，后减】 Call BigMult(D2, top, temp) Call BigSub(D1, temp, num1) r0(len1) = r0(len1) + top(1) Else '【试商后结果：0-1】【直接减】 Call BigSub(D1, D2, num1) r0(len1) = r0(len1) + 1 End If ReDim D1(UBound(num1)) D1 = num1 '剩余数据 GoTo st1 Else '【不够减】【len1<>0,缩位】【len1=0，结束】 If len1 >= 1 Then '若扩位，则缩位 len1 = len1 - 1: D2(0) = D2(0) - 1: ReDim Preserve D2(D2(0)): GoTo st1 '缩少1字节扩位 End If st2: For j = UBound(r0) To 0 Step -1 '倒序商数 If r0(j) <> 0 Then Exit For Next p1p2(0) = j + 1 For i = 0 To j: p1p2(i + 1) = r0(j - i): Next End If End Function '=============================================================================== '【10进制串->数组】【输入:字符串】【输出：长度+4字节数组】【高位在前)】 '调用函数：C2D数组映射、copymemory 内存数据复制 '=============================================================================== Public Function big32(msg As String, arr() As Double) Dim i&, top_len&, dest_len&, src_len&, bz&, Count&, temp() As Integer src_len = Len(msg) '输入字符串长度 dest_len = Int((Len(msg) - 1) / 4) + 1 '目的分组长度【4位上取整】 top_len = Len(msg) Mod 4 '头部分组长度(1-3字节) ReDim arr(dest_len) '目的数组数据 arr(0) = dest_len '目的数组长度 ReDim temp(src_len - 1) '字符串缓冲数组 i = StrPtr(msg) '字符串指针地址 CopyMemory ByVal VarPtr(temp(0)), ByVal i, src_len * 2 '读取字符串内容到内存 Count = 0 For i = 1 To top_len '【非4位整数的头字节】1-3字节 If i = 1 Then Count = Count + 1 '只加一次 arr(Count) = arr(Count) + C2D(top_len - i, temp(i - 1)) Next For i = top_len + 1 To src_len '【4位字节整数】 bz = (i - top_len - 1) Mod 4 If bz = 0 Then Count = Count + 1 arr(Count) = arr(Count) + C2D(3 - bz, temp(i - 1)) Next End Function '======================================================================= '【数组比较】【输入:数组、输出:1:长度大 2:长度相等大于 0:等于 -1:小于】 '======================================================================= Public Function BigComp(num1() As Double, num2() As Double) As Long Dim i& If num1(0) > num2(0) Then BigComp = 1: Exit Function '长度大，大数 If num1(0) < num2(0) Then BigComp = -1: Exit Function '长度小，小数 For i = 1 To num1(0) '逐位比较 If num1(i) > num2(i) Then BigComp = 2: Exit Function '长度相等，大数 If num1(i) < num2(i) Then BigComp = -1: Exit Function '长度相等，小数 Next If i > num1(0) Then BigComp = 0 '数组相等 End Function '======================================================================= '【清数组前置0】【输入:数组、输出:去前缀0数组】 '======================================================================= Public Sub NZero(Soure() As Double) '去除数组前置0 Dim i&, j& For i = 1 To Soure(0) If Soure(i) <> 0 Then Exit For Next If i > Soure(0) Then Soure(0) = 1: Soure(1) = 0: Exit Sub If i > 1 Then For j = i To Soure(0): Soure(j - i + 1) = Soure(j): Next Soure(0) = Soure(0) - i + 1 End If End Sub '========================================================================= '【数组->10进制串】【输入:byte数组、输出:字符串】 '========================================================================= Public Function B2D(byte1) As String Dim i& B2D = Trim(Str(byte1(1))) For i = 2 To byte1(0) B2D = B2D & Format(byte1(i), "0000") Next End Function '这个代码无法运行，启动后点击+-*或者/按钮，都是提示变量Big1没有定义，不知道咋回事，咋弄呢？ |
用牛顿迭代法做的除法程序（稍加修改可以用于大整数的快速除法，欢迎沟通探讨），这回准确了，小数点后也准确，代码如下：
Private Sub Command1_Click()
Dim a, b
a = Text1: b = Text2: b3 = b
If Len(b) = 1 Then
X1 = Mid(b, 1, 1): X2 = 1 / X1
Else
X1 = Mid(b, 1, 2): X2 = 10 / X1
End If
x = Mid(X2, 1, 4)
y = 0: x3 = 0
If Len(b) = 1 Then
b = b
Else
b1 = Mid(b, 1, 1)
b2 = Mid(b, 2)
b = b1 & "." & b2
End If
Do While Abs(x3 - x) >= 0.0000000001
Print x
y = Val(x * (2 - b * x))
x3 = x
x = Val(y)
Loop
a1 = Mid(a, 1, Len(a) - Len(b3) + 1)
a2 = Right(a, Len(b3) - 1)
a = a1 & "." & a2
Print a
s = Len(a) - Len(b3)
Text3 = a * y
End Sub
Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
End Sub