A (very hard) easy math qwestion

[kedaman]

Yep, this is just something for you who have nothing to do for the moment.

Multiply these values:

29345872602374560293475092374059716888384666023740523098028
20398602938570189304576187468987610438502734592487572345860

But you'll get no bonus points if you don't show your method.

[Arbiter]

OK, I've multiplied them.

I don't want any points so I'm going to show you neither my method, nor my answer.

[Iain17]

5886148021017041140702685048723535923611387590845662110441587235041736501033684329157951756090654878 83425026699964085

How i did it ?

I programmed a long multiplication with strings.

[Mad Compie]

Yeah right, lain17. But I think there's an error in your calculation!
The correct result should be:

5986148031017041140702685048723535933611397590845662210441587235041736501033684329157951756090654878 83425026699964080

and not

5886148021017041140702685048723535923611387590845662110441587235041736501033684329157951756090654878 83425026699964085

That was a nice thread Kedaman! You really are a guru.

My solution (add to a form):

Option Explicit
  ' Huge multiplications
  ' (c)2000 by Marc Compernolle "Mad Compie"
  '
  '
  '     V1
  '     V2
  ' x-------
  ' = Result
  '
  'This form needs a listbox (lstMultiply),
  '                two textboxes (txtV1, txtV2) with MultiLine=True and Scrollbars=1
  '                two buttons (cmdEnd, cmdMultiply)
  '
  ' Form width x height = 6975 x 5160 twips
  ' List width x height =  409 x  173 pixels
  ' Text width x height =  409 x   33 pixels
  '
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
  
  Const LB_SETHORIZONTALEXTENT = &H194
  
  Const GWL_STYLE = (-16)
  Const ES_NUMBER = &H2000&
  
  Dim Result     As String 'end result
  Dim SumTerms() As String 'number of sum terms

Private Sub cmdEnd_Click()
  Unload Me
End Sub

Private Sub cmdMultiply_Click()
  Dim V1        As String
  Dim V2        As String
  Dim V1_Length As Integer
  Dim V2_Length As Integer
  Dim SumLength As Integer
  Dim i         As Integer
  Dim j         As Integer
  Dim Adder     As Integer
  Dim POS       As Integer
  Dim a         As Integer
  Dim b         As Integer
  Dim c         As Integer
  
  '   V1
  '   V2
  'x------
  ' Result
  
  If Not IsNumeric(txtV1.Text) Then Beep: Exit Sub
  If Not IsNumeric(txtV2.Text) Then Beep: Exit Sub
  
  V1 = Trim$(txtV1.Text)
  V2 = Trim$(txtV2.Text)
  
  lstMultiply.Clear
  
  V1_Length = Len(V1)
  V2_Length = Len(V2)
  SumLength = V1_Length + V2_Length
  ReDim SumTerms(1 To V2_Length) As String
  
  For i = 1 To V2_Length
    SumTerms(i) = String$(SumLength, "0")
  Next i
  Result = String$(SumLength, "0")
  
  POS = 0
    
  For i = V2_Length To 1 Step -1
    a = Val(Mid$(V2, i, 1))
    Adder = 0
    For j = V1_Length To 1 Step -1
      b = Val(Mid$(V1, j, 1))
      c = Adder + a * b
      If (j > 1) Then
        Mid$(SumTerms(i), SumLength - (V1_Length - j) - POS, 1) = "" & (c Mod 10)
        Adder = c \ 10
      Else
        Mid$(SumTerms(i), SumLength - (V1_Length - j) - POS, 1) = "" & (c Mod 10)
        Mid$(SumTerms(i), SumLength - (V1_Length - j) - POS - 1, 1) = "" & (c \ 10)
      End If
    Next j
    POS = POS + 1
  Next i
  lstMultiply.AddItem ""
  lstMultiply.AddItem "The terms are:"
  For i = V2_Length To 1 Step -1
    lstMultiply.AddItem SumTerms(i)
  Next i
  lstMultiply.AddItem ""
  lstMultiply.AddItem "The product is:"
  Adder = 0
  For i = SumLength To 1 Step -1
    a = Adder
    For j = V2_Length To 1 Step -1
      a = a + Val(Mid$(SumTerms(j), i, 1))
    Next j
    Mid$(Result, i, 1) = "" & a Mod 10
    Adder = a \ 10
  Next i
  lstMultiply.AddItem Result
End Sub

Private Sub Form_Load()
  Dim CurrStyle As Long

  Me.ScaleMode = vbPixels
  
  'Set the textboxes numerical...
  CurrStyle = GetWindowLong(txtV1.hwnd, GWL_STYLE) Or ES_NUMBER
  SetWindowLong txtV1.hwnd, GWL_STYLE, CurrStyle
  CurrStyle = GetWindowLong(txtV2.hwnd, GWL_STYLE) Or ES_NUMBER
  SetWindowLong txtV2.hwnd, GWL_STYLE, CurrStyle
  txtV1.Text = "29345872602374560293475092374059716888384666023740523098028"
  txtV2.Text = "20398602938570189304576187468987610438502734592487572345860"
  'SendMessage lstMultiply.hwnd, LB_FINDSTRING, -1, ByVal CStr(Text1.Text)
  'Set the horizontal scrollbar on the listbox to 1024pels...
  SendMessage lstMultiply.hwnd, LB_SETHORIZONTALEXTENT, 1024, 0&
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Erase SumTerms
  End
End Sub

Private Sub txtV1_KeyPress(KeyAscii As Integer)
  If (KeyAscii = 13) Then KeyAscii = 0 'Suppress the CRLF
End Sub

Private Sub txtV2_KeyPress(KeyAscii As Integer)
  If (KeyAscii = 13) Then KeyAscii = 0 'Suppress the CRLF
End Sub

[Iain17]

Opps, i messed up the remainder in one place.

*bangs his head against the wall and goes off to die*

[KWell]

5986147103101610411310702685048723535933611397590845662110104415872350417365010336843291579517560906 5487883425026699964080

Here is my code

