extension.bas

一个VB小程序,能够进行大数的计算,可以作为学习的参考

Attribute VB_Name = "ExtndInt"
Attribute VB_Description = "Quadratic and rational standard operations for bignumVB.bas, a Visual Basic library for large-integer arithmetic."
'Author : Sjoerd.J.Schaper - [e-mail]
'URL    : http://largeint.sourceforge.net/index.html
'Date   : 12-27-2004
'Code   : Visual Basic for Windows 5.0
Option Explicit

Sub MulR(a As Long, r As Long)
  If Isf(r, -1) Then '                 rl for radical, rd for radicand
    Chs a '                            Gaussian integers, rd = -1
  Else
    Mult a, r, t2 '                    a times rd
  End If
End Sub

Sub QAdd(a As Long, b As Long, c As Long, d As Long)
  Add a, c
  Add b, d '                           a + c + (b + d)* rl
End Sub

Sub QDivd(a As Long, b As Long, c As Long, d As Long, r As Long)
Dim f As Integer: f = 7
  '
  Squ c, i(f): Squ d, t1
  MulR t1, r: Subt i(f), t1 '          f = c^2 - d^2* rd
  If Isf(i(f), 0) Then
    Data = " division by zero"
    ErrSw = -1: Exit Sub
  End If
  Mult a, c, t0: Swp a, t0
  Mult b, d, t1: Swp b, t1
  MulR t1, r: Subt t0, t1
  Mult a, d, t1
  Mult b, c, t1
  Subt b, a: Swp a, t0
  Divd a, i(f), t0: Swp a, t0
  Divd b, i(f), t0: Swp b, t0 '        (ac - bd* rd) / f + (bc - ad)* rl / f
End Sub

Sub QMod(a As Long, b As Long, c As Long, d As Long, r As Long)
Dim at As Integer, bt As Integer
  at = 5: bt = 6
  '
  Copyf a, i(at): Copyf b, i(bt)
  QDivd i(at), i(bt), c, d, r
  If ErrSw Then
    Data = " zero modulus"
    Exit Sub
  End If
  QMult i(at), i(bt), c, d, r
  QSubt a, b, i(at), i(bt) '           w - int(w / z) * z
End Sub

Sub QMult(a As Long, b As Long, c As Long, d As Long, r As Long)
  Mult a, c, t0: Swp a, t0
  Mult b, d, t1: Swp b, t1
  MulR t1, r: Add t0, t1
  Mult a, d, t1
  Mult b, c, t1
  Add b, a: Swp a, t0 '                ac + bd* rd + (bc + ad)* rl
End Sub

Sub QPwr(a As Long, b As Long, p As Long, r As Long)
Dim at As Integer, bt As Integer
Dim c As Integer, c0 As Integer, j As Integer
Dim k As Integer, s As Integer, sw As Boolean
  at = 5: bt = 6
  '
  If Isf(p, 0) Then
    Letf a, 1: Letf b, 0: Exit Sub
  End If
  If Isf(p, 1) Then Exit Sub
  Copyf a, i(at): Copyf b, i(bt)
  '
  k = Getl(p) - 1
  For j = k To 0 Step -1 '            L=>R binary exponentiation
    c = Gete(p, j): c0 = MH '          unsigned bitvector p
    If j = k Then
      c0 = Hp2(p)
      c = c And (c0 - 1): c0 = c0 \ 2
    End If
    Do While c0
      QSqu i(at), i(bt), r '           (at + bt* rl)^ 2
      If c And c0 Then
        QMult i(at), i(bt), a, b, r '  (at + bt* rl)(a + b* rl)
      End If
      c = c And (c0 - 1): c0 = c0 \ 2
      DoEvents: If Key Then Exit Sub
    Loop
  Next j
  Swp a, i(at): Swp b, i(bt) '         (a + b* rl)^ n
End Sub

Sub QSqu(a As Long, b As Long, r As Long)
  Squ a, t0: Squ b, t1
  MulR t1, r: Add t0, t1 '             a^2 + b^2* rd
  Lsft b, 1: Mult b, a, t1 '           2ab* rl
  Swp a, t0
End Sub

