pi_spgot.bas

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

Attribute VB_Name = "Pi_SPGOT"
Attribute VB_Description = "Calculation of pi with a fast version of the 1995 Rabinowitz-Wagon spigot algorithm."
'Author : Sjoerd.J.Schaper - [e-mail]
'URL    : http://largeint.sourceforge.net/index.html
'Date   : 11-11-2004
'Code   : Visual Basic for Windows 5.0
Option Explicit

Sub PiSPGOT(imx As Integer)
Dim c As Long, c0 As Long, e As Integer, f() As Long
Dim g As String, i As Integer, ix As Integer
Dim k As Integer, n As Integer, t As Long
  On Error GoTo errhand
  Data = "": Key = 0: tim = Timer
  '
  ix = (1 + imx \ 4) * 14 '            array length
  ReDim f(ix)
  Const m = 10000 '                    decimal base
  Const Bias = 32768 '                 unsigned
  For i = 1 To ix '                    pi = (2;2,2,2,..) in
    f(i) = 2000 - Bias '               mixed-radix base i / (2i + 1)
  Next i
  '
  k = 0: e = 0 '                       initiate buffer, length
  For i = ix To 1 Step -14 '    discard Int(1 + 4 * 10/3) = 14 terms / superdigit
    c0 = 0: t = CLng(i) + i + 1 '      radix conversion:
    For n = i To 1 Step -1 '           numerator previous base
      c = c0 * n + (f(n) + Bias) * m ' accumulator
      t = t - 2: c0 = c \ t '          denominator prev. base, carry
      f(n) = c - c0 * t - Bias '       reduce digit[n]
    Next n
    g = LTrim$(Str$(k + c \ m)) '      previous leftmost superdigit
    g = String$(4 - Len(g), "0") + g
    If i = ix Then
      g = "pi = " + Left$(g, 1) + "." + Right$(g, 3)
    End If
    Data = Data + g
    k = c Mod m: e = e + 4 '           save current superdigit
    If e Mod 100 < 4 Then
      Slate.Box.Text = Data
      Slate.Box.SelStart = e + 1
      DoEvents: If Key Then GoTo break
    End If
  Next i
  Data = Data & "  [" & e & "]" & vbCrLf
'
eind:
  Data = Data & vbCrLf & "Timer: " & CSng(Timer - tim) & "s"
  Slate.Box.Text = Data
  Slate.Box.SelStart = Len(Slate.Box.Text) + 1
  Lognr = FreeFile
  Open WrkD + "pi_spgot.log" For Output As Lognr
  Print #Lognr, Data
  Data = "": Close Lognr
  Erase f()
  On Error GoTo 0
  Exit Sub
break:
  Data = Data & vbCrLf & " break" & vbCrLf
  GoTo eind
errhand:
  MsgBox "Pi-Spigot", 48, "Error"
  Resume eind
End Sub