Function Multiplication(Nbr1 As String, Nbr2 As String) As String
 Dim N1() As Byte
 Dim Idx1 As Integer
 Dim IdxMax1 As Integer
 Dim N2() As Byte
 Dim Idx2 As Integer
 Dim IdxMax2 As Integer
 Dim NRes() As Byte
 Dim IdxRes As Integer
 Dim Idx As Integer
 Dim IdxResMax As Integer
 Dim Result As String
 Dim NResTemp() As Byte
 Dim Report As Byte
 Dim i As Integer
 
 ' Init of the arrays
 IdxMax1 = Len(Nbr1)
 IdxMax2 = Len(Nbr2)
 ReDim N1(IdxMax1)
 ReDim N2(IdxMax2)
 IdxResMax = IdxMax1 + IdxMax2
 ReDim NRes(IdxResMax)
 
 For i = 0 To IdxMax1 - 1
  N1(i + 1) = Mid(Nbr1, IdxMax1 - i, 1)
 Next
 
 For i = 0 To IdxMax2 - 1
  N2(i + 1) = Mid(Nbr2, IdxMax2 - i, 1)
 Next
 
 ' Multiplication
 For Idx1 = 1 To IdxMax1
  For Idx2 = 1 To IdxMax2
   NRes(Idx1 + Idx2 - 1) = NRes(Idx1 + Idx2 - 1) + N1(Idx1) * N2(Idx2)
   If NRes(Idx1 + Idx2 - 1) >= 10 Then
      NRes(Idx1 + Idx2) = NRes(Idx1 + Idx2) + Int(NRes(Idx1 + Idx2 - 1) / 10)
      NRes(Idx1 + Idx2 - 1) = NRes(Idx1 + Idx2 - 1) Mod 10
   End If
  Next Idx2
 Next Idx1
 
 ' Put the result in a string
 For i = IdxResMax To 1 Step -1
  Result = Result & Trim(Str(NRes(i)))
 Next
 ' Delete all zero before the number
 While Left(Result, 1) = "0"
  Result = Mid(Result, 2)
 Wend
 Multiplication = Result
End Function

Sub TestMultiplication()
 Dim Nbr1 As String
 Dim Nbr2 As String
 Dim Result As String
 Nbr1 = "29345872602374560293475092374059716888384666023740523098028"
 Nbr2 = "20398602938570189304576187468987610438502734592487572345860"
 Result = Multiplication(Nbr1, Nbr2)
 Debug.Print Nbr1
 Debug.Print Nbr2 & " x"
 Debug.Print String(Len(Nbr2), "-")
 Debug.Print Result
End Sub

[Edited by kwell on 09-26-2000 at 08:58 AM]

[Mad Compie]

Hmm, I think you're a little bit wrong here, KWell. I think the placement of the 10ths are miscalculated.
Long live my solution!
What about yours, Keda?

[Iain17]

Yeah, very good Mad Compie, just to let you know that your soloution wont even work on VERY big numbers. Try it and see.

[Mad Compie]

Hm, wouldn't it?
I don't know.
Maybe because VB6 only allows a integer sized max string length?
This means that the result string should have a max length 32767 digits?
Or is it not that what you are trying to say, Lain17 ?

[kedaman]

Oh nice work guys! I have looked trough your algoritms and we have a winner!
The winner is...






ok, first the correct answer is

5986148031017041140702685048723535933611397590845662210441587235041736501033684329157951756090654878 83425026699964080

and my own algoritm, if anyone doubts me...

Sub main()
    Debug.Print MultString("29345872602374560293475092374059716888384666023740523098028", "20398602938570189304576187468987610438502734592487572345860")
    '598614803101704114070268504872353593361139759084566221044158723504173650103368432915795175609065487883425026699964080
End Sub

Function MultString$(stra$, strb$)
    Dim a() As Byte, b() As Byte, res() As Byte, temp&, x&, y&, z&
    a = StrConv(stra, vbFromUnicode)
    b = StrConv(strb, vbFromUnicode)
    ReDim res(Len(stra) + Len(strb) - 2)
    For x = 0 To UBound(a)
        For y = 0 To UBound(b)
            Position = UBound(a) - x + UBound(b) - y
            z = Position
            temp = CLng(a(x) - 48) * (b(y) - 48)
            Do While temp
                If z > UBound(res) Then ReDim Preserve res(z)
                temp = temp + res(z)
                res(z) = temp Mod 10
                temp = Int(temp / 10)
                z = z + 1
            Loop
        Next y
    Next x
    For x = 0 To UBound(res)
        res(x) = res(x) + 48
    Next x
    MultString = ReverseString(StrConv(res, vbUnicode))
End Function
Function ReverseString(Str As String) As String
    For x = Len(Str) To 1 Step -1
        ReverseString = ReverseString & Mid(Str, x, 1)
    Next x
End Function