Sub QSqrt(a As Long, b As Long, r As Long)
Dim a1 As Integer, a2 As Integer, b1 As Integer, b2 As Integer
Dim j As Integer, jmin As Integer, N As Integer, s As Integer
Dim u(3) As Integer, v(3) As Integer
  a1 = 2: a2 = 3: b1 = 5
  b2 = 6: N = 7: s = Gets(b)
  '
  If Isf(r, 0) Then
    Data = " zero radicand"
    ErrSw = -1: Exit Sub
  End If
  Squ a, i(a1): Squ b, i(b1)
  MulR i(b1), r: Subt i(a1), i(b1)
  If Gets(i(a1)) = -1 Then
    Data = " can't handle negative norm"
    ErrSw = -1: Exit Sub
  End If
  Isqrt i(a1), i(b1) '                 t = sqrt(a^2 - b^2* rd)
  If Key Then Exit Sub
  Copyf i(b1), i(a1): Copyf i(b1), i(N)
  '
  Add i(a1), a: Sets i(a1), 1
  Subt i(b1), a: Sets i(b1), 1
  Copyf i(a1), a: Rsft i(a1), 1 '      a1:= |t + a| / 2
  Copyf i(b1), b: Rsft i(b1), 1 '      b1:= |t - a| / 2
  '
  If Isf(r, -1) Then '                complex square root
    Isqrt i(a1), a '                   a:= sqrt(a1)
    Isqrt i(b1), b '                   b:= sqrt(b1)* i
  Else
    Copyf r, t1
    Lsft t1, 1: Sets t1, 1
    Divd a, t1, i(a2) '                a2:= |t + a| / (2* rd)
    Divd b, t1, i(b2) '                b2:= |t - a| / (2* rd)
    u(0) = a1: v(0) = b2
    u(1) = a2: v(1) = b1
    u(2) = b1: v(2) = a2
    u(3) = b2: v(3) = a1
    For j = 0 To 3 '                  select combination u, v
      Copyf i(u(j)), a: Copyf i(v(j)), b
      MulR b, r: Subt a, b: Sets a, 1
      Subt a, i(N): Sets a, 1 '        a:= ||u^2 - v^2* rd| - t|
      If j = 0 Or Cmp(t0, a) = 1 Then 'a < t0
        jmin = j: Copyf a, t0
      End If
    Next j
    Isqrt i(u(jmin)), a
    Isqrt i(v(jmin)), b
  End If
  Sets b, s
  If Isf(b, 0) Then Sets b, 1
End Sub

Sub QSubt(a As Long, b As Long, c As Long, d As Long)
  Subt a, c
  Subt b, d '                          a - c + (b - d)* rl
End Sub

Sub RAdd(a As Long, b As Long, c As Long, d As Long)
  Mult a, d, t0
  Mult c, b, t0: Add a, c '            (ad + bc) / bd
  Mult b, d, t0
End Sub

Sub RDivd(a As Long, b As Long, c As Long, d As Long)
  Mult a, d, t0
  Mult b, c, t0 '                      ad / bc
End Sub

Sub RMult(a As Long, b As Long, c As Long, d As Long)
  Mult a, c, t0
  Mult b, d, t0 '                      ac / bd
End Sub

Sub RPwr(a As Long, b As Long, N As Long)
  Letf t2, 0
  Modpwr a, N, t2
  If Key Then Exit Sub
  Modpwr b, N, t2 '                    a^k / b^k
End Sub

Sub RSimpf(a As Long, b As Long)
Dim d As Integer, t As Integer
  d = 4: t = 5
  '
  Copyf a, i(t)
  Euclid i(t), b, i(d) '               d:= gcd(a,b)
  If Not Isf(i(d), 1) Then
    Divd a, i(d), t0: Swp a, t0
    If Isf(a, 0) Then Sets a, 1
  End If
End Sub

Sub RSqu(a As Long, b As Long)
  Squ a, t0: Swp a, t0
  Squ b, t0: Swp b, t0 '               a^2 / b^2
End Sub

Sub RSqrt(a As Long, b As Long)
Dim r As Boolean, t As Integer: t = 4
  '
  If Gets(a) = -1 And Gets(b) = -1 Then
    Sets a, 1: Sets b, 1
  End If
  If Gets(a) = -1 Or Gets(b) = -1 Then
    Data = " illegal argument"
    ErrSw = -1
  Else
    Isqrt a, i(t): Swp a, i(t)
    Isqrt b, i(t): Swp b, i(t) '       sqrt(a) / sqrt(b)
  End If
End Sub

Sub RSubt(a As Long, b As Long, c As Long, d As Long)
  Mult a, d, t0
  Mult c, b, t0: Subt a, c
  Mult b, d, t0 '                      (ad - bc) / bd
End Sub