Now the winner is (correct me if i'm wrong)
The winner is, Mad Compie, and you get one bonus points for solving it brilliantly
Iain and Kwell get's second,
Iain get one bonus point for having a very close answer (and you could get more if you posted your function too)
Kwell get's one bonus point for a nice try and organized code, nice work guys
Mad Compie 3p
Iain 1p
Kwell 1p
Arbiter could get a point if you show us your answer+code

[kedaman]

Also i forgot, the max length of a string is 2147483648, 2^31 or 2 Gb.

[Arbiter]

Well,

It's funny you should say that Kedaman, but I got the same answer you did and my code looked absolutely identical.

Remarkable really.

Okay, Okay I didn't even try. Come up with some more challenges though and I promise I'll try next time.

[kedaman]

Now this one is harder.

The squareroot of
8923650187589071592837401740527047801837856239745170

[Iain17]

Well, my code is comparitivley crap as i just threw it together to answer the question as quickly as possible, and look what happened, i forgot to carry the remaninder.

Function bigMultiply(strNum1 As String, strNum2 As String) As String
    Dim strAnswer() As String
    Dim strTemp As String
    Dim iNum1 As Integer, iNum2 As Integer
    Dim iTempAnswer As Integer, iRem As Integer
    Dim iAnswer As Integer
    Dim i As Long, j As Long

    ReDim strAnswer(1 To Len(strNum2)) As String

    For i = Len(strNum2) To 1 Step -1
      iNum1 = Mid$(strNum2, i, 1)
      For j = Len(strNum1) To 1 Step -1
        iNum2 = Mid$(strNum1, j, 1)

        iTempAnswer = iNum1 * iNum2 + iRem
        iAnswer = (iTempAnswer) Mod 10
        iRem = iTempAnswer \ 10

        strAnswer(i) = strAnswer(i) & iAnswer
      Next j
      If iRem > 0 Then
        strAnswer(i) = strAnswer(i) & iRem
        iRem = 0
      End If
      strAnswer(i) = String(Len(strNum2) - i, "0") & strAnswer(i)
    Next i


    For i = UBound(strAnswer) To LBound(strAnswer) Step -1
      For j = 1 To Len(strAnswer(i))
        iNum1 = Val(Mid$(bigMultiply, j, 1))
        iNum2 = Val(Mid$(strAnswer(i), j, 1))

        iTempAnswer = iNum1 + iNum2 + iRem
        iAnswer = iTempAnswer Mod 10
        iRem = iTempAnswer \ 10

        strTemp = strTemp & iAnswer
      Next j
      If iRem > 0 Then
        strTemp = strTemp & iRem
        iRem = 0
      End If
      bigMultiply = strTemp
      strTemp = ""
    Next i

    bigMultiply = StrReverse(bigMultiply)

End Function

[kedaman]

Ok, Iain get's another point, well not 2 because Mad compie got 2 for the "first correct answer"

Now How about The a bit more harder problem, you don't need to have the decimals below 10^0

Three points to the first correct answer, Two for correct answer, and some bonuspoints if you have something extra

[KWell]

The squareroot of 8923650187589071592837401740527047801837856239745170
is
94465073903475413482026203.3461236635024168025764851517941468748656
with 40 decimals

Here is my code

Option Explicit

Function Multiplication(Nbr1 As String, Nbr2 As String) As String
 Dim N1() As Byte
 Dim Idx1 As Integer
 Dim IdxMax1 As Integer
 Dim N2() As Byte
 Dim Idx2 As Integer
 Dim IdxMax2 As Integer
 Dim NRes() As Byte
 Dim IdxRes As Integer
 Dim Idx As Integer
 Dim IdxResMax As Integer
 Dim Result As String
 Dim NResTemp() As Byte
 Dim Report As Byte
 Dim i As Integer
 
 ' Init of the arrays
 IdxMax1 = Len(Nbr1)
 IdxMax2 = Len(Nbr2)
 ReDim N1(IdxMax1)
 ReDim N2(IdxMax2)
 IdxResMax = IdxMax1 + IdxMax2
 ReDim NRes(IdxResMax)
 
 For i = 0 To IdxMax1 - 1
  N1(i + 1) = Mid(Nbr1, IdxMax1 - i, 1)
 Next
 
 For i = 0 To IdxMax2 - 1
  N2(i + 1) = Mid(Nbr2, IdxMax2 - i, 1)
 Next
 
 ' Multiplication
 For Idx1 = 1 To IdxMax1
  For Idx2 = 1 To IdxMax2
   NRes(Idx1 + Idx2 - 1) = NRes(Idx1 + Idx2 - 1) + N1(Idx1) * N2(Idx2)
   If NRes(Idx1 + Idx2 - 1) >= 10 Then
      NRes(Idx1 + Idx2) = NRes(Idx1 + Idx2) + Int(NRes(Idx1 + Idx2 - 1) / 10)
      NRes(Idx1 + Idx2 - 1) = NRes(Idx1 + Idx2 - 1) Mod 10
   End If
  Next Idx2
 Next Idx1
 
 ' Put the result in a string
 For i = IdxResMax To 1 Step -1
  Result = Result & Trim(Str(NRes(i)))
 Next
 ' Delete all zero before the number
 While Left(Result, 1) = "0"
  Result = Mid(Result, 2)
 Wend
 Multiplication = Result
End Function

Sub TestMultiplication()
 Dim Nbr1 As String
 Dim Nbr2 As String
 Dim Result As String
 Nbr1 = "29345872602374560293475092374059716888384666023740523098028"
 Nbr2 = "20398602938570189304576187468987610438502734592487572345860"
 Result = Multiplication(Nbr1, Nbr2)
 Debug.Print Nbr1
 Debug.Print Nbr2 & " x"
 Debug.Print String(Len(Nbr2), "-")
 Debug.Print Result
End Sub

Function Addition(Nbr1 As String, Nbr2 As String) As String
 Dim Idx1 As Integer
 Dim IdxMax1 As Integer
 Dim Idx2 As Integer
 Dim IdxMax2 As Integer
 Dim IdxRes As Integer
 Dim IdxMaxRes As Integer
 Dim Nb1() As Byte
 Dim Nb2() As Byte
 Dim NbRes() As Byte
 Dim i As Integer
 Dim Report As Integer
 Dim Result As String
 IdxMax1 = Len(Nbr1)
 IdxMax2 = Len(Nbr2)
 IdxMaxRes = IIf(IdxMax1 > IdxMax2, IdxMax1 + 1, IdxMax2 + 1)
 ReDim Nb1(IdxMaxRes - 1)
 ReDim Nb2(IdxMaxRes - 1)
 ReDim NbRes(IdxMaxRes)
 
 For i = 0 To IdxMax1 - 1
  Nb1(i + 1) = Mid(Nbr1, IdxMax1 - i, 1)
 Next
 Report = 0
 For i = 0 To IdxMax2 - 1
  Nb2(i + 1) = Mid(Nbr2, IdxMax2 - i, 1)
 Next

 
 For i = 1 To IdxMaxRes - 1
  NbRes(i) = Nb1(i) + Nb2(i) + Report
  If NbRes(i) >= 10 Then
     Report = 1
     NbRes(i) = NbRes(i) Mod 10
  End If
 Next i
 If Report <> 0 Then
    NbRes(IdxMaxRes) = NbRes(IdxMaxRes) + Report
 End If
 
 ' Put the result in a string
 For i = IdxMaxRes To 1 Step -1
  Result = Result & Trim(Str(NbRes(i)))
 Next
 ' Delete all zero before the number
 While Left(Result, 1) = "0"
  Result = Mid(Result, 2)
 Wend
 Addition = Result
End Function

Function SquareRoot(Byval Number As String, Byval Decimale As Integer) As String
 Dim CurNumber As String
 Dim LastNumber As String
 Dim Increment As String
 Dim Square As String
 Number = Number & String(2 * Decimale, "0")
 LastNumber = "0"
 CurNumber = "0"
 Increment = "1" & String((Len(Number) / 2) - 1, "0")
 CurNumber = Increment
 Square = Multiplication(CurNumber, CurNumber)
 While (Not Square = Number) And Increment <> ""
  While Not Greater(Square, Number)
   LastNumber = CurNumber
   CurNumber = Addition(CurNumber, Increment)
   Square = Multiplication(CurNumber, CurNumber)
  Wend
  'Debug.Print CurNumber, LastNumber
  'Debug.Print " " & Square, Number
  'Debug.Print
  
  If Square <> Number Then
     Increment = Mid(Increment, 1, Len(Increment) - 1)
     CurNumber = LastNumber 'Addition(LastNumber, Increment)
     Square = Multiplication(CurNumber, CurNumber)
  End If
 Wend
 
 'PrintNumber CurNumber, Decimale
 'PrintNumber Square, 2 * Decimale
 'PrintNumber Number, 2 * Decimale
 SquareRoot = GetNumber(CurNumber, Decimale)
End Function

Function PrintNumber(Number As String, Decimale As Integer) As String
 Debug.Print Left(Number, Len(Number) - Decimale) & "." & Right(Number, Decimale)
End Function

Function GetNumber(Number As String, Decimale As Integer) As String
 GetNumber = Left(Number, Len(Number) - Decimale) & "." & Right(Number, Decimale)
End Function

Function Greater(Nb1 As String, Nb2 As String) As Boolean
  ' Delete all zero before the number
 While Left(Nb1, 1) = "0"
  Nb1 = Mid(Nb1, 2)
 Wend
 While Left(Nb2, 1) = "0"
  Nb1 = Mid(Nb2, 2)
 Wend
 If Len(Nb1) > Len(Nb2) Then
    Greater = True
 ElseIf Len(Nb2) > Len(Nb1) Then
    Greater = False
 Else
    Greater = Nb1 >= Nb2
 End If
End Function

Sub TestSquareroot()
 Dim Number As String
 Dim SqRoot As String
 Dim Decimale As Integer
 Number = "8923650187589071592837401740527047801837856239745170"
 
 Decimale = 40
 SqRoot = SquareRoot(Number, Decimale)
 Debug.Print "The Square root of "
 Debug.Print Number
 Debug.Print "is"
 Debug.Print SqRoot
 Debug.Print "with a precision of " & Decimale & " decimal(s)"
End Sub

[Arbiter]

Well, I did the easy bit. I got the answer with an incredibly small piece of code, but I'm far too stupid to get it to display all the decimal places.

Option Compare Database
Option Explicit

Dim blnStop As Boolean

Private Sub Command3_Click()
Dim storage

On Error Resume Next

temp.Caption = 2

Do While blnStop = False
    DoEvents
    temp2.Caption = ""
    storage = ((Val(Value.Caption) / Val(temp.Caption)) + Val(temp.Caption)) / 2
    current.Caption = storage * storage
    temp.Caption = storage
Loop

End Sub

Private Sub Command5_Click()
    blnStop = true
end sub

How would I go about getting it to display all the decimal place.

PS - I'm using VBA in Access as I'm at work, which is also why I don't have time to race people to the answer, sorry...

[kedaman]

Option Compare Database?!?!?

gives me an expected "text or binary", so i guess Database is something new in VB6 or???
What does it do and how is it related to your solution?

Anyway, hehe, not going to reveal the real asnwer until i've got some more replies

[Mad Compie]

Thanks for the bonus, Keda!

I was some time away and just read the new test. Hm, do I smell some recursive routines here?

Please wait for my answer (but not too long...)

[Yonatan]

Originally posted by kedaman
Option Compare Database?!?!?

gives me an expected "text or binary", so i guess Database is something new in VB6 or???
What does it do and how is it related to your solution?

It is not related.
Arbiter is using Microsoft Access VBA and it automatically adds Option Compare Database (an Access-VBA-only compare option) to all the code modules.

[Arbiter]

Yeah, I'm using VBA in Access as I don't have VB at work, only at home. I'm a Business Analyst not a developer, so I have no need for VB as part of my job.

It makes things a little awkward but hey, I shouldn't really be doing this in work time anyway!

You can just remove Option Compare Database.

[kedaman]

Seems that it was a pretty hard one, since not many got any solutions, but yes, we have a winner and you probably know who it is

But first, as usual, the correct answer is (without extra decimals)

94465073903475413482026203

And if anyone want's my code...

Function SqrString(str As String)
    Dim res() As Byte, x&
    res = StrConv(String(Int(Log(str) / Log(100) + 1), "0"), vbFromUnicode)
    For x = 0 To UBound(res)
        Do Until Right(String(Len(str), "0") & MultString(StrConv(res, vbUnicode), StrConv(res, vbUnicode)), Len(str) + 1) > "0" & str
            res(x) = res(x) + 1
        Loop
        res(x) = res(x) - 1
    Next x
    SqrString = StrConv(res, vbUnicode)
End Function

So, there is a winner, and he is...


He is KWell!!!!! 3 points! 3 points for the first correct answer and 1 bonus point for the 40 or more if needed decimals!!!
Arbiter get's 1 point for a very nice try Well that's better than 0 points for all the others that didn't try. Although i'm not sure what your code does but it surely get's the squareroot but you don't have the needed decimals.

[KWell]

Kwell 5
Mad Compie 3p
Arbiter 2p
Iain 2p

Wow, i'm the first with 5p!!

Kedaman, what's the new chalenge ?

[Mad Compie]

Sadly I did not have too much time to compete with you guys.
Maybe some other time.
By the way, Keda, why are you using vbUnicode and StrConv. I'm not quite familiar with it.
I tought that Windows does not support Unicode chars?

[kedaman]

ACtually Strings are unicode by default in vb So you can use use strconv to convert a unicode string to a byte array for instance. It's much more faster way to calculate with a byte array than converting a part of a string all the time.
Anyone want's more math problems? or was that last one too hard? hehe

[Mad Compie]

hm,

How about a calculation of PI with 1000 decimals?

There's a cool way of remembering Pi:

'May I have a large container of coffee? Thank you.
' 3  1  4   1   5       9     2     6      5    3
'
'The numbers under the words are the number of letters
'in each word. Put all the numbers together and you
'get exactly Pi:
'Pi = 3.141592653.... :)

[Yonatan]

Here are a few calculation methods.
None give you many decimals, but you'll get over it.
Here they are, from best to worst:

#1: Arctangent!

Dim Pi As Double

Pi = Atn(1) * 4
' Which is equivalent to...
Pi = Atn(0.2) - 4 * Atn(1 / 239)

#2: Algorithm-named-after-someone-with-a-long-name!

Dim Pi As Double
Dim I As Long

' Define how accurate the calculation will be, and how long it will take:
Const Precision = 1000000 ' 1 million is average precision.

For I = 1 To Precision Step 2
    Pi = Pi + (-I Mod 4 + 2) * (4 / I) ' I think this would be faster in C++. :rolleyes:
Next

#3: Another unknown method! Comes close, but not accurate.

Dim Pi As Double

Pi = ((0.5 + Sqr(0.125) + Sqr(Sqr(0.5))) ^ 2) / (1 - 4 * ((Sqr(0.125) - 0.5) ^ 2))

#4: A simple constant expression which comes quite close. This is a very very old method. (Babylonians?)

Const Pi As Double = (4 / 3) ^ 4

#5: Estimate the value of Pi! That's right, estimate! Different result every time!

Dim Pi As Double
Dim N As Long, I As Long

' Define how accurate the estimation will be, and how long it will take:
Const Precision = 100000 ' 100 thousand is about average for this one!

Call Randomize ' This line does not look good on Pi-calculation code, does it?

For I = 1 To Precision
    If Rnd ^ 2 + Rnd ^ 2 <= 1 Then N = N + 1
Next

Pi = 4 * N / Precision

Enjoy!

[oetje]

I know the value of pi in 50 decimals: 3.14159265358979323846264338327950288419716939937510

[KWell]

Here is my code (based on a C code)

 Declare Function GetTickCount Lib "kernel32.dll" () As Long
 
 Dim Result() As Long  ' Temp Result
 Dim Result1() As Long ' Final Result and Arctg(1/5)
 Dim Result2() As Long ' Arctg(1/239)
 Dim Lim As Long       ' Nbr of decimals
 Dim K As Long         ' Count of null cell
 Dim MAX As Long       ' Max dim of array
 Dim BASE As Long      ' Base of the number
 Dim GBASE As Long     ' Nbr group for the output
 Dim I5 As Long        ' Nbr iteration for the compute of the arctg 1/5
 Dim I239 As Long      ' Nbr iteration for the compute of the arctg 1/239
 Public Msg As String  '
 Dim TStart As Long
 Dim TEnd As Long
 
 
Sub LaunchComputation()
 Debug.Print CalculPi(1000)
 Debug.Print Msg
End Sub
 
Function CalculPi(NbDeci As Long) As String
 ' PI = 16*ArcTG(1/5) - 4*ArcTg(1/239)
 Lim = NbDeci
 ' Max decimale for Arctg(1/5) and arctg(1/239)
 ' Base 1000000 = 1502 and 5104
 ' Base  100000 = 15012 and 51070
 ' Base   10000 = ...
 If Lim <= 1500 Then
    BASE = 1000000
    NB = 6
    GBASE = 10
 ElseIf Lim <= 15000 Then
    BASE = 100000
    NB = 5
    GBASE = 12
 ElseIf Lim <= 150000 Then
    BASE = 10000
    NB = 4
    GBASE = 15
 ElseIf Lim <= 1500000 Then
    BASE = 1000
    NB = 3
    GBASE = 20
 Else
    MsgBox "This code is for compute not more than 1500000 decimals. You can but it take long time."
    Exit Function
 End If
 
 TStart = GetTickCount
 
 K = 0
 MAX = 3 + Lim / NB
 ReDim Result(4 * MAX)
 ReDim Result1(4 * MAX)
 I5 = ArcTg(Result, 5, Result1)
 K = 0
 Mult Result1, 16
 ReDim Result(4 * MAX)
 ReDim Result2(4 * MAX)
 I239 = ArcTg(Result, 239, Result2)
 K = 0
 Mult Result2, 4
 
 K = 0
 Sous Result1, Result2
 
 TEnd = GetTickCount
 
 Msg = "Decimal print: " & NB * (MAX - 2) & "  -  Nbr of Iteration: " & I5 & ", " & I239 & " (" & I5 + I239 & ")"
 Msg = Msg & vbCrLf
 Msg = Msg & "in " & (TEnd - TStart) / 1000 & "seconds"

 CalculPi = " Pi = " & BaseToDec(Result1)
End Function

Function BaseToDec(Table() As Long) As String ' Convert number in base BASE to base 10
 Dim i As Integer
 Dim Tmp As Long
 Dim BS10 As Long
 Dim StrPi As String
 BS10 = BASE / 10 ' max number of digit in the base number
 StrPi = StrPi & Table(0) & " "
 i = 1
 While i < MAX - 1
  Tmp = Table(i)
  Tmp = IIf(Tmp = 0, 1, Tmp)
  While Tmp < BS10
   StrPi = StrPi & "0"
   Tmp = 10 * Tmp
  Wend
  
  StrPi = StrPi & Trim(Table(i))
  If i Mod GBASE Then
     StrPi = StrPi & " "
     Else
     StrPi = StrPi & vbCrLf & "        "
  End If
  i = i + 1
 Wend
 BaseToDec = StrPi
End Function

Sub Add(a() As Long, b() As Long) ' Add 2 arrays
 Dim i As Integer
 Dim r As Long
 r = 0
 i = MAX - 1
 While i >= K
  r = a(i) + r + b(i)
  If r >= BASE Then
     a(i) = r - BASE
     r = 1
     Else
     a(i) = r
     r = 0
  End If
  i = i - 1
 Wend
 While r <> 0
  r = a(i) + r
  If r >= BASE Then
     a(i) = r - BASE
     r = 1
     Else
     a(i) = r
     r = 0
  End If
  i = i - 1
 Wend
End Sub

Sub Sous(a() As Long, b() As Long) ' Sub 2 arrays (singn of the result +)
 Dim i As Integer
 Dim r As Long
 r = 0
 i = MAX - 1
 While i >= K
  r = a(i) - r - b(i)
  If (r < 0) Then
     a(i) = r + BASE
     r = 1
     Else
     a(i) = r
     r = 0
  End If
  i = i - 1
 Wend
 While r <> 0
  r = a(i) - r
  If (r < 0) Then
     a(i) = r + BASE
     r = 1
     Else
     a(i) = r
     r = 0
  End If
  i = i - 1
 Wend
End Sub

Sub Mult(a() As Long, n As Long) ' Mult an array by a number
 Dim i As Integer
 Dim s As Long
 s = 0
 i = MAX - 1
 While i >= K
  a(i) = a(i) * n + s
  s = Int(a(i) / BASE)
  a(i) = a(i) Mod BASE
  i = i - 1
 Wend
 If i <> -1 Then
  a(i) = a(i) * n + s
  While ((s = a(i)) >= BASE)
   a(i - 1) = a(i - 1) + s / BASE
   a(i) = s Mod BASE
   i = i - 1
   K = K - 1
  Wend
 End If
 If K > 0 Then
    K = K - 1
 End If
 While (a(K) = 0) And K <= MAX
  K = K + 1 '   /* GESTION DES CASES NULLES */
 Wend
End Sub

Sub Div(t() As Long, n As Long) ' Divide a array by a number
 Dim i As Integer
 Dim a As Long
 a = t(K)
 i = K
 While i < MAX
  t(i) = Int(a / n)
  a = BASE * (a Mod n) + t(i + 1)
  i = i + 1
 Wend
 While (t(K) = 0) And K <= MAX
  K = K + 1 '  Count the number of first null cell for find when we stop
 Wend
End Sub

Function ArcTg(a() As Long, p As Long, Result() As Long) As Long ' arctg(1/p) where 1/p is in radian
 'ArtTg(1/X) = U0(X) + U1(X) + U2(X) + ... + Ui(X) + ...
 ' Where Ui(X)= -1^i/((2i+1)*X^(2i+1))
 '       and X = ° radian
 '
 ' -> U0(X)=1/X
 '    Un+1(X)=-1*(2n+1)/((2n+3)*X*X) * Un(X)
 '
 Dim i As Long
 K = 0
 i = 0
 a(i) = 1 '6
 Div a, p 'U0(X)
 Add Result, a
 While K < MAX
  ' Calcul of Ui+1(X)
  ' a = Ui(X)
  ' a / (2i+3)
  Div a, (2 * i + 3)
  ' a / X^2
  Div a, p
  Div a, p
  ' a * (2i+1)
  Mult a, (2 * i + 1)
  ' a * -1^i
  If i Mod 2 Then
     Add Result, a
     Else
     Sous Result, a
  End If
  i = i + 1
 Wend
 ArcTg = i
End Function

[Michael]

Too many people with wayyyyyyyyyyyy too much spare time on their hands.

My advice: Get out more.

[kedaman]

Oh my god!
I had made up 4 qwestion for you this weekend and now it seems like 3 of them have been completely answered!!!

Well actually the first one was of calculating Tangens of a value but while i was thinking about of how to solve it, i found you need to divide two values, calculate pi and Integrate a circle function, so i added them to the list for others who would like to solve a bit easier qwestions first.

Now i got your answers even before i asked the qwestions

but hey, i had a fourth qwestion, maybe you could find out the anwer?
20940562793640971452396459^2.258

Kwell, great work! You converted that from C and maybe you have a lot more math related stuff in C? I'm especially interested in the trigonometrical functions. Do you have them?

[Mad Compie]

Well guys, here's my solution. You can calculate PI at a given number of decimals:

'This form "frmPI" needs:
'  1 CommandButton "cmdCalculate"
'  1 Label: "lblPI"
'  2 TextBoxes: "txtNumbers" and "txtOutput"
'
    Dim CalculatingPi As Boolean  ' toggle true/false whether calc'ing pi
    
    '
    '   Infinite Sums Formulas:
    '
    '       Pi = 1/1 - 1/3 + 1/5 - 1/7 + 1/9 - 1/11 . . . = 4 / Pi
    '
    '       Pi = 1/1^2 + 1/2^2 + 1/3^2 +1/4^2 + 1/5^2 . . . = (Pi^2) / 6
    '
    '
    '   ArcTangent Formulas:
    '
    '       Pi = 4 * Atn(1)
    '
    '       Euler's Formula:
    '           Pi = 20 * Atn(1/7) + 8 * Atn(3/79)
    '
    '       Gauss's Formula:
    '           Pi = 48 * Atn(1/18) + 32 * Atn(1/57) - 20 * Atn(1/239)
    '
    '       Machin's Formula:
    '           Pi = 16 * Atn(1/5) - 4 * Atn(1/239)
    '
    '
    '       Power Series Expansion for ArcTangent:
    '           Atn(X) = X - X^3 /3 + X^5 /5 - X^7 /7 + X^9 /9 . . .
    '
    '
    '
    '   Ramanujan's Formulas:
    '
    '            1          1103   27493  1  1*3   53883  1*3  1*3*5*7
    '       -----------  =  ---- + -----  -  --- + -----  ---  ------- + . . .
    '       2*pi*Sqr(2)     99^2   99^6   2  4^2   99^10  2*4  4^2+8^2
    '
    '
    '       Elliptic Integral Formula:
    '
    '           1/pi = [ sqrt(8) / 9801 ] * sum { (4n)! * (1103+26390n) /
    '                  [(n!)^4 * 396^(4n) ] }      (n=0,1,2,... )
    

Sub cmdCalculate_Click()
  If Not (CalculatingPi) Then CalculatePi Else Unload Me
End Sub

Sub CalculatePi()
    Dim TimeSpent As Double
    Dim PiValue   As String
    
    If Not IsNumeric(txtNumbers.Text) Then Beep: txtNumbers.Text = 0: Exit Sub
    
    TimeSpent = Timer
    
    txtOutput = "Initializing": DoEvents
    CalculatingPi = True
    cmdCalculate.Caption = "Stop!"

    Dim X As Integer
    Dim CarryPosition As Integer
    '  to be used in subtraction routine below
    
    Dim NumberOfLoops As Integer
    Dim LengthOfNumbers As Integer
    '  variables to be passed to FindArcTangent sub

    LengthOfNumbers = txtNumbers + 3
    '  add 3 extra places because last couple may not be accurate
    NumberOfLoops = Int(2 / 3 * LengthOfNumbers)
    '  each iteration should produce about 1 1/2 accurate places
    
    
    '  all numbers needed to be super accurate in this program
    '  are represented by arrays consisting of single character
    '  length strings.  the 1 position contains the digit in the
    '  number to the far left, and the >1 positions in the array
    '  represent the numbers going to the right in the # from there
    
    ReDim ArcTangent5(1 To LengthOfNumbers) As String * 1
    ReDim ArcTangent239(1 To LengthOfNumbers) As String * 1
    '  arrays to be calculated by FindArcTangent sub
    ReDim MultipliedArcTangent5(1 To LengthOfNumbers + 1) As String * 1
    '  arrays to be calculated by MultiplyArray sub
    ReDim MultipliedArcTangent239(1 To LengthOfNumbers + 1) As String * 1
    
    '       Machin's Formula:
    '           Pi = 16 * Atn(1/5) - 4 * Atn(1/239)
    txtOutput = "Calculating ArcTangent of 1/5": DoEvents
    FindArcTangent 5, NumberOfLoops, LengthOfNumbers, ArcTangent5()
    txtOutput = "Calculating the ArcTangent of 1/239": DoEvents
    FindArcTangent 239, NumberOfLoops, LengthOfNumbers, ArcTangent239()
    txtOutput = "Multiplying ArcTan of 1/5 by 16": DoEvents
    MultiplyArray ArcTangent5(), 16, MultipliedArcTangent5()
    txtOutput = "Multiplying ArcTan of 1/239 by 4": DoEvents
    MultiplyArray ArcTangent239(), 4, MultipliedArcTangent239()
    txtOutput = "Subtracting the Multiplied Arctangents": DoEvents
    For X = LengthOfNumbers To 1 Step -1
        ' subtract MultipliedArcTangent239 array
        ' from MultipliedArcTangent5 array
        If MultipliedArcTangent5(X) < MultipliedArcTangent239(X) Then
            '  do we need to carry?
            CarryPosition = X - 1 ' start with 1st number to the left
            Do Until MultipliedArcTangent5(CarryPosition) <> "0"
              ' find a non-zero number to borrow from
              MultipliedArcTangent5(CarryPosition) = "9"  'fill the other #'s
              CarryPosition = CarryPosition - 1         ' with 9's
              ' go to the next number to the left
            Loop   '  loop until finding a non-zero number
            ' at end of loop, CarryPosition will be # to borrow from
            MultipliedArcTangent5(CarryPosition) = CStr(CInt(MultipliedArcTangent5(CarryPosition)) - 1)
            ' decrease number carried from by one
            MultipliedArcTangent5(X) = CStr((CInt(MultipliedArcTangent5(X)) + 10) - CInt(MultipliedArcTangent239(X)))
            'add an extra ten (borrowed) to MultipliedArcTangent5 and subtract MultipliedArcTangent239
        Else ' just simple subtraction if there isn't carrying
            MultipliedArcTangent5(X) = CStr(CInt(MultipliedArcTangent5(X)) - CInt(MultipliedArcTangent239(X)))
        End If
        DoEvents
    Next X  ' loop to subtract entire MultipliedArcTangent239 array
    
    '  with the MultipliedArcTangent239 array subtracted from the
    '  MultipliedArcTangent5 array, the MultipliedArcTangent5 array
    '  should now be equal to pi
    
    lblPI.Caption = "Pi = 3. + . . .": DoEvents
    txtOutput = ""  ' clear text box
    For X = 1 To LengthOfNumbers - 3  ' don't print the extra 3 numbers
    '  dump the value of pi into the text box
    '  the array does not include the "3."
    '  the 3 was bumped out of the array in the multiplication routine
        PiValue = PiValue & MultipliedArcTangent5(X)
        If X Mod 5 = 0 Then
        '  insert a space every 50 places for word wrapping
          PiValue = PiValue & " "
        End If
    Next X

    txtOutput.Text = PiValue
    MsgBox "Pi calculated to " & LengthOfNumbers - 3 & " decimal places." & Chr$(13) & "Completed " & NumberOfLoops & " iterations." & Chr$(13) & "Spent " & Format$((Timer - TimeSpent) / 60, "#0.0000") & " minutes calculating.", 64, "Calculations Complete"
    CalculatingPi = False
    cmdCalculate.Caption = "Calculate!"
End Sub

'                   Received                 Received                  Received                    Calculated and Passed
Sub FindArcTangent(ArcTanToFind As Integer, NumberOfLoops As Integer, LengthOfNumbers As Integer, ArcTangent() As String * 1)
  '  ArcTanToFind      reciprocal of number to find arctangent of
  '  NumberOfLoops     set number of iterations
  '  LengthOfNumbers   set length of numbers
  '
  '  Machin's Formula
  '  Pi = 16 * Atn(1/5) - 4 * Atn(1/239)
  '
  '  Atn(X) = X - X^3 /3 + X^5 /5 - X^7 /7 + X^9 /9 . . .
  Dim StartPos      As Integer  ' position to start division loops
  Dim Sum           As Long     ' keeps track of total and carrying in adding loops
  Dim X             As Integer  ' multiusage as counter in For...Next and Do loops
  Dim Divisor       As Long     ' keeps track of what the Answer is to be divided by
  Dim Remainder     As Long     ' remainder in the dividing loops
  Dim CarryPosition As Long     ' keeps track of position when carrying
  Dim DividedInto As Integer    ' counts how many times # has divided into
  
  ReDim Answer(1 To LengthOfNumbers) As String * 1
  '  answer after being raised to a certain power, built on each loop
  ReDim Divided(1 To LengthOfNumbers) As String * 1
  '  the Answer after being divided by the divisor
   
    StartPos = 1
    For X = 1 To LengthOfNumbers
      ArcTangent(X) = "0"    '  change arrays from having
      Divided(X) = "0"       '  nulls to having 0's
      Answer(X) = "0"
    Next X
    
    Select Case ArcTanToFind
        Case 5:     ArcTangent(1) = "2"      '  final answer is .2 (1/5) so far
        Case 239
            X = 1
FillInNumbers:
            If X <= LengthOfNumbers Then ArcTangent(X) = "0": X = X + 1
            If X <= LengthOfNumbers Then ArcTangent(X) = "0": X = X + 1
            If X <= LengthOfNumbers Then ArcTangent(X) = "4": X = X + 1
            If X <= LengthOfNumbers Then ArcTangent(X) = "1": X = X + 1
            If X <= LengthOfNumbers Then ArcTangent(X) = "8": X = X + 1
            If X <= LengthOfNumbers Then ArcTangent(X) = "4": X = X + 1
            If X <= LengthOfNumbers Then ArcTangent(X) = "1": X = X + 1
            '  final answer is .0041841 repeating (1/239) so far
            If X <= LengthOfNumbers Then GoTo FillInNumbers
            '  fill in entire array with the repeating fraction
    End Select
    
    For X = 1 To LengthOfNumbers   '  answer will be the same as
      Answer(X) = ArcTangent(X)    '  the final arctangent at this point
    Next X
    
    Divisor = 3 '  start with the divisor being 3
    
    Do Until (Divisor - 1) / 2 = NumberOfLoops + 1 '  stops after formula
        '  has been computed NumberOfLoops times
        For X = Int(StartPos) To LengthOfNumbers
          ' loop to divide Answer array by #^2
          Remainder = Remainder * 10 ' multiply by ten and add new number
          Remainder = Remainder + CInt(Answer(X)) '  like bringing down
          ' the next number in long division
          Do Until Remainder < (ArcTanToFind ^ 2) ' loop until # is smaller
            Remainder = Remainder - (ArcTanToFind ^ 2) 'subtract and count
            DividedInto = DividedInto + 1 ' times it has gone into the #
          Loop
          Answer(X) = CStr(DividedInto)  ' the answer of the long division
          Divided(X) = Answer(X)    ' make a copy in the divided array
          DividedInto = 0    ' clear for next loop
          DoEvents
        Next X        '  loop for whole array
        DoneDividing = 0  ' reset this for next iteration
        Remainder = 0     ' clear variables for the next loop
        DividedInto = 0
        For X = Int(StartPos) To LengthOfNumbers
          'loop to divide Divided array by Divisor
          Remainder = Remainder * 10       '  same long division loop
          Remainder = Remainder + CInt(Divided(X)) ' bring down number
          Do Until (Remainder < Divisor)   ' divide into remainder
            Remainder = Remainder - Divisor
            DividedInto = DividedInto + 1   ' count number of times
          Loop
          Divided(X) = CStr(DividedInto)  '  put answer back into array
          DividedInto = 0      ' clear variable for next loop
          DoEvents
        Next X     '  do this for entire Divided array
        Remainder = 0     ' clear variables for the next loop
        DividedInto = 0
        If (Divisor Mod 4) = 1 Then ' all answers to be added will be true
          For X = LengthOfNumbers To 1 Step -1
            '  add Divided array to ArcTangent array
            Sum = Sum + CInt(Divided(X)) + CInt(ArcTangent(X))
            '  add the two numbers together
            ArcTangent(X) = CStr(Sum Mod 10)
            '  the answer will just be the ones' place
            Sum = Int(Sum / 10) '  divide the remainder by ten for
            '  the increasing place value and drop the ones' place
            DoEvents
          Next X  '  loop for entire arrays
          Sum = 0  ' clear variable
        Else '  all answers to be subtracted will be false
          For X = LengthOfNumbers To 1 Step -1
            ' subtract Divided array from ArcTan array
            If (ArcTangent(X) < Divided(X)) Then '  do we need to carry?
              CarryPosition = X - 1 ' start with 1st number to the left
              Do Until ArcTangent(CarryPosition) <> "0"
                ' find a non-zero number to borrow from
                ArcTangent(CarryPosition) = "9"  'fill the other #'s
                CarryPosition = CarryPosition - 1         ' with 9's
                ' go to the next number to the left
              Loop   '  loop until finding a non-zero number
              ' at end of loop, CarryPosition will be # to borrow from
              ArcTangent(CarryPosition) = CStr(CInt(ArcTangent(CarryPosition)) - 1)
              ' decrease number carried from by one
              ArcTangent(X) = CStr((CInt(ArcTangent(X)) + 10) - CInt(Divided(X)))
              'add an extra ten (borrowed) to ArcTan and subtract Divided
            Else ' just simple subtraction if there isn't carrying
              ArcTangent(X) = CStr(CInt(ArcTangent(X)) - CInt(Divided(X)))
            End If
            DoEvents
          Next X  ' loop to subtract entire Divided array
          CarryPosition = 0  '  clear variable
        End If
        Divisor = Divisor + 2   ' each loop, power and divisor increase by 2
        txtOutput.Text = "Calculating ArcTangent of 1/" & ArcTanToFind & ", Done with iteration " & (Divisor - 1) / 2
        DoEvents
        StartPos = StartPos + 1.25
    Loop  '  loop NumberOfLoops times
          '  each time ArcTangent gets more accurate
End Sub

'                  Received                         Received                       Calculated and Passed
Sub MultiplyArray(ArrayToMultiply() As String * 1, NumberToMultiplyBy As Integer, Answer() As String * 1)
  Dim Position      As Integer  '  current position in array
  Dim SmallAnswer   As Integer  '  keeps track of "sub-answers" in the multiplication process
  Dim NumberToCarry As Integer  '  keeps track of carrying
    
  For Position = txtNumbers + 3 To 1 Step -1
    SmallAnswer = (CInt(ArrayToMultiply(Position)) * NumberToMultiplyBy) + NumberToCarry
    '  multiply the 2 numbers together and add the remainder
    Answer(Position) = Right$(CStr(SmallAnswer), 1)
    '  add ones place of SmallAnswer to the whole answer
    If SmallAnswer < 10 Then  '  if greater than ten we will need
      NumberToCarry = 0     '  to carry
    Else
      NumberToCarry = CInt(Left$(CStr(SmallAnswer), CInt(Len(CStr(SmallAnswer))) - 1))
    End If
    '  carry the Answer without the ones place
    '  (everything is shifted to the right so it get divided by 10)
    DoEvents
 Next Position  ' go on to the next position (moving to the left)
End Sub

Private Sub Form_Unload(Cancel As Integer)
  End
End Sub